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/MCT.f | 202 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 202 insertions(+) create mode 100644 Dragon/src/MCT.f (limited to 'Dragon/src/MCT.f') diff --git a/Dragon/src/MCT.f b/Dragon/src/MCT.f new file mode 100644 index 0000000..0681972 --- /dev/null +++ b/Dragon/src/MCT.f @@ -0,0 +1,202 @@ +*DECK MCT + SUBROUTINE MCT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Monte-Carlo method based on NXT geometry analysis. +* +*Copyright: +* Copyright (C) 2008 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): R. Le Tellier and B. Arsenault +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) creation type(L_MC); +* HENTRY(2) read-only or modification type(L_TRACK); +* HENTRY(3) read-only type(L_LIBRARY) or type(L_MACROLIB). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPOUT,IPTRK,IPLIB + INTEGER NSTATE,IOUT,ITC,NSRCK,IKZ,KCT,NGRP,NFREG,NBMIX,NMIX, + 1 NFM,NL,NDEL,NED,ISEED,IPRINT,NBSCO,NMERGE,NGCOND + PARAMETER (NSTATE=40,IOUT=6) + INTEGER ISTATE(NSTATE),GSTATE(NSTATE) + DOUBLE PRECISION XYZL(2,3),KEFF,REKEFF + CHARACTER NAMREC*12,HSIGN*12 + LOGICAL MODIF,LN2N +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INMIX,NAMEAD + REAL, ALLOCATABLE, DIMENSION(:) :: XST,XSS,XSSNN,XNUFI,XCHI,XSN2N, + < XSN3N,XSEDI +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.NE.3) CALL XABORT('MCT: THREE PARAMETERS EXPECTED.') +* output table in creation or modification mode + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) + 1 CALL XABORT('MCT: LCM OBJECT EXPECTED AT LHS (1).') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) + 1 CALL XABORT('MCT: ENTRY IN CREATION '// + 2 'OR MODIFICATION MODE EXPECTED.') + IPOUT=KENTRY(1) + MODIF=(JENTRY(1).EQ.1) +* tracking table in read-only mode + IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) + 1 CALL XABORT('MCT: LCM OBJECT EXPECTED AT LHS (2).') + IF((JENTRY(2).NE.1).AND.(JENTRY(2).NE.2)) CALL XABORT('MCT: ENTR' + 1 //'Y IN READ-ONLY OR MODIFICATION MODE EXPECTED.') + IPTRK=KENTRY(2) + CALL LCMGTC(IPTRK,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + NAMREC=HENTRY(2) + CALL XABORT('MCT: INVALID SIGNATURE FOR '//NAMREC) + ENDIF +* xs library in read-only mode + IF((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2)) + 1 CALL XABORT('MCT: LCM OBJECT EXPECTED AT LHS (3).') + IF(JENTRY(3).NE.2) + 1 CALL XABORT('MCT: ENTRY IN READ-ONLY MODE EXPECTED (2).') + IPLIB=KENTRY(3) + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_LIBRARY') THEN + CALL LCMSIX(IPLIB,'MACROLIB',1) + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') THEN + NAMREC=HENTRY(3) + CALL XABORT('MCT: INVALID SIGNATURE FOR '//NAMREC) + ENDIF + ELSE IF(HSIGN.NE.'L_MACROLIB') THEN + NAMREC=HENTRY(3) + CALL XABORT('MCT: INVALID SIGNATURE FOR '//NAMREC) + ENDIF +*---- +* INITIALIZE OUTPUT TABLE +*---- + IF(MODIF) THEN + CALL LCMGTC(IPOUT,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MC') THEN + NAMREC=HENTRY(1) + CALL XABORT('MCT: INVALID SIGNATURE FOR '//NAMREC) + ENDIF + CALL LCMGET(IPOUT,'STATE-VECTOR',ISTATE) + ELSE + HSIGN='L_MC' + CALL LCMPTC(IPOUT,'SIGNATURE',12,HSIGN) + ISTATE(:NSTATE)=0 + ENDIF +*---- +* READ INPUT PARAMETERS +*---- + GSTATE(:NSTATE)=0 + CALL LCMGET(IPLIB,'STATE-VECTOR',GSTATE) + NGRP = GSTATE(1) + GSTATE(:NSTATE)=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',GSTATE) + NFREG= GSTATE(1) + NBMIX= GSTATE(4) + ALLOCATE(INMIX(NFREG)) + CALL LCMGET(IPTRK,'MATCOD',INMIX) + CALL MCTGET(IPOUT,NGRP,NFREG,NBMIX,INMIX,IPRINT) + DEALLOCATE(INMIX) + CALL LCMGET(IPOUT,'STATE-VECTOR',ISTATE) + ISEED=ISTATE(4) + LN2N=(ISTATE(5).EQ.1) +*---- +* VALIDATE THE OPTIONS SPECIFIED FOR THE KCODE CARD +*---- + IF ((ISTATE(1).GT.0).AND. + < (ISTATE(2).GT.0).AND. + < (ISTATE(3).GT.0).AND. + < (ISTATE(2).LE.ISTATE(3))) THEN + NSRCK=ISTATE(1) + IKZ =ISTATE(2) + KCT =ISTATE(3) + ELSE + CALL XABORT('MCT: INVALID PARAMETERS SPECIFIED FOR KCODE CARD') + ENDIF +*---- +* RECOVER MACROSCOPIC CROSS SECTIONS. +*---- + GSTATE(:NSTATE)=0 + CALL LCMGET(IPLIB,'STATE-VECTOR',GSTATE) + NGRP = GSTATE(1) + NMIX = GSTATE(2) + NL = GSTATE(3) + NFM = GSTATE(4) + NED = GSTATE(5) + NDEL = GSTATE(7) + ALLOCATE(NAMEAD(2*NED)) + IF(NED.GT.0) CALL LCMGET(IPLIB,'ADDXSNAME-P0',NAMEAD) + ALLOCATE(XST(NMIX*NGRP),XSS(NMIX*NGRP*NL), + > XSSNN(NGRP*NGRP*NMIX*NL),XNUFI(NFM*NMIX*NGRP*(1+NDEL)), + > XCHI(NFM*NMIX*NGRP*(1+NDEL)),XSN2N(NMIX*NGRP),XSN3N(NMIX*NGRP), + > XSEDI(NMIX*NGRP*NED)) + CALL MCTLIB(IPLIB,NMIX,NGRP,NL,NFM,NDEL,NED,NAMEAD,LN2N, + < XST,XSS,XSSNN,XNUFI,XCHI,XSN2N,XSN3N,XSEDI) +*---- +* POWER ITERATION WITH THE MONTE-CARLO METHOD IN 1D/2D/3D CARTESIAN +* GEOMETRY. +*---- + GSTATE(:NSTATE)=0 + CALL LCMGET(IPOUT,'STATE-VECTOR',GSTATE) + NMERGE=GSTATE(7) + NGCOND=GSTATE(8) + NBSCO=5+NGCOND*NL+2*NFM*(1+NDEL)+NED + CALL MCTFLX(IPTRK,IPOUT,IPRINT,NMIX,NGRP,NL,NFM,NDEL,NED, + < NAMEAD,XST,XSS,XSSNN,XNUFI,XCHI,XSN2N,XSN3N, + < XSEDI,NSRCK,IKZ,KCT,ISEED,XYZL,NBSCO,NMERGE, + < NGCOND,KEFF,REKEFF) +* + DEALLOCATE(XSEDI,XSN3N,XSN2N,XCHI,XNUFI,XSSNN,XSS,XST,NAMEAD) +*---- +* RESET LIBRARY ON ROOT LEVEL +*---- + CALL LCMSIX(IPLIB,' ',0) +*---- +* SAVE KEFF INFORMATION ON MC OBJECT +*---- + CALL LCMPUT(IPOUT,'K-EFFECTIVE',1,2,REAL(KEFF)) + CALL LCMPUT(IPOUT,'K-EFFECTI-SD',1,2,REAL(REKEFF)) + IF(IPRINT.GT.0) WRITE(6,100) (ISTATE(ITC),ITC=1,9) + RETURN +* + 100 FORMAT(/8H OPTIONS/8H -------/ + 1 7H NSRCK ,I8,34H (NUMBER OF HISTORIES PER CYCLE)/ + 2 7H IKZ ,I8,29H (NUMBER OF CYCLES TO SKIP)/ + 3 7H KCT ,I8,27H (TOTAL NUMBER OF CYCLES)/ + 4 7H ISEED ,I8,45H (INITIAL SEED FOR RANDOM NUMBER GENERATOR)/ + 5 7H IN2N ,I8,24H (N2N PROCESSING FLAG)/ + 6 7H ITALLY,I8,20H (TYPE OF TALLIES)/ + 7 7H NMERGE,I8,44H (NUMBER OF HOMOGENIZED MIXTURES IN TALLY)/ + 8 7H NGCOND,I8,40H (NUMBER OF CONDENSED GROUPS IN TALLY)/ + 9 7H NREG ,I8,34H (NUMBER OF REGIONS IN GEOMETRY)) + END -- cgit v1.2.3