*DECK MCTOUT SUBROUTINE MCTOUT(IPOUT,NL,NFM,NDEL,NED,NAMEAD,NBSCO,NMERGE, 1 NGCOND,ASCORE1,ASCORE2) * *----------------------------------------------------------------------- * *Purpose: * Reconstruct the macrolib using a macrolib-related tally. * *Copyright: * Copyright (C) 2008 Ecole Polytechnique de Montreal * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version * *Author(s): A. Hebert * *Parameters: input * IPOUT pointer to the MC data structure. * NL number of Legendre orders required in the estimations * (NL=1 or higher). * NFM number of fissile isotopes. * NDEL number of delayed precursor groups. * NED number of extra edit vectors. * NAMEAD names of these extra edits. * NBSCO number of macrolib-related scores. * NMERGE number of homogenized regions. * NGCOND number of condensed energy groups. * ASCORE1 score for total flux and effective multiplication factor. * ASCORE2 macrolib score matrix. * *----------------------------------------------------------------------- * USE GANLIB IMPLICIT NONE *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPOUT INTEGER NL,NFM,NDEL,NED,NAMEAD(2,NED),NBSCO,NMERGE,NGCOND DOUBLE PRECISION ASCORE1(3),ASCORE2(NBSCO,NMERGE,NGCOND) *---- * LOCAL VARIABLES *---- INTEGER NSTATE PARAMETER(NSTATE=40) TYPE(C_PTR) JPOUT,KPOUT INTEGER ISTATE(NSTATE),IGR,JGR,IMIX,IPOSDE,IGMIN,IGMAX,IFM,IOF, > IOF2,IED,I0,IL,IDEL,HSIGN(3) CHARACTER TEXT12*12,CM*2 DOUBLE PRECISION SUM,SUM2 *---- * ALLOCATABLE ARRAYS *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS REAL, ALLOCATABLE, DIMENSION(:) :: GAR1,GAR2 REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR3 *---- * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(IJJ(NMERGE),NJJ(NMERGE),IPOS(NMERGE)) ALLOCATE(GAR1(NMERGE),GAR2(NMERGE*NGCOND),GAR3(NMERGE,NFM)) *---- * SCATTERING MATRIX NORMALIZATION *---- DO IMIX=1,NMERGE DO IGR=1,NGCOND SUM=0.0D0 DO JGR=1,NGCOND SUM=SUM+ASCORE2(5+JGR,IMIX,IGR) ! JGR <-- IGR ENDDO DO JGR=1,NGCOND ASCORE2(5+JGR,IMIX,IGR)=ASCORE2(5+JGR,IMIX,IGR)* 1 ASCORE2(3,IMIX,IGR)/SUM ENDDO ENDDO ENDDO *---- * FISSION SPECTRUM NORMALIZATION *---- IOF=5+NGCOND*NL IOF2=IOF+NFM DO IMIX=1,NMERGE DO IFM=1,NFM SUM=0.0D0 DO IGR=1,NGCOND SUM=SUM+ASCORE2(IOF+IFM,IMIX,IGR) ENDDO SUM2=0.0D0 DO IGR=1,NGCOND SUM2=SUM2+ASCORE2(IOF2+IFM,IMIX,IGR) ENDDO IF(SUM2.NE.0.0) THEN DO IGR=1,NGCOND ASCORE2(IOF2+IFM,IMIX,IGR)=ASCORE2(IOF2+IFM,IMIX,IGR)* 1 SUM/SUM2 ENDDO ENDIF ENDDO ENDDO *---- * REFORMAT CROSS-SECTION INFORMATION INTO MACROLIB FORMAT *---- CALL LCMSIX(IPOUT,'MACROLIB',1) JPOUT=LCMLID(IPOUT,'GROUP',NGCOND) DO IGR=1,NGCOND KPOUT=LCMDIL(JPOUT,IGR) DO IMIX=1,NMERGE GAR1(IMIX)=REAL(ASCORE2(1,IMIX,IGR)/ASCORE1(1)) ENDDO CALL LCMPUT(KPOUT,'NWT0',NMERGE,2,GAR1) DO IMIX=1,NMERGE GAR1(IMIX)=REAL(ASCORE2(2,IMIX,IGR)/ASCORE2(1,IMIX,IGR)) ENDDO CALL LCMPUT(KPOUT,'NTOT0',NMERGE,2,GAR1) DO IMIX=1,NMERGE GAR1(IMIX)=REAL((ASCORE2(3,IMIX,IGR)+2.0*ASCORE2(4,IMIX,IGR)+ 1 3.0*ASCORE2(5,IMIX,IGR))/ASCORE2(1,IMIX,IGR)) ENDDO CALL LCMPUT(KPOUT,'SIGS00',NMERGE,2,GAR1) *---- * REFORMAT SCATTERING INFORMATION *---- IOF=5 DO IL=1,NL WRITE(CM,'(I2.2)') IL-1 IPOSDE=0 DO IMIX=1,NMERGE IPOS(IMIX)=IPOSDE+1 IGMIN=IGR IGMAX=IGR DO JGR=NGCOND,1,-1 IF(ASCORE2(IOF+IGR,IMIX,JGR).NE.0.0) THEN IGMIN=MIN(IGMIN,JGR) IGMAX=MAX(IGMAX,JGR) ENDIF ENDDO IJJ(IMIX)=IGMAX NJJ(IMIX)=IGMAX-IGMIN+1 DO JGR=IGMAX,IGMIN,-1 IPOSDE=IPOSDE+1 GAR2(IPOSDE)=REAL(ASCORE2(IOF+IGR,IMIX,JGR)/ 1 ASCORE2(1,IMIX,JGR)) IF(JGR.EQ.IGR) THEN GAR2(IPOSDE)=GAR2(IPOSDE)+REAL((2.0*ASCORE2(4,IMIX,IGR)+ 1 3.0*ASCORE2(5,IMIX,IGR))/ASCORE2(1,IMIX,IGR)) ENDIF ENDDO GAR1(IMIX)=REAL((ASCORE2(IOF+IGR,IMIX,IGR) 1 +2.0*ASCORE2(4,IMIX,IGR)+3.0*ASCORE2(5,IMIX,IGR))/ 2 ASCORE2(1,IMIX,IGR)) ENDDO CALL LCMPUT(KPOUT,'SCAT'//CM,IPOSDE,2,GAR2) CALL LCMPUT(KPOUT,'NJJS'//CM,NMERGE,1,NJJ) CALL LCMPUT(KPOUT,'IJJS'//CM,NMERGE,1,IJJ) CALL LCMPUT(KPOUT,'IPOS'//CM,NMERGE,1,IPOS) CALL LCMPUT(KPOUT,'SIGW'//CM,NMERGE,2,GAR1) IF(IL.GT.1) THEN GAR1(:NMERGE)=0.0 DO IMIX=1,NMERGE DO JGR=1,NGCOND GAR1(IMIX)=GAR1(IMIX)+REAL(ASCORE2(IOF+JGR,IMIX,IGR)/ 1 ASCORE2(1,IMIX,IGR)) ENDDO GAR1(IMIX)=GAR1(IMIX)+REAL((2.0*ASCORE2(4,IMIX,IGR)+3.0* 1 ASCORE2(5,IMIX,IGR))/ASCORE2(1,IMIX,IGR)) ENDDO CALL LCMPUT(KPOUT,'SIGS'//CM,NMERGE,2,GAR1) ENDIF IOF=IOF+NGCOND ENDDO *---- * REFORMAT FISSION INFORMATION *---- DO IDEL=1,1+NDEL IF(IDEL.EQ.1) THEN TEXT12='NUSIGF' ELSE WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL-1 ENDIF DO IMIX=1,NMERGE DO IFM=1,NFM GAR3(IMIX,IFM)=REAL(ASCORE2(IOF+IFM,IMIX,IGR)/ 1 ASCORE2(1,IMIX,IGR)) ENDDO ENDDO CALL LCMPUT(KPOUT,TEXT12,NMERGE*NFM,2,GAR3) IF(IDEL.EQ.1) THEN TEXT12='CHI' ELSE WRITE(TEXT12,'(3HCHI,I2.2)') IDEL-1 ENDIF IOF2=IOF+NFM DO IMIX=1,NMERGE DO IFM=1,NFM SUM=0.0D0 DO JGR=1,NGCOND SUM=SUM+ASCORE2(IOF+IFM,IMIX,JGR) ENDDO IF(SUM.NE.0.0) THEN GAR3(IMIX,IFM)=REAL(ASCORE2(IOF2+IFM,IMIX,IGR)/SUM) ELSE GAR3(IMIX,IFM)=0.0 ENDIF ENDDO ENDDO CALL LCMPUT(KPOUT,TEXT12,NMERGE*NFM,2,GAR3) IOF=IOF2+NFM ENDDO *---- * REFORMAT ADDITIONAL EDIT INFORMATION *---- DO IED=1,NED WRITE(TEXT12,'(2A4)') NAMEAD(1,IED),NAMEAD(2,IED) DO IMIX=1,NMERGE GAR1(IMIX)=REAL(ASCORE2(IOF+IED,IMIX,IGR)/ 1 ASCORE2(1,IMIX,IGR)) ENDDO CALL LCMPUT(KPOUT,TEXT12,NMERGE,2,GAR1) ENDDO ENDDO *---- * CREATE THE STATE VECTOR AND THE SIGNATURE *---- ISTATE(:NSTATE)=0 ISTATE(1)=NGCOND ISTATE(2)=NMERGE ISTATE(3)=NL ISTATE(4)=NFM ISTATE(5)=NED ISTATE(7)=NDEL CALL LCMPUT(IPOUT,'STATE-VECTOR',NSTATE,1,ISTATE) TEXT12='L_MACROLIB' READ(TEXT12,'(3A4)') (HSIGN(I0),I0=1,3) CALL LCMPUT(IPOUT,'SIGNATURE',3,3,HSIGN) CALL LCMSIX(IPOUT,' ',2) *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(GAR3,GAR2,GAR1) DEALLOCATE(IPOS,NJJ,IJJ) RETURN END