Initial commit from Polytechnique Montreal

1 files changed, 172 insertions, 0 deletions

diff --git a/Donjon/src/NEWMDV.f b/Donjon/src/NEWMDV.f
new file mode 100644
index 0000000..0dfd906
--- /dev/null
+++ b/Donjon/src/NEWMDV.f
@@ -0,0 +1,172 @@
+*DECK NEWMDV
+      SUBROUTINE NEWMDV(IPMTX,IPMAC,IPMAC2,IPDEV,NMIX,NGRP,NL,NDEL,LEAK,
+     1 NEL,LX,LY,LZ,XFAC,IMPX)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Update the material properties and store them in a new macrolib.
+*
+*Copyright:
+* Copyright (C) 2007 Ecole Polytechnique de Montreal.
+*
+*Author(s): 
+* D. Sekki
+*
+*Parameters: input
+* IPMTX   pointer to matex information.
+* IPMAC   pointer to create mode macrolib.
+* IPMAC2  pointer to read-only mode macrolib.
+* IPDEV   pointer to device information.
+* NMIX    maximum number of material mixtures.
+* NGRP    number of energy groups.
+* NL      number of legendre orders (=1 for isotropic scattering).
+* NDEL    number of precursor groups for delayed neutron.
+* LEAK    diffusion coefficient flag (=1: isotropic; =2: anisotropic).
+* NEL     total number of elements.
+* LX      number of elements along x-axis.
+* LY      number of elements along y-axis.
+* LZ      number of elements along z-axis.
+* XFAC    corrective factor for delta sigmas.
+* IMPX    printing index (=0 for no print).
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPMTX,IPMAC,IPMAC2,IPDEV
+      INTEGER NMIX,NGRP,NL,NDEL,LEAK,NEL,LX,LY,LZ
+      REAL XFAC
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER(NSTATE=40,IOUT=6,EPSI=1.0E-4,MAXPRT=10)
+      INTEGER INDX(NEL),ISTATE(NSTATE),DMIX(2,MAXPRT),INAME(3)
+      REAL MESHX(LX+1),MESHY(LY+1),MESHZ(LZ+1),DPOS(6,MAXPRT),LEVEL
+      CHARACTER RNAME*12
+      TYPE(C_PTR) JPDEV,KPDEV
+*----
+* ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ
+      REAL, ALLOCATABLE, DIMENSION(:) :: TOT0,TOT1,ZNUS,CHI,SIGF,DIFX,
+     1 DIFY,DIFZ,HFAC,SCAT
+*----
+* SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(IJJ(NMIX*NGRP*NL),NJJ(NMIX*NGRP*NL),TOT0(NMIX*NGRP),
+     1 TOT1(NMIX*NGRP),ZNUS(NMIX*NGRP*(NDEL+1)),CHI(NMIX*NGRP*(NDEL+1)),
+     2 SIGF(NMIX*NGRP),DIFX(NMIX*NGRP),DIFY(NMIX*NGRP),DIFZ(NMIX*NGRP),
+     3 HFAC(NMIX*NGRP),SCAT(NMIX*NL*NGRP*NGRP))
+*----
+*  RECOVER EXISTING PROPERTIES
+*----
+      CALL NEWMGT(IPMAC2,NMIX,NGRP,NL,NDEL,LEAK,TOT0,TOT1,ZNUS,CHI,SIGF,
+     1 DIFX,DIFY,DIFZ,HFAC,IJJ,NJJ,SCAT)
+*----
+*  RECOVER MATEX INFORMATION
+*----
+      MESHX(:LX+1)=0.0
+      MESHY(:LY+1)=0.0
+      MESHZ(:LZ+1)=0.0
+      CALL LCMGET(IPMTX,'MESHX',MESHX)
+      CALL LCMGET(IPMTX,'MESHY',MESHY)
+      CALL LCMGET(IPMTX,'MESHZ',MESHZ)
+      INDX(:NEL)=0
+      CALL LCMGET(IPMTX,'INDEX',INDX)
+      CALL LCMGET(IPDEV,'STATE-VECTOR',ISTATE)
+      IF(ISTATE(2).EQ.0)GOTO 30
+*----
+*  UPDATE ROD PROPERTIES
+*----
+      ITOT=0
+      NROD=ISTATE(2)
+      JPDEV=LCMGID(IPDEV,'DEV_ROD')
+      IF(IMPX.GT.0)WRITE(IOUT,1000)
+      DO 20 ID=1,NROD
+      KPDEV=LCMGIL(JPDEV,ID)
+      IF(IMPX.GT.5)CALL LCMLIB(KPDEV)
+      CALL LCMGET(KPDEV,'LEVEL',LEVEL)
+      IF(LEVEL.LT.EPSI)GOTO 20
+      CALL LCMGET(KPDEV,'ROD-NAME',INAME)
+      WRITE(RNAME,'(3A4)') (INAME(I),I=1,3)
+      CALL LCMGET(KPDEV,'ROD-PARTS',NPART)
+      IF(NPART.GT.MAXPRT) CALL XABORT('NEWMDV: MAXPRT OVERFLOW.')
+      CALL LCMGET(KPDEV,'ROD-POS',DPOS)
+      CALL LCMGET(KPDEV,'ROD-MIX',DMIX)
+      DO 10 IPART=1,NPART
+      IF(IMPX.GT.2)WRITE(IOUT,1001)ID,IPART,RNAME,LEVEL,DPOS(1,IPART)
+      CALL NEWMVF(INDX,DPOS(1,IPART),DMIX(1,IPART),NGRP,NL,NDEL,LEAK,
+     1 NEL,NMIX,LX,LY,LZ,MESHX,MESHY,MESHZ,TOT0,TOT1,ZNUS,CHI,SIGF,DIFX,
+     2 DIFY,DIFZ,HFAC,SCAT,XFAC,IMPX)
+      IF(IMPX.GT.2)WRITE(IOUT,1002)
+   10 CONTINUE
+      ITOT=ITOT+1
+   20 CONTINUE
+      IF(IMPX.GT.0)WRITE(IOUT,1003)ITOT
+   30 IF(ISTATE(4).EQ.0)GOTO 50
+*----
+*  UPDATE LZC PROPERTIES
+*----
+      ITOT=0
+      NLZC=ISTATE(4)
+      JPDEV=LCMGID(IPDEV,'DEV_LZC')
+      IF(IMPX.GT.0)WRITE(IOUT,1004)
+      DO 40 ID=1,NLZC
+      KPDEV=LCMGIL(JPDEV,ID)
+      IF(IMPX.GT.2)WRITE(IOUT,1005)ID
+      IF(IMPX.GT.5)CALL LCMLIB(KPDEV)
+*     EMPTY-PART
+      CALL LCMGET(KPDEV,'EMPTY-POS',DPOS)
+      CALL LCMGET(KPDEV,'EMPTY-MIX',DMIX)
+      IF(IMPX.GT.2)WRITE(IOUT,1006)DPOS
+      CALL NEWMVF(INDX,DPOS(1,1),DMIX(1,1),NGRP,NL,NDEL,LEAK,NEL,NMIX,
+     1 LX,LY,LZ,MESHX,MESHY,MESHZ,TOT0,TOT1,ZNUS,CHI,SIGF,DIFX,DIFY,
+     2 DIFZ,HFAC,SCAT,XFAC,IMPX)
+*     FULL-PART
+      CALL LCMGET(KPDEV,'FULL-POS',DPOS)
+      CALL LCMGET(KPDEV,'FULL-MIX',DMIX)
+      IF(IMPX.GT.2)WRITE(IOUT,1007)DPOS
+      CALL NEWMVF(INDX,DPOS(1,1),DMIX(1,1),NGRP,NL,NDEL,LEAK,NEL,NMIX,
+     1 LX,LY,LZ,MESHX,MESHY,MESHZ,TOT0,TOT1,ZNUS,CHI,SIGF,DIFX,DIFY,
+     2 DIFZ,HFAC,SCAT,XFAC,IMPX)
+      IF(IMPX.GT.2)WRITE(IOUT,1002)
+      ITOT=ITOT+1
+   40 CONTINUE
+      IF(IMPX.GT.0)WRITE(IOUT,1008)ITOT
+*----
+*  STORE NEW PROPERTIES
+*----
+   50 CALL NEWMPT(IPMAC,NMIX,NGRP,NL,NDEL,LEAK,TOT0,TOT1,ZNUS,CHI,SIGF,
+     1 DIFX,DIFY,DIFZ,HFAC,IJJ,NJJ,SCAT)
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(NJJ,IJJ,SCAT,HFAC,DIFZ,DIFY,DIFX,SIGF,CHI,ZNUS,TOT1,
+     1 TOT0)
+      RETURN
+*
+ 1000 FORMAT(/1X,'**',1X,'UPDATING PROPERTIES',
+     1  1X,'FOR ALL INSERTED RODS',1X,'**'/)
+ 1001 FORMAT(
+     1 /5X,'=>',2X,'ROD-ID #',I3.3,' PART:',I4,5X,'ROD-NAME:',1X,A
+     2 /1X,'ROD INSERTION LEVEL =',F8.4
+     3 /1X,'CURRENT ROD POSITION :'
+     4 /1X,'X-',F10.4,5X,'Y-',F10.4,5X,'Z-',F10.4
+     5 /1X,'X+',F10.4,5X,'Y+',F10.4,5X,'Z+',F10.4)
+ 1002 FORMAT(/1X,38('-')/)
+ 1003 FORMAT(/1X,'TOTAL NUMBER OF TREATED RODS:',I3/)
+*
+ 1004 FORMAT(/1X,'**',1X,'UPDATING PROPERTIES',
+     1  1X,'FOR ALL LZC-DEVICES',1X,'**'/)
+ 1005 FORMAT(/5X,'=>',2X,'LZC-ID #',I2.2)
+ 1006 FORMAT(/1X,'EMPTY-PART POSITION :'
+     1 /1X,'X-',F10.4,5X,'Y-',F10.4,5X,'Z-',F10.4
+     2 /1X,'X+',F10.4,5X,'Y+',F10.4,5X,'Z+',F10.4)
+ 1007 FORMAT(/1X,'FULL-PART POSITION :'
+     1 /1X,'X-',F10.4,5X,'Y-',F10.4,5X,'Z-',F10.4
+     2 /1X,'X+',F10.4,5X,'Y+',F10.4,5X,'Z+',F10.4)
+ 1008 FORMAT(/1X,'TOTAL NUMBER OF TREATED LZC:',I2/)
+      END