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 --- Donjon/src/SCRLIB.f | 1052 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1052 insertions(+) create mode 100644 Donjon/src/SCRLIB.f (limited to 'Donjon/src/SCRLIB.f') diff --git a/Donjon/src/SCRLIB.f b/Donjon/src/SCRLIB.f new file mode 100644 index 0000000..5b98de3 --- /dev/null +++ b/Donjon/src/SCRLIB.f @@ -0,0 +1,1052 @@ +*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 -- cgit v1.2.3