*DECK EPCRMD SUBROUTINE EPCRMD(NENTRY,KENTRY,IPRINT,NOPT,IOPT,CARRET) * *----------------------------------------------------------------------- * *Purpose: * Driver for Error Propagation Module with option "RNDMicXS". * *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 * NENTRY number of data structures transfered to this module. * KENTRY data structure pointer. * IPRINT print level. * NOPT length of array IOPT containing the procession option flags. * IOPT processing option with: * IOPT(1) type of processing (3 for current option); * IOPT(2) entry number for L_EPC structure; * IOPT(3) entry number for read only SEQ_ASCII or BINARY file; * IOPT(4) entry number for update microlib. * CARRET last input option read. * *----------------------------------------------------------------------- * USE GANLIB IMPLICIT NONE *---- * Subroutine arguments *---- INTEGER NENTRY TYPE(C_PTR) KENTRY(NENTRY) INTEGER IPRINT,NOPT,IOPT(NOPT) CHARACTER*12 CARRET *---- * Local parameters *---- INTEGER IOUT CHARACTER NAMSBR*6 PARAMETER (IOUT=6,NAMSBR='EPCRMD') INTEGER ILCMUP,ILCMDN PARAMETER (ILCMUP=1,ILCMDN=2) INTEGER NSTATE,NTC PARAMETER (NSTATE=40,NTC=3) INTEGER NDPROC PARAMETER (NDPROC=20) *---- * Input and output parameters *---- INTEGER ITYPLU,INTLIR CHARACTER CARLIR*12 REAL REALIR DOUBLE PRECISION DBLLIR *---- * Local variables *---- TYPE(C_PTR) IPEPC,IPMIC INTEGER IPCOV,IFMT,IEN,IPRTL,IXS INTEGER ISTATE(NSTATE),ISTATM(NSTATE) CHARACTER*6 NAMDXS(NDPROC+1) CHARACTER*8 XSN INTEGER NGR,NIS,NXS,NCV,ISOREC INTEGER NMIXT,NBISO,NGROUP,NIFISS,NFI,NISL INTEGER ITOTL,ISCAT *---- * Allocatable arrays *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: NAMISO,NISOU,ISOMIX,IDVF, > IDMF,IDXS *---- * Read instruction for RNDMicXS *---- IPRTL=IPRINT IF(IPRTL .GE. 10) THEN WRITE(IOUT,6000) NAMSBR ENDIF IF(CARRET .EQ. ';') GO TO 105 100 CONTINUE CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) CONTINUE IF(ITYPLU .EQ. 10) GO TO 105 IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR// >': Read error -- Character variable expected') CARRET=CARLIR IF(CARLIR .EQ. ';') THEN GO TO 105 ELSE CALL XABORT(NAMSBR//': Read error -- keyword'//CARLIR// >'for processing option is invalid.') ENDIF GO TO 100 105 CONTINUE *---- * Output structure *---- IEN=ABS(IOPT(3)) IPEPC=KENTRY(ABS(IOPT(2))) IPCOV=FILUNIT(KENTRY(IEN)) IPMIC=KENTRY(ABS(IOPT(4))) IF(IOPT(3) .NE. 0) THEN *---- * Transfer Variance and covariance data on EPC data structure *---- IFMT=IOPT(3)/IEN IF(IFMT .GT. 0) THEN READ(IPCOV,'(3I8)') NGR,NIS,NXS ELSE READ(IPCOV) NGR,NIS,NXS ENDIF IF(IPRTL .GE. 10) THEN WRITE(IOUT,6010) NGR,NIS,NXS ENDIF NCV=(NGR*(NGR+1))/2 CALL EPCRMV(IPEPC,IPCOV,IPRINT,IFMT,NGR,NIS,NXS,NCV) ISTATE(:NSTATE)=0 ISTATE(1)=IOPT(1) ISTATE(2)=NGR ISTATE(3)=NIS ISTATE(4)=NXS CALL LCMPUT(IPEPC,'STATE-VECTOR',NSTATE,1,ISTATE) ENDIF IF(IOPT(4) .NE. 0) THEN *---- * Get info for EPC data structure *---- ISTATE(:NSTATE)=0 CALL LCMGET(IPEPC,'STATE-VECTOR',ISTATE) IF(ISTATE(1) .NE. 3) CALL XABORT(NAMSBR// >': Invalid format for EPC data structure') NGR=ISTATE(2) NIS=ISTATE(3) NXS=ISTATE(4) ISOREC=ISTATE(5) NFI=ISTATE(6) NISL=ISTATE(7) IF(IPRTL .GE. 10) THEN WRITE(IOUT,6011) NGR,NIS,NXS ENDIF NCV=(NGR*(NGR+1))/2 *---- * Get info for microlib data structure *---- ISTATM(:NSTATE)=0 CALL LCMGET(IPMIC,'STATE-VECTOR',ISTATM) NMIXT=ISTATM(1) NBISO=ISTATM(2) NGROUP=ISTATM(3) IF(NGROUP .NE. NGR) CALL XABORT(NAMSBR// >': Number of groups in MICROLIB and EPC incoherent.') CALL LCMSIX(IPMIC,'MACROLIB ',ILCMUP) ISTATM(:NSTATE)=0 CALL LCMGET(IPMIC,'STATE-VECTOR',ISTATM) NIFISS=ISTATM(4) CALL LCMSIX(IPMIC,'MACROLIB ',ILCMDN) *---- * Allocate memory *---- ALLOCATE(NAMISO(3*NIS),NISOU(3*NBISO),ISOMIX(NBISO),IDVF(2*NIS), > IDMF(2*NBISO)) CALL LCMGET(IPMIC,'ISOTOPESUSED',NISOU) CALL LCMGET(IPMIC,'ISOTOPESMIX ',ISOMIX) CALL LCMSIX(IPEPC,'XSVariances ',ILCMUP) CALL LCMGET(IPEPC,'NAMEISO ',NAMISO) *---- * Variance XS *---- ALLOCATE(IDXS(2*NXS)) CALL LCMGET(IPEPC,'NAMEXS ',IDXS) ISCAT=0 ITOTL=0 DO IXS=1,NXS WRITE(XSN,'(2A4)') IDXS(2*IXS-1),IDXS(2*IXS) NAMDXS(IXS)=XSN(1:6) IF(NAMDXS(IXS).EQ.'TOTAL ') THEN ITOTL=IXS ELSE IF(NAMDXS(IXS).EQ.'SIGS00') THEN ISCAT=IXS ENDIF ENDDO DEALLOCATE(IDXS) IF(ISOREC .EQ. 0) THEN CALL EPCRMI(IPMIC,IPRINT,NIS,NBISO,NMIXT,NIFISS, > NAMISO,NISOU,IDVF,IDMF) CALL LCMPUT(IPEPC,'INDEXISOV',2*NIS,1,IDVF) CALL LCMPUT(IPEPC,'INDEXISOM',2*NBISO,1,IDMF) ISOREC=1 NFI=NIFISS NISL=NBISO ISTATE(5)=ISOREC ISTATE(6)=NFI ISTATE(7)=NISL CALL LCMPUT(IPEPC,'STATE-VECTOR',NSTATE,1,ISTATE) ELSE IF(NFI .NE. NIFISS) CALL XABORT(NAMSBR// >': Number of fissile isotopes in MICROLIB and EPC incoherent.') IF(NISL .NE. NBISO) CALL XABORT(NAMSBR// >': Number of isotopes in MICROLIB and EPC incoherent.') CALL LCMGET(IPEPC,'INDEXISOV',IDVF) CALL LCMGET(IPEPC,'INDEXISOM',IDMF) ENDIF *---- * Update macrolib from random error distribution *---- CALL EPCRMU(IPEPC,IPMIC,IPRINT,NGR,NIS,NXS,NCV, > NBISO,NMIXT,NIFISS,ITOTL,ISCAT,NAMDXS, > NAMISO,NISOU,ISOMIX,IDVF,IDMF) DEALLOCATE(IDMF,IDVF,ISOMIX,NISOU,NAMISO) CALL LCMSIX(IPEPC,'XSVariances ',ILCMDN) ENDIF IF(IPRTL .GE. 10) THEN WRITE(IOUT,6001) NAMSBR ENDIF RETURN *---- * Formats *---- 6000 FORMAT('(* Output from --',A6,'-- follows ') 6001 FORMAT(' Output from --',A6,'-- completed *)') 6010 FORMAT(' Creating EPC data structure with:'/ > ' NGROUP = ',I8/ > ' NISO = ',I8/ > ' NXS = ',I8) 6011 FORMAT(' Updating MICROLIB from EPC with:'/ > ' NGROUP = ',I8/ > ' NISO = ',I8/ > ' NXS = ',I8) END