diff options
Diffstat (limited to 'Dragon/src/MACNXS.f')
| -rw-r--r-- | Dragon/src/MACNXS.f | 141 |
1 files changed, 141 insertions, 0 deletions
diff --git a/Dragon/src/MACNXS.f b/Dragon/src/MACNXS.f new file mode 100644 index 0000000..255e884 --- /dev/null +++ b/Dragon/src/MACNXS.f @@ -0,0 +1,141 @@ +*DECK MACNXS + SUBROUTINE MACNXS(IPLIST,MAXFIS,NGROUP,NBMIX,NIFISS,NANISO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Normalization of macroscopic cross section information. +* +*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. +* MAXFIS set to max(1,NIFISS). +* 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. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER MAXFIS,NGROUP,NBMIX,NIFISS,NANISO +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPLIST,KPLIST + CHARACTER CANISO*2 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INGSCT,IFGSCT + REAL, ALLOCATABLE, DIMENSION(:) :: XSWORK,XSWOR2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: CHWORK + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: SCWORK +*---- +* SCRATCH STORAGE ALLOCATION +* INGSCT number of scattering group for cross sections. +* IFGSCT first scattering group for cross sections. +*---- + ALLOCATE(INGSCT(NBMIX),IFGSCT(NBMIX)) + ALLOCATE(XSWORK(NBMIX*NGROUP),XSWOR2(NBMIX*NIFISS), + > CHWORK(NBMIX,MAXFIS)) + ALLOCATE(SCWORK(NBMIX,NANISO,NGROUP)) +* + DO 100 IMIX=1,NBMIX + DO 110 IAN=1,NANISO + DO 120 IG=1,NGROUP + SCWORK(IMIX,IAN,IG)=0.0D0 + 120 CONTINUE + 110 CONTINUE + DO 130 JFIS=1,NIFISS + CHWORK(IMIX,JFIS)=0.0 + 130 CONTINUE + 100 CONTINUE + JPLIST=LCMGID(IPLIST,'GROUP') + DO 140 IGR=1,NGROUP + KPLIST=LCMGIL(JPLIST,IGR) +*---- +* COMPUTE SUM OF FISSION SPECTRUM. +*---- + CALL LCMLEN(KPLIST,'CHI',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'CHI',XSWOR2) + DO 150 IFISS=1,NIFISS + DO 160 IMAT=1,NBMIX + CHWORK(IMAT,IFISS)=CHWORK(IMAT,IFISS) + > +XSWOR2((IFISS-1)*NBMIX+IMAT) + 160 CONTINUE + 150 CONTINUE + ENDIF +*---- +* SUM TRANSFER MATRICES OVER SECONDARY GROUPS. +*---- + DO 170 IANIS=1,NANISO + WRITE(CANISO,'(I2.2)') IANIS-1 + CALL LCMLEN(KPLIST,'NJJS'//CANISO,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'NJJS'//CANISO,INGSCT) + CALL LCMGET(KPLIST,'IJJS'//CANISO,IFGSCT) + CALL LCMGET(KPLIST,'SCAT'//CANISO,XSWORK) + IPO=0 + DO 180 IMAT=1,NBMIX + IDG=IFGSCT(IMAT) + IFG=IDG-INGSCT(IMAT)+1 + DO 190 JGR=IDG,IFG,-1 + IPO=IPO+1 + SCWORK(IMAT,IANIS,JGR)=SCWORK(IMAT,IANIS,JGR) + > +XSWORK(IPO) + 190 CONTINUE + 180 CONTINUE + ENDIF + 170 CONTINUE + 140 CONTINUE +*---- +* WRITE NORMALIZED X-S ON THE MACROLIB. +*---- + DO 200 IGR=1,NGROUP + KPLIST=LCMGIL(JPLIST,IGR) + CALL LCMLEN(KPLIST,'CHI',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + CALL LCMGET(KPLIST,'CHI',XSWOR2) + DO 210 IFISS=1,NIFISS + DO 220 IMAT=1,NBMIX + IF(CHWORK(IMAT,IFISS).GT.0.5) XSWOR2((IFISS-1)*NBMIX+IMAT) + > =XSWOR2((IFISS-1)*NBMIX+IMAT)/CHWORK(IMAT,IFISS) + 220 CONTINUE + 210 CONTINUE + CALL LCMPUT(KPLIST,'CHI',NBMIX*NIFISS,2,XSWOR2) + ENDIF + DO 230 IANIS=1,NANISO + WRITE(CANISO,'(I2.2)') IANIS-1 + CALL LCMLEN(KPLIST,'SIGS'//CANISO,ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + DO 240 IMAT=1,NBMIX + XSWORK(IMAT)=REAL(SCWORK(IMAT,IANIS,IGR)) + 240 CONTINUE + CALL LCMPUT(KPLIST,'SIGS'//CANISO,NBMIX,2,XSWORK) + ENDIF + 230 CONTINUE + 200 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SCWORK) + DEALLOCATE(CHWORK,XSWOR2,XSWORK) + DEALLOCATE(IFGSCT,INGSCT) + RETURN + END |