*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