Initial commit from Polytechnique Montreal

1 files changed, 206 insertions, 0 deletions

diff --git a/Donjon/src/MACCRE.f b/Donjon/src/MACCRE.f
new file mode 100644
index 0000000..40615f1
--- /dev/null
+++ b/Donjon/src/MACCRE.f
@@ -0,0 +1,206 @@
+*DECK MACCRE
+      SUBROUTINE MACCRE(IPOLD,IPNEW,NL,NW,NF,NGRP,NMXOLD,NMXNEW,NTOT,
+     1 MIX,LMAP,IMPX)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Recover nuclear properties from an initial macrolib and store them
+* in a new one containing one mixture per region.
+*
+*Copyright:
+* Copyright (C) 2007 Ecole Polytechnique de Montreal.
+*
+*Author(s): 
+* J. Koclas, E. Varin, D. Sekki
+*
+*Parameters: input
+* IPOLD   pointer to the initial macrolib.
+* NL      number of legendre orders (=1 for isotropic scattering).
+* NW      legendre order of NWT information (=0: NTOT0; =1: NTOT1).
+* NF      number of fissile isotopes.
+* NGRP    number of energy groups.
+* NMXOLD  number of material mixtures in the initial macrolib.
+* NMXNEW  number of material mixtures in the final macrolib.
+* NTOT    total number of all (material and virtual) mixtures.
+* MIX     index of all (material and virtual) mixtures.
+* LMAP    flag for the initial macrolib:
+*          =.true. if the fuel map macrolib.
+* IMPX    printing index (=0 for no print).
+*
+*Parameters: output
+* IPNEW   pointer to the final macrolib.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPOLD,IPNEW
+      INTEGER NL,NW,NF,NGRP,NMXOLD,NMXNEW,NTOT,MIX(NTOT)
+      LOGICAL LMAP
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER(IOUT=6)
+      CHARACTER CM*2,NAME*12,FIRST*12
+      TYPE(C_PTR) JPOLD,JPNEW,KPOLD,KPNEW
+      REAL, ALLOCATABLE, DIMENSION(:) ::SCAT,SCAT2,DATA,DATA2
+*
+      ALLOCATE(SCAT(NMXOLD*NL*NGRP*NGRP))
+      ALLOCATE(SCAT2(NMXNEW*NL*NGRP*NGRP))
+      SCAT(:NMXOLD*NL*NGRP*NGRP)=0.0
+      SCAT2(:NMXNEW*NL*NGRP*NGRP)=0.0
+*----
+*  RECOVER MACROLIB DATA
+*----
+      JPOLD=LCMGID(IPOLD,'GROUP')
+      JPNEW=LCMLID(IPNEW,'GROUP',NGRP)
+      DO 100 JGR=1,NGRP
+      KPOLD=LCMGIL(JPOLD,JGR)
+      KPNEW=LCMDIL(JPNEW,JGR)
+      IF(IMPX.GT.3)CALL LCMLIB(KPOLD)
+      IF(IMPX.GT.2)WRITE(IOUT,*)'** TREATING ENERGY GROUP #',JGR
+      NAME=' '
+      CALL LCMNXT(KPOLD,NAME)
+      FIRST=NAME
+   10 CALL LCMLEN(KPOLD,NAME,LENGT,ITYP)
+      IF((INDEX(NAME,'NTOT0').EQ.1).OR.(INDEX(NAME,'DIF').EQ.1).OR.
+     1   (INDEX(NAME,'NFT').EQ.1).OR.(INDEX(NAME,'OVE').EQ.1).OR.
+     2   (INDEX(NAME,'H-F').EQ.1).OR.(INDEX(NAME,'SIG').EQ.1))THEN
+*     RECOVER THESE PROPERTIES
+        IF(IMPX.GT.2)WRITE(IOUT,*)'PROPERTY NAME : ',NAME
+        IF(LENGT.EQ.NMXOLD)THEN
+          ALLOCATE(DATA(NMXOLD),DATA2(NMXNEW))
+          DATA(:NMXOLD)=0.0
+          DATA2(:NMXNEW)=0.0
+          CALL LCMGET(KPOLD,NAME,DATA)
+          IF(LMAP)THEN
+*         RECOVER EXISTING DATA
+            CALL LCMLEN(KPNEW,NAME,LENGT2,ITYP2)
+            IF(LENGT2.NE.0)CALL LCMGET(KPNEW,NAME,DATA2)
+          ENDIF
+          ITOT=0
+          DO 20 IBM=1,NTOT
+          IF(MIX(IBM).EQ.0)GOTO 20
+          ITOT=ITOT+1
+          IF(LMAP)THEN
+*         ONLY FUEL DATA WILL BE COPIED
+            IF(MIX(IBM).GT.0)GOTO 20
+            J=-MIX(IBM)
+          ELSE
+*         FUEL DATA WILL NOT BE COPIED
+            IF(MIX(IBM).LT.0)GOTO 20
+            J=MIX(IBM)
+          ENDIF
+*         COPY DATA
+          DATA2(ITOT)=DATA(J)
+   20     CONTINUE
+*         STORE DATA
+          CALL LCMPUT(KPNEW,NAME,NMXNEW,ITYP,DATA2)
+          DEALLOCATE(DATA,DATA2)
+        ELSEIF(LENGT.EQ.-1)THEN
+          CALL XABORT('@MACCRE: '//NAME//' IS A DIRECTORY.')
+        ELSEIF(LENGT.NE.0)THEN
+          CALL XABORT('@MACCRE: INVALID INPUT MACROLIB(1).')
+        ENDIF
+      ELSE IF((INDEX(NAME,'NUS').EQ.1).OR.(INDEX(NAME,'CHI').EQ.1))THEN
+*       RECOVER FISSION-RELATED PROPERTIES
+        IF(IMPX.GT.2)WRITE(IOUT,*)'PROPERTY NAME : ',NAME
+        IF(LENGT.EQ.NMXOLD*NF)THEN
+          ALLOCATE(DATA(NMXOLD*NF),DATA2(NMXNEW*NF))
+          DATA(:NMXOLD*NF)=0.0
+          DATA2(:NMXNEW*NF)=0.0
+          CALL LCMGET(KPOLD,NAME,DATA)
+          IF(LMAP)THEN
+*         RECOVER EXISTING DATA
+            CALL LCMLEN(KPNEW,NAME,LENGT2,ITYP2)
+            IF(LENGT2.NE.0)CALL LCMGET(KPNEW,NAME,DATA2)
+          ENDIF
+          ITOT=0
+          DO 35 INF=1,NF
+          DO 30 IBM=1,NTOT
+          IF(MIX(IBM).EQ.0)GOTO 30
+          ITOT=ITOT+1
+          IF(LMAP)THEN
+*         ONLY FUEL DATA WILL BE COPIED
+            IF(MIX(IBM).GT.0)GOTO 30
+            J=-MIX(IBM)
+          ELSE
+*         FUEL DATA WILL NOT BE COPIED
+            IF(MIX(IBM).LT.0)GOTO 30
+            J=MIX(IBM)
+          ENDIF
+*         COPY DATA
+          J1=(INF-1)*NMXOLD+J
+          DATA2(ITOT)=DATA(J1)
+   30     CONTINUE
+   35     CONTINUE
+*         STORE DATA
+          CALL LCMPUT(KPNEW,NAME,NMXNEW*NF,ITYP,DATA2)
+          DEALLOCATE(DATA,DATA2)
+        ELSEIF(LENGT.EQ.-1)THEN
+          CALL XABORT('@MACCRE: '//NAME//' IS A DIRECTORY.')
+        ELSEIF(LENGT.NE.0)THEN
+          CALL XABORT('@MACCRE: INVALID INPUT MACROLIB(2).')
+        ENDIF
+      ENDIF
+      CALL LCMNXT(KPOLD,NAME)
+      IF(FIRST.EQ.NAME)GOTO 40
+      GOTO 10
+*     RECOVER SCAT,IJJ,NJJ,IPOS
+   40 IF(IMPX.GT.2)WRITE(IOUT,*)'RECOVERING OF SCAT,IJJ,NJJ,IPOS'
+      DO IL=1,NL
+        WRITE (CM,'(I2.2)') IL-1
+        CALL LCMLEN(KPOLD,'SCAT'//CM,LENGT,ITYP)
+        IF(LENGT.EQ.0)THEN
+          EXIT
+        ELSEIF(LENGT.GT.NMXOLD*NL*NGRP*NGRP)THEN
+          CALL XABORT('@MACCRE: INVALID INPUT MACROLIB(3).')
+        ELSEIF(LENGT.GT.0)THEN
+          CALL MACSCA(KPOLD,KPNEW,SCAT,SCAT2,CM,JGR,IL,MIX,NMXNEW,NTOT,
+     1    NMXOLD,NL,NGRP,LMAP)
+        ENDIF
+      ENDDO
+*     RECOVER NTOT1 information
+      IF(NW.GT.0) THEN
+        ALLOCATE(DATA(NMXOLD),DATA2(NMXNEW))
+        DATA(:NMXOLD)=0.0
+        DATA2(:NMXNEW)=0.0
+        CALL LCMGET(KPOLD,'NTOT1',DATA)
+        IF(LMAP)THEN
+*       RECOVER EXISTING DATA
+          CALL LCMLEN(KPNEW,'NTOT0',LENGT1,ITYP1)
+          CALL LCMLEN(KPNEW,'NTOT1',LENGT2,ITYP2)
+          IF(LENGT2.NE.0) THEN
+            CALL LCMGET(KPNEW,'NTOT1',DATA2)
+          ELSE IF(LENGT1.NE.0) THEN
+            CALL LCMGET(KPNEW,'NTOT0',DATA2)
+          ENDIF
+        ENDIF
+        ITOT=0
+        DO 50 IBM=1,NTOT
+        IF(MIX(IBM).EQ.0)GOTO 50
+        ITOT=ITOT+1
+        IF(LMAP)THEN
+*       ONLY FUEL DATA WILL BE COPIED
+          IF(MIX(IBM).GT.0)GOTO 50
+          J=-MIX(IBM)
+        ELSE
+*       FUEL DATA WILL NOT BE COPIED
+          IF(MIX(IBM).LT.0)GOTO 50
+          J=MIX(IBM)
+        ENDIF
+*       COPY DATA
+        DATA2(ITOT)=DATA(J)
+   50   CONTINUE
+*       STORE DATA
+        CALL LCMPUT(KPNEW,'NTOT1',NMXNEW,ITYP,DATA2)
+        DEALLOCATE(DATA,DATA2)
+      ENDIF
+      IF(IMPX.GT.3)CALL LCMLIB(KPNEW)
+  100 CONTINUE
+      DEALLOCATE(SCAT,SCAT2)
+      RETURN
+      END