Initial commit from Polytechnique Montreal

1 files changed, 244 insertions, 0 deletions

diff --git a/Dragon/src/MCTOUT.f b/Dragon/src/MCTOUT.f
new file mode 100644
index 0000000..1bca444
--- /dev/null
+++ b/Dragon/src/MCTOUT.f
@@ -0,0 +1,244 @@
+*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