From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Dragon/src/EPCRMI.f | 131 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 131 insertions(+) create mode 100644 Dragon/src/EPCRMI.f (limited to 'Dragon/src/EPCRMI.f') 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 -- cgit v1.2.3