1 files changed, 131 insertions, 0 deletions
diff --git a/Dragon/src/EPCRMI.f b/Dragon/src/EPCRMI.f
new file mode 100644
index 0000000..5c4d631
--- /dev/null
+++ b/Dragon/src/EPCRMI.f
@@ -0,0 +1,131 @@
+*DECK EPCRMI
+      SUBROUTINE EPCRMI(IPMIC,IPRINT,NIS,NBISO,NMIXT,NIFISS,
+     >                  NAMISO,NISOU,IDVF,IDMF)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Cross reference variance isotopes and MICROLIB isotopes.
+*
+*Copyright:
+* Copyright (C) 2009 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
+* IPMIC   pointer to microlib.
+* IPRINT  print level.
+* NIS     number of isotopes on EPC.
+* NBISO   number of isotopes on MICROLIB.
+* NMIXT   number of mixtures on MICROLIB.
+* NIFISS  number of fissiles isotopes on MICROLIB.
+*
+*Parameters: output
+* NAMISO  array containing the isotope names.
+* NISOU   MICROLIB isotopes used.
+* IDVF    variance isotopes to analyze and fission id.
+* IDMF    MICROLIB isotopes to analyze and fission id.
+*
+*-----------------------------------------------------------------------
+*
+      USE              GANLIB
+      IMPLICIT         NONE
+*----
+*  Subroutine arguments
+*----
+      TYPE(C_PTR)      IPMIC
+      INTEGER          IPRINT,NIS,NBISO,NMIXT,NIFISS
+      INTEGER          NAMISO(3,NIS),NISOU(3,NBISO),
+     >                 IDVF(2,NIS),IDMF(2,NBISO)
+*----
+*  Local parameters
+*----
+      INTEGER          IOUT
+      CHARACTER        NAMSBR*6
+      PARAMETER       (IOUT=6,NAMSBR='EPCRMI')
+      INTEGER          ILCMUP,ILCMDN
+      PARAMETER       (ILCMUP=1,ILCMDN=2)
+*----
+*  Local variables
+*----
+      INTEGER          IPRTL,NBIU,ISO,JSO,IFI
+*----
+*  Allocatable arrays
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NISON,FID,FNM
+*----
+*  Scratch storage allocation
+*   NISON   MICROLIB isotopes reference names
+*   FID     MICROLIB fissile id
+*   FNM     MICROLIB fissile name
+*----
+      ALLOCATE(NISON(3,NBISO),FID(NMIXT,NIFISS),FNM(2,NIFISS))
+*----
+*  Write header
+*----
+      IPRTL=IPRINT
+      IF(IPRTL .GE. 10) THEN
+        WRITE(IOUT,6000) NAMSBR
+      ENDIF
+*----
+*  Isotope names identification
+*----
+      CALL LCMGET(IPMIC,'ISOTOPERNAME',NISON)
+*----
+*  Fissile isotopes identifier
+*----
+      CALL LCMSIX(IPMIC,'MACROLIB    ',ILCMUP)
+      CALL LCMGET(IPMIC,'FISSIONINDEX',FID)
+      CALL LCMGET(IPMIC,'FISSIONNAMES',FNM)
+      CALL LCMSIX(IPMIC,'MACROLIB    ',ILCMDN)
+      IDVF(:2,:NIS)=0
+      IDMF(:2,:NBISO)=0
+      DO ISO=1,NIS
+*----
+*  Test if isotope used in Microlib
+*----
+        NBIU=0
+        DO JSO=1,NBISO
+          IF( (NISON(1,JSO) .EQ. NAMISO(1,ISO)) .AND.
+     >        (NISON(2,JSO) .EQ. NAMISO(2,ISO)) .AND.
+     >        (NISON(3,JSO) .EQ. NAMISO(3,ISO)) ) THEN
+            IDMF(1,JSO)=ISO
+            NBIU=NBIU+1
+          ENDIF
+        ENDDO
+        IF(NBIU .GT. 0) IDVF(1,ISO)=1
+      ENDDO
+*----
+*  Find fissile isotope id
+*----
+      DO JSO=1,NBISO
+        ISO=IDMF(1,JSO)
+        IF(ISO .GT. 0) THEN
+          DO IFI=1,NIFISS
+            IF( (FNM(1,IFI) .EQ. NISOU(1,JSO)) .AND.
+     >          (FNM(2,IFI) .EQ. NISOU(2,JSO))  ) THEN
+              IDMF(2,JSO)=IFI
+              IDVF(2,ISO)=IFI
+            ENDIF
+          ENDDO
+        ENDIF
+      ENDDO
+      IF(IPRTL .GE. 2) THEN
+        WRITE(IOUT,6001) NAMSBR
+      ENDIF
+*----
+*  Scratch storage deallocation
+*----
+      DEALLOCATE(FNM,FID,NISON)
+      RETURN
+*----
+*  Formats
+*----
+ 6000 FORMAT('(* Output from --',A6,'-- follows ')
+ 6001 FORMAT('   Output from --',A6,'-- completed *)')
+      END