*DECK EDIRES SUBROUTINE EDIRES(IPEDIT,IPFLUX,IPLIB,IADJ,NL,NDEL,NBESP,NBISO, 1 NDEPL,ISONAM,ISONRF,IPISO,MIX,TN,NED,HVECT,NOUT,HVOUT,IPRINT, 2 NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,NDFI,NDFP,ILEAKS,ILUPS,NW, 3 MATCOD,VOLUME,KEYFLX,CURNAM,IGCOND,IMERGE,FLUXES,AFLUXE,EIGENK, 4 EIGINF,B2,DEN,ITYPE,LSISO,EMEVF,DECAY,YIELD,FIPI,FIFP,PYIELD, 5 ITRANC,LISO,NMLEAK) * *----------------------------------------------------------------------- * *Purpose: * Calculation of residual macroscopic cross sections. * *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 * IPEDIT pointer to the edition LCM object (L_EDIT signature). * IPFLUX pointer to the solution LCM object (L_FLUX signature). * IPLIB pointer to the reference microscopic cross section library * LCM object (L_LIBRARY signature). * IADJ type of flux weighting: * =0: direct flux weighting; * =1: direct-adjoint flux weighting. * NL number of Legendre orders required in the calculation * (NL=1 or higher). * NDEL number of delayed precursor groups. * NBESP number of energy-dependent fission spectra. * NBISO number of isotopes. * NDEPL number of depleting isotopes. * ISONAM local names of NBISO isotopes: * chars 1 to 8 is the local isotope name; * chars 9 to 12 is a suffix function of the mix number. * ISONRF library name of isotopes. * IPISO pointer array towards microlib isotopes. * MIX mixture number associated with each isotope. * TN absolute temperature associated with each isotope. * NED number of extra vector edits from MATXS. * HVECT MATXS names of the extra vector edits. * NOUT number of output cross section types (set to zero to recover * all cross section types). * HVOUT MATXS names of the output cross section types. * IPRINT print index. * NGROUP number of energy groups. * NGCOND number of condensed groups. * NBMIX number of mixtures. * NREGIO number of volumes. * NMERGE number of merged regions. * NDFI number of fissile isotopes. * NDFP number of fission products. * ILEAKS leakage calculation type: =0: no leakage; =1: homogeneous * leakage (Diffon); =2: isotropic streaming (Ecco); * =3: anisotropic streaming (Tibere). * ILUPS up-scattering removing flag (=1 to remove up-scattering from * output cross-sections). * NW type of weighting for P1 cross section info (=0: P0 ; =1: P1). * MATCOD mixture index per volume. * VOLUME volumes. * KEYFLX position of average fluxes. * CURNAM name of the LCM directory where the microscopic cross sections * are stored (blank name means no save). * IGCOND limits of condensed groups. * IMERGE index of merged regions. * FLUXES fluxes. * AFLUXE adjoint fluxes. * EIGENK effective multiplication factor. * EIGINF infinite multiplication factor. * B2 bucklings. * DEN number density of each isotope. * ITYPE type of each isotope. * LSISO flag for isotopes saved. * EMEVF fission production energy. * DECAY radioactive decay constant. * YIELD group-ordered condensed fission product yield. * FIPI fissile isotope index assigned to each microlib isotope. * FIFP fission product index assigned to each microlib isotope. * PYIELD fissile isotope ordered condensed fission product yield. * ITRANC type of transport correction (=0: no correction). * LISO =.TRUE. if we want to keep all the isotopes after * homogeneization. * NMLEAK number of leakage zones. * *----------------------------------------------------------------------- * USE GANLIB *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPEDIT,IPFLUX,IPLIB,IPISO(NBISO) INTEGER NL,NDEL,NBESP,NBISO,NDEPL,ISONAM(3,NBISO),ISONRF(3,NBISO), 1 MIX(NBISO),NED,NOUT,IPRINT,NGROUP,NGCOND,NBMIX,NREGIO,NMERGE, 2 NDFI,NDFP,ILEAKS,ILUPS,NW,MATCOD(NREGIO),KEYFLX(NREGIO), 3 IGCOND(NGCOND),IMERGE(NREGIO),ITYPE(NBISO),LSISO(NBISO), 4 FIPI(NBISO,NMERGE),FIFP(NBISO,NMERGE),ITRANC,NMLEAK REAL TN(NBISO),VOLUME(NREGIO),FLUXES(NREGIO,NGROUP,NW+1), 1 EIGENK,EIGINF,B2(4),DEN(NBISO),EMEVF(NBISO),DECAY(NBISO), 2 YIELD(NGCOND+1,NDFP,NMERGE),PYIELD(NDFI,NDFP,NMERGE) CHARACTER HVECT(NED)*8,HVOUT(NOUT)*8,CURNAM*12 LOGICAL LISO *---- * LOCAL VARIABLES *---- PARAMETER (NSTATE=40) TYPE(C_PTR) JPEDIT,KPEDIT,IPWORK,JPWORK,KPWORK CHARACTER TEXT8*8,TEXT12*12,CM*2 LOGICAL LWD,LYIEL,LFISS INTEGER IPAR(NSTATE) INTEGER, ALLOCATABLE, DIMENSION(:) :: LSIS2,IEVOL2,ISMIX,ISTYP, 1 ISTOD,ITYPRO,JPIFI INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHNISO,IHNIRF REAL, ALLOCATABLE, DIMENSION(:) :: WDLA,SDEN,VOLISO,TNISO,WORK, 1 WPY,DENTOT,DAWR,TNTOT,YIELD2,PYIELD2 REAL, ALLOCATABLE, DIMENSION(:,:) :: GAS,SIGS,PNFIRA REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WSCAT,WORK2 CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HMAKE *---- * SCRATCH STORAGE ALLOCATION (PART 1) *---- MAXH=9+NBESP+2*NDEL+NED+NL+3*NW ALLOCATE(LSIS2(NBISO),IEVOL2(NBISO),JPIFI(NDFI),ITYPRO(NL)) ALLOCATE(WDLA(NDEL),WSCAT(NGCOND,NGCOND,NL),GAS(NGCOND,MAXH), 1 WORK(NGCOND+1),WPY(NDFI),PNFIRA(0:NDEL,2), 2 WORK2(NGCOND,NGCOND,NL),DENTOT(NMERGE),DAWR(NMERGE), 3 TNTOT(NMERGE),YIELD2(1+NGCOND),PYIELD2(NDFI)) ALLOCATE(HMAKE(MAXH+NL)) *---- * RECOVER THE RADIOACTIVE DECAY CONSTANTS OF DELAYED NEUTRON GROUPS * FROM THE MACROLIB IF THEY EXIST. *---- IOF0H=8+NED+NL+3*NW IOF1H=8+NED+NL+3*NW+NDEL IF(IPRINT.GT.3) THEN WRITE(6,'(/36H EDIRES: COMPUTE A RESIDUAL ISOTOPE.)') ENDIF CALL LCMOP(IPWORK,'*TEMPORARY*',0,1,0) LWD=.FALSE. IF(CURNAM.EQ.' ') CALL XABORT('EDIRES: NO CURNAM DIRECTORY.') CALL LCMSIX(IPEDIT,CURNAM,1) ! step up CURNAM CALL LCMSIX(IPEDIT,'MACROLIB',1) CALL LCMLEN(IPEDIT,'LAMBDA-D',ILONG,ITYLCM) LWD=(ILONG.EQ.NDEL).AND.(NDEL.GT.0) IF(LWD) CALL LCMGET(IPEDIT,'LAMBDA-D',WDLA) CALL LCMSIX(IPEDIT,' ',2) CALL LCMSIX(IPEDIT,' ',2) * IF(LWD) THEN CALL LCMSIX(IPWORK,'DEFAULT',1) CALL LCMSIX(IPWORK,'MACROLIB',1) CALL LCMPUT(IPWORK,'LAMBDA-D',NDEL,2,WDLA) CALL LCMSIX(IPWORK,' ',2) CALL LCMSIX(IPWORK,' ',2) ENDIF *---- * COMPUTE MICROSCOPIC CROSS SECTIONS OF REMAINING ISOTOPES. WE SET * NDFI=0 TO GET RID OF PPF YIELDS. *---- DO 10 ISO=1,NBISO LSIS2(ISO)=0 IEVOL2(ISO)=1 IF(LSISO(ISO).EQ.0) LSIS2(ISO)=1 10 CONTINUE IPRIN2=MAX(0,IPRINT-2) TEXT12='DEFAULT' CALL EDIMIC(IPWORK,IPFLUX,IPLIB,IADJ,NL,NDEL,NBESP,NBISO,NDEPL, 1 ISONAM,ISONRF,IPISO,MIX,TN,NED,HVECT,NOUT,HVOUT,IPRIN2,NGROUP, 2 NGCOND,NBMIX,NREGIO,NMERGE,0,0,ILEAKS,ILUPS,NW,MATCOD,VOLUME, 3 KEYFLX,TEXT12,IGCOND,IMERGE,FLUXES,AFLUXE,EIGENK,EIGINF,B2,DEN, 4 ITYPE,IEVOL2,LSIS2,EMEVF,DECAY,YIELD,FIPI,FIFP,PYIELD,ITRANC, 5 LISO,NMLEAK) * CALL LCMSIX(IPEDIT,CURNAM,1) CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) JJISO=IPAR(2) JPEDIT=LCMLID(IPEDIT,'ISOTOPESLIST',JJISO+NMERGE) CALL LCMSIX(IPWORK,'DEFAULT',1) CALL LCMGET(IPWORK,'STATE-VECTOR',IPAR) JJWRK=IPAR(2) *---- * SCRATCH STORAGE ALLOCATION (PART 2) *---- MAXISO=MAX(JJISO+NMERGE,JJWRK) ALLOCATE(IHNISO(3,MAXISO),SDEN(MAXISO),IHNIRF(3,MAXISO), 1 ISMIX(MAXISO),ISTYP(MAXISO),ISTOD(MAXISO),VOLISO(MAXISO), 2 TNISO(MAXISO)) *---- * RECOVER INFORMATION FROM EDIMIC *---- IF(JJWRK.GT.0) THEN CALL LCMGET(IPWORK,'ISOTOPESUSED',IHNISO) CALL LCMGET(IPWORK,'ISOTOPESDENS',SDEN) CALL LCMGET(IPWORK,'ISOTOPESMIX',ISMIX) CALL LCMGET(IPWORK,'ISOTOPESTEMP',TNISO) JPWORK=LCMGID(IPWORK,'ISOTOPESLIST') ENDIF *---- * LOOP OVER HOMOGENEOUS MIXTURES. *---- DO 240 INM=1,NMERGE DO 20 J=1,MAXH+NL HMAKE(J)=' ' 20 CONTINUE GAS(:NGCOND,:MAXH)=0.0 WSCAT(:NGCOND,:NGCOND,:NL)=0.0 PNFIRA(0:NDEL,2)=0.0 YIELD2(:1+NGCOND)=0.0 PYIELD2(:NDFI)=0.0 DENTOT(INM)=0.0 DAWR(INM)=0.0 DECISO=0.0 LFISS=.FALSE. DO 170 ISO=1,JJWRK IF(ISMIX(ISO).EQ.INM) THEN WRITE(TEXT12,'(3A4)') (IHNISO(I0,ISO),I0=1,3) DDEN=SDEN(ISO) DENTOT(INM)=DENTOT(INM)+DDEN KPWORK=LCMGIL(JPWORK,ISO) ! set ISO-th isotope CALL LCMLEN(KPWORK,'AWR',LENGTH,ITYLCM) IF(LENGTH.EQ.1) THEN CALL LCMGET(KPWORK,'AWR',FLOTT) DAWR(INM)=DAWR(INM)+DDEN*FLOTT ENDIF TNTOT(INM)=TNISO(ISO) CALL LCMLEN(KPWORK,'DECAY',LENGTH,ITYLCM) IF(LENGTH.EQ.1) THEN CALL LCMGET(KPWORK,'DECAY',FLOTT) DECISO=DECISO+FLOTT*DDEN ENDIF IF(NDFI.GT.0) THEN CALL LCMLEN(KPWORK,'YIELD',LENGTH,ITYLCM) IF(LENGTH.EQ.NGCOND+1) THEN CALL LCMGET(KPWORK,'YIELD',WORK) DO 30 IGR=1,NGCOND+1 YIELD2(IGR)=YIELD2(IGR)+WORK(IGR) 30 CONTINUE ENDIF CALL LCMLEN(KPWORK,'PYIELD',LENGTH,ITYLCM) IF((LENGTH.GT.0).AND.(LENGTH.EQ.NDFI)) THEN CALL LCMGET(KPWORK,'PIFI',JPIFI) CALL LCMGET(KPWORK,'PYIELD',WPY) DO 40 I=1,NDFI PYIELD2(I)=PYIELD2(I)+WPY(I) 40 CONTINUE ENDIF ENDIF * * SET ARRAY HMAKE. DO 45 IW=1,MIN(NW+1,10) WRITE(TEXT8,'(3HNWT,I1)') IW-1 CALL LCMLEN(KPWORK,TEXT8,ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) HMAKE(IW)=TEXT8 WRITE(TEXT8,'(4HNWAT,I1)') IW-1 CALL LCMLEN(KPWORK,TEXT8,ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) HMAKE(1+NW+IW)=TEXT8 WRITE(TEXT8,'(4HNTOT,I1)') IW-1 CALL LCMLEN(KPWORK,TEXT8,ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) HMAKE(2+2*NW+IW)=TEXT8 45 CONTINUE IOF=3+3*NW DO 50 IL=0,NL-1 IOF=IOF+1 WRITE (CM,'(I2.2)') IL CALL LCMLEN(KPWORK,'SIGS'//CM,ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) HMAKE(IOF)='SIGS'//CM 50 CONTINUE IOF=IOF+1 CALL LCMLEN(KPWORK,'NUSIGF',ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) THEN LFISS=.TRUE. HMAKE(IOF)='NUSIGF' ENDIF DO 60 IED=1,NED IOF=IOF+1 CALL LCMLEN(KPWORK,HVECT(IED),ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) HMAKE(IOF)=HVECT(IED) 60 CONTINUE CALL LCMLEN(KPWORK,'H-FACTOR',ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) HMAKE(IOF+1)='H-FACTOR' CALL LCMLEN(KPWORK,'OVERV',ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) HMAKE(IOF+2)='OVERV' CALL LCMLEN(KPWORK,'TRANC',ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) HMAKE(IOF+3)='TRANC' CALL LCMLEN(KPWORK,'STRD',ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) HMAKE(IOF+4)='STRD' IOF=IOF+4 DO 70 IDEL=1,NDEL IOF=IOF+1 WRITE(TEXT8,'(6HNUSIGF,I2.2)') IDEL CALL LCMLEN(KPWORK,TEXT8,ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) HMAKE(IOF)=TEXT8 70 CONTINUE IOF=IOF+1 CALL LCMLEN(KPWORK,'CHI',ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) HMAKE(IOF)='CHI' DO 80 IDEL=1,NDEL IOF=IOF+1 WRITE(TEXT8,'(3HCHI,I2.2)') IDEL CALL LCMLEN(KPWORK,TEXT8,ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) HMAKE(IOF)=TEXT8 80 CONTINUE DO 85 ISP=1,NBESP IOF=IOF+1 WRITE(TEXT8,'(5HCHI--,I2.2)') ISP CALL LCMLEN(KPWORK,TEXT8,ILONG,ITYLCM) IF(ILONG.EQ.NGCOND) HMAKE(IOF)=TEXT8 85 CONTINUE IF(IOF.NE.MAXH) CALL XABORT('EDIRES: WRONG OFFSET.') * PNFIRA(0:NDEL,1)=0.0 DO 150 J=1,MAXH IF(HMAKE(J).NE.' ') THEN CALL LCMLEN(KPWORK,HMAKE(J),ILONG,ITYLCM) IF(ILONG.GT.0) THEN CALL LCMGET(KPWORK,HMAKE(J),WORK) IF(HMAKE(J).EQ.'NUSIGF') THEN DO 90 IGR=1,NGCOND DEL=WORK(IGR)*GAS(IGR,1)*MAX(DDEN,1.0E-30) PNFIRA(0,1)=PNFIRA(0,1)+DEL PNFIRA(0,2)=PNFIRA(0,2)+DEL GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*DDEN 90 CONTINUE ELSE IF(HMAKE(J)(:3).EQ.'NUS') THEN IDEL=J-IOF0H DO 100 IGR=1,NGCOND DEL=WORK(IGR)*GAS(IGR,1)*MAX(DDEN,1.0E-30) PNFIRA(IDEL,1)=PNFIRA(IDEL,1)+DEL PNFIRA(IDEL,2)=PNFIRA(IDEL,2)+DEL GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*DDEN 100 CONTINUE ELSE IF(HMAKE(J)(:3).EQ.'NWT') THEN DO 110 IGR=1,NGCOND GAS(IGR,J)=WORK(IGR) 110 CONTINUE ELSE IF((HMAKE(J).EQ.'CHI').OR. 1 (HMAKE(J)(:5).EQ.'CHI--')) THEN DO 120 IGR=1,NGCOND GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*PNFIRA(0,1) 120 CONTINUE ELSE IF(HMAKE(J)(:3).EQ.'CHI') THEN IDEL=J-IOF1H-1 DO 130 IGR=1,NGCOND GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*PNFIRA(IDEL,1) 130 CONTINUE ELSE DO 140 IGR=1,NGCOND GAS(IGR,J)=GAS(IGR,J)+WORK(IGR)*DDEN 140 CONTINUE ENDIF ENDIF ENDIF 150 CONTINUE CALL LCMLEN(KPWORK,'SCAT-SAVED',ILONG,ITYLCM) IF(ILONG.GT.0) THEN ALLOCATE(SIGS(NGCOND,NL)) CALL XDRLGS(KPWORK,-1,IPRINT,0,NL-1,1,NGCOND,SIGS(1,1), 1 WORK2,ITYPRO) DEALLOCATE(SIGS) DO 162 IL=1,NL WRITE (CM,'(I2.2)') IL-1 IF(ITYPRO(IL).NE.0) HMAKE(MAXH+IL)='SCAT'//CM DO 161 JGR=1,NGCOND DO 160 IGR=1,NGCOND WSCAT(IGR,JGR,IL)=WSCAT(IGR,JGR,IL)+WORK2(IGR,JGR,IL)*DDEN 160 CONTINUE 161 CONTINUE 162 CONTINUE ENDIF ENDIF 170 CONTINUE IF((DENTOT(INM).GT.0.0).OR.LFISS) THEN JJISO=JJISO+1 IF(JJISO.GT.MAXISO) CALL XABORT('EDIRES: MAXISO OVERFLOW(1).') WRITE(TEXT12,'(A8,I4.4)') '*MAC*RES',INM IF(IPRINT.GT.0) WRITE (6,600) TEXT12,JJISO KPEDIT=LCMDIL(JPEDIT,JJISO) ! set JJISO-th isotope CALL LCMPTC(KPEDIT,'ALIAS',12,TEXT12) CALL LCMPUT(KPEDIT,'AWR',1,2,DAWR(INM)) DECISO=DECISO/DENTOT(INM) IF(DECISO.GT.0.0) CALL LCMPUT(KPEDIT,'DECAY',1,2,DECISO) IF(NDFI.GT.0) THEN LYIEL=.FALSE. DO 175 IGR=1,NGCOND+1 LYIEL=LYIEL.OR.(YIELD2(IGR).GT.0.0) 175 CONTINUE IF(LYIEL) THEN CALL LCMPUT(KPEDIT,'YIELD',NGCOND+1,2,YIELD2) CALL LCMPUT(KPEDIT,'PYIELD',NDFI,2,PYIELD2) CALL LCMPUT(KPEDIT,'PIFI',NDFI,1,JPIFI) ENDIF ENDIF IF(NOUT.GT.0) THEN DO J=1,MAXH+NL DO IOUT=1,NOUT IF(HMAKE(J).EQ.HVOUT(IOUT)) GO TO 180 ENDDO HMAKE(J)=' ' 180 CONTINUE ENDDO ENDIF DO 210 J=1,MAXH IF(HMAKE(J).EQ.'OVERV') THEN DO 185 IGR=1,NGCOND GAS(IGR,J)=GAS(IGR,J)/DENTOT(INM) 185 CONTINUE ELSE IF((HMAKE(J).EQ.'CHI').OR.(HMAKE(J)(:5).EQ.'CHI--')) THEN DO 190 IGR=1,NGCOND IF(GAS(IGR,J).NE.0.0) THEN GAS(IGR,J)=GAS(IGR,J)/PNFIRA(0,2) ENDIF 190 CONTINUE ELSE IF(HMAKE(J)(:3).EQ.'CHI') THEN IDEL=J-IOF1H-1 DO 200 IGR=1,NGCOND IF(GAS(IGR,J).NE.0.0) THEN GAS(IGR,J)=GAS(IGR,J)/PNFIRA(IDEL,2) ENDIF 200 CONTINUE ENDIF IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN CALL LCMPUT(KPEDIT,HMAKE(J),NGCOND,2,GAS(1,J)) ENDIF 210 CONTINUE DO 220 IL=1,NL ITYPRO(IL)=0 IF(HMAKE(MAXH+IL).NE.' ') ITYPRO(IL)=1 220 CONTINUE IF(ITYPRO(1).GT.0) THEN CALL XDRLGS(KPEDIT,1,IPRINT,0,NL-1,1,NGCOND,GAS(1,4+3*NW), 1 WSCAT,ITYPRO) ENDIF IF(LWD) CALL LCMPUT(KPEDIT,'LAMBDA-D',NDEL,2,WDLA) * IF(IPRINT.GT.3) THEN WRITE(6,'(/17H NUMBER DENSITY =,1P,E12.4)') 1.0 WRITE(6,'(23H WEIGHTED ATOMIC MASS =,1P,E13.5)') DAWR(INM) DO 230 J=1,MAXH IF(HMAKE(J).NE.' ') THEN WRITE (6,610) HMAKE(J),(GAS(I,J),I=1,NGCOND) ENDIF 230 CONTINUE WRITE (6,610) 'SIGA ',(GAS(I,3+2*NW)-GAS(I,4+3*NW), > I=1,NGCOND) WRITE (6,610) 'SIGW00 ',(WSCAT(I,I,1),I=1,NGCOND) IF(NL.GT.1) THEN WRITE (6,610) 'SIGW01 ',(WSCAT(I,I,2),I=1,NGCOND) ENDIF IF(LWD) WRITE (6,610) 'LAMBDA-D',(WDLA(I),I=1,NDEL) ENDIF ENDIF 240 CONTINUE CALL LCMSIX(IPWORK,' ',2) CALL LCMCL(IPWORK,2) *---- * UPDATE RECORDS ISOTOPESUSED, ISOTOPERNAME, ISOTOPESMIX, ETC. *---- CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) JJISO=IPAR(2) IF(JJISO.GT.MAXISO) CALL XABORT('EDIRES: MAXISO OVERFLOW(2).') IF(JJISO.GT.0) THEN CALL LCMGET(IPEDIT,'ISOTOPESUSED',IHNISO) CALL LCMGET(IPEDIT,'ISOTOPERNAME',IHNIRF) CALL LCMGET(IPEDIT,'ISOTOPESDENS',SDEN) CALL LCMGET(IPEDIT,'ISOTOPESMIX',ISMIX) CALL LCMGET(IPEDIT,'ISOTOPESTYPE',ISTYP) CALL LCMGET(IPEDIT,'ISOTOPESTODO',ISTOD) CALL LCMGET(IPEDIT,'ISOTOPESVOL',VOLISO) CALL LCMGET(IPEDIT,'ISOTOPESTEMP',TNISO) ENDIF DO 260 INM=1,NMERGE IF(DENTOT(INM).GT.0.0) THEN JJISO=JJISO+1 IF(JJISO.GT.MAXISO) CALL XABORT('EDIRES: MAXISO OVERFLOW(3).') WRITE(TEXT12,'(A8,I4.4)') '*MAC*RES',INM READ(TEXT12,'(3A4)') (IHNISO(I0,JJISO),I0=1,3) WRITE(TEXT12,'(A12)') '*MAC*RES ' READ(TEXT12,'(3A4)') (IHNIRF(I0,JJISO),I0=1,3) SDEN(JJISO)=1.0 ISMIX(JJISO)=INM ISTYP(JJISO)=1 ISTOD(JJISO)=1 DVOL=0.0 DO 250 IREGIO=1,NREGIO IF(IMERGE(IREGIO).EQ.INM) DVOL=DVOL+VOLUME(IREGIO) 250 CONTINUE VOLISO(JJISO)=DVOL TNISO(JJISO)=TNTOT(INM) ENDIF 260 CONTINUE IPAR(2)=JJISO IPAR(22)=IPAR(22)+1 CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,IPAR) CALL LCMPUT(IPEDIT,'ISOTOPESUSED',3*JJISO,3,IHNISO) CALL LCMPUT(IPEDIT,'ISOTOPERNAME',3*JJISO,3,IHNIRF) CALL LCMPUT(IPEDIT,'ISOTOPESDENS',JJISO,2,SDEN) CALL LCMPUT(IPEDIT,'ISOTOPESMIX',JJISO,1,ISMIX) CALL LCMPUT(IPEDIT,'ISOTOPESTYPE',JJISO,1,ISTYP) CALL LCMPUT(IPEDIT,'ISOTOPESTODO',JJISO,1,ISTOD) CALL LCMPUT(IPEDIT,'ISOTOPESVOL',JJISO,2,VOLISO) CALL LCMPUT(IPEDIT,'ISOTOPESTEMP',JJISO,2,TNISO) CALL LCMSIX(IPEDIT,' ',2) ! step down CURNAM *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(TNISO,VOLISO,ISTOD,ISTYP,ISMIX,IHNIRF,SDEN,IHNISO) DEALLOCATE(HMAKE) DEALLOCATE(PYIELD2,YIELD2,TNTOT,DAWR,DENTOT,WORK2,PNFIRA,WPY, 1 WORK,GAS,WSCAT,WDLA) DEALLOCATE(ITYPRO,JPIFI,IEVOL2,LSIS2) RETURN * 600 FORMAT (//44H CROSS SECTION OF MERGED/CONDENSED ISOTOPE ',A12, 1 7H' (ISO=,I8,2H):) 610 FORMAT (/11H REACTION ',A12,2H':/(1X,1P,10E12.4)) END