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/FMAC.f | 259 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 259 insertions(+) create mode 100644 Dragon/src/FMAC.f (limited to 'Dragon/src/FMAC.f') diff --git a/Dragon/src/FMAC.f b/Dragon/src/FMAC.f new file mode 100644 index 0000000..40c6723 --- /dev/null +++ b/Dragon/src/FMAC.f @@ -0,0 +1,259 @@ +*DECK FMAC + SUBROUTINE FMAC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Convert a macroscopic cross section file in ascii FMAC-M format +* towards Version5 macrolib format. +* +*Copyright: +* Copyright (C) 2020 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 type(L_MACROLIB); +* HENTRY(2) read-only ascii file containing FMAC-M data. +* 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) IPMACR + PARAMETER(NSTATE=40,IOUT=6,MAS=38) + CHARACTER TEXT12*12,TEXT18*18,HSIGN*12,TEX(50)*6,HPART*1 + INTEGER ISTATE(NSTATE),N(MAS),IZA(40) + DOUBLE PRECISION DFLOTT +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NGPRT,NPMIN,NPMAX,NANIS, + 1 MUFIS + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NWA + REAL, ALLOCATABLE, DIMENSION(:,:) :: H2 + CHARACTER(LEN=1), ALLOCATABLE, DIMENSION(:) :: HNPRT +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.NE.2) CALL XABORT('FMAC: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('FMAC: LCM' + 1 //' OBJECT EXPECTED AT LHS.') + IF(JENTRY(1).NE.0) CALL XABORT('FMAC: ENTRY IN CREATE MODE EXPEC' + 1 //'TED.') + IPMACR=KENTRY(1) + HSIGN='L_MACROLIB' + CALL LCMPTC(IPMACR,'SIGNATURE',12,HSIGN) +*---- +* RECOVER FMAC-M FILE +*---- + TEXT12=HENTRY(2) + IF(IENTRY(2).NE.4) CALL XABORT('FMAC: ASCII FILE NAMED '//TEXT12 + 1 //' EXPECTED AT LHS.') + IF(JENTRY(2).NE.2) CALL XABORT('FMAC: ASCII FILE IN READ-ONLY MO' + 1 //'DE EXPECTED.') + LIN=FILUNIT(KENTRY(2)) +*---- +* READ THE INPUT DATA +*---- + IMPX=1 + HPART=' ' + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('FMAC: CHARACTER DATA EXPECTED.') + IF(TEXT12.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT12,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('FMAC: INTEGER DATA EXPECTED.') + ELSE IF(TEXT12.EQ.'PARTICLE') THEN +* READ THE PARTICLE TYPE ('N', 'G', 'C', 'P') + CALL REDGET(INDIC,NITMA,FLOTT,HPART,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('FMAC: CHARACTER DATA EXPECTED.') + CALL LCMPTC(IPMACR,'PARTICLE',1,HPART) + ELSE IF(TEXT12.EQ.';') THEN + GO TO 20 + ELSE + CALL XABORT('FMAC: '//TEXT12//' IS AN INVALID KEYWORD.') + ENDIF + GO TO 10 +*---- +* MACROLIB INITIALIZATION +*---- + 20 IPART=0 + NANISO=0 + ITRANC=0 + NALBP=0 + NSTEP=0 + IDF=0 +*---- +* PROCESS THE FMAC FILE FOR 1D COUPLED CROSS-SECTION DATA +*---- + READ(LIN,'(A18,I12)') TEXT18,IVERS + IF(IMPX.GT.0) WRITE(IOUT,1002) TEXT18,IVERS + READ(LIN,'(A72)') + READ(LIN,'(A30)') + READ(LIN,'(6I12)') NTYPE,(N(I),I=1,9) + READ(LIN,'(12A6)')(TEX(I),I=1,NTYPE) + IF(TEX(1).NE.'NGCAP ') THEN + CALL XABORT('FMAC: INVALID DATA TYPE='//TEX(1)//'.') + ENDIF + READ(LIN,'(6I12)') (IZA(I),I=1,40) + WRITE(IOUT,1101) (IZA(I),I=1,40) + NGP=IZA(1) + NPART=IZA(2) + NGXI=IZA(3) + NGXIF=IZA(4) + NDELG=IZA(5) + NEDIT=IZA(8) + KLEIN=IZA(10) + IADJ=IZA(12) + NUCL=IZA(13) + NK=IZA(15) + NUFIS=IZA(16) + MASM3=IZA(17) + NWO=IZA(20) + MPOINT=IZA(21) + ALLOCATE(NGPRT(NPART),HNPRT(NPART),NPMIN(NGP),NPMAX(NGP), + 1 NANIS(NGP),MUFIS(NUFIS)) + NPMIN=1 + NPMAX=NGP + NANIS=NWO + IF(MASM3.GT.38) CALL XABORT('FMAC: MASM3 OVERFLOW.') + READ(LIN,'(6I12)')(N(I),I=1,MASM3) + CALL FMAC01(IPMACR,IMPX,HPART,LIN,IVERS,NGP,NPART,NGXI,NEDIT, + 1 NUCL,NK,NUFIS,MASM3,N,NGPRT,HNPRT,NPMIN,NPMAX,NANIS,MUFIS) +*---- +* PROCESS SCATTERING INFORMATION +*---- + DO I=1,NPART + IF(HNPRT(I).EQ.HPART) THEN + IPART=I + GO TO 30 + ENDIF + ENDDO + CALL XABORT('FMAC: PARTICLE '//HPART//' NOT AVAILABLE IN FMAC-M ' + 1 //'FILE.') + 30 IF(IPART.EQ.0) CALL XABORT('FMAC: PARTICLE TYPE NOT DEFINED.') + IG1=1 + DO I=1,IPART-1 + IG1=IG1+NGPRT(I) + ENDDO + IG2=IG1+NGPRT(IPART)-1 + DO IG=IG1,IG2 + NANISO=MAX(NANISO,NANIS(IG)) + ENDDO + DO IG=1,NGP + MAXLEN=2*(NANISO+1)*NK + ALLOCATE(H2(NGP,MAXLEN),NWA(NGP,NK)) + H2(:NGP,:MAXLEN)=0.0 + NWA(:NGP,:NK)=0 + DO NP=NPMIN(IG),NPMAX(IG) + READ(LIN,'(6I12)') NPP,NQQ,(NWA(NPP,I),I=1,NK),LENGTH + IF(LENGTH.GT.MAXLEN) CALL XABORT('FMAC: MAXLEN OVERFLOW.') + READ(LIN,'(6E12.0)') (H2(NPP,J),J=1,LENGTH) + ENDDO + IF((IG.GE.IG1).AND.(IG.LE.IG2)) THEN + CALL FMAC03(IPMACR,IG,IPART,NGP,MAXLEN,NANISO,NK,NPART,HNPRT, + 1 NGPRT,NWA,H2) + ENDIF + DEALLOCATE(NWA,H2) + ENDDO +*---- +* WRITE THE STATE VECTOR AND EXIT +*---- + ISTATE(:NSTATE)=0 + ISTATE(1)=NGPRT(IPART) + ISTATE(2)=NK + ISTATE(3)=NANISO + ISTATE(4)=NUFIS + ISTATE(5)=0 + ISTATE(6)=ITRANC + ISTATE(7)=NDELG + ISTATE(8)=NALBP + ISTATE(11)=NSTEP + ISTATE(12)=IDF + ISTATE(13)=IADJ + ISTATE(17)=NPART-1 + CALL LCMPUT(IPMACR,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(IMPX.GT.1) CALL LCMLIB(IPMACR) + IF(IMPX.GT.0) THEN + WRITE(IOUT,1010) IMPX,(ISTATE(I),I=1,7),ISTATE(9),ISTATE(11), + 1 ISTATE(12),ISTATE(13),ISTATE(17),HPART + WRITE(IOUT,1020) (HNPRT(I),I=1,NPART) + WRITE(IOUT,1030) (NGPRT(I),I=1,NPART) + ENDIF + DEALLOCATE(MUFIS,NANIS,NPMAX,NPMIN,HNPRT,NGPRT) + RETURN +* + 1101 FORMAT(1X,'NG =',I3,' number of energy groups;',/ + +,1X,'NPART =',I3,' number of particle types;',/ + +,1X,'NGXI =',I3,' number of groups with non-zero fission spectr + +um;',/ + +,1X,'NGXIF =',I3,' number of the first group with non-zero fissi + +on spectrum;',/ + +,1X,'NGRET =',I3,' number of delayed neutron groups;',/ + +,1X,'NGXIR =',I3,' number of groups with non-zero fission spectr + +um for delayed neutrons;',/ + +,1X,'NGXIFR=',I3,' number of the first group with non-zero fissi + +on spectrum for delayed neutrons;',/ + +,1X,'NEDIT =',I3,' number of additional edit cross-sections;' + +,/ + +,1X,'MAXGS =',I3,' not used;',/ + +,1X,'KLEIN =',I3,' not used;',/ + +,1X,'NGHIGH=',I3,' total number of groups of cascade region;',/ + +,1X,'IADJ =',I3,' 0/1 - regular/adjoint cross-section file;',/ + +,1X,'NUCL =',I3,' number of nuclides;',/ + +,1X,'NUCLF =',I3,' number of fission nuclides;',/ + +,1X,'MIX =',I3,' number of materials (compositions);',/ + +,1X,'NUFIS =',I3,' number of fission materials;',/ + +,1X,'MAS =',I3,' length of integer control array LL(MAS);',/ + +,1X,'KIN=',I6,' total number of scattering transitions (not used + +);',/ + +,1X,'MX =',I3,' maximal length of transition array (not used) + +;',/ + +,1X,'MNW =',I3,' order of PL approximation used +1;',/ + +,1X,'MPOINT=',I3,' order of discrete approximation of scattering + + indicatrix (number of angular scattering cosine points used);',/ + +,1X,'NUMD(I)=',19I3,' not used') + 1002 FORMAT(1X,A18/' FMAC: Format FMAC-M version =',I2) + 1010 FORMAT(/8H OPTIONS/8H -------/ + 1 7H IMPX ,I6,30H (0=NO PRINT/1=SHORT/2=MORE)/ + 2 7H NGROUP,I6,28H (NUMBER OF ENERGY GROUPS)/ + 3 7H NBMIX ,I6,39H (NUMBER OF MIXTURES IN THE MACROLIB)/ + 4 7H NANISO,I6,34H (MAXIMUM SCATTERING ANISOTROPY)/ + 5 7H NIFISS,I6,45H (MAXIMUM NUMBER OF FISSILE ISOTOPES IN A M, + 6 7HIXTURE)/ + 7 7H NEDMAC,I6,34H (NUMBER OF CROSS SECTION EDITS)/ + 8 7H ITRANC,I6,45H (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2, + 9 43H=RECOVER FROM LIBRARY/4=LEAKAGE CORRECTION)/ + 1 7H NLG ,I6,39H (NUMBER OF DELAYED PRECURSOR GROUPS)/ + 2 7H ILEAK ,I6,40H (1=DIFF AVAILABLE; 2=DIFFX AVAILABLE)/ + 3 7H NSTEP ,I6,39H (NUMBER OF PERTURBATION DIRECTORIES)/ + 4 7H IDF ,I6,48H (=0/2 BOUNDARY FLUXES FOR ADF ABSENT/PRESENT)/ + 5 7H IADJ ,I6,33H (=0/1 DIRECT/ADJOINT MACROLIB)/ + 6 7H NPART0,I6,34H (NUMBER OF COMPANION PARTICLES)/ + 7 6H HPART ,A7,22H (MACROLIB PARTICLE)) + 1020 FORMAT(/22H PARTICLE NAMES:,10A8) + 1030 FORMAT(22H NB. OF ENERGY GROUPS:,10I8) + END -- cgit v1.2.3