*DECK SCRLIB SUBROUTINE SCRLIB(MAXNIS,MAXISO,IPLIB,IPMEM,IACCS,NMIX,NGRP,IMPX, 1 HEQUI,HMASL,NCAL,ITER,MY1,MY2,MD1,MD2,TERP,NISO,LISO,HISO,CONC, 2 ITODO,MIXC,LRES,LPURE,ILUPS,B2,VTOT,YLDS,DECAYC) * *----------------------------------------------------------------------- * *Purpose: * Build the Microlib by scanning the NCAL elementary calculations in * a Saphyb and weighting them with TERP factors. * *Copyright: * Copyright (C) 2012 Ecole Polytechnique de Montreal * *Author(s): * A. Hebert * *Parameters: input * MAXNIS maximum value of NISO(I) in user data. * MAXISO maximum allocated space for output Microlib TOC information. * IPLIB address of the output Microlib LCM object. * IPMEM pointer to the memory-resident Saphyb object. * IACCS =0 Microlib is created; =1 ... is updated. * NMIX maximum number of material mixtures in the Microlib. * NGRP number of energy groups. * 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. * NCAL number of elementary calculations in the Saphyb. * ITER completion flag (=0: compute the macrolib). * MY1 number of fissile isotopes including macroscopic sets. * MY2 number of fission fragment. * MD1 number of types of radioactive decay reactions. * MD2 number of particularized isotopes including macro. * TERP interpolation factors. * NISO number of user-selected isotopes. * LISO type of treatment (=.true.: ALL; =.false.: ONLY). * HISO name of the user-selected isotopes. * CONC user-defined number density of the user-selected isotopes. A * value of -99.99 is set to indicate that the Saphyb value is * used. * ITODO non-depletion mask (=1 to force a user-selected isotope to be * non-depleting) * MIXC mixture index in the Saphyb corresponding to each Microlib * mixture. Equal to zero if a Microlib mixture is not updated. * LRES =.true. if the interpolation is done without updating isotopic * densities * LPURE =.true. if the interpolation is a pure linear interpolation * with TERP factors. * ILUPS up-scattering removing flag (=1 to remove up-scattering from * output cross-sections). * B2 buckling * VTOT volume of updated core. * YLDS fission yields. * DECAYC radioactive decay constants. * *----------------------------------------------------------------------- * USE GANLIB IMPLICIT NONE *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPLIB,IPMEM INTEGER MAXNIS,MAXISO,IACCS,NMIX,NGRP,IMPX,NCAL,ITER,MY1,MY2,MD1, 1 MD2,NISO(NMIX),HISO(2,NMIX,MAXNIS),ITODO(NMIX,MAXNIS),MIXC(NMIX), 2 ILUPS REAL TERP(NCAL,NMIX),CONC(NMIX,MAXNIS),B2 DOUBLE PRECISION VTOT,YLDS(MY1,MY2),DECAYC(MD1,MD2) LOGICAL LISO(NMIX),LRES,LPURE CHARACTER HEQUI*4,HMASL*4 *---- * LOCAL VARIABLES *---- INTEGER, PARAMETER::IOUT=6 INTEGER, PARAMETER::MAXLOC=10 INTEGER, PARAMETER::MAXDIV=3 INTEGER, PARAMETER::MAXMAC=2 INTEGER, PARAMETER::MAXREA=50 INTEGER, PARAMETER::NSTATE=40 TYPE(C_PTR) JPLIB,KPLIB,JPMEM,KPMEM,LPMEM,MPMEM REAL B2SAP, FACT0, WEIGHT INTEGER I, I0, IAD, IBM, IBMOLD, ICAL, ID1, IED2, IFISS, IGR, & ILENG, ILOC, ILONG, IMAC, IOF, IPRC, IREA, IREAF, IRES, IS2, & ISO, ISOKEP, ITRANC, ITSTMP, ITYLCM, IY1, IY2, JSIGS, JSO, & JSS2D, JXS, KSO, KSO1, LMY1, LSO, MAXMIX, NADRX, NBISO, NBISO1, & NBISO2, NBISO2I, NBS1, NCALS, NDATAP, NDATAX, NED2, NISF, NISOP, & NISOT2, NISOTS, NISP, NL, NLAM, NLOC, NMAC, NMIL, NPARL, NPR, & NPRC, NREA, NSURFD, NVDIV CHARACTER TEXT12*12,HSMG*131,HVECT2(MAXREA)*8,NOMREA(MAXREA)*12, 1 LOCTYP(MAXLOC)*4,LOCKEY(MAXLOC)*4,IDVAL(MAXDIV)*4,HHISO*8, 2 NOMMAC(MAXMAC)*8,HRESID*8,HNISO*12 INTEGER ISTATE(NSTATE),DIMSAP(50),INAME(2),IHRES(2) REAL VALDIV(MAXDIV),TMPDAY(3) LOGICAL LUSER,LSPH,LMASL,LSTRD *---- * ALLOCATABLE ARRAYS *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: IMIX2,ITOTM,IRESM,IADRX, 1 ISOTS,LOCAD,ISADRX,LENGDX,LENGDP,IDATA,ISONA,ISOMI,ITOD2,ISTY1, 2 ISTY2,IPIFI,IMICR,ITOD1,JJSO,IPYMIX INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INOMIS,HUSE2,HNAM2,IPYNAM REAL, ALLOCATABLE, DIMENSION(:) :: DENS2,DENS3,VOL2,VOLMI2,SPH, 1 ENER,XVOLM,CONCE,TAUXFI,NWT0,SIGS,SS2D,XS,RVALO,FLUXS,RDATA, 2 SIGSB,SS2DB,XSB,DENIS,GAR1,GAR2,LAMB,CHIRS,BETAR,INVELS,CHIRSB, 3 BETARB,INVELSB,SURF,FMASL REAL, ALLOCATABLE, DIMENSION(:,:) :: DENS1,FACT,YLDS2,DECAY2, 1 SURFLX REAL, ALLOCATABLE, DIMENSION(:,:,:) :: DENS0,FLUX,ADF2 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: YLDSM LOGICAL, ALLOCATABLE, DIMENSION(:) :: LXS,MASK,MASKL CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF *---- * RECOVER THE NUMBER OF DISCONTINUITY FACTORS *---- NSURFD=0 CALL LCMSIX(IPMEM,'geom',1) CALL LCMLEN(IPMEM,'outgeom',ILONG,ITYLCM) IF(ILONG.NE.0) THEN CALL LCMSIX(IPMEM,'outgeom',1) CALL LCMLEN(IPMEM,'SURF',NSURFD,ITYLCM) IF(IMPX.GT.1) THEN WRITE(IOUT,'(42H SCRLIB: number of discontinuity factors =, 1 I4/)') NSURFD ENDIF CALL LCMSIX(IPMEM,' ',2) ENDIF CALL LCMSIX(IPMEM,' ',2) *---- * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(IMIX2(MAXISO),ITOD2(MAXISO),ISTY1(MAXISO),ISTY2(MAXISO), 1 HUSE2(3,MAXISO),HNAM2(3,MAXISO)) ALLOCATE(DENS2(MAXISO),DENS3(MAXISO),VOL2(MAXISO),VOLMI2(NMIX), 1 FLUX(NMIX,NGRP,2),SPH(NGRP),FMASL(NMIX)) ALLOCATE(HADF(NSURFD),ADF2(NMIX,NGRP,NSURFD)) *---- * MICROLIB INITIALIZATION *---- VOLMI2(:NMIX)=0.0 DENS2(:MAXISO)=0.0 VOL2(:MAXISO)=0.0 IMIX2(:MAXISO)=0 ITOD2(:MAXISO)=0 ISTY2(:MAXISO)=0 IF(IACCS.EQ.0) THEN IF(LRES) CALL XABORT('SCRLIB: RES OPTION IS INVALID.') NBISO2=0 NED2=0 TEXT12='L_LIBRARY' CALL LCMPTC(IPLIB,'SIGNATURE',12,TEXT12) ELSE CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) IF(ISTATE(1).NE.NMIX) CALL XABORT('SCRLIB: INVALID NUMBER OF ' 1 //'MATERIAL MIXTURES IN THE MICROLIB.') IF(ISTATE(3).NE.NGRP) CALL XABORT('SCRLIB: INVALID NUMBER OF ' 1 //'ENERGY GROUPS IN THE MICROLIB.') NBISO2=ISTATE(2) IF(NBISO2.GT.MAXISO) CALL XABORT('SCRLIB: MAXISO OVERFLOW(1).') NED2=ISTATE(13) IF(NED2.GT.MAXREA) CALL XABORT('SCRLIB: MAXREA OVERFLOW(1).') CALL LCMLEN(IPLIB,'MIXTURESVOL',ILONG,ITYLCM) IF(ILONG.GT.0) THEN CALL LCMGET(IPLIB,'MIXTURESVOL',VOLMI2) ELSE VOLMI2(:NMIX)=0.0 ENDIF CALL LCMGET(IPLIB,'ISOTOPESUSED',HUSE2) CALL LCMGET(IPLIB,'ISOTOPERNAME',HNAM2) CALL LCMGET(IPLIB,'ISOTOPESDENS',DENS2) CALL LCMGET(IPLIB,'ISOTOPESVOL',VOL2) CALL LCMGET(IPLIB,'ISOTOPESMIX',IMIX2) CALL LCMGET(IPLIB,'ISOTOPESTODO',ITOD2) CALL LCMGET(IPLIB,'ISOTOPESTYPE',ISTY2) IF(NED2.GT.0) CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED2,HVECT2) IF(NSURFD.GT.0) THEN CALL LCMSIX(IPLIB,'MACROLIB',1) CALL LCMLEN(IPLIB,'ADF',ILONG,ITYLCM) IF(ILONG.EQ.0) THEN CALL LCMLIB(IPLIB) CALL XABORT('SCRLIB: UNABLE TO FIND DIRECTORY ADF.') ENDIF CALL LCMSIX(IPLIB,'ADF',1) CALL LCMGTC(IPLIB,'HADF',8,NSURFD,HADF) DO I=1,NSURFD CALL LCMGET(IPLIB,HADF(I),ADF2(1,1,I)) ENDDO CALL LCMSIX(IPLIB,' ',2) CALL LCMSIX(IPLIB,' ',2) ENDIF ENDIF *---- * RECOVER SAPHYB CHARACTERISTICS *---- CALL LCMLEN(IPMEM,'DIMSAP',ILENG,ITYLCM) IF(ILENG.EQ.0) CALL XABORT('SCRLIB: INVALID SAPHYB.') CALL LCMGET(IPMEM,'DIMSAP',DIMSAP) IF(NGRP.NE.DIMSAP(20)) THEN CALL XABORT('SCRLIB: INVALID VALUE OF NGRP.') ENDIF NLAM=DIMSAP(3) ! number of radioactive decay reactions NREA=DIMSAP(4) ! number of neutron-induced reactions NISOP=DIMSAP(5) ! number of particularized isotopes NMAC=DIMSAP(6) ! number of macroscopic sets NMIL=DIMSAP(7) ! number of mixtures in the Saphyb 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) ! maximum number of isotopes in output tables IF(IMPX.GT.1) THEN WRITE(IOUT,'(30H SCRLIB: number of reactions =,I3)') NREA WRITE(IOUT,'(46H SCRLIB: number of radioactive decay reactions, 1 2H =,I3)') NLAM WRITE(IOUT,'(46H SCRLIB: number of neutron-induced reactions =, 1 I3)') NREA WRITE(IOUT,'(44H SCRLIB: number of particularized isotopes =, 1 I4)') NISOP WRITE(IOUT,'(37H SCRLIB: number of macroscopic sets =,I2)') NMAC WRITE(IOUT,'(29H SCRLIB: number of mixtures =,I5)') NMIL WRITE(IOUT,'(36H SCRLIB: number of local variables =,I4)') NPARL WRITE(IOUT,'(33H SCRLIB: number of address sets =,I4)') NADRX WRITE(IOUT,'(33H SCRLIB: number of calculations =,I7)') NCALS WRITE(IOUT,'(34H SCRLIB: number of energy groups =,I4)') NGRP WRITE(IOUT,'(37H SCRLIB: number of precursor groups =,I4)') NPRC WRITE(IOUT,'(46H SCRLIB: maximum number of isotopes in output , 1 8Htables =,I4)') NISOTS ENDIF IF(NREA.GT.MAXREA) CALL XABORT('SCRLIB: MAXREA OVERFLOW(2)') IF(NMAC.GT.MAXMAC) CALL XABORT('SCRLIB: MAXMAC OVERFLOW') *---- * RECOVER INFORMATION FROM constphysiq DIRECTORY. *---- ALLOCATE(ENER(NGRP+1)) CALL LCMSIX(IPMEM,'constphysiq',1) CALL LCMGET(IPMEM,'ENRGS',ENER) CALL LCMSIX(IPMEM,' ',2) DO IGR=1,NGRP+1 ENER(IGR)=ENER(IGR)/1.0E-6 ENDDO CALL LCMPUT(IPLIB,'ENERGY',NGRP+1,2,ENER) DO IGR=1,NGRP ENER(IGR)=LOG(ENER(IGR)/ENER(IGR+1)) ENDDO CALL LCMPUT(IPLIB,'DELTAU',NGRP,2,ENER) DEALLOCATE(ENER) *---- * RECOVER INFORMATION FROM contenu DIRECTORY. *---- ALLOCATE(ITOTM(NMIL),IRESM(NMIL)) CALL LCMSIX(IPMEM,'contenu',1) IREAF=0 IF(NREA.GT.0) THEN CALL LCMGTC(IPMEM,'NOMREA',12,NREA,NOMREA) IF(IMPX.GT.1) THEN WRITE(IOUT,'(29H SCRLIB: Available reactions:/(1X,10A13))') 1 (NOMREA(I),I=1,NREA) ENDIF DO IREA=1,NREA IF(NOMREA(IREA).EQ.'NU*FISSION') THEN IREAF=IREA EXIT ENDIF ENDDO ENDIF CALL LCMGET(IPMEM,'TOTMAC',ITOTM) CALL LCMGET(IPMEM,'RESMAC',IRESM) ALLOCATE(INOMIS(2,NISOP+NMAC),JJSO(NISOP+NMAC)) NBISO1=NISOP IF(NISOP.GT.0) CALL LCMGET(IPMEM,'NOMISO',INOMIS) IF(NMAC.GT.0) THEN CALL LCMLEN(IPMEM,'NOMMAC',ILONG,ITYLCM) IF(ILONG.GT.2*MAXMAC) CALL XABORT('SCRLIB: MAXMAC OVERFLOW') CALL LCMGTC(IPMEM,'NOMMAC',8,NMAC,NOMMAC) HHISO='*MAC*RES' NBISO1=NBISO1+1 READ(HHISO,'(2A4)') (INOMIS(I0,NBISO1),I0=1,2) ENDIF CALL LCMSIX(IPMEM,' ',2) IF(NBISO1.EQ.0) CALL XABORT('SCRLIB: NO CROSS SECTIONS FOUND.') IF(NBISO1.GT.MAXISO) CALL XABORT('SCRLIB: MAXISO OVERFLOW(2).') *---- * RECOVER INFORMATION FROM adresses DIRECTORY. *---- NL=0 IF(NADRX.GT.0) THEN ALLOCATE(IADRX((NREA+2)*(NISOP+NMAC)*NADRX)) CALL LCMSIX(IPMEM,'adresses',1) CALL LCMGET(IPMEM,'ADRX',IADRX) CALL LCMSIX(IPMEM,' ',2) DO IAD=1,NADRX DO ISO=1,NISOP+NMAC IOF=(NREA+2)*(NISOP+NMAC)*(IAD-1)+(NREA+2)*(ISO-1)+NREA+1 NL=MAX(NL,IADRX(IOF)) IOF=(NREA+2)*(NISOP+NMAC)*(IAD-1)+(NREA+2)*(ISO-1)+NREA+2 NL=MAX(NL,IADRX(IOF)) ENDDO ENDDO ENDIF IF(IMPX.GT.1) THEN WRITE(IOUT,'(36H SCRLIB: number of Legendre orders =,I4)') NL ENDIF *---- * RECOVER INFORMATION FROM geom DIRECTORY. *---- CALL LCMSIX(IPMEM,'geom',1) ALLOCATE(XVOLM(NMIL)) CALL LCMGET(IPMEM,'XVOLMT',XVOLM) ALLOCATE(SURFLX(NSURFD,NGRP),SURF(NSURFD)) IF(NSURFD.GT.0) THEN CALL LCMSIX(IPMEM,'outgeom',1) CALL LCMGET(IPMEM,'SURF',SURF) CALL LCMSIX(IPMEM,' ',2) ENDIF CALL LCMSIX(IPMEM,' ',2) *---- * LOOP OVER SAPHYB MIXTURES TO COMPUTE DENS0(NMIL,NCAL,NBISO1) *---- JPMEM=LCMGID(IPMEM,'calc') ALLOCATE(DENS0(NMIL,NCAL,NBISO1)) IF(NISOTS.GT.0) ALLOCATE(ISOTS(NISOTS*2)) DENS0(:NMIL,:NCAL,:NBISO1)=0.0 ALLOCATE(CONCE(NISOTS)) DO 30 IBMOLD=1,NMIL DO ICAL=1,NCAL DO IBM=1,NMIX IF((TERP(ICAL,IBM).NE.0.0).AND.(MIXC(IBM).EQ.IBMOLD)) GO TO 10 ENDDO CYCLE 10 KPMEM=LCMGIL(JPMEM,ICAL) CALL LCMSIX(KPMEM,'info',1) CALL LCMGET(KPMEM,'NISOTS',NISOT2) IF(NISOT2.GT.NISOTS) CALL XABORT('SCRLIB: NISOTS OVERFLOW.') IF(NISOT2.GT.0) CALL LCMGET(KPMEM,'ISOTS',ISOTS) CALL LCMSIX(KPMEM,' ',2) LPMEM=LCMGID(KPMEM,'mili') MPMEM=LCMGIL(LPMEM,IBMOLD) IF(NISOT2.GT.0) THEN CALL LCMGET(MPMEM,'CONCES',CONCE) DO ISO=1,NISOP INAME(1)=INOMIS(1,ISO) INAME(2)=INOMIS(2,ISO) DO IS2=1,NISOT2 ISOKEP=IS2 IF(INAME(1).NE.ISOTS(2*(IS2-1)+1)) CYCLE IF(INAME(2).NE.ISOTS(2*(IS2-1)+2)) CYCLE GO TO 20 ENDDO CYCLE 20 DENS0(IBMOLD,ICAL,ISO)=CONCE(ISOKEP) ENDDO ENDIF ENDDO 30 CONTINUE DEALLOCATE(CONCE) *---- * LOOP OVER MICROLIB MIXTURES *---- YLDS(:MY1,:MY2)=0.0D0 DECAYC(:MD1,:MD2)=0.0D0 VTOT=0.0D0 DO 40 IBM=1,NMIX IBMOLD=MIXC(IBM) IF(IBMOLD.NE.0) VTOT=VTOT+XVOLM(IBMOLD) 40 CONTINUE ALLOCATE(YLDSM(MY1,MY2)) ALLOCATE(ISADRX(NMIL),LENGDX(NMIL),LENGDP(NMIL),ITOD1(NBISO1)) ALLOCATE(TAUXFI(NISOP+NMAC),NWT0(NGRP),SIGS(NGRP*NL*(NISOP+NMAC)), 1 SS2D(NGRP*NGRP*NL*(NISOP+NMAC)),XS(NGRP*NREA*(NISOP+NMAC))) ALLOCATE(LXS(NREA)) ALLOCATE(LAMB(NPRC),CHIRS(NGRP*NPRC),BETAR(NPRC),INVELS(NGRP)) LAMB(:NPRC)=0.0 CHIRS(:NGRP*NPRC)=0.0 BETAR(:NPRC)=0.0 INVELS(:NGRP)=0.0 FMASL(:NMIX)=0.0 ALLOCATE(CHIRSB(NGRP*NPRC),BETARB(NPRC),INVELSB(NGRP)) ALLOCATE(DENS1(NBISO1,NCAL),FACT(NBISO1,NCAL)) JPLIB=LCMLID(IPLIB,'ISOTOPESLIST',(NISOP+NMAC)*NMIX) * DO 180 IBM=1,NMIX IBMOLD=MIXC(IBM) IF(IBMOLD.EQ.0) GO TO 180 IF(NISO(IBM).GT.MAXNIS) CALL XABORT('SCRLIB: MAXNIS OVERFLOW.') VOLMI2(IBM)=XVOLM(IBMOLD) IMAC=ITOTM(IBMOLD) IRES=IRESM(IBMOLD) *---- * RECOVER ITOD1(NBISO1) INDICES. *---- ITOD1(:NBISO1)=0 DO 50 ISO=1,NBISO1 ! Saphyb isotope INAME(1)=INOMIS(1,ISO) INAME(2)=INOMIS(2,ISO) DO KSO=1,NISO(IBM) ! user-selected isotope IF((INAME(1).EQ.HISO(1,IBM,KSO)).AND. 1 (INAME(2).EQ.HISO(2,IBM,KSO))) THEN ITOD1(ISO)=ITODO(IBM,KSO) GO TO 50 ENDIF ENDDO 50 CONTINUE *---- * COMPUTE THE NUMBER DENSITIES OF EACH ELEMENTARY CALCULATION. *---- DENS1(:NBISO1,:NCAL)=0.0 DENS3(:NBISO1)=0.0 DO ICAL=1,NCAL WEIGHT=TERP(ICAL,IBM) IF(WEIGHT.EQ.0.0) CYCLE DO ISO=1,NISOP LUSER=.FALSE. INAME(1)=INOMIS(1,ISO) INAME(2)=INOMIS(2,ISO) KSO1=0 DO KSO=1,NISO(IBM) ! user-selected isotope IF((INAME(1).EQ.HISO(1,IBM,KSO)).AND. 1 (INAME(2).EQ.HISO(2,IBM,KSO))) THEN KSO1=KSO LUSER=(CONC(IBM,KSO1).NE.-99.99) GO TO 60 ENDIF ENDDO 60 IF(LUSER) THEN DENS1(ISO,ICAL)=CONC(IBM,KSO1) CYCLE ENDIF IF(.NOT.LISO(IBM)) CYCLE DENS1(ISO,ICAL)=DENS0(IBMOLD,ICAL,ISO) ENDDO IF(NMAC.GT.0) DENS1(NISOP+1,ICAL)=1.0 DO ISO=1,NBISO1 DENS3(ISO)=DENS3(ISO)+WEIGHT*DENS1(ISO,ICAL) ENDDO ENDDO FACT(:NBISO1,:NCAL)=1.0 IF(.NOT.LPURE) THEN DO ICAL=1,NCAL IF(TERP(ICAL,IBM).EQ.0.0) CYCLE DO ISO=1,NBISO1 IF(DENS3(ISO).GT.DENS1(ISO,ICAL)*1.0E-9) THEN FACT(ISO,ICAL)=DENS1(ISO,ICAL)/DENS3(ISO) ENDIF ENDDO ENDDO ENDIF *---- * INITIALIZE WORKING ARRAYS. *---- TAUXFI(:NBISO1)=0.0 NWT0(:NGRP)=0.0 SIGS(:NGRP*NL*NBISO1)=0.0 SS2D(:NGRP*NGRP*NL*NBISO1)=0.0 XS(:NGRP*NREA*NBISO1)=0.0 LXS(:NREA)=.FALSE. YLDSM(:MY1,:MY2)=0.0D0 *---- * MAIN LOOP OVER ELEMENTARY CALCULATIONS *---- TEXT12='*MAC*RES' READ(TEXT12,'(2A4)') IHRES(1),IHRES(2) LSTRD=.FALSE. B2SAP=B2 DO 80 ICAL=1,NCAL WEIGHT=TERP(ICAL,IBM) IF(WEIGHT.EQ.0.0) GO TO 80 *---- * RECOVER INFORMATION FROM caldir DIRECTORY. *---- KPMEM=LCMGIL(JPMEM,ICAL) IF(NPRC.GT.0) THEN CHIRSB(:NGRP*NPRC)=0.0 BETARB(:NPRC)=0.0 INVELSB(:NGRP)=0.0 ENDIF CALL LCMSIX(KPMEM,'info',1) LSPH=.FALSE. LMASL=.FALSE. IF(NPARL.GT.0) THEN CALL LCMGET(KPMEM,'NLOC',NLOC) IF(NLOC.GT.MAXLOC) CALL XABORT('SCRLIB: MAXLOC OVERFLOW') CALL LCMGTC(KPMEM,'LOCTYP',4,NLOC,LOCTYP) CALL LCMGTC(KPMEM,'LOCKEY',4,NLOC,LOCKEY) ALLOCATE(LOCAD(NLOC+1)) CALL LCMGET(KPMEM,'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,'(46HSCRLIB: 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,'(46HSCRLIB: UNABLE TO FIND A LOCAL PARAMETER SET O, 1 25HF TYPE MASL WITH KEYWORD ,A4,1H.)') HMASL CALL XABORT(HSMG) ENDIF CALL LCMGET(KPMEM,'ISADRX',ISADRX) CALL LCMGET(KPMEM,'LENGDX',LENGDX) CALL LCMGET(KPMEM,'LENGDP',LENGDP) CALL LCMGET(KPMEM,'NISF',NISF) IF(NISF+NMAC.NE.MY1) CALL XABORT('SCRLIB: MY1 ERROR') CALL LCMGET(KPMEM,'NISP',NISP) IF(NISP.NE.MY2) CALL XABORT('SCRLIB: MY2 ERROR') CALL LCMGET(KPMEM,'NISOTS',NISOT2) IF(NISOT2.GT.NISOTS) CALL XABORT('SCRLIB: NISOTS OVERFLOW.') IF(NISOT2.GT.0) CALL LCMGET(KPMEM,'ISOTS',ISOTS) CALL LCMSIX(KPMEM,' ',2) CALL LCMSIX(KPMEM,'divers',1) CALL LCMLEN(KPMEM,'NVDIV',ILENG,ITYLCM) IF(ILENG.EQ.0) THEN NVDIV=0 ELSE CALL LCMGET(KPMEM,'NVDIV',NVDIV) ENDIF IF(NVDIV.GT.0) THEN IF(NVDIV.GT.MAXDIV) CALL XABORT('SCRLIB: MAXDIV OVERFLOW.') CALL LCMGTC(KPMEM,'IDVAL',4,NVDIV,IDVAL) CALL LCMGET(KPMEM,'VALDIV',VALDIV) DO I=1,NVDIV IF(IMPX.GT.3) THEN WRITE(IOUT,'(9H SCRLIB: ,I3,2X,A,1H=,1P,E13.5)') I,IDVAL(I), 1 VALDIV(I) ENDIF IF(IDVAL(I).EQ.'B2') B2SAP=VALDIV(I) ENDDO ENDIF * CALL LCMLEN(KPMEM,'NPR',ILONG,ITYLCM) IF((NPRC.GT.0).AND.(ILONG.EQ.1)) THEN CALL LCMGET(KPMEM,'NPR',NPR) IF(NPR.NE.NPRC) CALL XABORT('SCRLIB: NPR INCONSISTENCY(1).') CALL LCMGET(KPMEM,'LAMBRS',LAMB) CALL LCMGET(KPMEM,'CHIRS',CHIRSB) CALL LCMGET(KPMEM,'BETARS',BETARB) CALL LCMGET(KPMEM,'INVELS',INVELSB) ENDIF CALL LCMSIX(KPMEM,' ',2) *---- * SELECT SAPHYB MIXTURE IBMOLD. *---- IF(NADRX.EQ.0) CALL XABORT('SCRLIB: NO ADDRESS SETS AVAILABLE.') LPMEM=LCMGID(KPMEM,'mili') MPMEM=LCMGIL(LPMEM,IBMOLD) SPH(:NGRP)=1.0 IF(LSPH) THEN ALLOCATE(RVALO(LOCAD(NLOC+1)-1)) CALL LCMGET(MPMEM,'RVALOC',RVALO) DO ILOC=1,NLOC IF((LOCTYP(ILOC).EQ.'EQUI').AND.(LOCKEY(ILOC).EQ.HEQUI)) THEN IF(LOCAD(ILOC+1)-LOCAD(ILOC).NE.NGRP) THEN CALL XABORT('SCRLIB: INVALID NUMBER OF COMPONENTS FOR ' 1 //'SPH FACTORS') ENDIF DO IGR=1,NGRP SPH(IGR)=RVALO(LOCAD(ILOC)+IGR-1) ENDDO ENDIF ENDDO DEALLOCATE(RVALO) ENDIF IF(LMASL) THEN ALLOCATE(RVALO(LOCAD(NLOC+1)-1)) CALL LCMGET(MPMEM,'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('SCRLIB: INVALID NUMBER OF COMPONENTS FOR ' 1 //'MASL') ENDIF FMASL(IBM)=FMASL(IBM)+WEIGHT*RVALO(LOCAD(ILOC)) ENDIF ENDDO DEALLOCATE(RVALO) ENDIF IF(NPARL.GT.0) DEALLOCATE(LOCAD) IAD=ISADRX(IBMOLD) NDATAX=LENGDX(IBMOLD) NDATAP=LENGDP(IBMOLD) ALLOCATE(FLUXS(NGRP),RDATA(NDATAX),IDATA(NDATAP)) CALL LCMGET(MPMEM,'FLUXS',FLUXS) CALL LCMGET(MPMEM,'RDATAX',RDATA) CALL LCMGET(MPMEM,'IDATAP',IDATA) DO I=1,NGRP FLUXS(I)=FLUXS(I)/XVOLM(IBMOLD) NWT0(I)=NWT0(I)+WEIGHT*FLUXS(I)/SPH(I) ENDDO ALLOCATE(SIGSB(NGRP*NL),SS2DB(NGRP*NGRP*NL),XSB(NGRP*NREA)) IF(NISOP.NE.0) THEN DO ISO=1,NISOP FACT0=FACT(ISO,ICAL) JXS=(ISO-1)*NGRP*NREA JSIGS=(ISO-1)*NGRP*NL JSS2D=(ISO-1)*NGRP*NGRP*NL CALL SPHSXS(NREA,NISOP+NMAC,NADRX,NGRP,NL,NDATAX,NDATAP, 1 ISO,IAD,IADRX,RDATA,IDATA,NOMREA,SIGSB,SS2DB,XSB,LXS) CALL SCRSXS(NGRP,NL,NREA,IREAF,NOMREA,LXS,B2SAP,FACT0, 1 WEIGHT,SPH,FLUXS,XSB,SIGSB,SS2DB,LPURE,XS(JXS+1), 2 SIGS(JSIGS+1),SS2D(JSS2D+1),TAUXFI(ISO)) ENDDO IF(IRES.NE.0) THEN FACT0=1.0 JXS=NISOP*NGRP*NREA JSIGS=NISOP*NGRP*NL JSS2D=NISOP*NGRP*NGRP*NL CALL SPHSXS(NREA,NISOP+NMAC,NADRX,NGRP,NL,NDATAX,NDATAP, 1 NISOP+IRES,IAD,IADRX,RDATA,IDATA,NOMREA,SIGSB,SS2DB,XSB,LXS) CALL SCRSXS(NGRP,NL,NREA,IREAF,NOMREA,LXS,B2SAP,FACT0, 1 WEIGHT,SPH,FLUXS,XSB,SIGSB,SS2DB,LPURE,XS(JXS+1), 2 SIGS(JSIGS+1),SS2D(JSS2D+1),TAUXFI(NISOP+1)) ENDIF ELSE IF(IMAC.NE.0) THEN FACT0=1.0 JXS=NISOP*NGRP*NREA JSIGS=NISOP*NGRP*NL JSS2D=NISOP*NGRP*NGRP*NL CALL SPHSXS(NREA,NISOP+NMAC,NADRX,NGRP,NL,NDATAX,NDATAP, 1 NISOP+IMAC,IAD,IADRX,RDATA,IDATA,NOMREA,SIGSB,SS2DB,XSB,LXS) CALL SCRSXS(NGRP,NL,NREA,IREAF,NOMREA,LXS,B2SAP,FACT0,WEIGHT, 1 SPH,FLUXS,XSB,SIGSB,SS2DB,LPURE,XS(JXS+1),SIGS(JSIGS+1), 2 SS2D(JSS2D+1),TAUXFI(NISOP+1)) ELSE CALL XABORT('SCRLIB: NO MACROSCOPIC SET.') ENDIF DEALLOCATE(XSB,SS2DB,SIGSB,IDATA,RDATA,FLUXS) * CALL LCMLEN(MPMEM,'cinetique',ILONG,ITYLCM) IF((NPRC.GT.0).AND.(ILONG.NE.0)) THEN CALL LCMSIX(MPMEM,'cinetique',1) CALL LCMGET(MPMEM,'NPR',NPR) IF(NPR.NE.NPRC) CALL XABORT('SCRLIB: NPR INCONSISTENCY(2).') CALL LCMGET(MPMEM,'LAMBRS',LAMB) CALL LCMGET(MPMEM,'CHIRS',CHIRSB) CALL LCMGET(MPMEM,'BETARS',BETARB) CALL LCMGET(MPMEM,'INVELS',INVELSB) CALL LCMSIX(MPMEM,' ',2) ENDIF IF(NPRC.GT.0) THEN DO IGR=1,NGRP INVELS(IGR)=INVELS(IGR)+SPH(IGR)*WEIGHT*INVELSB(IGR) DO IPRC=1,NPRC IOF=(IPRC-1)*NGRP+IGR CHIRS(IOF)=CHIRS(IOF)+WEIGHT*CHIRSB(IOF) ENDDO ENDDO DO IPRC=1,NPRC BETAR(IPRC)=BETAR(IPRC)+WEIGHT*BETARB(IPRC) ENDDO ENDIF *---- * COMPUTE DEPLETION CHAIN DATA *---- IF(MY1*MY2.GT.0) THEN CALL LCMLEN(MPMEM,'YLDS',ILONG,ITYLCM) IF(ILONG.NE.MY1*MY2) CALL XABORT('SCRLIB: BAD YLDS.') ALLOCATE(YLDS2(MY1,MY2)) CALL LCMGET(MPMEM,'YLDS',YLDS2) DO IY1=1,MY1 DO IY2=1,MY2 YLDSM(IY1,IY2)=YLDSM(IY1,IY2)+WEIGHT*YLDS2(IY1,IY2) YLDS(IY1,IY2)=YLDS(IY1,IY2)+WEIGHT*YLDS2(IY1,IY2)* > VOLMI2(IBM)/VTOT ENDDO ENDDO DEALLOCATE(YLDS2) ENDIF IF((MD1*MD2.GT.0).AND.(NISOT2.GT.0)) THEN CALL LCMLEN(MPMEM,'DECAYC',ILONG,ITYLCM) IF(ILONG.NE.NLAM*NISOT2) CALL XABORT('SCRLIB: BAD DECAYC.') ALLOCATE(DECAY2(NLAM,NISOT2)) CALL LCMGET(MPMEM,'DECAYC',DECAY2) DO ISO=1,NISOP INAME(1)=INOMIS(1,ISO) INAME(2)=INOMIS(2,ISO) DO IS2=1,NISOT2 ISOKEP=IS2 IF(INAME(1).NE.ISOTS(2*(IS2-1)+1)) CYCLE IF(INAME(2).NE.ISOTS(2*(IS2-1)+2)) CYCLE GO TO 70 ENDDO CYCLE 70 DO ID1=1,NLAM DECAYC(ID1,ISO)=DECAYC(ID1,ISO)+WEIGHT*DECAY2(ID1,ISOKEP)* > VOLMI2(IBM)/VTOT ENDDO ENDDO DEALLOCATE(DECAY2) ENDIF 80 CONTINUE ! end of loop over elementary calculations. *---- * IDENTIFY SPECIAL FLUX EDITS *---- 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).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 DO 90 IED2=1,NED2 IF(HVECT2(IED2).EQ.NOMREA(IREA)(:8)) GO TO 100 IF(HVECT2(IED2).EQ.'NFTOT') GO TO 100 90 CONTINUE NED2=NED2+1 IF(NED2.GT.MAXREA) CALL XABORT('SCRLIB: MAXREA OVERFLOW(3).') IF(NOMREA(IREA).EQ.'FISSION') THEN HVECT2(NED2)='NFTOT' ELSE HVECT2(NED2)=NOMREA(IREA)(:8) ENDIF 100 CONTINUE ENDDO *---- * SET FLAG LSTRD *---- LSTRD=.TRUE. DO IREA=1,NREA IF(NOMREA(IREA).EQ.'FUITES') THEN IF(LXS(IREA).AND.(B2SAP.NE.0.0)) LSTRD=.FALSE. EXIT ENDIF ENDDO *---- * SAVE CROSS SECTIONS IN MICROLIB FOR MIXTURE IBM *---- ISTY1(:NBISO1)=0 JJSO(:NBISO1)=0 NBISO2I=NBISO2 IF(NISOP.NE.0) THEN HRESID=' ' DO ISO=1,NISOP JXS=(ISO-1)*NGRP*NREA JSIGS=(ISO-1)*NGRP*NL JSS2D=(ISO-1)*NGRP*NGRP*NL INAME(1)=INOMIS(1,ISO) INAME(2)=INOMIS(2,ISO) CALL SCRFND(MAXISO,NBISO2I,NBISO2,INAME,IBM,HRESID,HUSE2, 1 HNAM2,IMIX2,JJSO(ISO)) KPLIB=LCMDIL(JPLIB,JJSO(ISO)) ! step up isot JJSO(ISO) CALL SCRISO(KPLIB,NREA,NGRP,NL,NPRC,NOMREA,NWT0,XS(JXS+1), 1 SIGS(JSIGS+1),SS2D(JSS2D+1),TAUXFI(ISO),LXS,LAMB,CHIRS,BETAR, 2 INVELS,INAME,LSTRD,LPURE,ILUPS,ITRANC,IFISS) IF(MY1*MY2.GT.0) CALL SCRNDF(IMPX,NISOP+NMAC,ISO,IBM,INOMIS, 1 IPMEM,KPLIB,NCAL,TERP(1,IBM),MY1,MY2,YLDSM,ISTY1(ISO)) ENDDO IF(IRES.NE.0) THEN HRESID=NOMMAC(IRES) JXS=NISOP*NGRP*NREA JSIGS=NISOP*NGRP*NL JSS2D=NISOP*NGRP*NGRP*NL CALL SCRFND(MAXISO,NBISO2I,NBISO2,IHRES,IBM,HRESID,HUSE2, 1 HNAM2,IMIX2,JJSO(NISOP+1)) KPLIB=LCMDIL(JPLIB,JJSO(NISOP+1)) ! step up isot JJSO(NISOP+1) CALL SCRISO(KPLIB,NREA,NGRP,NL,NPRC,NOMREA,NWT0,XS(JXS+1), 1 SIGS(JSIGS+1),SS2D(JSS2D+1),TAUXFI(NISOP+1),LXS,LAMB,CHIRS, 2 BETAR,INVELS,IHRES,LSTRD,LPURE,ILUPS,ITRANC,IFISS) IF(MY1*MY2.GT.0) CALL SCRNDF(IMPX,NISOP+NMAC,NISOP+IRES, 1 IBM,INOMIS,IPMEM,KPLIB,NCAL,TERP(1,IBM),MY1,MY2,YLDSM, 2 ISTY1(NISOP+IRES)) ENDIF ELSE IF(IMAC.NE.0) THEN HRESID=NOMMAC(IMAC) JXS=NISOP*NGRP*NREA JSIGS=NISOP*NGRP*NL JSS2D=NISOP*NGRP*NGRP*NL CALL SCRFND(MAXISO,NBISO2I,NBISO2,IHRES,IBM,HRESID,HUSE2,HNAM2, 1 IMIX2,JJSO(1)) KPLIB=LCMDIL(JPLIB,JJSO(1)) ! step up isot JJSO(1) CALL SCRISO(KPLIB,NREA,NGRP,NL,NPRC,NOMREA,NWT0,XS(JXS+1), 1 SIGS(JSIGS+1),SS2D(JSS2D+1),TAUXFI(NISOP+1),LXS,LAMB,CHIRS, 2 BETAR,INVELS,IHRES,LSTRD,LPURE,ILUPS,ITRANC,IFISS) ENDIF *---- * SET NUMBER DENSITIES AND VOLUMES IN OUTPUT MICROLIB *---- IF(LRES) THEN * -- Number densities are left unchanged except if they are * -- listed in HISO array. DO 110 KSO=1,NISO(IBM) ! user-selected isotope DO JSO=1,NBISO2 ! microlib isotope IF(IMIX2(JSO).NE.IBM) CYCLE IF((HISO(1,IBM,KSO).EQ.HUSE2(1,JSO)).AND. 1 (HISO(2,IBM,KSO).EQ.HUSE2(2,JSO))) THEN ITOD2(JSO)=ITODO(IBM,KSO) IF(CONC(IBM,KSO).EQ.-99.99) THEN * -- Only number densities of isotopes set with "MICR" and * -- "*" keywords are interpolated DENS2(JSO)=0.0 DO ISO=1,NBISO1 ! Saphyb isotope IF(JJSO(ISO).EQ.JSO) DENS2(JSO)=DENS2(JSO)+DENS3(ISO) ENDDO ELSE IF(CONC(IBM,KSO).NE.-99.99) THEN * -- Number densities of isotopes set with "MICR" and * -- fixed value are forced to this value DENS2(JSO)=CONC(IBM,KSO) ENDIF GO TO 110 ENDIF ENDDO WRITE(HSMG,'(31HSCRLIB: UNABLE TO FIND ISOTOPE ,2A4,6H IN MI, 1 5HXTURE,I8,1H.)') HISO(1,IBM,KSO),HISO(2,IBM,KSO),IBM CALL XABORT(HSMG) 110 CONTINUE ELSE * -- Number densities are interpolated or not according to * -- ALL/ONLY option DO JSO=1,NBISO2 ! microlib isotope IF(IBM.EQ.IMIX2(JSO)) THEN DO ISO=1,NBISO1 ! Saphyb isotope IF((INOMIS(1,ISO).EQ.HUSE2(1,JSO)).AND. 1 (INOMIS(2,ISO).EQ.HUSE2(2,JSO))) THEN DENS2(JSO)=0.0 VOL2(JSO)=0.0 CYCLE ENDIF ENDDO ENDIF ENDDO DO 130 ISO=1,NBISO1 ! Saphyb isotope INAME(1)=INOMIS(1,ISO) INAME(2)=INOMIS(2,ISO) IF(.NOT.LISO(IBM)) THEN * --ONLY option DO KSO=1,NISO(IBM) ! user-selected isotope IF((INAME(1).EQ.HISO(1,IBM,KSO)).AND. 1 (INAME(2).EQ.HISO(2,IBM,KSO))) GO TO 120 ENDDO GO TO 130 ENDIF 120 JSO=JJSO(ISO) IF(JSO.GT.0) THEN ITOD2(JSO)=ITOD1(ISO) ISTY2(JSO)=ISTY1(ISO) DENS2(JSO)=DENS2(JSO)+DENS3(ISO) VOL2(JSO)=VOL2(JSO)+XVOLM(IBMOLD) ENDIF 130 CONTINUE ENDIF *---- * SET PIFI INFORMATION *---- ALLOCATE(IMICR(NBISO1)) IMICR(:NBISO1)=0 NBS1=0 DO 140 JSO=1,NBISO2 ! microlib isotope IF(IMIX2(JSO).EQ.IBM) THEN NBS1=NBS1+1 IF(NBS1.GT.NBISO1) CALL XABORT('SCRLIB: NBISO1 OVERFLOW.') IMICR(NBS1)=JSO ENDIF 140 CONTINUE DO 170 ISO=1,NBS1 ! Saphyb isotope JSO=IMICR(ISO) KPLIB=LCMDIL(JPLIB,JSO) ! step up isot JSO CALL LCMLEN(KPLIB,'PYIELD',LMY1,ITYLCM) IF(LMY1.GT.0) THEN ALLOCATE(IPYNAM(2,LMY1),IPYMIX(LMY1),IPIFI(LMY1)) IPIFI(:LMY1)=0 CALL LCMGET(KPLIB,'PYNAM',IPYNAM) CALL LCMGET(KPLIB,'PYMIX',IPYMIX) DO 160 IY1=1,LMY1 INAME(1)=IPYNAM(1,IY1) INAME(2)=IPYNAM(2,IY1) WRITE(HNISO,'(2A4)') (INAME(I0),I0=1,2) IF(HNISO.NE.' ') THEN DO 150 KSO=1,NBS1 LSO=IMICR(KSO) IF((INAME(1).EQ.HUSE2(1,LSO)).AND.(INAME(2).EQ.HUSE2(2,LSO)) 1 .AND.(IPYMIX(IY1).EQ.IMIX2(LSO))) THEN IPIFI(IY1)=LSO GO TO 160 ENDIF 150 CONTINUE IF(IPIFI(IY1).EQ.0) THEN WRITE(HSMG,'(40HSCRLIB: FAILURE TO FIND FISSILE ISOTOPE , 1 A12,25H AMONG MICROLIB ISOTOPES.)') HNISO CALL XABORT(HSMG) ENDIF ENDIF 160 CONTINUE CALL LCMPUT(KPLIB,'PIFI',LMY1,1,IPIFI) DEALLOCATE(IPIFI,IPYMIX,IPYNAM) ENDIF 170 CONTINUE DEALLOCATE(IMICR) 180 CONTINUE ! end of loop over microlib mixtures. *---- * RELEASE MEMORY *---- DEALLOCATE(FACT,DENS1) DEALLOCATE(INVELSB,BETARB,CHIRSB) DEALLOCATE(INVELS,BETAR,CHIRS,LAMB) DEALLOCATE(LXS) DEALLOCATE(XS,SS2D,SIGS,NWT0,TAUXFI) DEALLOCATE(ITOD1,LENGDP,LENGDX,ISADRX) DEALLOCATE(YLDSM) IF(NISOTS.GT.0) DEALLOCATE(ISOTS) IF(NADRX.GT.0) DEALLOCATE(IADRX) DEALLOCATE(DENS0,XVOLM,JJSO,INOMIS,IRESM,ITOTM) *---- * MICROLIB FINALIZATION *---- IF(.NOT.LRES) THEN ISTATE(:NSTATE)=0 ISTATE(1)=NMIX ISTATE(2)=NBISO2 ISTATE(3)=NGRP ISTATE(4)=NL ISTATE(5)=ITRANC ISTATE(7)=1 IF(ITER.EQ.3) ISTATE(12)=NMIX ISTATE(13)=NED2 ISTATE(14)=NMIX ISTATE(18)=1 ISTATE(19)=NPRC ISTATE(20)=MY1 ISTATE(22)=MAXISO/NMIX IF(NSURFD.GT.0) ISTATE(24)=2 ! ADF information IF(NBISO2.EQ.0) CALL XABORT('SCRLIB: NBISO2=0.') CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) CALL LCMPUT(IPLIB,'MIXTURESVOL',NMIX,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,'ISOTOPESVOL',NBISO2,2,VOL2) IF(NED2.GT.0) CALL LCMPTC(IPLIB,'ADDXSNAME-P0',8,NED2,HVECT2) CALL LCMPUT(IPLIB,'ISOTOPESTODO',NBISO2,1,ITOD2) CALL LCMPUT(IPLIB,'ISOTOPESTYPE',NBISO2,1,ISTY2) ELSE IF(LRES.AND.(NISOP.GT.0)) THEN CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO2,2,DENS2) CALL LCMPUT(IPLIB,'ISOTOPESVOL',NBISO2,2,VOL2) ENDIF IF(IMPX.GT.5) CALL LCMLIB(IPLIB) IACCS=1 *---- * COMPUTE THE MACROSCOPIC X-SECTIONS *---- IF((ITER.NE.0).AND.(ITER.NE.3)) GO TO 280 CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) MAXMIX=ISTATE(1) IF(MAXMIX.NE.NMIX) CALL XABORT('SCRLIB: INVALID NMIX.') NBISO=ISTATE(2) ALLOCATE(MASK(MAXMIX),MASKL(NGRP)) ALLOCATE(ISONA(3*NBISO),ISOMI(NBISO),DENIS(NBISO)) CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONA) CALL LCMGET(IPLIB,'ISOTOPESMIX',ISOMI) CALL LCMGET(IPLIB,'ISOTOPESDENS',DENIS) MASK(:MAXMIX)=.TRUE. MASKL(:NGRP)=.TRUE. ITSTMP=0 TMPDAY(1)=0.0 TMPDAY(2)=0.0 TMPDAY(3)=0.0 CALL LCMLEN(IPLIB,'MACROLIB',ILONG,ITYLCM) IF(ILONG.NE.0) CALL LCMDEL(IPLIB,'MACROLIB') CALL LIBMIX(IPLIB,MAXMIX,NGRP,NBISO,ISONA,ISOMI,DENIS,MASK,MASKL, 1 ITSTMP,TMPDAY) DEALLOCATE(MASKL,MASK) DEALLOCATE(DENIS,ISOMI,ISONA) IF(NSURFD.GT.0) THEN CALL LCMSIX(IPLIB,'MACROLIB',1) CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) ISTATE(12)=2 CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) CALL LCMSIX(IPLIB,' ',2) ENDIF *---- * SAVE MASL INFORMATION *---- IF(HMASL.NE.' ') THEN CALL LCMSIX(IPLIB,'MACROLIB',1) CALL LCMPUT(IPLIB,'MASL',NMIX,2,FMASL) CALL LCMSIX(IPLIB,' ',2) ENDIF *---- * INCLUDE LEAKAGE IN THE MACROLIB (USED ONLY FOR NON-REGRESSION TESTS) *---- IF(B2.NE.0.0) THEN IF(IMPX.GT.0) WRITE(IOUT,'(/31H SCRLIB: INCLUDE LEAKAGE IN THE, 1 14H MACROLIB (B2=,1P,E12.5,2H).)') B2 CALL LCMSIX(IPLIB,'MACROLIB',1) JPLIB=LCMGID(IPLIB,'GROUP') ALLOCATE(GAR1(NMIX),GAR2(NMIX)) DO 270 IGR=1,NGRP KPLIB=LCMGIL(JPLIB,IGR) CALL LCMGET(KPLIB,'NTOT0',GAR1) CALL LCMGET(KPLIB,'DIFF',GAR2) DO 260 IBM=1,NMIX IF(MIXC(IBM).NE.0) GAR1(IBM)=GAR1(IBM)+B2*GAR2(IBM) 260 CONTINUE CALL LCMPUT(KPLIB,'NTOT0',NMIX,2,GAR1) 270 CONTINUE DEALLOCATE(GAR2,GAR1) CALL LCMSIX(IPLIB,' ',2) ENDIF *---- * PROCESS ADF INFORMATION *---- 280 IF(NSURFD.GT.0) THEN DO 285 IBM=1,NMIX ! mixtures in Macrolib IF(MIXC(IBM).NE.0) ADF2(IBM,:NGRP,:NSURFD)=0.0 285 CONTINUE DO 300 ICAL=1,NCAL DO 290 IBM=1,NMIX ! mixtures in Macrolib IF(MIXC(IBM).EQ.0) GO TO 290 WEIGHT=TERP(ICAL,IBM) IF(WEIGHT.EQ.0.0) GO TO 290 KPMEM=LCMGIL(JPMEM,ICAL) CALL LCMSIX(KPMEM,'outflx',1) CALL LCMGET(KPMEM,'SURFLX',SURFLX) CALL LCMSIX(KPMEM,' ',2) CALL LCMSIX(KPMEM,' ',2) DO I=1,NSURFD WRITE(HADF(I),'(3HFD_,I5.5)') I DO IGR=1,NGRP ADF2(IBM,IGR,I)=ADF2(IBM,IGR,I)+WEIGHT*SURFLX(I,IGR)/SURF(I) ENDDO ENDDO 290 CONTINUE 300 CONTINUE CALL LCMSIX(IPLIB,'MACROLIB',1) CALL LCMSIX(IPLIB,'ADF',1) CALL LCMPUT(IPLIB,'NTYPE',1,1,NSURFD) CALL LCMPTC(IPLIB,'HADF',8,NSURFD,HADF) DO I=1,NSURFD CALL LCMPUT(IPLIB,HADF(I),NMIX*NGRP,2,ADF2(1,1,I)) ENDDO CALL LCMSIX(IPLIB,' ',2) CALL LCMSIX(IPLIB,' ',2) DEALLOCATE(ADF2,HADF) ENDIF *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(SURFLX,SURF) DEALLOCATE(ADF2,HADF) DEALLOCATE(FMASL,SPH,FLUX,VOLMI2,VOL2,DENS3,DENS2) DEALLOCATE(HNAM2,HUSE2,ISTY2,ISTY1,ITOD2,IMIX2) RETURN END