Initial commit from Polytechnique Montreal

1 files changed, 234 insertions, 0 deletions

diff --git a/Dragon/src/EPCRMD.f b/Dragon/src/EPCRMD.f
new file mode 100644
index 0000000..07696d5
--- /dev/null
+++ b/Dragon/src/EPCRMD.f
@@ -0,0 +1,234 @@
+*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