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/USSIN1.f | 296 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 296 insertions(+) create mode 100644 Dragon/src/USSIN1.f (limited to 'Dragon/src/USSIN1.f') diff --git a/Dragon/src/USSIN1.f b/Dragon/src/USSIN1.f new file mode 100644 index 0000000..086610b --- /dev/null +++ b/Dragon/src/USSIN1.f @@ -0,0 +1,296 @@ +*DECK USSIN1 + SUBROUTINE USSIN1(IPLI0,IPLIB,NGRP,NBMIX,NBISO,NIRES,NBNRS,NL, + 1 NED,NDEL,IREX,IMPX,ISONAM,ISOBIS,MIX,IAPT,MASKI,SPH,PHGAR,STGAR, + 2 SFGAR,SSGAR,S0GAR,SAGAR,SDGAR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Write the self-shielded and SPH-corrected cross sections on the +* internal library. +* +*Copyright: +* Copyright (C) 2003 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 +* IPLI0 pointer to the internal microscopic cross section library +* builded by the self-shielding module (L_LIBRARY signature). +* IPLIB pointer to the internal microscopic cross section library +* with subgroups (L_LIBRARY signature). +* NGRP number of energy groups. +* NBMIX number of mixtures in the internal library. +* NBISO number of isotopes. +* NIRES number of resonant isotopes in fuel regions. +* NBNRS number of totally correlated fuel regions. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NED number of extra vector edits. +* NDEL number of delayed neutron precursor groups. +* IREX fuel region index assigned to each mixture (equal to zero +* in non-resonant mixtures or in mixtures not used). +* IMPX print flag (equal to zero for no print). +* ISONAM alias name of isotopes in IPLIB. +* ISOBIS alias name of isotopes in IPLI0. +* MIX mix number of each isotope (can be zero). +* IAPT resonant isotope index associated with isotope I. Mixed +* moderator if IAPT(I)=NIRES+1. Out-of-fuel isotope if +* IAPT(I)=0. +* MASKI isotopic flag (MASKI(ISO)=.TRUE. to process isotope ISO). +* SPH SPH factors. +* PHGAR averaged fluxes in correlated fuel regions. +* STGAR microscopic self-shielded total x-s. +* SFGAR microscopic self-shielded fission x-s. +* SSGAR microscopic self-shielded scattering x-s. +* S0GAR microscopic transfer scattering xs (isotope,secondary, +* primary). +* SAGAR microscopic self-shielded additional xs. +* SDGAR microscopic self-shielded delayed nu-sigf xs. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLI0,IPLIB + INTEGER NGRP,NBMIX,NBISO,NIRES,NBNRS,NL,NED,NDEL,IREX(NBMIX), + 1 IMPX,ISONAM(3,NBISO),ISOBIS(3,NBISO),MIX(NBISO),IAPT(NBISO) + REAL SPH(NBNRS,NIRES,NGRP),PHGAR(NBNRS,NIRES,NGRP), + 1 STGAR(NBNRS,NIRES,NGRP),SFGAR(NBNRS,NIRES,NGRP), + 2 SSGAR(NBNRS,NIRES,NL,NGRP),S0GAR(NBNRS,NIRES,NL,NGRP,NGRP), + 3 SAGAR(NBNRS,NIRES,NED,NGRP),SDGAR(NBNRS,NIRES,NDEL,NGRP) + LOGICAL MASKI(NBISO) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXED=50,MAXSAV=100,MAXESP=4) + TYPE(C_PTR) JPLI0,KPLI0,KPLIB + INTEGER IPAR(40),ISAV(MAXSAV),IESP(MAXESP+1) + REAL EESP(MAXESP+1) + CHARACTER TEXT12*12,HSIGN*12,CM*2,HVECT(MAXED)*8,HCHI*12 + LOGICAL LOGNF,LTEST +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: ISONR,ITITLE + REAL, ALLOCATABLE, DIMENSION(:) :: GAR1,ENERGY,LAMB + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR2 + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GAR1(NGRP),GAR2(NGRP,NGRP),ENERGY(NGRP+1),IPISO(NBISO)) +* + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + CALL XABORT('USSIN1: SIGNATURE IS '//HSIGN//'. L_LIBRARY EXPEC' + 1 //'TED.') + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + IF(NGRP.NE.IPAR(3)) CALL XABORT('USSIN1: INVALID NB OF GROUPS.') + IF(NL.NE.IPAR(4)) CALL XABORT('USSIN1: INVALID VALUE OF NL.') + IF(NED.NE.IPAR(13)) CALL XABORT('USSIN1: INVALID VALUE OF NED.') + IF(NED.GT.0) THEN + IF(NED.GT.MAXED) CALL XABORT('USSIN1: INVALID VALUE OF MAXED.') + CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT) + ENDIF + CALL LCMLEN(IPLIB,'ENERGY',LENGT,ITYLCM) + IF(LENGT-1.NE.NGRP) CALL XABORT('LIBIN2: INVALID GROUP STRUCTU' + 1 //'RE.') + CALL LCMGET(IPLIB,'ENERGY',ENERGY) + CALL LCMPUT(IPLI0,'ENERGY',NGRP+1,2,ENERGY) + CALL LCMGET(IPLIB,'DELTAU',ENERGY) + CALL LCMPUT(IPLI0,'DELTAU',NGRP,2,ENERGY) + CALL LCMLEN(IPLIB,'CHI-LIMITS',NBESP,ITYLCM) + IF(NBESP.GT.0) THEN + NBESP=NBESP-1 + IF(NBESP.GT.MAXESP) CALL XABORT('USSIN1: MAXESP OVERFLOW.') + CALL LCMGET(IPLIB,'CHI-LIMITS',IESP) + CALL LCMPUT(IPLI0,'CHI-LIMITS',NBESP+1,1,IESP) + CALL LCMGET(IPLIB,'CHI-ENERGY',EESP) + CALL LCMPUT(IPLI0,'CHI-ENERGY',NBESP+1,2,EESP) + ENDIF + ALLOCATE(ISONR(3*NBISO)) + CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONR) + CALL LCMPUT(IPLI0,'ISOTOPERNAME',3*NBISO,3,ISONR) + DEALLOCATE(ISONR) + CALL LIBIPS(IPLIB,NBISO,IPISO) + JPLI0=LCMLID(IPLI0,'ISOTOPESLIST',NBISO) + DO 370 ISOT=1,NBISO + IRES=IAPT(ISOT) + IF(MASKI(ISOT).AND.(IRES.GT.0).AND.(IRES.LE.NIRES)) THEN + KPLIB=IPISO(ISOT) ! set ISOT-th isotope + WRITE(TEXT12,'(3A4)') (ISOBIS(J,ISOT),J=1,3) + IF(IMPX.GT.0) WRITE (6,'(/29H USSIN1: PROCESSING ISOTOPE '', + 1 A12,2H''.)') TEXT12 + KPLI0=LCMDIL(JPLI0,ISOT) ! set ISOT-th isotope + CALL LCMPTC(KPLI0,'ALIAS',12,TEXT12) + CALL LCMGET(KPLIB,'AWR',AWR) + CALL LCMPUT(KPLI0,'AWR',1,2,AWR) + CALL LCMLEN(KPLIB,'README',LENTIT,ITYLCM) + IF(LENTIT.GT.0) THEN + ALLOCATE(ITITLE(LENTIT)) + CALL LCMGET(KPLIB,'README',ITITLE) + CALL LCMPUT(KPLI0,'README',LENTIT,3,ITITLE) + DEALLOCATE(ITITLE) + ENDIF + CALL LCMLEN(KPLIB,'NUSIGF',NFIS,ITYLCM) + LOGNF=(NFIS.GT.0) + IF(LOGNF) THEN + IF(NBESP.EQ.0) THEN + CALL LCMGET(KPLIB,'CHI',GAR1) + CALL LCMPUT(KPLI0,'CHI',NGRP,2,GAR1) + ELSE + DO ISP=1,NBESP + WRITE(HCHI,'(5HCHI--,I2.2)') ISP + CALL LCMLEN(KPLIB,HCHI,ILONG,ITYLCM) + IF(ILONG.EQ.NGRP) THEN + CALL LCMGET(KPLIB,HCHI,GAR1) + CALL LCMPUT(KPLI0,HCHI,NGRP,2,GAR1) + ENDIF + ENDDO + ENDIF + ENDIF + IND=IREX(MIX(ISOT)) + IF(IND.EQ.0) CALL XABORT('USSIN1: IREX FAILURE.') + DO 20 IG1=1,NGRP + GAR1(IG1)=PHGAR(IND,IRES,IG1) + 20 CONTINUE + CALL LCMPUT(KPLI0,'NWT0',NGRP,2,GAR1) + DO 30 IG1=1,NGRP + GAR1(IG1)=SPH(IND,IRES,IG1) + 30 CONTINUE + CALL LCMPUT(KPLI0,'NSPH',NGRP,2,GAR1) + DO 40 IG1=1,NGRP + GAR1(IG1)=STGAR(IND,IRES,IG1) + 40 CONTINUE + CALL LCMPUT(KPLI0,'NTOT0',NGRP,2,GAR1) + IF(LOGNF) THEN + DO 50 IG1=1,NGRP + GAR1(IG1)=SFGAR(IND,IRES,IG1) + 50 CONTINUE + CALL LCMPUT(KPLI0,'NUSIGF',NGRP,2,GAR1) + ENDIF + DO 90 IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + DO 70 IG1=1,NGRP + GAR1(IG1)=SSGAR(IND,IRES,IL,IG1) + DO 60 IG2=1,NGRP + GAR2(IG2,IG1)=S0GAR(IND,IRES,IL,IG2,IG1) + 60 CONTINUE + 70 CONTINUE + CALL XDRLGS(KPLI0,1,IMPX,IL-1,IL-1,1,NGRP,GAR1,GAR2,ITYPRO) + 90 CONTINUE + CALL LCMLEN(KPLIB,'XS-SAVED',ILENG,ITYLCM) + IF(ILENG.GT.MAXSAV) CALL XABORT('USSIN1: XS-SAVED OVERFLOW.') + IF(ILENG.GT.0) CALL LCMGET(KPLIB,'XS-SAVED',ISAV) + IF(ILENG.GT.0) CALL LCMPUT(KPLI0,'XS-SAVED',ILENG,1,ISAV) + CALL LCMLEN(KPLIB,'SCAT-SAVED',ILENG,ITYLCM) + IF(ILENG.GT.MAXSAV) CALL XABORT('USSIN1: SCAT-SAVED OVERFLOW.') + IF(ILENG.GT.0) CALL LCMGET(KPLIB,'SCAT-SAVED',ISAV) + IF(ILENG.GT.0) CALL LCMPUT(KPLI0,'SCAT-SAVED',ILENG,1,ISAV) + DO 110 IED=1,NED + CALL LCMLEN(KPLIB,HVECT(IED),NEDI,ITYLCM) + IF((NEDI.GT.0).AND.(HVECT(IED)(:3).NE.'CHI').AND. + 1 (HVECT(IED)(:2).NE.'NU').AND.(HVECT(IED).NE.'NGOLD').AND. + 2 (HVECT(IED)(:3).NE.'NWT').AND.(HVECT(IED).NE.'NTOT0')) THEN + DO 100 IG1=1,NGRP + GAR1(IG1)=SAGAR(IND,IRES,IED,IG1) + 100 CONTINUE + CALL LCMPUT(KPLI0,HVECT(IED),NGRP,2,GAR1) + ENDIF + 110 CONTINUE + CALL LCMLEN(KPLIB,'NUSIGF01',ILONG,ITYLCM) + IF(ILONG.EQ.NGRP) THEN + CALL LCMLEN(KPLIB,'LAMBDA-D',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + WRITE(TEXT12,'(3A4)') (ISONAM(J,ISOT),J=1,3) + CALL XABORT('USSIN1: MISSING LAMBDA-D INFO '//'FOR '// + 1 TEXT12//'.') + ENDIF + ALLOCATE(LAMB(ILONG)) + CALL LCMGET(KPLIB,'LAMBDA-D',LAMB) + CALL LCMPUT(KPLI0,'LAMBDA-D',ILONG,2,LAMB) + DEALLOCATE(LAMB) + DO 130 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + LTEST=.FALSE. + DO 120 IG1=1,NGRP + GAR1(IG1)=SDGAR(IND,IRES,IDEL,IG1) + LTEST=LTEST.OR.(GAR1(IG1).NE.0.0) + 120 CONTINUE + IF(LTEST) THEN + CALL LCMPUT(KPLI0,TEXT12,NGRP,2,GAR1) + WRITE(TEXT12,'(3HCHI,I2.2)') IDEL + CALL LCMGET(KPLIB,TEXT12,GAR1) + CALL LCMPUT(KPLI0,TEXT12,NGRP,2,GAR1) + ENDIF + 130 CONTINUE + ENDIF +* + IF(IMPX.GT.2) THEN + CALL LCMGET(KPLI0,'NWT0',GAR1) + WRITE (6,'(/20H SELF-SHIELDED FLUX:/ + 1 (1X,1P,10E12.4))') (GAR1(I),I=1,NGRP) + WRITE (6,'(/13H SPH FACTORS:/(1X,1P,10E12.4))') + 1 (SPH(IND,IRES,I),I=1,NGRP) + CALL LCMGET(KPLI0,'NTOT0',GAR1) + WRITE (6,'(/36H SELF-SHIELDED MICROSCOPIC TOTAL XS:/ + 1 (1X,1P,10E12.4))') (GAR1(I),I=1,NGRP) + DO 350 IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + CALL LCMLEN(KPLI0,'SCAT'//CM,ILSCAT,ITYLCM) + IF(ILSCAT.GT.NGRP**2) CALL XABORT('USSIN1: OVERWRITING ME' + 1 //'MORY(2).') + IF((IL.EQ.1).OR.(ILSCAT.GT.0)) THEN + CALL LCMGET(KPLI0,'SIGS'//CM,GAR1) + WRITE (6,'(/16H SELF-SHIELDED P,A2,18H MICROSCOPIC SCATT, + 1 9HERING XS:/(1X,1P,10E12.4))') CM,(GAR1(I),I=1,NGRP) + ENDIF + 350 CONTINUE + IF(LOGNF) THEN + CALL LCMGET(KPLI0,'NUSIGF',GAR1) + WRITE (6,'(/38H SELF-SHIELDED MICROSCOPIC FISSION XS:/ + 1 (1X,1P,10E12.4))') (GAR1(I),I=1,NGRP) + IF(NBESP.EQ.0) THEN + CALL LCMGET(KPLI0,'CHI',GAR1) + WRITE (6,'(/18H FISSION SPECTRUM:/ + 1 (1X,1P,10E12.4))') (GAR1(I),I=1,NGRP) + ELSE + DO 355 ISP=1,NBESP + WRITE(HCHI,'(5HCHI--,I2.2)') ISP + CALL LCMLEN(KPLI0,HCHI,ILONG,ITYLCM) + IF(ILONG.EQ.NGRP) THEN + CALL LCMGET(KPLI0,HCHI,GAR1) + WRITE (6,'(/I3,21H-TH FISSION SPECTRUM:/ + 1 (1X,1P,10E12.4))') ISP,(GAR1(I),I=1,NGRP) + ENDIF + 355 CONTINUE + ENDIF + ENDIF + DO 360 IED=1,NED + CALL LCMLEN(KPLI0,HVECT(IED),NEDI,ITYLCM) + IF((NEDI.GT.0).AND.(HVECT(IED)(:3).NE.'CHI').AND. + 1 (HVECT(IED)(:2).NE.'NU').AND.(HVECT(IED).NE.'NGOLD').AND. + 2 (HVECT(IED)(:3).NE.'NWT').AND.(HVECT(IED).NE.'NTOT0')) THEN + CALL LCMGET(KPLI0,HVECT(IED),GAR1) + WRITE (6,'(/15H SELF-SHIELDED ,A6,1H:/(1X,1P,10E12.4))') + 1 HVECT(IED),(GAR1(I),I=1,NGRP) + ENDIF + 360 CONTINUE + ENDIF + ENDIF + 370 CONTINUE + IF(IMPX.GT.3) CALL LCMLIB(IPLI0) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO,ENERGY,GAR2,GAR1) + RETURN + END -- cgit v1.2.3