diff options
Diffstat (limited to 'Dragon/src/EPCRMU.f')
| -rw-r--r-- | Dragon/src/EPCRMU.f | 201 |
1 files changed, 201 insertions, 0 deletions
diff --git a/Dragon/src/EPCRMU.f b/Dragon/src/EPCRMU.f new file mode 100644 index 0000000..7021bee --- /dev/null +++ b/Dragon/src/EPCRMU.f @@ -0,0 +1,201 @@ +*DECK EPCRMU + SUBROUTINE EPCRMU(IPEPC,IPMIC,IPRINT,NGR,NIS,NXS,NCV, + > NBISO,NMIXT,NIFISS,ITOTL,ISCAT,NAMDXS, + > NAMISO,NISOU,ISOMIX,IDVF,IDMF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Update MACROLIB from random error distribution. +* +*Copyright: +* Copyright (C) 2009 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): +* G. Marleau +* +*Parameters: input +* IPEPC pointer to EPC data structure. +* IPMIC pointer to MICROLIB. +* IPRINT print level. +* NGR number of groups. +* NIS number of isotopes on EPC. +* NXS number of cross section types on EPC. +* NCV maximum dimension of symmetrized covariance matrix. +* NBISO number of isotopes on MICROLIB. +* NMIXT number of mixtures on MICROLIB. +* NIFISS number of fissiles isotopes on MICROLIB. +* ITOTL position of total XS in NAMDXS. +* ISCAT position of scattering XS in NAMDXS. +* NAMDXS names of XS. +* NAMISO array containing the isotope names. +* NISOU MICROLIB isotopes used. +* ISOMIX MICROLIB isotopes mixtures. +* IDVF variance isotopes to analyze and fission id. +* IDMF MICROLIB isotopes to analyze and fission id. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPEPC,IPMIC + INTEGER IPRINT,NGR,NIS,NXS,NCV, + > NBISO,NMIXT,NIFISS,ITOTL,ISCAT + CHARACTER*6 NAMDXS(NXS) + INTEGER NAMISO(3,NIS),NISOU(3,NBISO),ISOMIX(NBISO), + > IDVF(2,NIS),IDMF(2,NBISO) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='EPCRMU') + INTEGER ILCMUP,ILCMDN + PARAMETER (ILCMUP=1,ILCMDN=2) +*---- +* Local variables +*---- + INTEGER ILCMLN,ILCMTY,IPRTL + INTEGER ISO,IXS,JSO,IGR,ISOF + CHARACTER ISONAM*12,RECNAM*12,NAMMIC*12 + INTEGER ITC,IMIX + REAL DENSI + INTEGER ISEED,IGS,IORD,MINLEG,MAXLEG + SAVE ISEED,IGS,IORD,MINLEG,MAXLEG +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ICOV + REAL, ALLOCATABLE, DIMENSION(:) :: DENS,XSMAC,XSREC,VAR,VAROLD,RST + REAL, ALLOCATABLE, DIMENSION(:,:) :: COV + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DRVAR +*---- +* Data statement +*---- + DATA ISEED,IGS,IORD,MINLEG,MAXLEG + > /0, -1, 1, 0, 0/ +*---- +* Scratch storage allocation +* ICOV array to store indices to reconstructe full covariance +* matrix from compressed covariance matrix. +* COV array to store compressed covariance matrix. +* DENS MICROLIB isotopes densities +* DRVAR Random variance distribution (width=1) +*---- + ALLOCATE(ICOV(NGR,NXS)) + ALLOCATE(DENS(NBISO),COV(NCV,NXS)) + ALLOCATE(DRVAR(NGR,NXS)) +*---- +* Write header +*---- + IPRTL=IPRINT + IF(IPRTL .GE. 2) THEN + WRITE(IOUT,6000) NAMSBR + ENDIF +*---- +* Isotope densities +*---- + ALLOCATE(XSMAC(NGR*NXS*NMIXT*NIFISS)) + XSMAC(:NGR*NXS*NMIXT*NIFISS)=0.0 + ALLOCATE(XSREC(NGR*(NXS+1)),VAR(NGR),VAROLD(NGR),RST(NGR)) + CALL LCMGET(IPMIC,'ISOTOPESDENS',DENS) + DO ISO=1,NIS +*---- +* Test if isotope used in Microlib +*---- + IF(IDVF(1,ISO) .GT .0) THEN +*---- +* Isotope is used +* read covariance matrices +*---- + ICOV(:NGR,:NXS)=0 + COV(:NCV,:NXS)=0.0 + WRITE(ISONAM,'(3A4)') (NAMISO(ITC,ISO),ITC=1,3) + IF(IPRTL .GE. 2) THEN + WRITE(IOUT,*) ISONAM + ENDIF + CALL LCMSIX(IPEPC,ISONAM,ILCMUP) + DO IXS=1,NXS +*---- +* Get covariance matrices +*---- + RECNAM='INDX'//NAMDXS(IXS)//' ' + CALL LCMLEN(IPEPC,RECNAM,ILCMLN,ILCMTY) + IF(ILCMLN .EQ. NGR) THEN + CALL LCMGET(IPEPC,RECNAM,ICOV(1,IXS)) + RECNAM=NAMDXS(IXS)//' ' + CALL LCMGET(IPEPC,RECNAM,COV(1,IXS)) +*---- +* Generate random numbers from normal distribution +*---- + CALL RANDDN(ISEED,NGR,DRVAR(1,IXS)) + IF(IPRTL .GE. 5) THEN + WRITE(IOUT,*) NAMDXS(IXS),'DRVAR=[' + WRITE(IOUT,6010) (DRVAR(IGR,IXS),IGR=1,NGR) + WRITE(IOUT,*) '];' + ENDIF + ENDIF + ENDDO + CALL LCMSIX(IPEPC,ISONAM,ILCMDN) +*---- +* Scan over Microlib isotopes associated with this variance isotope +*---- + DO JSO=1,NBISO + IF(IDMF(1,JSO) .EQ. ISO) THEN + ISOF=IDMF(2,JSO) +*---- +* Read microlib for isotope +*---- + WRITE(NAMMIC,'(3A4)') (NISOU(ITC,JSO),ITC=1,3) + CALL LCMSIX(IPMIC,NAMMIC,ILCMUP) +*---- +* Get microscopic xs +*---- + CALL XDRLXS(IPMIC,IGS,IPRINT,NXS,NAMDXS,IORD,NGR,XSREC) +*---- +* Add contribution to macrolib +*---- + DENSI=DENS(JSO) + IMIX=ISOMIX(JSO) + CALL LCMSIX(IPMIC,'VARIANCES ',ILCMUP) + CALL EPCRMA(IPMIC,IPRINT,NGR,NXS,NCV,NMIXT,NIFISS, + > IMIX,ISOF,ITOTL,ISCAT,NAMDXS,DENSI,ICOV, + > COV,DRVAR,XSREC,XSMAC,VAR,VAROLD,RST) + CALL LCMSIX(IPMIC,'VARIANCES ',ILCMDN) + CALL LCMSIX(IPMIC,NAMMIC,ILCMDN) + ENDIF + ENDDO + ENDIF + ENDDO + IF(IPRTL .GE. 2) THEN + WRITE(IOUT,6001) NAMSBR + ENDIF + DEALLOCATE(RST,VAROLD,VAR,XSREC) +*---- +* Update macrolib +*---- + CALL LCMSIX(IPMIC,'MACROLIB ',ILCMUP) + CALL EPCRMS(IPMIC,IPRINT,NGR,NXS,NMIXT,NIFISS,NAMDXS,XSMAC) + CALL LCMSIX(IPMIC,'MACROLIB ',ILCMDN) + DEALLOCATE(XSMAC) +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(DRVAR) + DEALLOCATE(COV,DENS) + DEALLOCATE(ICOV) + RETURN +*---- +* Formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6010 FORMAT(10F10.4,:,' ...') + END |