*DECK OUTPRO SUBROUTINE OUTPRO (IPMAC1,IPMAC2,NBMIX,NL,NBFIS,NGRP,NEL,NUN, 1 NALBP,NZS,NGCOND,MAT,VOL,IDL,EVECT,ADECT,IHOM,IGCOND,IMPX) * *----------------------------------------------------------------------- * *Purpose: * Perform direct-adjoint homogenization into NZS regions and * condensation into NGCOND macrogroups based on averaged fluxes * contained in EVECT and adjoint fluxes contained in ADECT. Create * an output extended macrolib containing homogenized volumes, * integrated fluxes and cross sections. * *Copyright: * Copyright (C) 2018 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 * IPMAC1 L_MACROLIB pointer to the input macrolib. * IPMAC2 L_MACROLIB pointer to the output extended macrolib. * NBMIX number of material mixtures. * NL scattering anisotropy. * NBFIS number of fissionable isotopes. * NGRP total number of energy groups. * NEL number of finite elements. * NUN number of unknowns per energy group. * NALBP number of physical albedos. * NZS number of homogenized regions so that NZS=max(IHOM(i)). * NGCOND number of macrogroups after energy condensation. * MAT index-number of the mixture type assigned to each volume. * VOL volumes. * IDL position of the average flux component associated with * each volume. * EVECT unknowns. * ADECT adjoint flux unknowns. * IHOM homogenized index assigned to each element. * IGCOND limit of condensed groups. * IMPX print parameter (equal to zero for no print). * *----------------------------------------------------------------------- * USE GANLIB *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPMAC1,IPMAC2 PARAMETER(NREAC=11) INTEGER NBMIX,NL,NBFIS,NGRP,NEL,NUN,NALBP,NZS,NGCOND,MAT(NEL), 1 IDL(NEL),IHOM(NEL),IGCOND(NGCOND),IMPX REAL VOL(NEL),EVECT(NUN,NGRP),ADECT(NUN,NGRP) *---- * LOCAL VARIABLES *---- TYPE(C_PTR) JPMAC1,KPMAC1,JPMAC2,KPMAC2 PARAMETER(NSTATE=40) CHARACTER HREAC(NREAC)*12,TEXT12*12,SUFF*2,TEXT6*6 INTEGER IDATA(NSTATE) LOGICAL LNUSIG,LESTOP,LFIXE,LREAC(NREAC) *---- * ALLOCATABLE ARRAYS *---- INTEGER, DIMENSION(:), ALLOCATABLE :: IJJ,NJJ,IPOS REAL, DIMENSION(:), ALLOCATABLE :: VOLI,WORK,SCAT,RATE,GAR,RATEF, 1 DEN,DEN2 REAL, DIMENSION(:,:), ALLOCATABLE :: FLINT,AFLINT,CHI,ZUFIS, 1 ALBPGR,ALBP,OUTR,ESTOP,DEN3 REAL, DIMENSION(:,:,:), ALLOCATABLE :: OUTSC DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: ACCUM *---- * DATA STATEMENT *---- DATA HREAC/'NTOT0','SIGW00','NUSIGF','NFTOT','H-FACTOR', 1 'OVERV','DIFF','DIFFX','DIFFY','DIFFZ','C-FACTOR'/ *---- * SCRATCH STORAGE ALLOCATION * OUTR(IBM,NREAC+1): volume * OUTR(IBM,NREAC+2): integrated direct flux * OUTR(IBM,NREAC+3): adjoint weighting flux * OUTR(IBM,NREAC+4): fission spectrum * OUTR(IBM,NREAC+5): fixed sources *---- ALLOCATE(VOLI(NZS),WORK(NZS),RATE(NZS),FLINT(NZS,NGRP), 1 AFLINT(NZS,NGRP),CHI(NBMIX,NBFIS),ZUFIS(NBMIX,NBFIS), 2 OUTR(NZS+1,NREAC+5),OUTSC(NZS,NL+2,NGCOND),GAR(NGRP), 3 ALBPGR(NALBP,NGRP),ALBP(NALBP,NGCOND),ESTOP(NZS,NGRP+1)) ALLOCATE(ACCUM(NZS,NBFIS)) * ALBP(:NALBP,:NGCOND)=0.0 ESTOP(:NZS,:NGRP+1)=0.0 LNUSIG=.FALSE. LESTOP=.FALSE. LFIXE=.FALSE. LREAC(:NREAC)=.FALSE. *---- * RECOVER PHYSICAL ALBEDOS. *---- IF(NALBP.GT.0) CALL LCMGET(IPMAC1,'ALBEDO',ALBPGR) *---- * DIRECT FLUX CALCULATION. *---- VOLI(:NZS)=0.0 FLINT(:NZS,:NGRP)=0.0 DO 20 K=1,NEL IBM=IHOM(K) IPFL=IDL(K) IF((IBM.NE.0).AND.(MAT(K).NE.0).AND.(IPFL.NE.0)) THEN VOLI(IBM)=VOLI(IBM)+VOL(K) DO 10 IGR=1,NGRP FLINT(IBM,IGR)=FLINT(IBM,IGR)+EVECT(IPFL,IGR)*VOL(K) 10 CONTINUE ENDIF 20 CONTINUE CALL LCMPUT(IPMAC2,'VOLUME',NZS,2,VOLI) *---- * ADJOINT FLUX CALCULATION. *---- AFLINT(:NZS,:NGRP)=0.0 DO 40 K=1,NEL IBM=IHOM(K) IPFL=IDL(K) IF((IBM.NE.0).AND.(MAT(K).NE.0).AND.(IPFL.NE.0)) THEN DO 30 IGR=1,NGRP AFLINT(IBM,IGR)=AFLINT(IBM,IGR)+ADECT(IPFL,IGR)* 1 EVECT(IPFL,IGR)*VOL(K) 30 CONTINUE ENDIF 40 CONTINUE DO 60 IGR=1,NGRP DO 50 IBM=1,NZS AFLINT(IBM,IGR)=AFLINT(IBM,IGR)/FLINT(IBM,IGR) 50 CONTINUE 60 CONTINUE *---- * FISSION RATE CALCULATION. *---- IF(IMPX.GT.0) WRITE(6,'(/35H OUTPRO: REACTION RATE CALCULATION.)') JPMAC1=LCMGID(IPMAC1,'GROUP') JPMAC2=LCMLID(IPMAC2,'GROUP',NGCOND) IF(NBFIS.GT.0) THEN ACCUM(:NZS,:NBFIS)=0.0D0 DO 100 IGR=1,NGRP KPMAC1=LCMGIL(JPMAC1,IGR) CALL LCMGET(KPMAC1,'NUSIGF',ZUFIS) DO 90 IFISS=1,NBFIS DO 80 K=1,NEL IBM=IHOM(K) L=MAT(K) IPFL=IDL(K) IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN ACCUM(IBM,IFISS)=ACCUM(IBM,IFISS)+ADECT(IPFL,IGR)* 1 EVECT(IPFL,IGR)*VOL(K)*ZUFIS(L,IFISS) ENDIF 80 CONTINUE 90 CONTINUE 100 CONTINUE ENDIF *---- * LOOP OVER ENERGY GROUP LIST. *---- IGRFIN=0 DO 500 IGRC=1,NGCOND IGRDEB=IGRFIN+1 IGRFIN=IGCOND(IGRC) OUTR(:NZS+1,:NREAC+5)=0.0 OUTSC(:NZS,:NL+2,:NGCOND)=0.0 ALLOCATE(RATEF(NZS),DEN(NZS)) RATEF(:NZS)=0.0 DEN(:NZS)=0.0 DO 310 IGR=IGRDEB,IGRFIN KPMAC1=LCMGIL(JPMAC1,IGR) DO 110 IBM=1,NZS OUTR(IBM,NREAC+2)=OUTR(IBM,NREAC+2)+FLINT(IBM,IGR) OUTR(IBM,NREAC+3)=OUTR(IBM,NREAC+3)+AFLINT(IBM,IGR) 110 CONTINUE *---- * SET VOLUMES. *---- DO 120 IBM=1,NZS OUTR(IBM,NREAC+1)=VOLI(IBM) 120 CONTINUE *---- * REACTION RATE CALCULATION. *---- DO 150 IREAC=1,NREAC CALL LCMLEN(KPMAC1,HREAC(IREAC),LENGT,ITYLCM) LREAC(IREAC)=LREAC(IREAC).OR.(LENGT.NE.0) IF((HREAC(IREAC).EQ.'H-FACTOR').AND.(LENGT.EQ.0)) THEN WRITE(6,'(/46H OUTPRO: *** WARNING *** NO H-FACTOR FOUND ON , 1 25HLCM. USE NU*SIGF INSTEAD.)') LNUSIG=.TRUE. GO TO 150 ELSE IF(HREAC(IREAC).EQ.'NUSIGF') THEN GO TO 150 ELSE IF(HREAC(IREAC).EQ.'SIGW00') THEN GO TO 150 ELSE TEXT12=HREAC(IREAC) ENDIF IF(LENGT.GT.0) THEN IF(LENGT.GT.NBMIX) CALL XABORT('OUTPRO: INVALID LENGTH FOR '// 1 HREAC(IREAC)//' CROSS SECTIONS.') CALL LCMGET(KPMAC1,TEXT12,WORK) RATE(:NZS)=0.0 DO 130 K=1,NEL IBM=IHOM(K) L=MAT(K) IPFL=IDL(K) IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN RATE(IBM)=RATE(IBM)+ADECT(IPFL,IGR)*EVECT(IPFL,IGR)*VOL(K)* 1 WORK(L) ENDIF 130 CONTINUE DO 140 IBM=1,NZS OUTR(IBM,IREAC)=OUTR(IBM,IREAC)+RATE(IBM) 140 CONTINUE ENDIF 150 CONTINUE *---- * FIXED SOURCES *---- CALL LCMLEN(KPMAC1,'FIXE',LENGT,ITYLCM) IF(LENGT.GT.0) THEN LFIXE=.TRUE. IF(LENGT.GT.NBMIX) CALL XABORT('OUTPRO: INVALID LENGTH FOR '// 1 'FIXE SOURCE.') CALL LCMGET(KPMAC1,'FIXE',WORK) RATE(:NZS)=0.0 DO 160 K=1,NEL IBM=IHOM(K) L=MAT(K) IPFL=IDL(K) IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN RATE(IBM)=RATE(IBM)+ADECT(IPFL,IGR)*VOL(K)*WORK(L) ENDIF 160 CONTINUE DO 170 IBM=1,NZS OUTR(IBM,NREAC+5)=OUTR(IBM,NREAC+5)+RATE(IBM) 170 CONTINUE ENDIF *---- * SCATTERING MATRIX INFORMATION IGR <-- JGR. *---- ALLOCATE(IJJ(NBMIX),NJJ(NBMIX),IPOS(NBMIX)) ALLOCATE(SCAT(NBMIX*NGRP)) DO 220 IL=1,NL WRITE(SUFF,'(I2.2)') IL-1 CALL LCMLEN(KPMAC1,'NJJS'//SUFF,LENGT,ITYLCM) IF(LENGT.GT.0) THEN IF(LENGT.GT.NBMIX) CALL XABORT('OUTPRO: INVALID LENGTH FOR '// 1 'SCATTERING CROSS SECTIONS.') CALL LCMLEN(KPMAC1,'SCAT'//SUFF,LENGT,ITYLCM) IF(LENGT.GT.NBMIX*NGRP) CALL XABORT('OUTPRO: SCAT OVERFLOW.') CALL LCMGET(KPMAC1,'NJJS'//SUFF,NJJ) CALL LCMGET(KPMAC1,'IJJS'//SUFF,IJJ) CALL LCMGET(KPMAC1,'IPOS'//SUFF,IPOS) CALL LCMGET(KPMAC1,'SCAT'//SUFF,SCAT) IPOSDE=0 DO 210 K=1,NEL IBM=IHOM(K) L=MAT(K) IPFL=IDL(K) IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN GAR(:NGRP)=0.0 IPOSDE=IPOS(L)-1 DO 180 JGR=IJJ(L),IJJ(L)-NJJ(L)+1,-1 IPOSDE=IPOSDE+1 GAR(JGR)=SCAT(IPOSDE) 180 CONTINUE JGRFIN=0 DO 200 JGRC=1,NGCOND JGRDEB=JGRFIN+1 JGRFIN=IGCOND(JGRC) DO 190 JGR=JGRDEB,JGRFIN OUTSC(IBM,IL,JGRC)=OUTSC(IBM,IL,JGRC)+ADECT(IPFL,JGR)* 1 EVECT(IPFL,JGR)*VOL(K)*GAR(JGR) 190 CONTINUE 200 CONTINUE ENDIF 210 CONTINUE IF(IL.EQ.1) OUTR(:NZS,2)=OUTSC(:NZS,IL,IGRC) ENDIF 220 CONTINUE DEALLOCATE(SCAT) DEALLOCATE(IJJ,NJJ,IPOS) *---- * FISSION SPECTRUM AND NUSIGF HOMOGENIZATION. *---- IF(NBFIS.GT.0) THEN CALL LCMLEN(KPMAC1,'NUSIGF',LENGT,ITYLCM) IF(LENGT.NE.NBMIX*NBFIS) CALL XABORT('OUTPRO: INVALID LENGTH ' 1 //'FOR FISSION SPECTRUM.') CALL LCMGET(KPMAC1,'NUSIGF',ZUFIS) CALL LCMLEN(KPMAC1,'CHI',LENGT,ITYLCM) IF(LENGT.EQ.0) THEN IF(IGR.EQ.IGRDEB) OUTR(:NZS,NREAC+4)=1.0 ELSE CALL LCMGET(KPMAC1,'CHI',CHI) DO 240 K=1,NEL IBM=IHOM(K) L=MAT(K) IF((IBM.NE.0).AND.(L.NE.0)) THEN DO 230 IFISS=1,NBFIS RATE(IBM)=RATE(IBM)+CHI(L,IFISS)*REAL(ACCUM(IBM,IFISS)) DEN(IBM)=DEN(IBM)+REAL(ACCUM(IBM,IFISS)) 230 CONTINUE ENDIF 240 CONTINUE ENDIF DO 260 IFISS=1,NBFIS DO 250 K=1,NEL IBM=IHOM(K) L=MAT(K) IPFL=IDL(K) IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN OUTR(IBM,3)=OUTR(IBM,3)+ADECT(IPFL,IGR)*EVECT(IPFL,IGR)* 1 VOL(K)*ZUFIS(L,IFISS) ENDIF 250 CONTINUE 260 CONTINUE ENDIF *---- * CONDENSE PHYSICAL ALBEDOS. *---- IF(NALBP.GT.0) THEN DO 280 IAL=1,NALBP DO 270 IBM=1,NZS ALBP(IAL,IGRC)=ALBP(IAL,IGRC)+ALBPGR(IAL,IGR)*AFLINT(IBM,IGR)* 1 FLINT(IBM,IGR) 270 CONTINUE 280 CONTINUE ENDIF *---- * RECOVER AND HOMOGENIZE STOPPING POWERS *---- CALL LCMLEN(KPMAC1,'ESTOPW',LENGT,ITYLCM) IF(LENGT.EQ.2*NBMIX) THEN ALLOCATE(DEN3(NBMIX,2)) LESTOP=.TRUE. CALL LCMGET(KPMAC1,'ESTOPW',DEN3) DO 290 K=1,NEL IBM=IHOM(K) L=MAT(K) IPFL=IDL(K) IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN IF(IGR.EQ.1) THEN FACTOR=ADECT(IPFL,IGR)*EVECT(IPFL,IGR)/(AFLINT(IBM,IGR)* 1 FLINT(IBM,IGR)) ELSE FACTOR=(ADECT(IPFL,IGR-1)*EVECT(IPFL,IGR-1)+ 1 ADECT(IPFL,IGR)*EVECT(IPFL,IGR))/(AFLINT(IBM,IGR-1)* 2 FLINT(IBM,IGR-1)+AFLINT(IBM,IGR)*FLINT(IBM,IGR)) ENDIF ESTOP(IBM,IGR)=ESTOP(IBM,IGR)+FACTOR*VOL(K)*DEN3(L,1) ENDIF 290 CONTINUE IF(IGR.EQ.NGRP) THEN DO 300 K=1,NEL IBM=IHOM(K) L=MAT(K) IPFL=IDL(K) IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN FACTOR=ADECT(IPFL,IGR)*EVECT(IPFL,IGR)/(AFLINT(IBM,IGR)* 1 FLINT(IBM,IGR)) ESTOP(IBM,IGR+1)=ESTOP(IBM,IGR+1)+FACTOR*VOL(K)*DEN3(L,2) ENDIF 300 CONTINUE ENDIF DEALLOCATE(DEN3) ENDIF 310 CONTINUE * DO 340 K=1,NEL IBM=IHOM(K) L=MAT(K) IPFL=IDL(K) IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN JGRFIN=0 DO 330 JGRC=1,NGCOND JGRDEB=JGRFIN+1 JGRFIN=IGCOND(JGRC) DO 320 JGR=JGRDEB,JGRFIN OUTSC(IBM,NL+1,JGRC)=OUTSC(IBM,NL+1,JGRC)+EVECT(IPFL,JGR)*VOL(K) OUTSC(IBM,NL+2,JGRC)=OUTSC(IBM,NL+2,JGRC)+ADECT(IPFL,JGR)*VOL(K) 320 CONTINUE 330 CONTINUE ENDIF 340 CONTINUE IF(NBFIS.GT.0) THEN DO 350 IBM=1,NZS IF(DEN(IBM).NE.0.0) OUTR(IBM,NREAC+3)=RATEF(IBM)/DEN(IBM) 350 CONTINUE ENDIF DEALLOCATE(DEN,RATEF) *---- * PRINT THE REACTION RATES: *---- IF(IMPX.GT.0) THEN DO 360 I=1,NREAC+3 OUTR(NZS+1,I)=0.0 360 CONTINUE WRITE(6,520) IGRC,'VOLUME ','FLUX-INTG ', 1 (HREAC(I),I=1,6),'CHI ' DO 380 IBM=1,NZS DO 370 I=1,NREAC+3 OUTR(NZS+1,I)=OUTR(NZS+1,I)+OUTR(IBM,I) 370 CONTINUE WRITE(6,530) IBM,OUTR(IBM,NREAC+1),OUTR(IBM,NREAC+2), 1 (OUTR(IBM,I),I=1,6),OUTR(IBM,NREAC+4) 380 CONTINUE WRITE(6,540) OUTR(NZS+1,NREAC+1),OUTR(NZS+1,NREAC+2), 1 (OUTR(NZS+1,I),I=1,6) ENDIF *---- * COMPUTE HOMOGENIZED-CONDENSED MACROLIB *---- KPMAC2=LCMDIL(JPMAC2,IGRC) CALL LCMPUT(KPMAC2,'FLUX-INTG',NZS,2,OUTR(1,NREAC+2)) CALL LCMPUT(KPMAC2,'NWAT0',NZS,2,OUTR(1,NREAC+3)) DO 400 IREAC=1,NREAC IF(LREAC(IREAC)) THEN DO 390 IBM=1,NZS RATE(IBM)=OUTR(IBM,IREAC) IF(RATE(IBM).NE.0.0) RATE(IBM)=RATE(IBM)/(OUTR(IBM,NREAC+2)* 1 OUTR(IBM,NREAC+3)) 390 CONTINUE CALL LCMPUT(KPMAC2,HREAC(IREAC),NZS,2,RATE) IF(LNUSIG.AND.(IREAC.EQ.3)) THEN CALL LCMPUT(KPMAC2,'H-FACTOR',NZS,2,RATE) ENDIF ENDIF 400 CONTINUE IF(LREAC(3)) CALL LCMPUT(KPMAC2,'CHI',NZS,2,OUTR(1,NREAC+4)) IF(LFIXE) THEN DO 410 IBM=1,NZS RATE(IBM)=OUTR(IBM,NREAC+5) IF(RATE(IBM).NE.0.0) RATE(IBM)=RATE(IBM)/OUTR(IBM,NREAC+3) 410 CONTINUE CALL LCMPUT(KPMAC2,'FIXE',NZS,2,RATE) ENDIF * ALLOCATE(IJJ(NZS),NJJ(NZS),IPOS(NZS)) ALLOCATE(SCAT(NZS*NGCOND)) DO 460 IL=1,NL WRITE(SUFF,'(I2.2)') IL-1 DO 430 IBM=1,NZS IGMIN=IGRC IGMAX=IGRC DO 420 JGRC=NGCOND,1,-1 IF(OUTSC(IBM,IL,JGRC).NE.0.0) THEN IGMIN=MIN(IGMIN,JGRC) IGMAX=MAX(IGMAX,JGRC) OUTSC(IBM,IL,JGRC)=OUTSC(IBM,IL,JGRC)/(OUTSC(IBM,NL+1,JGRC)* 1 OUTSC(IBM,NL+2,JGRC)) ENDIF 420 CONTINUE IJJ(IBM)=IGMAX NJJ(IBM)=IGMAX-IGMIN+1 430 CONTINUE IPOSDE=0 DO 450 IBM=1,NZS IPOS(IBM)=IPOSDE+1 DO 440 JGRC=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1 IPOSDE=IPOSDE+1 SCAT(IPOSDE)=OUTSC(IBM,IL,JGRC) 440 CONTINUE 450 CONTINUE CALL LCMPUT(KPMAC2,'SCAT'//SUFF,IPOSDE,2,SCAT) CALL LCMPUT(KPMAC2,'IPOS'//SUFF,NZS,1,IPOS) CALL LCMPUT(KPMAC2,'NJJS'//SUFF,NZS,1,NJJ) CALL LCMPUT(KPMAC2,'IJJS'//SUFF,NZS,1,IJJ) CALL LCMPUT(KPMAC2,'SIGW'//SUFF,NZS,2,OUTSC(1,IL,IGRC)) 460 CONTINUE DEALLOCATE(SCAT) DEALLOCATE(IJJ,NJJ,IPOS) * IF(NALBP.GT.0) THEN DFI=0.0 DO 470 IBM=1,NZS DFI=DFI+OUTR(IBM,NREAC+2)*OUTR(IBM,NREAC+3) 470 CONTINUE DO 480 IAL=1,NALBP ALBP(IAL,IGRC)=ALBP(IAL,IGRC)/DFI 480 CONTINUE ENDIF *---- * SAVE STOPPING POWERS *---- IF(LESTOP) THEN ALLOCATE(DEN3(NZS,2)) DO 490 IBM=1,NZS IF(IGRC.EQ.1) THEN DEN3(IBM,1)=ESTOP(IBM,1) ELSE DEN3(IBM,1)=ESTOP(IBM,IGCOND(IGRC-1)) ENDIF DEN3(IBM,2)=ESTOP(IBM,IGCOND(IGRC)+1) 490 CONTINUE CALL LCMPUT(KPMAC2,'ESTOPW',NZS*2,2,DEN3) DEALLOCATE(DEN3) ENDIF 500 CONTINUE *---- * END OF LOOP OVER MACROGROUPS *---- *---- * RECOVER AND CONDENSE ENERGY MESH *---- CALL LCMLEN(IPMAC1,'ENERGY',LENGT,ITYLCM) IF(LENGT.EQ.NGRP+1) THEN ALLOCATE(DEN(NGRP+1),DEN2(NGCOND+1)) CALL LCMGET(IPMAC1,'ENERGY',DEN) DEN2(1)=DEN(1) DO 510 IGRC=1,NGCOND DEN2(IGRC+1)=DEN(IGCOND(IGRC)+1) 510 CONTINUE CALL LCMPUT(IPMAC2,'ENERGY',NGCOND+1,2,DEN2) DEALLOCATE(DEN2,DEN) ENDIF *---- * SAVE ALBEDO AND STATE-VECTOR *---- IF(NALBP.GT.0) THEN CALL LCMPUT(IPMAC2,'ALBEDO',NALBP*NGCOND,2,ALBP) ENDIF CALL LCMLEN(IPMAC1,'PARTICLE',LENGT,ITYLCM) IF(LENGT.GT.0) THEN CALL LCMGTC(IPMAC1,'PARTICLE',12,TEXT6) CALL LCMPTC(IPMAC2,'PARTICLE',12,TEXT6) ENDIF IDATA(:NSTATE)=0 IDATA(1)=NGCOND IDATA(2)=NZS IDATA(3)=NL IDATA(4)=1 IDATA(8)=NALBP IF(LREAC(7)) THEN IDATA(9)=1 ELSE IF(LREAC(8)) THEN IDATA(9)=2 ENDIF IDATA(15)=0 CALL LCMPUT(IPMAC2,'STATE-VECTOR',NSTATE,1,IDATA) *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(ACCUM) DEALLOCATE(ESTOP,ALBP,ALBPGR,GAR,OUTSC,OUTR,ZUFIS,CHI,AFLINT, 1 FLINT,RATE,WORK,VOLI) RETURN * 520 FORMAT(/' G R O U P : ',I3/1X,'IHOM',9A14) 530 FORMAT(1X,I4,1P,9E14.5) 540 FORMAT(/5H SUM,1P,8E14.5) END