*DECK MACWXS SUBROUTINE MACWXS(IPLIST,IPRINT,NGROUP,NBMIX,NIFISS,NANISO,ICTRA, > NEDMAC) * *----------------------------------------------------------------------- * *Purpose: * Print/check cross section information if required. * *Copyright: * Copyright (C) 2002 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 * IPLIST LCM pointer to the macrolib. * IPRINT print level. * NGROUP number of energy groups. * NBMIX number of mixtures. * NIFISS number of fissile isotopes. * NANISO maximum Legendre order: * =1 isotropic collision; * =2 linearly anisotropic collision. * ICTRA type of transport correction. * NEDMAC number of macro edit cross sections. * *----------------------------------------------------------------------- * USE GANLIB *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPLIST INTEGER IPRINT,NGROUP,NBMIX,NIFISS,NANISO,ICTRA,NEDMAC *---- * LOCAL VARIABLES *---- TYPE(C_PTR) JPLIST,KPLIST CHARACTER CANISO*2,NAMREC*12,CEDNAM*12,NAMRE1*12,NAMRE2*12 PARAMETER (IUNOUT=6,ILCMUP=1,ILCMDN=2,IOUT=6) *---- * ALLOCATABLE ARRAYS *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: INGSCT,IFGSCT,IPOSCT INTEGER, ALLOCATABLE, DIMENSION(:,:) :: CADNAM REAL, ALLOCATABLE, DIMENSION(:) :: XSWORK,XSWOR2,TCOR REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCWORK *---- * SCRATCH STORAGE ALLOCATION * INGSCT number of scattering group for cross sections. * IFGSCT first scattering group for cross sections. * IPOSCT mixture location in cross section matrix. * TCOR transport correction. * CADNAM additional cross section names. *---- ALLOCATE(INGSCT(NBMIX),IFGSCT(NBMIX),IPOSCT(NBMIX), > CADNAM(2,NEDMAC+1)) ALLOCATE(XSWORK(NBMIX*(2+NGROUP)),XSWOR2(NBMIX*NIFISS), > SCWORK(NBMIX,NANISO,NGROUP),TCOR(NBMIX)) * IF(IPRINT.GT.1) WRITE(IUNOUT,6000) SCWORK(:NBMIX,:NANISO,:NGROUP)=0.0 IF(NEDMAC.GT.0) CALL LCMGET(IPLIST,'ADDXSNAME-P0',CADNAM) JPLIST=LCMGID(IPLIST,'GROUP') DO 100 IGR=1,NGROUP KPLIST=LCMGIL(JPLIST,IGR) IF(ICTRA.EQ.0) THEN TCOR(:NBMIX)=0.0 ELSE CALL LCMGET(KPLIST,'TRANC',TCOR) ENDIF *---- * PRINT TOTAL X-S AND FIXE SOURCES INFORMATION *---- IF(IPRINT.GT.1) THEN IF(NBMIX.LE.7) THEN WRITE(IUNOUT,6001) IGR,(II,II=1,NBMIX) ELSE WRITE(IUNOUT,6001) IGR,(II,II=1,7) WRITE(IUNOUT,6011) (II,II=8,NBMIX) ENDIF CALL LCMGET(KPLIST,'NTOT0',XSWORK) IF(NBMIX.LE.7) THEN WRITE(IUNOUT,6002) 'NTOT0 ', > (XSWORK(II)-TCOR(II),II=1,NBMIX) ELSE WRITE(IUNOUT,6002) 'NTOT0 ', > (XSWORK(II)-TCOR(II),II=1,7) WRITE(IUNOUT,6010) (XSWORK(II)-TCOR(II),II=8,NBMIX) ENDIF CALL LCMLEN(KPLIST,'NTOT1',ILCMLN,ITYLCM) IF(ILCMLN.GT.0) THEN CALL LCMGET(KPLIST,'NTOT1',XSWORK) IF(NBMIX.LE.7) THEN WRITE(IUNOUT,6002) 'NTOT1 ',(XSWORK(II),II=1,NBMIX) ELSE WRITE(IUNOUT,6002) 'NTOT1 ',(XSWORK(II),II=1,7) WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) ENDIF ENDIF CALL LCMLEN(KPLIST,'FIXE',ILCMLN,ITYLCM) IF(ILCMLN.GT.0) THEN CALL LCMGET(KPLIST,'FIXE',XSWORK) IF(NBMIX.LE.7) THEN WRITE(IUNOUT,6002) 'FIXE ',(XSWORK(II),II=1,NBMIX) ELSE WRITE(IUNOUT,6002) 'FIXE ',(XSWORK(II),II=1,7) WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) ENDIF ENDIF CALL LCMLEN(KPLIST,'TRANC',ILCMLN,ITYLCM) IF(ILCMLN.GT.0) THEN CALL LCMGET(KPLIST,'TRANC',XSWORK) IF(NBMIX.LE.7) THEN WRITE(IUNOUT,6002) 'TRANC ',(XSWORK(II),II=1,NBMIX) ELSE WRITE(IUNOUT,6002) 'TRANC ',(XSWORK(II),II=1,7) WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) ENDIF ENDIF CALL LCMLEN(KPLIST,'DIFF',ILCMLN,ITYLCM) IF(ILCMLN.GT.0) THEN CALL LCMGET(KPLIST,'DIFF',XSWORK) IF(NBMIX.LE.7) THEN WRITE(IUNOUT,6002) 'DIFF ',(XSWORK(II),II=1,NBMIX) ELSE WRITE(IUNOUT,6002) 'DIFF ',(XSWORK(II),II=1,7) WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) ENDIF ENDIF CALL LCMLEN(KPLIST,'H-FACTOR',ILCMLN,ITYLCM) IF(ILCMLN.GT.0) THEN CALL LCMGET(KPLIST,'H-FACTOR',XSWORK) IF(NBMIX.LE.7) THEN WRITE(IUNOUT,6002) 'H-FACTOR ',(XSWORK(II),II=1,NBMIX) ELSE WRITE(IUNOUT,6002) 'H-FACTOR ',(XSWORK(II),II=1,7) WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) ENDIF ENDIF CALL LCMLEN(KPLIST,'FLUX-INTG',ILCMLN,ITYLCM) IF(ILCMLN.GT.0) THEN CALL LCMGET(KPLIST,'FLUX-INTG',XSWORK) IF(NBMIX.LE.7) THEN WRITE(IUNOUT,6002) 'FLUX-INTG ',(XSWORK(II),II=1,NBMIX) ELSE WRITE(IUNOUT,6002) 'FLUX-INTG ',(XSWORK(II),II=1,7) WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) ENDIF ENDIF CALL LCMLEN(KPLIST,'FLUX-INTG-P1',ILCMLN,ITYLCM) IF(ILCMLN.GT.0) THEN CALL LCMGET(KPLIST,'FLUX-INTG-P1',XSWORK) IF(NBMIX.LE.7) THEN WRITE(IUNOUT,6002) 'FLUX-INTG-P1',(XSWORK(II),II=1,NBMIX) ELSE WRITE(IUNOUT,6002) 'FLUX-INTG-P1',(XSWORK(II),II=1,7) WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) ENDIF ENDIF ENDIF *---- * PRINT FISSION INFORMATION *---- IF(IPRINT.GT.1) THEN CALL LCMLEN(KPLIST,'NUSIGF',ILCMLN,ITYLCM) IF(ILCMLN.GT.0) THEN CALL LCMGET(KPLIST,'NUSIGF',XSWOR2) DO 110 IFISS=1,NIFISS IOF=(IFISS-1)*NBMIX WRITE(IUNOUT,6003) IFISS IF(NBMIX.LE.7) THEN WRITE(IUNOUT,6002) 'NUSIGF',(XSWOR2(IOF+II),II=1,NBMIX) ELSE WRITE(IUNOUT,6002) 'NUSIGF',(XSWOR2(IOF+II),II=1,7) WRITE(IUNOUT,6010) (XSWOR2(IOF+II),II=8,NBMIX) ENDIF 110 CONTINUE ENDIF * CALL LCMLEN(KPLIST,'CHI',ILCMLN,ITYLCM) IF(ILCMLN.GT.0) THEN CALL LCMGET(KPLIST,'CHI',XSWOR2) DO 115 IFISS=1,NIFISS IOF=(IFISS-1)*NBMIX WRITE(IUNOUT,6003) IFISS IF(NBMIX.LE.7) THEN WRITE(IUNOUT,6002) 'CHI',(XSWOR2(IOF+II),II=1,NBMIX) ELSE WRITE(IUNOUT,6002) 'CHI',(XSWOR2(IOF+II),II=1,7) WRITE(IUNOUT,6010) (XSWOR2(IOF+II),II=8,NBMIX) ENDIF 115 CONTINUE ENDIF * CALL LCMLEN(KPLIST,'NFTOT',ILCMLN,ITYLCM) IF(ILCMLN.GT.0) THEN CALL LCMGET(KPLIST,'NFTOT',XSWORK) IF(NBMIX.LE.7) THEN WRITE(IUNOUT,6002) 'NFTOT ',(XSWORK(II),II=1,NBMIX) ELSE WRITE(IUNOUT,6002) 'NFTOT ',(XSWORK(II),II=1,7) WRITE(IUNOUT,6010) (XSWORK(II),II=8,NBMIX) ENDIF ENDIF ENDIF *---- * PRINT SCATTERING MATRICES INFORMATION *---- MAXMXR=0 IF(ICTRA.NE.0) THEN NNANIS=1 ELSE NNANIS=NANISO ENDIF DO 120 IANIS=1,NNANIS WRITE(CANISO,'(I2.2)') IANIS-1 CALL LCMLEN(KPLIST,'NJJS'//CANISO,ILCMLN,ITYLCM) IF(ILCMLN.EQ.0) GO TO 120 IF(ILCMLN.LT.NBMIX) THEN MAXMXR=ILCMLN ELSE IF(ILCMLN.GT.NBMIX) THEN CALL XABORT('MACWXS: NUMBER OF MIXTURES ON LCM IS LARGER'// > ' THAN THE MAXIMUM PROVIDED ON NMIX CARD') ELSE MAXMXR=NBMIX ENDIF NAMREC='SIGW'//CANISO NAMRE1='SIGS'//CANISO NAMRE2='SCAT'//CANISO CALL LCMGET(KPLIST,'NJJS'//CANISO,INGSCT) CALL LCMGET(KPLIST,'IJJS'//CANISO,IFGSCT) CALL LCMGET(KPLIST,'IPOS'//CANISO,IPOSCT) CALL LCMGET(KPLIST,NAMREC,XSWORK) CALL LCMLEN(KPLIST,NAMRE1,ILCMLN,ITYLCM) IF(ILCMLN.GT.0) CALL LCMGET(KPLIST,NAMRE1,XSWORK(NBMIX+1)) CALL LCMGET(KPLIST,NAMRE2,XSWORK(2*NBMIX+1)) IF(IPRINT.GT.1) THEN IF(NBMIX.LE.7) THEN WRITE(IUNOUT,6002) NAMREC, > (XSWORK(II)-TCOR(II),II=1,MAXMXR) IF(ILCMLN.GT.0) THEN WRITE(IUNOUT,6002) NAMRE1, > (XSWORK(NBMIX+II)-TCOR(II),II=1,MAXMXR) ENDIF ELSE WRITE(IUNOUT,6002) NAMREC, > (XSWORK(II)-TCOR(II),II=1,7) WRITE(IUNOUT,6010) (XSWORK(II)-TCOR(II),II=8,MAXMXR) IF(ILCMLN.GT.0) THEN WRITE(IUNOUT,6002) NAMRE1, > (XSWORK(NBMIX+II)-TCOR(II),II=1,7) WRITE(IUNOUT,6010) (XSWORK(NBMIX+II)-TCOR(II),II=8, > MAXMXR) ENDIF ENDIF ENDIF IF(IPRINT.GT.2) THEN IF=2*NBMIX+1 IS=2*NBMIX+INGSCT(1) IDG=IFGSCT(1) IFG=IDG-INGSCT(1)+1 IDIAG=IS+IFG-IGR XSWORK(IDIAG)=XSWORK(IDIAG)-TCOR(1) IF(INGSCT(1).GT.0) THEN IF(IS-IF+1.LE.4) THEN WRITE(IUNOUT,6004) NAMRE2,1,IFG,IDG, > (XSWORK(J),J=IS,IF,-1) ELSE WRITE(IUNOUT,6004) NAMRE2,1,IFG,IDG, > (XSWORK(J),J=IS,IS-3,-1) WRITE(IUNOUT,6010)(XSWORK(J),J=IS-4,IF,-1) ENDIF ENDIF DO 130 IMAT=2,MAXMXR IF=IS+1 IS=IS+INGSCT(IMAT) IDG=IFGSCT(IMAT) IFG=IDG-INGSCT(IMAT)+1 IDIAG=IS+IFG-IGR XSWORK(IDIAG)=XSWORK(IDIAG)-TCOR(IMAT) IF(INGSCT(IMAT).GT.0) THEN IF(IS-IF+1.LE.4) THEN WRITE(IUNOUT,6005) IMAT,IFG,IDG, > (XSWORK(J),J=IS,IF,-1) ELSE WRITE(IUNOUT,6005) IMAT,IFG,IDG, > (XSWORK(J),J=IS,IS-3,-1) WRITE(IUNOUT,6010)(XSWORK(J),J=IS-4,IF,-1) ENDIF ENDIF 130 CONTINUE ENDIF IF((IPRINT.GT.4).OR.(IPRINT.LT.0)) THEN *---- * VALIDATION OF SCATTERING INFORMATION *---- IPO=0 DO 90 IMAT=1,NBMIX IDG=IFGSCT(IMAT) IFG=IDG-INGSCT(IMAT)+1 IF(IPOSCT(IMAT).NE.IPO+1) THEN WRITE(IUNOUT,6006) 'IPOS'//CANISO,IGR,IMAT ENDIF XS=XSWORK(IMAT) IF(XS.GT.0.0) THEN ERR=ABS((XS-XSWORK(2*NBMIX+IPO+1+IDG-IGR))/XS) IF(ERR.GT.1.0E-5) THEN WRITE(IUNOUT,6006) 'SIGW'//CANISO,IGR,IMAT WRITE(IUNOUT,'(7H ERROR=,1P,E15.5)') ERR ENDIF ENDIF DO 80 JGR=IDG,IFG,-1 IPO=IPO+1 SCWORK(IMAT,IANIS,JGR)=SCWORK(IMAT,IANIS,JGR) > +XSWORK(2*NBMIX+IPO) 80 CONTINUE 90 CONTINUE ENDIF 120 CONTINUE IF(IPRINT.GE.4) THEN *---- * PRINT ADDITIONAL XS INFORMATION IF REQUIRED *---- DO 200 IED=1,NEDMAC WRITE(CEDNAM,'(2A4)') CADNAM(1,IED),CADNAM(2,IED) CALL LCMLEN(KPLIST,CEDNAM,ILCMLN,ILCMTY) IF(ILCMLN .GT. 0) THEN CALL LCMGET(KPLIST,CEDNAM,XSWORK) IF(NBMIX .LE. 6) THEN WRITE(IOUT,6007) CEDNAM,(XSWORK(ITC),ITC=1,NBMIX) ELSE WRITE(IOUT,6007) CEDNAM,(XSWORK(ITC),ITC=1,6) WRITE(IOUT,6010) (XSWORK(ITC),ITC=7,NBMIX) ENDIF ENDIF 200 CONTINUE ENDIF 100 CONTINUE IF((IPRINT.GT.4).OR.(IPRINT.LT.0)) THEN DO 160 IGR=1,NGROUP KPLIST=LCMGIL(JPLIST,IGR) DO 150 IANIS=1,NANISO WRITE(CANISO,'(I2.2)') IANIS-1 CALL LCMLEN(KPLIST,'SIGS'//CANISO,ILCMLN,ITYLCM) IF(ILCMLN.GT.0) THEN CALL LCMGET(KPLIST,'SIGS'//CANISO,XSWORK) DO 140 IMAT=1,NBMIX XS=XSWORK(IMAT) IF(XS.GT.0.0) THEN ERR=ABS((SCWORK(IMAT,IANIS,IGR)-XS)/XS) IF(ERR.GT.1.0E-4) THEN WRITE(IUNOUT,6006) 'SIGS'//CANISO,IGR,IMAT WRITE(IUNOUT,'(7H ERROR=,1P,E15.5)') ERR ENDIF ENDIF 140 CONTINUE ENDIF 150 CONTINUE 160 CONTINUE ENDIF *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(TCOR,SCWORK,XSWOR2,XSWORK) DEALLOCATE(CADNAM,IPOSCT,IFGSCT,INGSCT) RETURN *---- * FORMAT *---- 6000 FORMAT(//' EDITION OF X-S STORED ON LCM.'/1X,29(1H-)) 6001 FORMAT(/' G R O U P : ',I5/' MIXTURE',I8,6I16) 6002 FORMAT(1X,A12,1P,7E16.8) 6003 FORMAT(/14X,'FISSIONABLE ISOTOPE POSITION:',I5) 6004 FORMAT(1X,A12,1X,'MIXTURE:',I5,3X,'FROM GROUPS:',I5,' TO ',I5,5X, >1P,4E16.8) 6005 FORMAT(14X,'MIXTURE:',I5,3X,'FROM GROUPS:',I5,' TO ',I5,5X, >1P,4E16.8) 6006 FORMAT(/39H MACWXS: INCONSISTENT VALUE OF RECORD ',A12,7H' IN GR, >3HOUP,I4,12H AND MIXTURE,I6,1H.) 6007 FORMAT(1X,'ADDITIONAL XS : ',A12,1P,6E16.8) 6010 FORMAT(1P,(13X,7E16.8)) 6011 FORMAT(7I16) END