Initial commit from Polytechnique Montreal

1 files changed, 295 insertions, 0 deletions

diff --git a/Dragon/src/MACIXS.f b/Dragon/src/MACIXS.f
new file mode 100644
index 0000000..4fdf812
--- /dev/null
+++ b/Dragon/src/MACIXS.f
@@ -0,0 +1,295 @@
+*DECK MACIXS
+      SUBROUTINE MACIXS(IPLIST,MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG,
+     >                  XSTOTL,XSTOT1,XSFISS,XSSPEC,XSFIXE,XSTRAN,
+     >                  XSDIFF,XSNFTO,XSH,XSSCAT,LOLDXS,ISCATA,XSNUDL,
+     >                  XSCHDL,XSDIFX,XSDIFY,XSDIFZ,XSOVRV,XSINT0,
+     >                  XSINT1)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Cross sections initialization.
+*
+*Copyright:
+* Copyright (C) 2006 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): G. Marleau
+*
+*Parameters: input
+* IPLIST  LCM pointer to the macrolib.
+* MAXFIS  set to max(1,NIFISS).
+* NGROUP  number of energy groups.
+* NBMIX   maximum number of mixtures.
+* NIFISS  number of fissile isotopes.
+* NANISO  maximum Legendre order:
+*         =1 isotropic collision;
+*         =2 linearly anisotropic collision.
+* NDELG   number of precursor groups for delayed neutrons.
+*
+*Parameters: output
+* XSTOTL  P0 total cross section of mixture.
+* XSTOT1  P1 total cross section of mixture.
+* XSFISS  nu*fission cross section of mixture.
+* XSSPEC  fission spectrum.
+* XSFIXE  fixed sources.
+* XSTRAN  transport correction.
+* XSDIFF  isotropic diffusion coefficient.
+* XSNFTO  fission cross section of mixture.
+* XSH     power factor (h-factor).
+* XSSCAT  scattering cross section of mixture/group.
+* XSNUDL  delayed nu*fission cross section of mixture.
+* XSCHDL  delayed neutron fission spectrum.
+* XSDIFX  x-directed diffusion coefficients.
+* XSDIFY  y-directed diffusion coefficients.
+* XSDIFZ  z-directed diffusion coefficients.
+* XSOVRV  reciprocal neutron velocities.
+* XSINT0  P0 volume-integrated flux of mixture.
+* XSINT1  P1 volume-integrated flux of mixture.
+* LOLDXS  flag to check if cross section type is already present on
+*         the macrolib.
+* ISCATA  check for scattering anisotropy.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPLIST
+      INTEGER   MAXFIS,NGROUP,NBMIX,NIFISS,NANISO,NDELG,ISCATA(NANISO)
+      REAL      XSTOTL(NBMIX,NGROUP),XSTOT1(NBMIX,NGROUP),
+     >          XSFISS(NBMIX,MAXFIS,NGROUP),XSSPEC(NBMIX,MAXFIS,NGROUP),
+     >          XSFIXE(NBMIX,NGROUP),XSTRAN(NBMIX,NGROUP),
+     >          XSDIFF(NBMIX,NGROUP),XSNFTO(NBMIX,NGROUP),
+     >          XSH(NBMIX,NGROUP),XSSCAT(NGROUP,NBMIX,NANISO,NGROUP),
+     >          XSNUDL(NBMIX,MAXFIS,NDELG,NGROUP),
+     >          XSCHDL(NBMIX,MAXFIS,NDELG,NGROUP),
+     >          XSDIFX(NBMIX,NGROUP),XSDIFY(NBMIX,NGROUP),
+     >          XSDIFZ(NBMIX,NGROUP),XSOVRV(NBMIX,NGROUP),
+     >          XSINT0(NBMIX,NGROUP),XSINT1(NBMIX,NGROUP)
+      LOGICAL   LOLDXS(18)
+*----
+*  LOCAL VARIABLES
+*----
+      TYPE(C_PTR) JPLIST,KPLIST
+      CHARACTER CANISO*2,NAMREC*12,CHID*12,NUSIGD*12
+*----
+* ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: INGSCT,IFGSCT
+      REAL, ALLOCATABLE, DIMENSION(:) :: XSWORK
+*----
+*  SCRATCH STORAGE ALLOCATION
+*   INGSCT   number of scattering group for cross sections.
+*   IFGSCT   first scattering group for cross sections.
+*   XSWORK   work cross-section vector.
+*----
+      ALLOCATE(INGSCT(NBMIX),IFGSCT(NBMIX))
+      ALLOCATE(XSWORK(NBMIX*NGROUP))
+*----
+*  READ/INITIALIZE MACROLIB CROSS SECTION DATA
+*----
+      XSTOTL(:NBMIX,:NGROUP)=0.0
+      XSTOT1(:NBMIX,:NGROUP)=0.0
+      XSFISS(:NBMIX,:NIFISS,:NGROUP)=0.0
+      XSSPEC(:NBMIX,:NIFISS,:NGROUP)=0.0
+      XSFIXE(:NBMIX,:NGROUP)=0.0
+      XSTRAN(:NBMIX,:NGROUP)=0.0
+      XSDIFF(:NBMIX,:NGROUP)=0.0
+      XSNFTO(:NBMIX,:NGROUP)=0.0
+      XSH(:NBMIX,:NGROUP)=0.0
+      XSSCAT(:NGROUP,:NBMIX,:NANISO,:NGROUP)=0.0
+      IF(NDELG.GT.0) THEN
+         XSNUDL(:NBMIX,:NIFISS,:NDELG,:NGROUP)=0.0
+         XSCHDL(:NBMIX,:NIFISS,:NDELG,:NGROUP)=0.0
+      ENDIF
+      XSDIFX(:NBMIX,:NGROUP)=0.0
+      XSDIFY(:NBMIX,:NGROUP)=0.0
+      XSDIFZ(:NBMIX,:NGROUP)=0.0
+      XSOVRV(:NBMIX,:NGROUP)=0.0
+      XSINT0(:NBMIX,:NGROUP)=0.0
+      XSINT1(:NBMIX,:NGROUP)=0.0
+      JPLIST=LCMLID(IPLIST,'GROUP',NGROUP)
+      DO 200 IGROUP=1,NGROUP
+        KPLIST=LCMDIL(JPLIST,IGROUP)
+*----
+*  READ OR INITIALISE CHI AND NUSIGF
+*----
+        CALL LCMLEN(KPLIST,'NUSIGF',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(2)=.TRUE.
+          CALL LCMGET(KPLIST,'NUSIGF',XSFISS(1,1,IGROUP))
+        ELSE
+          XSFISS(:NBMIX,:NIFISS,IGROUP)=0.0
+        ENDIF
+        CALL LCMLEN(KPLIST,'CHI',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(4)=.TRUE.
+          CALL LCMGET(KPLIST,'CHI',XSSPEC(1,1,IGROUP))
+        ELSE
+          XSSPEC(:NBMIX,:NIFISS,IGROUP)=0.0
+        ENDIF
+*----
+*  READ OR INITIALISE TOTAL XS, FIXED SOURCES AND TRANSPORT CORRECTION
+*----
+        CALL LCMLEN(KPLIST,'NTOT0',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(1)=.TRUE.
+          CALL LCMGET(KPLIST,'NTOT0',XSTOTL(1,IGROUP))
+        ELSE
+          XSTOTL(:NBMIX,IGROUP)=0.0
+        ENDIF
+        CALL LCMLEN(KPLIST,'FIXE',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(3)=.TRUE.
+          CALL LCMGET(KPLIST,'FIXE',XSFIXE(1,IGROUP))
+        ELSE
+          XSFIXE(:NBMIX,IGROUP)=0.0
+        ENDIF
+        CALL LCMLEN(KPLIST,'TRANC',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(6)=.TRUE.
+          CALL LCMGET(KPLIST,'TRANC',XSTRAN(1,IGROUP))
+        ELSE
+          XSTRAN(:NBMIX,IGROUP)=0.0
+        ENDIF
+        CALL LCMLEN(KPLIST,'DIFF',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(7)=.TRUE.
+          CALL LCMGET(KPLIST,'DIFF',XSDIFF(1,IGROUP))
+        ELSE
+          XSDIFF(:NBMIX,IGROUP)=0.0
+        ENDIF
+        CALL LCMLEN(KPLIST,'H-FACTOR',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(8)=.TRUE.
+          CALL LCMGET(KPLIST,'H-FACTOR',XSH(1,IGROUP))
+        ELSE
+          XSH(:NBMIX,IGROUP)=0.0
+        ENDIF
+        CALL LCMLEN(KPLIST,'NTOT1',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(9)=.TRUE.
+          CALL LCMGET(KPLIST,'NTOT1',XSTOT1(1,IGROUP))
+        ELSE
+          XSTOT1(:NBMIX,IGROUP)=0.0
+        ENDIF
+*----
+*  READ OR INITIALISE DIFFX, DIFFY, DIFFZ, CHID AND OVERV
+*----
+        CALL LCMLEN(KPLIST,'DIFFX',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(10)=.TRUE.
+          CALL LCMGET(KPLIST,'DIFFX',XSDIFX(1,IGROUP))
+        ELSE
+          XSDIFX(:NBMIX,IGROUP)=0.0
+        ENDIF
+        CALL LCMLEN(KPLIST,'DIFFY',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(11)=.TRUE.
+          CALL LCMGET(KPLIST,'DIFFY',XSDIFY(1,IGROUP))
+        ELSE
+          XSDIFY(:NBMIX,IGROUP)=0.0
+        ENDIF
+        CALL LCMLEN(KPLIST,'DIFFZ',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(12)=.TRUE.
+          CALL LCMGET(KPLIST,'DIFFZ',XSDIFZ(1,IGROUP))
+        ELSE
+          XSDIFZ(:NBMIX,IGROUP)=0.0
+        ENDIF
+        DO I=1,NDELG
+          WRITE(NUSIGD,'(A6,I2.2)') 'NUSIGF',I
+          CALL LCMLEN(KPLIST,NUSIGD,ILCMLN,ITYLCM)
+          IF(ILCMLN.GT.0) THEN
+            LOLDXS(13)=.TRUE.
+            CALL LCMGET(KPLIST,NUSIGD,XSNUDL(1,1,I,IGROUP))
+          ELSE
+            XSNUDL(:NBMIX,:NIFISS,I,IGROUP)=0.0
+          ENDIF
+          WRITE(CHID,'(A3,I2.2)') 'CHI',I
+          CALL LCMLEN(KPLIST,CHID,ILCMLN,ITYLCM)
+          IF(ILCMLN.GT.0) THEN
+            LOLDXS(14)=.TRUE.
+            CALL LCMGET(KPLIST,CHID,XSCHDL(1,1,I,IGROUP))
+          ELSE
+            XSCHDL(:NBMIX,:NIFISS,I,IGROUP)=0.0
+          ENDIF
+        ENDDO
+        CALL LCMLEN(KPLIST,'OVERV',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(15)=.TRUE.
+          CALL LCMGET(KPLIST,'OVERV',XSOVRV(1,IGROUP))
+        ELSE
+          XSOVRV(:NBMIX,IGROUP)=0.0
+        ENDIF
+        CALL LCMLEN(KPLIST,'NFTOT',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(16)=.TRUE.
+          CALL LCMGET(KPLIST,'NFTOT',XSNFTO(1,IGROUP))
+        ELSE
+          XSNFTO(:NBMIX,IGROUP)=0.0
+        ENDIF
+        CALL LCMLEN(KPLIST,'FLUX-INTG',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(17)=.TRUE.
+          CALL LCMGET(KPLIST,'FLUX-INTG',XSINT0(1,IGROUP))
+        ELSE
+          XSINT0(:NBMIX,IGROUP)=0.0
+        ENDIF
+        CALL LCMLEN(KPLIST,'FLUX-INTG-P1',ILCMLN,ITYLCM)
+        IF(ILCMLN.GT.0) THEN
+          LOLDXS(18)=.TRUE.
+          CALL LCMGET(KPLIST,'FLUX-INTG-P1',XSINT1(1,IGROUP))
+        ELSE
+          XSINT1(:NBMIX,IGROUP)=0.0
+        ENDIF
+*----
+*  READ OR INITIALISE SCATTERING CROSS SECTIONS
+*----
+        DO 203 IANIS=1,NANISO
+          WRITE(CANISO,'(I2.2)') IANIS-1
+          NAMREC='SCAT'//CANISO
+          CALL LCMLEN(KPLIST,NAMREC,ILCMLN,ITYLCM)
+          ICMATR=0
+          IF(ILCMLN.GT.0) THEN
+            LOLDXS(5)=.TRUE.
+            ISCATA(IANIS)=1
+*----
+*  READ COMPRESS SCATTERING XS PLUS INFORMATION TO EXPAND XS
+*----
+            CALL LCMGET(KPLIST,NAMREC,XSWORK)
+            NAMREC='NJJS'//CANISO
+            CALL LCMLEN(KPLIST,NAMREC,ICMATR,ITYLCM)
+            CALL LCMGET(KPLIST,NAMREC,INGSCT)
+            NAMREC='IJJS'//CANISO
+            CALL LCMGET(KPLIST,NAMREC,IFGSCT)
+*----
+*  EXPAND SCATTERING XS TO XSSCAT(JGROUP,IMATER,IANIS,IGROUP)
+*  WHERE IGROUP IS THE SECONDARY GROUP.
+*----
+            IPWRK=1
+            DO 204 IMATER=1,ICMATR
+              IF(INGSCT(IMATER).GT.0) THEN
+                IGD=IFGSCT(IMATER)
+                IGF=IGD-INGSCT(IMATER)+1
+                DO 205 JGROUP=IGD,IGF,-1
+                  XSSCAT(JGROUP,IMATER,IANIS,IGROUP)=XSWORK(IPWRK)
+                  IPWRK=IPWRK+1
+ 205            CONTINUE
+              ENDIF
+ 204        CONTINUE
+          ENDIF
+ 203    CONTINUE
+ 200  CONTINUE
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(XSWORK)
+      DEALLOCATE(IFGSCT,INGSCT)
+      RETURN
+      END