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/M2T.f | 156 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 156 insertions(+) create mode 100644 Dragon/src/M2T.f (limited to 'Dragon/src/M2T.f') diff --git a/Dragon/src/M2T.f b/Dragon/src/M2T.f new file mode 100644 index 0000000..427c21c --- /dev/null +++ b/Dragon/src/M2T.f @@ -0,0 +1,156 @@ +*DECK M2T + SUBROUTINE M2T(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover information from a macrolib and translate the requested data +* towards an Apotrim interface file. +* +*Copyright: +* Copyright (C) 2007 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/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) create or modification ascii file containing +* Apotrim data; +* HENTRY(2) read-only 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 +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) IPMAC + PARAMETER (NSTATE=40,IOUT=6) + CHARACTER TEXT12*12,TEXT20*20,HSIGN*12 + DOUBLE PRECISION DFLOTT + INTEGER ISTATE(NSTATE) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NBM,HBM + REAL, ALLOCATABLE, DIMENSION(:) :: BUP,TEMP +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.LE.1) CALL XABORT('M2T: MINIMUM OF 2 OBJECTS EXPECTED.') + TEXT12=HENTRY(1) + IF(IENTRY(1).NE.4) CALL XABORT('M2T: ASCII FILE NAMED '//TEXT12 + 1 //' EXPECTED AT LHS.') + IF(JENTRY(1).EQ.2) CALL XABORT('M2T: ASCII FILE IN CREATE OR MOD' + 1 //'IFICATION MODE EXPECTED.') + LOUT=FILUNIT(KENTRY(1)) + IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) CALL XABORT('M2T: LCM ' + 1 //'OBJECT EXPECTED AT RHS.') + IF(JENTRY(2).NE.2) CALL XABORT('M2T: LCM OBJECTS IN READ-ONLY MO' + 1 //'DE EXPECTED AT RHS.') + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') CALL XABORT('M2T: MACROLIB OBJECT EXPE' + 1 //'CTED AT RHS.') + IPMAC=KENTRY(2) + CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) + NGRP=ISTATE(1) + MAXMIX=ISTATE(2) + MAXNL=ISTATE(3) + NBFIS=ISTATE(4) + IF(NBFIS.GT.1) CALL XABORT('M2T: THE CAPABILITY TO MERGE MANY FI' + 1 //'SSION SPECTRA IS NOT IMPLEMENTED.') +*---- +* ALLOCATE MEMORY +*---- + ALLOCATE(NBM(MAXMIX),HBM(5*MAXMIX),BUP(MAXMIX),TEMP(MAXMIX)) + NBM(:MAXMIX)=1 + BUP(:MAXMIX)=0.0 + TEMP(:MAXMIX)=0.0 +*---- +* READ THE INPUT DATA +*---- + NL=1 + NBMIX=0 + ICTR=0 + IGMAIL=0 + IMPX=1 + 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('M2T: CHARACTER DATA EXPECTED(1).') + IF(TEXT12.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('M2T: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT12.EQ.'MIX') THEN +* READ A MATERIAL MIXTURE. + TEXT20=' ' + CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('M2T: CHARACTER DATA EXPECTED(2).') + NBMIX=NBMIX+1 + IF(NBMIX.GT.MAXMIX) CALL XABORT('M2T: MAXMIX OVERFLOW.') + READ(TEXT20,'(5A4)') (HBM(5*(NBMIX-1)+I0),I0=1,5) + 30 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('M2T: CHARACTER DATA EXPECTED(3).') + IF(TEXT12.EQ.'FROM') THEN + CALL REDGET(INDIC,NBM(NBMIX),FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('M2T: INTEGER DATA EXPECTED(2).') + GO TO 30 + ELSE IF(TEXT12.EQ.'BURN') THEN +* READ A BURNUP. + CALL REDGET(INDIC,NITMA,BUP(NBMIX),TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('M2T: REAL DATA EXPECTED(1).') + GO TO 30 + ELSE IF(TEXT12.EQ.'TEMP') THEN +* READ A TEMPERATURE. + CALL REDGET(INDIC,NITMA,TEMP(NBMIX),TEXT12,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('M2T: REAL DATA EXPECTED(2).') + GO TO 30 + ELSE IF(TEXT12.NE.'ENDMIX') THEN + CALL XABORT('M2T: FROM, BURN, TEMP OR ENDMIX EXPECTED.') + ENDIF + ELSE IF(TEXT12.EQ.'PN') THEN +* READ THE ANISOTROPY ORDER + CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('M2T: INTEGER DATA EXPECTED(3).') + NL=MIN(NITMA+1,MAXNL) + ELSE IF(TEXT12.EQ.'TRAN') THEN +* PERFORM TRANSPORT CORRECTION + ICTR=1 + ELSE IF(TEXT12.EQ.'NOMA') THEN +* DO NOT WRITE ENERGY MESH ON APOTRIM FILE + IGMAIL=1 + ELSE IF(TEXT12.EQ.';') THEN + GO TO 40 + ELSE + CALL XABORT('M2T: '//TEXT12//' IS AN INVALID KEYWORD.') + ENDIF + GO TO 20 +*---- +* RECOVER INFORMATION +*---- + 40 CALL M2TDRV(IMPX,LOUT,IPMAC,NGRP,NBMIX,MAXMIX,NL,NBFIS,ICTR, + 1 IGMAIL,BUP,TEMP,HBM,NBM) +*---- +* RELEASE MEMORY +*---- + DEALLOCATE(TEMP,BUP,HBM,NBM) + RETURN + END -- cgit v1.2.3