1 files changed, 152 insertions, 0 deletions
diff --git a/Dragon/src/LIBMIX.f b/Dragon/src/LIBMIX.f
new file mode 100644
index 0000000..1a800bc
--- /dev/null
+++ b/Dragon/src/LIBMIX.f
@@ -0,0 +1,152 @@
+*DECK LIBMIX
+      SUBROUTINE LIBMIX(IPLIB,NBMIX,NGROUP,NBISO,ISONAM,MIX,DEN,MASK,
+     1 MASKL,ITSTMP,TMPDAY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Transformation of the isotope ordered microscopic cross sections to
+* group ordered macroscopic cross sections (part 1).
+*
+*Copyright:
+* Copyright (C) 2002 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
+* IPLIB   pointer to the lattice microscopic cross section library
+*         (L_LIBRARY signature).
+* NBMIX   number of material mixtures.
+* NGROUP  number of energy groups.
+* NBISO   number of isotopes present in the calculation domain.
+* ISONAM  names of microlib isotopes.
+* MIX     mixture number of each isotope (can be zero).
+* DEN     density of each isotope.
+* MASK    mixture mask (=.true. if a mixture is to be made).
+* MASKL   group mask (=.true. if an energy group is to be treated).
+* ITSTMP  type of cross section perturbation (=0 perturbation
+*         forbidden; =1 perturbation not used even if present;
+*         =2 perturbation used if present).
+* TMPDAY  time stamp in day/burnup/irradiation.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPLIB
+      INTEGER NBMIX,NGROUP,NBISO,ISONAM(3,NBISO),MIX(NBISO),ITSTMP
+      REAL DEN(NBISO),TMPDAY(3)
+      LOGICAL MASK(NBMIX),MASKL(NGROUP)
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER NBLK,NSTATE
+      PARAMETER (NBLK=50,NSTATE=40)
+      LOGICAL LSAME,LSTOPW
+      INTEGER ISTATE(NSTATE),I,IPROB,ITRANC,LENGTH,ITYLCM,MAXNFI,NBESP,
+     1 NDEL,NED,NESP,NFISSI,NL,NPART,STERN
+      CHARACTER TEXT12*12,HPRT1*1
+      REAL OLDTIM(3)
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: JNED
+      TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO
+*----
+*  RECOVER SOME LIBRARY PARAMETERS.
+*----
+      CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE)
+      NL=ISTATE(4)
+      ITRANC=ISTATE(5)
+      IPROB=ISTATE(6)
+      NED=ISTATE(13)
+      NBESP=ISTATE(16)
+      NDEL=ISTATE(19)
+      NPART=ISTATE(26)
+      STERN=ISTATE(27)
+      ALLOCATE(JNED(2*NED))
+      IF(NED.GT.0) CALL LCMGET(IPLIB,'ADDXSNAME-P0',JNED)
+*----
+*  LOOK FOR OLD LIBRARY DATA
+*----
+      CALL LCMLEN(IPLIB,'MACROLIB',LENGTH,ITYLCM)
+      IF(LENGTH.EQ.-1) THEN
+        CALL LCMSIX(IPLIB,'MACROLIB',1)
+        CALL LCMGTC(IPLIB,'SIGNATURE',12,TEXT12)
+        IF(TEXT12.NE.'L_MACROLIB') THEN
+          CALL XABORT('LIBMIX: INVALID SIGNATURE ON THE MACROLIB.')
+        ENDIF
+        CALL LCMLEN(IPLIB,'TIMESTAMP',LENGTH,ITYLCM)
+        IF((LENGTH.GT.0).AND.(LENGTH.LE.3)) THEN
+          CALL LCMGET(IPLIB,'TIMESTAMP',OLDTIM)
+          IF(ITSTMP.EQ.0) THEN
+            TMPDAY(1)=OLDTIM(1)
+            TMPDAY(2)=OLDTIM(2)
+            TMPDAY(3)=OLDTIM(3)
+          ENDIF
+        ENDIF
+        CALL LCMSIX(IPLIB,' ',2)
+      ENDIF
+*----
+*  SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES.
+*----
+      ALLOCATE(IPISO(NBISO))
+      CALL LIBIPS(IPLIB,NBISO,IPISO)
+*----
+*  TRANSPOSE THE MICROSCOPIC CROSS SECTIONS TO ADJOINT ORDERING.
+*----
+      IF(IPROB.EQ.1) THEN
+         CALL LIBADJ (IPLIB,NGROUP,NBISO,NL,NDEL,NBESP,IPISO,NED,JNED)
+      ENDIF
+*----
+*  SET MULTIPLE FISSION SPECTRA INFORMATION.
+*----
+      IF(NBESP.EQ.0) THEN
+        NESP=1
+      ELSE
+        NESP=NBESP
+      ENDIF
+*----
+*  COMPUTE THE MAXIMUM NUMBER OF FISSIONABLE ISOTOPES IN A MIXTURE.
+*----
+      DO 20 I=1,NBISO
+      IF(MIX(I).GT.NBMIX) CALL XABORT('LIBMIX: NBMIX OVERFLOW.')
+   20 CONTINUE
+      MAXNFI=MIN(NBISO,200)
+      CALL LIBNFI (IPLIB,NGROUP,NBISO,NBMIX,NDEL,NESP,IPISO,MIX,MAXNFI,
+     1 NFISSI,LSAME)
+*----
+*  BUILD THE MACROSCOPIC CROSS SECTIONS.
+*----
+      CALL LIBDEN (IPLIB,NGROUP,NBISO,NBMIX,NL,NDEL,NESP,ISONAM,IPISO,
+     1 MIX,DEN,MASK,MASKL,NED,JNED,ITRANC,NFISSI,NPART,LSAME,ITSTMP,
+     2 TMPDAY,STERN)
+*----
+* RECOVER STOPPING POWERS.
+*----
+      LSTOPW=.FALSE.
+      CALL LCMLEN(IPLIB,'PARTICLE',LENGTH,ITYLCM)
+      IF(LENGTH.GT.0) THEN
+         CALL LCMGTC(IPLIB,'PARTICLE',1,HPRT1)
+         LSTOPW=((HPRT1.EQ.'B').OR.(HPRT1.EQ.'C'))
+      ENDIF
+      IF(LSTOPW) THEN
+         CALL LIBEST (IPLIB,NGROUP,NBISO,NBMIX,IPISO,MIX,DEN,MASK,MASKL,
+     1   NED,JNED,ITSTMP,TMPDAY,STERN)
+      ENDIF
+*----
+*  TRANSPOSE THE MICROSCOPIC CROSS SECTIONS BACK TO FORWARD ORDERING.
+*----
+      IF(IPROB.EQ.1) THEN
+         CALL LIBADJ (IPLIB,NGROUP,NBISO,NL,NDEL,NBESP,IPISO,NED,JNED)
+      ENDIF
+      DEALLOCATE(IPISO,JNED)
+      RETURN
+      END