*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