*DECK LIBSUB SUBROUTINE LIBSUB (MAXISO,MAXTRA,IPLIB,IPROC,NGRO,NBISO,NLIB, 1 ISONAM,TN,MASKI,IPRECI,SVDEPS,IMPX) * *----------------------------------------------------------------------- * *Purpose: * Production of an internal library with subgroups. * *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 * MAXISO maximum number of isotopes permitted. * MAXTRA maximum number of energy bins of size DELI. * IPLIB pointer to the lattice microscopic cross section library * (L_LIBRARY signature). * IPROC type of microlib processing: * =2: perform temperature interpolation and build a * temperature-independent draglib; * =3: perform temperature interpolation and compute calendf- * type mathematical probability tables based on bin-type * cross-sections for total cross sections; * =4: perform temperature interpolation and compute physical * probability tables or slowing-down correlated probability * tables. * =5: perform temperature interpolation and compute calendf- * type mathematical probability tables based on bin-type * cross-sections for all available cross-sections types. * =6: compute orthogonal bases for the resonance spectrum * expansion (RSE) method. * NGRO number of energy groups. * NBISO number of isotopes present in the calculation domain. * NLIB number of independent libraries. * ISONAM alias name of isotopes. * TN temperature of each isotope. * MASKI isotope masks (isotope with index I is process if * MASKI(I)=.true.). * IPRECI accuracy index for probability tables in CALENDF. * SVDEPS rank accuracy of the singular value decomposition. * IMPX print flag. * *----------------------------------------------------------------------- * USE GANLIB *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPLIB INTEGER MAXISO,MAXTRA,IPROC,NGRO,NBISO,NLIB,ISONAM(3,NBISO), 1 IPRECI,IMPX LOGICAL MASKI(NBISO) REAL TN(NBISO),SVDEPS *---- * LOCAL VARIABLES *---- PARAMETER (MAXDIL=65,MAXED=50,NSTATE=40,MAXESP=4,IALTER=0) TYPE(C_PTR) JPLIB,KPLIB,IPTMP,JPTMP,KPTMP,IPDRL CHARACTER NAMLBT*8,NAMFIL*64,HNISOR*12,HSMG*131,TEXT12*12, 1 HSHI*12,HVECT(MAXED)*8,HNAMIS*12,HNAMIS2*12,TEXT4*4,CFILNA2*64 LOGICAL LLENG,LLSHI,LTRANC,LINDEX,MASK2(MAXDIL) INTEGER ISOR(3),IPAR(NSTATE),IPAR2(NSTATE),IESP(MAXESP+1) REAL DILUT(MAXDIL),EESP(MAXESP+1) *---- * ALLOCATABLE ARRAYS *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: LSHI,NFS,ILLIB,NTFG,NIR, 1 INAME,IJCEDM,KISONA,KISONR,KSHI,KTYPE,KNAME,KCOH,KINC,KRSK,KNTFG, 2 KNIR,KSHIN INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONRF,ISHINA INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: IHLIB LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKJ REAL, ALLOCATABLE, DIMENSION(:) :: GIR,KGIR,KSN,KTN,ENER,EBIN REAL, ALLOCATABLE, DIMENSION(:,:) :: SN *---- * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(LSHI(NBISO),NFS(NGRO),ISONRF(3,MAXISO),ISHINA(3,MAXISO), 2 IHLIB(2,MAXISO,4),ILLIB(MAXISO),NTFG(MAXISO),NIR(MAXISO)) ALLOCATE(MASKJ(NBISO)) ALLOCATE(SN(NGRO,NBISO),GIR(MAXISO)) * TKSUB=0.0 TKTAB=0.0 *---- * CHECK FOR DUPLICATE ISOTOPE NAMES. MASKI(I) NUST BE SET IN SUCH A WAY * THAT TWO IDENTICAL ISOTOPES ARE NEVER PROCESSED. *---- CALL LCMGET(IPLIB,'ILIBRARYINDX',ILLIB) DO 20 I=1,NBISO IF(MASKI(I).AND.(ILLIB(I).NE.0)) THEN DO 10 J=I+1,NBISO IF(MASKI(J).AND.(ISONAM(1,I).EQ.ISONAM(1,J)).AND.(ISONAM(2,I) 1 .EQ.ISONAM(2,J)).AND.(ISONAM(3,I).EQ.ISONAM(3,J))) THEN WRITE (HSMG,300) (ISONAM(I0,I),I0=1,3) CALL XABORT(HSMG) ENDIF 10 CONTINUE ENDIF 20 CONTINUE *---- * PROCESS THE NON-RESONANT ISOTOPES. *---- CALL LCMGET(IPLIB,'ISOTOPESSHI',LSHI) DO 35 ISOT=1,NBISO MASKJ(ISOT)=MASKI(ISOT).AND.(LSHI(ISOT).EQ.0) DO 30 I=1,NGRO SN(I,ISOT)=1.0E10 30 CONTINUE 35 CONTINUE CALL KDRCPU(TK1) * -------------------------------------- CALL LIBLIB(IPLIB,NBISO,MASKJ(1),IMPX) * -------------------------------------- CALL KDRCPU(TK2) TKSUB=TKSUB+(TK2-TK1) CALL LCMLEN(IPLIB,'ENERGY',ILENG,ITYLCM) LLENG=(ILENG.EQ.NGRO+1) CALL LCMLEN(IPLIB,'INDEX',ILENG,ITYLCM) LINDEX=(ILENG.NE.0) *---- * RECOVER SOME LIBRARY PARAMETERS. *---- CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) NL=IPAR(4) NDEPL=IPAR(11) NED=IPAR(13) NDEL=IPAR(19) IF(NED.GT.0) THEN IF(NED.GT.MAXED) CALL XABORT('LIBSUB: MAXED OVERFLOW.') CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT) ENDIF *---- * RECOVER INFORMATION FROM THE /MICROLIB/ DIRECTORY. *---- CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONRF) CALL LCMGET(IPLIB,'ILIBRARYTYPE',IHLIB(1,1,1)) CALL LCMLEN(IPLIB,'ISOTOPESNTFG',ILENG,ITYLCM) IF(ILENG.GT.0) THEN CALL LCMGET(IPLIB,'ISOTOPESNTFG',NTFG) CALL LCMGET(IPLIB,'ISOTOPESCOH',IHLIB(1,1,2)) CALL LCMGET(IPLIB,'ISOTOPESINC',IHLIB(1,1,3)) ELSE NTFG(:NBISO)=0 ENDIF CALL LCMLEN(IPLIB,'ISOTOPESRESK',ILENG,ITYLCM) IF(ILENG.GT.0) THEN CALL LCMGET(IPLIB,'ISOTOPESRESK',IHLIB(1,1,4)) ELSE NAMLBT=',' DO ISOT=1,NBISO READ(NAMLBT,'(2A4)') IHLIB(1,ISOT,4),IHLIB(2,ISOT,4) ENDDO ENDIF CALL LCMLEN(IPLIB,'ISOTOPESHIN',ILENG,ITYLCM) LLSHI=(ILENG.GT.0) IF(LLSHI) CALL LCMGET(IPLIB,'ISOTOPESHIN',ISHINA) CALL LCMLEN(IPLIB,'ISOTOPESNIR',ILENG,ITYLCM) IF(ILENG.GT.0) THEN CALL LCMGET(IPLIB,'ISOTOPESNIR',NIR) CALL LCMGET(IPLIB,'ISOTOPESGIR',GIR) ELSE NIR(:NBISO)=0 GIR(:NBISO)=0.0 ENDIF *---- * PROCESS THE RESONANT ISOTOPES. *---- JPLIB=LCMLID(IPLIB,'ISOTOPESLIST',NBISO) IMPY=MAX(0,IMPX-5) LTRANC=.FALSE. DO 200 ISOT=1,NBISO IF(MASKI(ISOT).AND.(LSHI(ISOT).NE.0)) THEN WRITE(HNAMIS,'(3A4)') (ISONAM(I0,ISOT),I0=1,3) IF(IMPX.GT.0) WRITE (6,'(/33H LIBSUB: PROCESSING ISOTOPE/MATER, 1 5HIAL '',A12,2H''.)') HNAMIS * * RECOVER MULTI-DILUTION INFORMATION. * * FIND THE DILUTION VALUES. NDIL=0 CALL LCMOP(IPTMP,'*TEMPORARY*',0,1,0) IF(NDEPL.GT.0) THEN CALL LCMLEN(IPLIB,'DEPL-CHAIN',ILENG,ITYLCM) IF(ILENG.EQ.0)CALL XABORT('LIBSUB: MISSING DEPL-CHAIN DATA.') CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) CALL LCMSIX(IPTMP,'DEPL-CHAIN',1) CALL LCMEQU(IPLIB,IPTMP) CALL LCMSIX(IPTMP,' ',2) CALL LCMSIX(IPLIB,' ',2) ENDIF WRITE(HNISOR,'(3A4)') (ISONRF(I0,ISOT),I0=1,3) WRITE(NAMLBT,'(2A4)') IHLIB(1,ISOT,1),IHLIB(2,ISOT,1) ALLOCATE(INAME(16*NLIB)) CALL LCMGET(IPLIB,'ILIBRARYNAME',INAME) ILIB=ILLIB(ISOT) WRITE(NAMFIL,'(16A4)') (INAME(16*(ILIB-1)+I),I=1,16) DEALLOCATE(INAME) IF(NAMLBT.EQ.'DRAGON') THEN CALL LCMOP(IPDRL,NAMFIL(:12),2,2,0) CALL LIBDI1(MAXDIL,IPDRL,HNISOR,NDIL,DILUT) CALL LCMCL(IPDRL,1) ELSE IF(NAMLBT.EQ.'MATXS') THEN CALL LIBDI2(MAXDIL,NAMFIL,HNISOR,NDIL,DILUT) ELSE IF(NAMLBT.EQ.'MATXS2') THEN CALL LIBDI3(MAXDIL,NAMFIL,HNISOR,NDIL,DILUT) ELSE IF(NAMLBT.EQ.'APLIB1') THEN WRITE(HSHI,'(3A4)') (ISHINA(I0,ISOT),I0=1,3) CALL LIBDI4(MAXDIL,NAMFIL,HSHI,NDIL,DILUT) ELSE IF(NAMLBT.EQ.'APLIB2') THEN WRITE(HSHI,'(3A4)') (ISHINA(I0,ISOT),I0=1,3) IF(HSHI.EQ.' ') THEN WRITE (HSMG,'(35HLIBSUB: SELF-SHIELDING ISOTOPE NOT , 1 25HDEFINED FOR MAIN ISOTOPE ,A12,1H.)') HNISOR CALL XABORT(HSMG) ENDIF CALL LIBDI5(MAXDIL,NAMFIL,HSHI,NDIL,DILUT) ELSE IF(NAMLBT.EQ.'APXSM') THEN WRITE(HSHI,'(3A4)') (ISHINA(I0,ISOT),I0=1,3) IF(HSHI.EQ.' ') THEN WRITE (HSMG,'(35HLIBSUB: SELF-SHIELDING ISOTOPE NOT , 1 25HDEFINED FOR MAIN ISOTOPE ,A12,1H.)') HNISOR CALL XABORT(HSMG) ENDIF CALL LIBXS6(MAXDIL,NAMFIL,HSHI,NDIL,DILUT) ELSE IF(NAMLBT.EQ.'APLIB3') THEN IND = INDEX(NAMFIL, ":") IF(IND.EQ.0) THEN CALL XABORT('LIBSUB: NO SELF SHIELDING DATA AVAILABLE,') ELSE CFILNA2=NAMFIL(IND+1:) ENDIF CALL LIBD10(MAXDIL,CFILNA2,HNISOR,NDIL,DILUT) ELSE IF(NAMLBT.EQ.'WIMSAECL') THEN WRITE(HSHI,'(3A4)') (ISHINA(I0,ISOT),I0=1,3) CALL LIBDI6(MAXDIL,NGRO,NAMFIL,HNISOR,HSHI,NDIL,DILUT) ELSE IF(NAMLBT.EQ.'NDAS') THEN CALL LIBND7(MAXDIL,NGRO,NAMFIL,HNISOR,NDIL,DILUT) ELSE IF(NAMLBT.EQ.'WIMSD4') THEN WRITE(HSHI,'(3A4)') (ISHINA(I0,ISOT),I0=1,3) CALL LIBDI8(MAXDIL,NGRO,NAMFIL,HNISOR,HSHI,NDIL,DILUT) ELSE IF(NAMLBT.EQ.'WIMSE') THEN WRITE(HSHI,'(3A4)') (ISHINA(I0,ISOT),I0=1,3) CALL LIBDI9(MAXDIL,NGRO,NAMFIL,HNISOR,HSHI,NDIL,DILUT) ELSE CALL XABORT('LIBSUB: '//NAMLBT//' LIBRARY TREATMENT IS ' 1 //'NOT IMPLEMENTED.') ENDIF IF(NDIL.EQ.0) GO TO 70 50 IF(DILUT(1).LT.1.0) THEN DO 60 I=2,NDIL+1 DILUT(I-1)=DILUT(I) 60 CONTINUE NDIL=NDIL-1 GO TO 50 ENDIF IF(IMPX.GT.4) THEN WRITE(6,'(/32H LIBSUB: DILUTIONS FOR ISOTOPE '',A12, 1 2H'':/(1X,1P,10E12.4))') HNAMIS,(DILUT(I),I=1,NDIL+1) ENDIF 70 IF(NDIL.EQ.0) THEN WRITE(HSMG,'(41HLIBSUB: NOT ENOUGH DILUTIONS FOR ISOTOPE , 1 A,1H.)') HNAMIS CALL XABORT(HSMG) ENDIF * * PROCESS THE ISOTOPE FOR EACH DILUTION. TEXT12='L_LIBRARY' READ(TEXT12,'(3A4)') (ISOR(I),I=1,3) CALL LCMPUT(IPTMP,'SIGNATURE',3,3,ISOR) DO 80 I=1,NSTATE IPAR2(I)=IPAR(I) 80 CONTINUE IPAR2(2)=NDIL+1 CALL LCMPUT(IPTMP,'STATE-VECTOR',NSTATE,1,IPAR2) IF(NED.GT.0) THEN ALLOCATE(IJCEDM(2*NED)) CALL LCMGET(IPLIB,'ADDXSNAME-P0',IJCEDM) CALL LCMPUT(IPTMP,'ADDXSNAME-P0',2*NED,3,IJCEDM) DEALLOCATE(IJCEDM) ENDIF IF(LINDEX) THEN CALL LCMSIX(IPLIB,'INDEX',1) CALL LCMSIX(IPTMP,'INDEX',1) CALL LCMEQU(IPLIB,IPTMP) CALL LCMSIX(IPTMP,' ',2) CALL LCMSIX(IPLIB,' ',2) ENDIF * * BUILD A MICROLIB WITH NDIL+1 ISOTOPES. ALLOCATE(KISONA(3*(NDIL+1)),KISONR(3*(NDIL+1)),KSHI(NDIL+1), 1 KTYPE(2*(NDIL+1)),KNAME(NDIL+1)) IF(NTFG(ISOT).GT.0) THEN ALLOCATE(KCOH(2*(NDIL+1)),KINC(2*(NDIL+1)),KRSK(2*(NDIL+1)), 1 KNTFG(NDIL+1)) ENDIF IF(NIR(ISOT).NE.0) THEN ALLOCATE(KGIR(NDIL+1),KNIR(NDIL+1)) ENDIF IF(LLSHI) ALLOCATE(KSHIN(3*(NDIL+1))) ALLOCATE(KSN(NGRO*(NDIL+1)),KTN(NDIL+1)) DO 100 IDIL=1,NDIL+1 KSHI(IDIL)=LSHI(ISOT) MASK2(IDIL)=.TRUE. KISONA(3*(IDIL-1)+1)=ISONAM(1,ISOT) KISONA(3*(IDIL-1)+2)=ISONAM(2,ISOT) KISONR(3*(IDIL-1)+1)=ISONRF(1,ISOT) KISONR(3*(IDIL-1)+2)=ISONRF(2,ISOT) KISONR(3*(IDIL-1)+3)=ISONRF(3,ISOT) WRITE(TEXT4,'(I4.4)') IDIL READ(TEXT4,'(A4)') KISONA(3*(IDIL-1)+3) IF(NIR(ISOT).NE.0) THEN KGIR(IDIL)=GIR(ISOT) KNIR(IDIL)=NIR(ISOT) ENDIF KTYPE(2*(IDIL-1)+1)=IHLIB(1,ISOT,1) KTYPE(2*(IDIL-1)+2)=IHLIB(2,ISOT,1) KNAME(IDIL)=ILLIB(ISOT) IF(NTFG(ISOT).GT.0) THEN KCOH(2*(IDIL-1)+1)=IHLIB(1,ISOT,2) KCOH(2*(IDIL-1)+2)=IHLIB(2,ISOT,2) KINC(2*(IDIL-1)+1)=IHLIB(1,ISOT,3) KINC(2*(IDIL-1)+2)=IHLIB(2,ISOT,3) KRSK(2*(IDIL-1)+1)=IHLIB(1,ISOT,4) KRSK(2*(IDIL-1)+2)=IHLIB(2,ISOT,4) KNTFG(IDIL)=NTFG(ISOT) ENDIF IF(LLSHI) THEN KSHIN(3*(IDIL-1)+1)=ISHINA(1,ISOT) KSHIN(3*(IDIL-1)+2)=ISHINA(2,ISOT) KSHIN(3*(IDIL-1)+3)=ISHINA(3,ISOT) ENDIF DO 90 I=1,NGRO KSN((IDIL-1)*NGRO+I)=DILUT(IDIL) 90 CONTINUE KTN(IDIL)=TN(ISOT) 100 CONTINUE ALLOCATE(INAME(16*NLIB)) CALL LCMGET(IPLIB,'ILIBRARYNAME',INAME) CALL LCMPUT(IPTMP,'ILIBRARYNAME',16*NLIB,3,INAME) DEALLOCATE(INAME) CALL LCMPUT(IPTMP,'ISOTOPESUSED',3*(NDIL+1),3,KISONA) CALL LCMPUT(IPTMP,'ISOTOPERNAME',3*(NDIL+1),3,KISONR) DEALLOCATE(KISONR,KISONA) IF(NIR(ISOT).NE.0) THEN CALL LCMPUT(IPTMP,'ISOTOPESGIR',NDIL+1,2,KGIR) CALL LCMPUT(IPTMP,'ISOTOPESNIR',NDIL+1,1,KNIR) DEALLOCATE(KNIR,KGIR) ENDIF CALL LCMPUT(IPTMP,'ISOTOPESSHI',NDIL+1,1,KSHI) CALL LCMPUT(IPTMP,'ILIBRARYTYPE',2*(NDIL+1),3,KTYPE) CALL LCMPUT(IPTMP,'ILIBRARYINDX',NDIL+1,1,KNAME) DEALLOCATE(KNAME,KTYPE,KSHI) IF(NTFG(ISOT).GT.0) THEN CALL LCMPUT(IPTMP,'ISOTOPESCOH',2*(NDIL+1),3,KCOH) CALL LCMPUT(IPTMP,'ISOTOPESINC',2*(NDIL+1),3,KINC) CALL LCMPUT(IPTMP,'ISOTOPESRESK',2*(NDIL+1),3,KRSK) CALL LCMPUT(IPTMP,'ISOTOPESNTFG',NDIL+1,1,KNTFG) DEALLOCATE(KNTFG,KRSK,KINC,KCOH) ENDIF IF(LLSHI) THEN CALL LCMPUT(IPTMP,'ISOTOPESHIN',3*(NDIL+1),3,KSHIN) DEALLOCATE(KSHIN) ENDIF CALL LCMPUT(IPTMP,'ISOTOPESDSN',NGRO*(NDIL+1),2,KSN) CALL LCMPUT(IPTMP,'ISOTOPESDSB',NGRO*(NDIL+1),2,KSN) CALL LCMPUT(IPTMP,'ISOTOPESTEMP',NDIL+1,2,KTN) IF(NED.GT.0) CALL LCMPTC(IPTMP,'ADDXSNAME-P0',8,NED,HVECT) DEALLOCATE(KTN,KSN) * CALL KDRCPU(TK1) * --------------------------------------- CALL LIBLIB(IPTMP,NDIL+1,MASK2(1),IMPY) * --------------------------------------- CALL KDRCPU(TK2) TKSUB=TKSUB+(TK2-TK1) * * RECOVER THE SELF-SHIELDING GROUP LIMITS. CALL LCMGET(IPTMP,'STATE-VECTOR',IPAR2) LTRANC=LTRANC.OR.(IPAR2(5).NE.0) IPAR(9)=MIN(IPAR(9),IPAR2(9)) IPAR(10)=MAX(IPAR(10),IPAR2(10)) IPAR(16)=MAX(IPAR(16),IPAR2(16)) IPAR(19)=MAX(IPAR(19),IPAR2(19)) * * RECOVER GROUP STRUCTURE IF(.NOT.LLENG) THEN ALLOCATE(ENER(NGRO+1)) CALL LCMGET(IPTMP,'ENERGY',ENER) CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENER) CALL LCMGET(IPTMP,'DELTAU',ENER) CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,ENER) DEALLOCATE(ENER) LLENG=.TRUE. ENDIF * * RECOVER ENERGY-DEPENDENT FISSION SPECTRA CALL LCMLEN(IPTMP,'CHI-LIMITS',NBESP,ITYLCM) IF(NBESP.GT.0) THEN NBESP=NBESP-1 IF(NBESP.GT.MAXESP) CALL XABORT('LIBSUB: MAXESP OVERFLOW.') CALL LCMGET(IPTMP,'CHI-LIMITS',IESP) CALL LCMPUT(IPLIB,'CHI-LIMITS',NBESP+1,1,IESP) CALL LCMGET(IPTMP,'CHI-ENERGY',EESP) CALL LCMPUT(IPLIB,'CHI-ENERGY',NBESP+1,2,EESP) ENDIF * * RECOVER BIN TYPE INFORMATION (IF AVAILABLE). JPTMP=LCMGID(IPTMP,'ISOTOPESLIST') KPLIB=LCMDIL(JPLIB,ISOT) ! set ISOT-th isotope CALL LCMLEL(JPTMP,NDIL+1,ILENG,ITYLCM) IF(ILENG.EQ.0) THEN TEXT12=HNAMIS(1:8) WRITE(TEXT12(9:12),'(I4.4)') NDIL+1 CALL XABORT('LIBSUB: MISSING LIST ITEM FOR '//TEXT12) ENDIF KPTMP=LCMGIL(JPTMP,NDIL+1) ! set (NDIL+1)-th isotope CALL LCMGET(KPTMP,'AWR',AWR) CALL LCMLEN(KPTMP,'BIN-NFS',ILENG,ITYLCM) IF(ILENG.GT.0) THEN CALL LCMGET(KPTMP,'BIN-NFS',NFS) CALL LCMPUT(KPLIB,'BIN-NFS',NGRO,1,NFS) LBIN=0 DO 130 I=1,NGRO LBIN=LBIN+NFS(I) 130 CONTINUE IF(IMPX.GT.1) THEN WRITE(6,'(/41H LIBSUB: NUMBER OF UFG BINS FOR ISOTOPE '', 1 A12,2H''=,I10)') HNAMIS,LBIN ENDIF ALLOCATE(EBIN(LBIN+1)) CALL LCMLEN(KPTMP,'BIN-ENERGY',ILONG,ITYLCM) IF(ILONG.GT.LBIN+1) CALL XABORT('LIBSUB: NFS OVERFLOW.') CALL LCMGET(KPTMP,'BIN-ENERGY',EBIN) CALL LCMPUT(KPLIB,'BIN-ENERGY',LBIN+1,2,EBIN) CALL LCMGET(KPTMP,'BIN-NTOT0',EBIN) CALL LCMPUT(KPLIB,'BIN-NTOT0',LBIN,2,EBIN) CALL LCMGET(KPTMP,'BIN-SIGS00',EBIN) CALL LCMPUT(KPLIB,'BIN-SIGS00',LBIN,2,EBIN) CALL LCMLEN(KPTMP,'BIN-NUSIGF',ILONG,ITYLCM) IF(ILONG.GT.0) THEN CALL LCMGET(KPTMP,'BIN-NUSIGF',EBIN) CALL LCMPUT(KPLIB,'BIN-NUSIGF',LBIN,2,EBIN) ENDIF DEALLOCATE(EBIN) ENDIF * CALL KDRCPU(TK1) IF(IPROC.EQ.6) THEN * USE THE RESONANCE SPECTRUM EXPANSION METHOD. CALL LCMLEN(KPTMP,'BIN-NFS',ILENG,ITYLCM) IF(ILENG.EQ.0) THEN CALL LCMLIB(KPTMP) WRITE(HSMG,'(38HLIBSUB: BIN DATA MISSING FOR ISOTOPE '', 1 A12,2H''.)') HNAMIS CALL XABORT(HSMG) ENDIF NDEL=IPAR(19) CALL LIBRSE(KPLIB,IPTMP,MAXTRA,HNAMIS,LBIN,NGRO,NL,NED,NDEL, 1 HVECT,NFS,IMPX,DELI,AWR,IALTER,SVDEPS) ELSE * RESET CALENDF MAXIMUM ACCURACY FOR INTERMEDIATE ISOTOPES. IPRECJ=IPRECI IF((AWR.LT.220.0).AND.(IPRECI.GT.3)) IPRECJ=3 * * USE THE SUBGROUP METHOD. CALL LIBPTW(KPLIB,IPTMP,IPROC,NGRO,NL,HNAMIS,NED,HVECT,NDIL, 1 DILUT,AWR,IPRECJ,IMPX,MAXTRA) ENDIF * * RESET ALIAS CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) CALL KDRCPU(TK2) TKTAB=TKTAB+(TK2-TK1) ENDIF 200 CONTINUE *---- * COMPUTE CORRELATION INFORMATION BETWEEN PAIRS OF RESONANT ISOTOPES. *---- CALL KDRCPU(TK1) IF((IPROC.EQ.3).OR.(IPROC.EQ.4).OR.(IPROC.EQ.5)) THEN DO 220 ISOT=1,NBISO WRITE(HNAMIS,'(3A4)') (ISONAM(I0,ISOT),I0=1,3) IF(MASKI(ISOT).AND.(LSHI(ISOT).LT.0)) THEN DO 210 JSOT=1,ISOT-1 IF(MASKI(JSOT).AND.(LSHI(ISOT).EQ.LSHI(JSOT))) THEN WRITE(HNAMIS2,'(3A4)') (ISONAM(I0,JSOT),I0=1,3) IF(IMPX.GT.0) WRITE (6,'(/26H LIBSUB: COMPUTING CORRELA, 1 41HTION EFFECTS BETWEEN ISOTOPES/MATERIALS '',A12, 2 7H'' AND '',A12,2H''.)') HNAMIS,HNAMIS2 CALL LIBCOR(IPLIB,NGRO,ISOT,JSOT,HNAMIS,HNAMIS2) ENDIF 210 CONTINUE ENDIF 220 CONTINUE ELSE IF(IPROC.EQ.6) THEN CALL LIBRSC(MAXTRA,IPLIB,LBIN,NGRO,NBISO,ISONAM,MASKI,LSHI, 1 NFS,IMPX,IALTER) ENDIF CALL KDRCPU(TK2) TKTAB=TKTAB+(TK2-TK1) *---- * RESET IPAR(5) FOR TRANSPORT CORRECTION AND SAVE STATE-VECTOR. *---- IF((IPROC.LE.2).AND.LTRANC) IPAR(5)=2 CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,IPAR) * IF(IMPX.GT.0) WRITE(6,'(/30H LIBSUB: CPU TIME IN LIBLIB=,F10.2, 1 9H SECONDS./9X,21HCPU TIME IN SUBGROUP=,F10.2,9H SECONDS.)') 2 TKSUB,TKTAB *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(GIR,SN) DEALLOCATE(MASKJ) DEALLOCATE(NIR,NTFG,ILLIB,IHLIB,ISHINA,ISONRF,NFS,LSHI) RETURN * 300 FORMAT(8HLIBSUB: ,3A4,34H IS A DUPLICATE ISOTOPE/MATERIAL N, 1 4HAME.) END