diff options
Diffstat (limited to 'Donjon/src/SCRSPH.f')
| -rw-r--r-- | Donjon/src/SCRSPH.f | 728 |
1 files changed, 728 insertions, 0 deletions
diff --git a/Donjon/src/SCRSPH.f b/Donjon/src/SCRSPH.f new file mode 100644 index 0000000..e99385a --- /dev/null +++ b/Donjon/src/SCRSPH.f @@ -0,0 +1,728 @@ +*DECK SCRSPH + SUBROUTINE SCRSPH(IPMEM,IPMAC,ICAL,IMPX,HEQUI,HMASL,NMIL,NGROUP, + > ILUPS,SPH,B2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Extract a Macrolib corresponding to an elementary calculation in a +* memory-resident 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 +* IPMEM pointer to the memory-resident Saphyb object. +* 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 + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMEM,IPMAC + INTEGER ICAL,IMPX,NMIL,NGROUP,ILUPS + REAL SPH(NMIL,NGROUP),B2 + CHARACTER HEQUI*4,HMASL*4 +*---- +* LOCAL VARIABLES +*---- + INTEGER, PARAMETER::IOUT=6 + INTEGER, PARAMETER::MAXDIV=3 + INTEGER, PARAMETER::MAXLOC=10 + INTEGER, PARAMETER::MAXREA=25 + INTEGER, PARAMETER::MAXMAC=2 + INTEGER, PARAMETER::NSTATE=40 + REAL DEN,FF,CSCAT + INTEGER I, J, IR, I0, IAD, IBM, IDF, IFISS, IGMAX, IGMIN, IGR, IL, + & ILENG, ILOC, ILONG, IMAC, INDX, IPOSDE, IPRC, IREA, IRES, IS2, + & ISO, ISOKEP, ITRANC, ITYLCM, JGR, NADRX, NCALS, NDATAP, NDATAX, + & NED, NISO, NISOTS, NL, NW, NLOC, NMAC, NPARL, NPR, NPRC, NREA, + & NSURFD, NVDIV, IRENT0, IRENT1 + 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,JPMEM,KPMEM,LPMEM,MPMEM +*---- +* 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(IPMEM,'DIMSAP',ILENG,ITYLCM) + IF(ILENG.EQ.0) CALL XABORT('SCRSPH: INVALID SAPHYB.') + CALL LCMGET(IPMEM,'DIMSAP',DIMSAP) + IF(NMIL.NE.DIMSAP(7)) THEN + CALL XABORT('SCRSPH: INVALID VALUE OF NMIL.') + ELSE IF(NGROUP.NE.DIMSAP(20)) THEN + CALL XABORT('SCRSPH: 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(IOUT,'(30H SCRSPH: number of reactions =,I3)') NREA + WRITE(IOUT,'(44H SCRSPH: number of particularized isotopes =, + 1 I4)') NISO + WRITE(IOUT,'(37H SCRSPH: number of macroscopic sets =,I2)') NMAC + WRITE(IOUT,'(29H SCRSPH: number of mixtures =,I5)') NMIL + WRITE(IOUT,'(36H SCRSPH: number of local variables =,I4)') NPARL + WRITE(IOUT,'(33H SCRSPH: number of address sets =,I4)') NADRX + WRITE(IOUT,'(33H SCRSPH: number of calculations =,I5)') NCALS + WRITE(IOUT,'(34H SCRSPH: number of energy groups =,I4)') NGROUP + WRITE(IOUT,'(37H SCRSPH: number of precursor groups =,I4)') NPRC + WRITE(IOUT,'(46H SCRSPH: number of isotopes in output tables =, + 1 I4)') NISOTS + ENDIF + IF(NREA.GT.MAXREA) CALL XABORT('SCRSPH: MAXREA OVERFLOW') + IF(NMAC.GT.MAXMAC) CALL XABORT('SCRSPH: MAXMAC OVERFLOW') + INDX=NISO+NMAC + IF(INDX.EQ.0) CALL XABORT('SCRSPH: NO CROSS SECTIONS FOUND.') +*---- +* RECOVER INFORMATION FROM constphysiq DIRECTORY. +*---- + ALLOCATE(ENER(NGROUP+1)) + CALL LCMSIX(IPMEM,'constphysiq',1) + CALL LCMGET(IPMEM,'ENRGS',ENER) + CALL LCMSIX(IPMEM,' ',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(IPMEM,'contenu',1) + IF(NREA.GT.0) THEN + CALL LCMGTC(IPMEM,'NOMREA',12,NREA,NOMREA) + IF(IMPX.GT.1) THEN + WRITE(IOUT,'(29H SCRSPH: Available reactions:/(1X,10A13))') + 1 (NOMREA(I),I=1,NREA) + ENDIF + ENDIF + CALL LCMGET(IPMEM,'TOTMAC',TOTM) + CALL LCMGET(IPMEM,'RESMAC',RESM) + IF(NISO.GT.0) THEN + ALLOCATE(NOMISO(NISO*2)) + CALL LCMGET(IPMEM,'NOMISO',NOMISO) + ENDIF + CALL LCMSIX(IPMEM,' ',2) +*---- +* RECOVER INFORMATION FROM adresses DIRECTORY. +*---- + NL=0 + IF(NADRX.GT.0) THEN + ALLOCATE(IADRX((NREA+2),(NISO+NMAC),NADRX)) + CALL LCMSIX(IPMEM,'adresses',1) + CALL LCMGET(IPMEM,'ADRX',IADRX) + CALL LCMSIX(IPMEM,' ',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(IOUT,'(36H SCRSPH: number of legendre orders =,I4)') NL + ENDIF +*---- +* RECOVER INFORMATION FROM geom DIRECTORY. +*---- + NSURFD=0 + CALL LCMSIX(IPMEM,'geom',1) + ALLOCATE(XVOLM(NMIL)) + CALL LCMGET(IPMEM,'XVOLMT',XVOLM) + CALL LCMGTC(IPMEM,'NOMMIL',20,NMIL,NOMMIL) + 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 SCRSPH: number of discontinuity factors =, + 1 I4/)') NSURFD + ENDIF + CALL LCMSIX(IPMEM,' ',2) + ENDIF + ALLOCATE(SURFLX(NSURFD,NGROUP),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) +*---- +* RECOVER INFORMATION FROM caldir DIRECTORY. +*---- + JPMEM=LCMGID(IPMEM,'calc') + KPMEM=LCMGIL(JPMEM,ICAL) + 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('SCRSPH: 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,'(46HSCRSPH: 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,'(46HSCRSPH: 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(KPMEM,'ISADRX',ISADRX) + CALL LCMGET(KPMEM,'LENGDX',LENGDX) + CALL LCMGET(KPMEM,'LENGDP',LENGDP) + IF(NISOTS.GT.0) THEN + ALLOCATE(ISOTS(NISOTS*2)) + CALL LCMGET(KPMEM,'ISOTS',ISOTS) + ENDIF + CALL LCMSIX(KPMEM,' ',2) + CALL LCMSIX(KPMEM,'divers',1) + CALL LCMLEN(KPMEM,'NVDIV',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + NVDIV=0 + ELSE + CALL LCMGET(KPMEM,'NVDIV',NVDIV) + ENDIF + LSTRD=(B2.EQ.0.0) + IF(NVDIV.GT.0) THEN + IF(NVDIV.GT.MAXDIV) CALL XABORT('SCRSPH: MAXDIV OVERFLOW.') + CALL LCMGTC(KPMEM,'IDVAL',4,NVDIV,IDVAL) + CALL LCMGET(KPMEM,'VALDIV',VALDIV) + DO I=1,NVDIV + IF(IMPX.GT.1) THEN + WRITE(IOUT,'(9H SCRSPH: ,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(KPMEM,' ',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)) + NWT0(: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. +*---- +* 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(KPMEM,'divers',1) + 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('SCRSPH: NPR INCONSISTENCY(1).') + CALL LCMGET(KPMEM,'LAMBRS',LAMB) + DO IBM=1,NMIL + CALL LCMGET(IPMEM,'CHIRS',CHIRS(1,1,IBM)) + CALL LCMGET(IPMEM,'BETARS',BETAR(1,IBM)) + CALL LCMGET(IPMEM,'INVELS',INVELS(1,IBM)) + ENDDO + ENDIF + CALL LCMSIX(KPMEM,' ',2) +*---- +* LOOP OVER SAPHYB MIXTURES. +*---- + IF(NADRX.EQ.0) CALL XABORT('SCRSPH: NO ADDRESS SETS AVAILABLE.') + LPMEM=LCMGID(KPMEM,'mili') + DO IBM=1,NMIL + CALL LCMLEL(LPMEM,IBM,ILONG,ITYLCM) + IF(ILONG.EQ.0) CYCLE + MPMEM=LCMGIL(LPMEM,IBM) + IMAC=TOTM(IBM) + IRES=RESM(IBM) + IAD=ISADRX(IBM) + NDATAX=LENGDX(IBM) + NDATAP=LENGDP(IBM) + ALLOCATE(FLUXS(NGROUP),RDATA(NDATAX),IDATA(NDATAP)) + CALL LCMGET(MPMEM,'FLUXS',FLUXS) + CALL LCMGET(MPMEM,'RDATAX',RDATA) + CALL LCMGET(MPMEM,'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('SCRSPH: MISSING CONCES INFO.') + ALLOCATE(CONCES(NISOTS)) + CALL LCMGET(MPMEM,'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('SCRSPH: 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('SCRSPH: 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(MPMEM,'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('SCRSPH: 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(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('SCRSPH: INVALID NUMBER OF COMPONENTS FOR ' + 1 //'MASL') + ENDIF + FMASL(IBM)=RVALO(LOCAD(ILOC)) + ENDIF + ENDDO + DEALLOCATE(RVALO) + ENDIF +* + 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('SCRSPH: NPR INCONSISTENCY(2).') + CALL LCMGET(MPMEM,'LAMBRS',LAMB) + CALL LCMGET(MPMEM,'CHIRS',CHIRS(1,1,IBM)) + CALL LCMGET(MPMEM,'BETARS',BETAR(1,IBM)) + CALL LCMGET(MPMEM,'INVELS',INVELS(1,IBM)) + CALL LCMSIX(MPMEM,' ',2) + ENDIF +* 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(KPMEM,'outflx',1) + CALL LCMGET(KPMEM,'SURFLX',SURFLX) + CALL LCMSIX(KPMEM,' ',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) +*---- +* 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.'FISSION') 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 + READ(NOMREA(IREA),'(2A4)') IHEDI(2*NED-1),IHEDI(2*NED) + 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 |