diff options
Diffstat (limited to 'Dragon/src/LIBEXT.f')
| -rw-r--r-- | Dragon/src/LIBEXT.f | 211 |
1 files changed, 211 insertions, 0 deletions
diff --git a/Dragon/src/LIBEXT.f b/Dragon/src/LIBEXT.f new file mode 100644 index 0000000..c8d54be --- /dev/null +++ b/Dragon/src/LIBEXT.f @@ -0,0 +1,211 @@ +*DECK LIBEXT + SUBROUTINE LIBEXT (IPDRL,NGRO,NL,NDIL,NED,HVECT,NDEL,LSTAY,IMPX, + 1 DILUT,MDIL,LSCAT,LSIGF,LADD,LGOLD,FLUX,TOTAL,SIGF,SIGS,SCAT, + 2 SADD,ZDEL,DELTG,GOLD,ISMIN,ISMAX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read dilution-dependent information of one isotope in multi-dilution +* internal library format. +* +*Copyright: +* Copyright (C) 2002 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 +* IPDRL pointer to the multi-dilution internal library. +* NGRO number of energy groups. +* NL number of Legendre orders required in the calculation +* (NL=1 or higher). +* NDIL number of finite dilutions. +* NED number of extra vector edits. +* HVECT names of the extra vector edits. +* NDEL number of delayed neutron precursor groups. +* LSTAY dilution reduction flag (=.true. do not reduce). +* IMPX print flag. +* +*Parameters: input/output +* DILUT dilutions. +* +*Parameters: output +* MDIL number of finite dilutions used. +* LSCAT Legendre flag (=.true. if a given Legendre order of the +* scattering cross section exists). +* LSIGF fission flag (=.true. if the isotope can fission). +* LADD additional xs flag (=.true. if a given additional cross +* section exists). +* LGOLD Goldstein-Cohen flag (=.true. if Goldstein-Cohen parameters +* exists). +* FLUX weighting flux. +* TOTAL total cross sections. +* SIGF nu*fission cross sections. +* SIGS scattering cross sections. +* SCAT scattering transfer matrices (sec,prim,Legendre,dilution). +* SADD additional cross sections. +* ZDEL delayed nu-sigf cross sections. +* DELTG lethargy widths. +* GOLD Goldstein-Cohen parameters. +* ISMIN minimum secondary group corresponding to each primary group. +* ISMAX maximum secondary group corresponding to each primary group. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPDRL + INTEGER NGRO,NL,NDIL,NED,NDEL,IMPX,MDIL,ISMIN(NL,NGRO), + 1 ISMAX(NL,NGRO) + REAL DILUT(NDIL+1),FLUX(NGRO,NDIL+1),TOTAL(NGRO,NDIL+1), + 1 SIGF(NGRO,NDIL+1),SIGS(NGRO,NL,NDIL+1),SCAT(NGRO,NGRO,NL,NDIL+1), + 2 SADD(NGRO,NED,NDIL+1),ZDEL(NGRO,NDEL,NDIL+1),DELTG(NGRO), + 3 GOLD(NGRO) + CHARACTER HVECT(NED)*8 + LOGICAL LSTAY,LSIGF,LSCAT(NL),LADD(NED),LGOLD + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,IPDIL +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXTIT=10) + TYPE(C_PTR) JPDRL,KPDRL + CHARACTER TEXNUD*12 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ITYPRO(NL),IPDIL(NDIL+1)) +* + DO 10 IL=1,NL + LSCAT(IL)=.FALSE. + 10 CONTINUE + LSIGF=.FALSE. + DO 20 IED=1,NED + LADD(IED)=.FALSE. + 20 CONTINUE + CALL LCMGET(IPDRL,'DELTAU',DELTG) +*---- +* RECOVER DILUTION-DEPENDENT VALUES. +*---- + JPDRL=LCMGID(IPDRL,'ISOTOPESLIST') + DO 80 IDIL=1,NDIL+1 + KPDRL=LCMGIL(JPDRL,IDIL) ! set IDIL-th isotope + CALL LCMGET(KPDRL,'NWT0',FLUX(1,IDIL)) + CALL LCMGET(KPDRL,'NTOT0',TOTAL(1,IDIL)) + CALL LCMLEN(KPDRL,'NUSIGF',LENGT,ITYLCM) + LSIGF=LSIGF.OR.(LENGT.GT.0) + IF(LENGT.GT.0) THEN + CALL LCMGET(KPDRL,'NUSIGF',SIGF(1,IDIL)) + ELSE + SIGF(:NGRO,IDIL)=0.0 + ENDIF + CALL XDRLGS(KPDRL,-1,IMPX,0,NL-1,1,NGRO,SIGS(1,1,IDIL), + 1 SCAT(1,1,1,IDIL),ITYPRO) + DO 30 IL=0,NL-1 + LSCAT(IL+1)=LSCAT(IL+1).OR.(ITYPRO(IL+1).GT.0) + 30 CONTINUE + DO 50 IED=1,NED + DO 40 IG1=1,NGRO + SADD(IG1,IED,IDIL)=0.0 + 40 CONTINUE + CALL LCMLEN(KPDRL,HVECT(IED),LENGT,ITYLCM) + LADD(IED)=LADD(IED).OR.(LENGT.GT.0) + IF(LENGT.GT.0) CALL LCMGET(KPDRL,HVECT(IED),SADD(1,IED,IDIL)) + 50 CONTINUE + DO 70 IDEL=1,NDEL + WRITE(TEXNUD,'(6HNUSIGF,I2.2)') IDEL + DO 60 IG1=1,NGRO + ZDEL(IG1,IDEL,IDIL)=0.0 + 60 CONTINUE + CALL LCMLEN(KPDRL,TEXNUD,LENGT,ITYLCM) + IF(LENGT.GT.0) CALL LCMGET(KPDRL,TEXNUD,ZDEL(1,IDEL,IDIL)) + 70 CONTINUE + IF(IDIL.EQ.NDIL+1) THEN + CALL LCMLEN(KPDRL,'NGOLD',LENGT,ITYLCM) + LGOLD=LENGT.GT.0 + IF(LGOLD) THEN + CALL LCMGET(KPDRL,'NGOLD',GOLD) + ELSE + GOLD(:NGRO)=1.0 + ENDIF + ENDIF + 80 CONTINUE +*---- +* SET THE SIGNIFICANT DILUTIONS. +*---- + MDIL=0 + IF(LSTAY) THEN + MDIL=NDIL + DO 85 IDIL=1,NDIL + IPDIL(IDIL)=IDIL + 85 CONTINUE + ELSE + DO 90 IDIL=1,NDIL + IF(DILUT(IDIL).LT.1.5) THEN + CONTINUE + ELSE IF((DILUT(IDIL).GT.1.0E5).AND.(DILUT(IDIL).LT.1.0E10)) THEN + CONTINUE + ELSE + MDIL=MDIL+1 + IPDIL(MDIL)=IDIL + ENDIF + 90 CONTINUE + ENDIF + IPDIL(MDIL+1)=NDIL+1 + DO 122 IDIL=1,MDIL+1 + DILUT(IDIL)=DILUT(IPDIL(IDIL)) + DO 121 IG1=1,NGRO + FLUX(IG1,IDIL)=FLUX(IG1,IPDIL(IDIL)) + TOTAL(IG1,IDIL)=TOTAL(IG1,IPDIL(IDIL)) + SIGF(IG1,IDIL)=SIGF(IG1,IPDIL(IDIL)) + DO 105 IL=1,NL + SIGS(IG1,IL,IDIL)=SIGS(IG1,IL,IPDIL(IDIL)) + DO 100 IG2=1,NGRO + SCAT(IG2,IG1,IL,IDIL)=SCAT(IG2,IG1,IL,IPDIL(IDIL)) + 100 CONTINUE + 105 CONTINUE + DO 110 IED=1,NED + SADD(IG1,IED,IDIL)=SADD(IG1,IED,IPDIL(IDIL)) + 110 CONTINUE + DO 120 IDEL=1,NDEL + ZDEL(IG1,IDEL,IDIL)=ZDEL(IG1,IDEL,IPDIL(IDIL)) + 120 CONTINUE + 121 CONTINUE + 122 CONTINUE +*---- +* COMPUTE THE SCATTERING BANDWIDTH AND MOST THERMAL GROUPS. +*---- + DO 160 IL=1,NL + IF(LSCAT(IL)) THEN + DO 130 IG1=1,NGRO + ISMIN(IL,IG1)=NGRO + ISMAX(IL,IG1)=1 + 130 CONTINUE + DO 142 IG2=1,NGRO + DO 141 IDIL=1,MDIL+1 + DO 140 IG1=NGRO,1,-1 + IF(SCAT(IG2,IG1,IL,IDIL).NE.0.0) THEN + ISMIN(IL,IG1)=MIN(ISMIN(IL,IG1),IG2) + ISMAX(IL,IG1)=MAX(ISMAX(IL,IG1),IG2) + ENDIF + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE + ELSE + DO 150 IG1=1,NGRO + ISMIN(IL,IG1)=NGRO+1 + ISMAX(IL,IG1)=0 + 150 CONTINUE + ENDIF + 160 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPDIL,ITYPRO) + RETURN + END |