diff options
Diffstat (limited to 'Trivac/src/MACXSI.f')
| -rwxr-xr-x | Trivac/src/MACXSI.f | 354 |
1 files changed, 354 insertions, 0 deletions
diff --git a/Trivac/src/MACXSI.f b/Trivac/src/MACXSI.f new file mode 100755 index 0000000..6cfac6a --- /dev/null +++ b/Trivac/src/MACXSI.f @@ -0,0 +1,354 @@ +*DECK MACXSI + SUBROUTINE MACXSI (IPLIST,IND,NMIXT,NGRP,NDG,NL,IMPX,NBMIX,JND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Input macroscopic cross sections in Trivac. +* +*Copyright: +* Copyright (C) 2007 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): A. Hebert +* +*Parameters: input +* IPLIST LCM pointer to the macrolib. +* IND =1: the macrolib is created; +* =2: an existing macrolib is modified. +* NMIXT maximum number of material mixtures. +* NGRP number of energy groups. +* NDG number of delayed precursor groups. +* NL number of Legendre orders (=1 for isotropic scattering). +* IMPX print level. +* +*Parameters: output +* NBMIX number of mixtures. +* JND REDGET flag (=1 ';' encountered; =2 'STEP' encountered). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER IND,NMIXT,NGRP,NDG,NL,IMPX,NBMIX,JND +*---- +* LOCAL VARIABLES +*---- + LOGICAL LTO,LT1,LFI,LCH,LOV,LD,LDX,LDY,LDZ,LHF,LSC,LSO,LDI,LBI + DOUBLE PRECISION DFLOTT + CHARACTER CM*2,TEXT4*4,TEXT8*8,TEXT*8 + TYPE(C_PTR) JPLIST,KPLIST + REAL, DIMENSION(:), ALLOCATABLE :: WORK + REAL, DIMENSION(:,:), ALLOCATABLE :: TOTAL,TOTA1,ZNUG,CHI,OVERV, + 1 DIFFX,DIFFY,DIFFZ,H,S + REAL, DIMENSION(:,:,:), ALLOCATABLE :: NUSDL,CHDL + REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: SCAT + INTEGER, DIMENSION(:), ALLOCATABLE :: IPOS + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: IJJ,NJJ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(TOTAL(NMIXT,NGRP),TOTA1(NMIXT,NGRP),ZNUG(NMIXT,NGRP), + 1 CHI(NMIXT,NGRP),NUSDL(NMIXT,NDG,NGRP),CHDL(NMIXT,NDG,NGRP), + 2 OVERV(NMIXT,NGRP),DIFFX(NMIXT,NGRP),DIFFY(NMIXT,NGRP), + 3 DIFFZ(NMIXT,NGRP),H(NMIXT,NGRP),S(NMIXT,NGRP), + 4 SCAT(NMIXT,NL,NGRP,NGRP),WORK(NMIXT*NGRP)) + ALLOCATE(IJJ(NMIXT,NL,NGRP),NJJ(NMIXT,NL,NGRP),IPOS(NMIXT)) +* + IF(NMIXT.EQ.0) CALL XABORT('MACXSI: ZERO NUMBER OF MIXTURES.') + IF(NGRP.EQ.0) CALL XABORT('MACXSI: ZERO NUMBER OF GROUPS.') + NBMIX=0 + LTO=.FALSE. + LT1=.FALSE. + LFI=.FALSE. + LCH=.FALSE. + LOV=.FALSE. + LD=.FALSE. + LDX=.FALSE. + LDY=.FALSE. + LDZ=.FALSE. + LHF=.FALSE. + LSC=.FALSE. + LSO=.FALSE. + LDI=.FALSE. + LBI=.FALSE. + DO 13 IGR=1,NGRP + DO 12 IBM=1,NMIXT + TOTAL(IBM,IGR)=0.0 + TOTA1(IBM,IGR)=0.0 + ZNUG(IBM,IGR)=0.0 + CHI(IBM,IGR)=0.0 + DIFFX(IBM,IGR)=0.0 + DIFFY(IBM,IGR)=0.0 + DIFFZ(IBM,IGR)=0.0 + H(IBM,IGR)=0.0 + S(IBM,IGR)=0.0 + DO 11 IL=1,NL + IJJ(IBM,IL,IGR)=IGR + NJJ(IBM,IL,IGR)=1 + DO 10 JGR=1,NGRP + SCAT(IBM,IL,JGR,IGR)=0.0 + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + 13 CONTINUE + IF(IND.EQ.2) THEN +* RECOVER THE EXISTING MACROLIB DATA. + JPLIST=LCMLID(IPLIST,'GROUP',NGRP) + DO 40 JGR=1,NGRP + KPLIST=LCMDIL(JPLIST,JGR) + CALL LCMLEN(KPLIST,'NTOT0',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) THEN + CALL LCMGET(KPLIST,'NTOT0',TOTAL(1,JGR)) + ELSE IF(ILENGT.NE.0) THEN + CALL XABORT('MACXSI: INVALID INPUT MACROLIB(1).') + ENDIF + CALL LCMLEN(KPLIST,'NTOT1',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'NTOT1',TOTA1(1,JGR)) + CALL LCMLEN(KPLIST,'NUSIGF',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'NUSIGF',ZNUG(1,JGR)) + CALL LCMLEN(KPLIST,'CHI',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'CHI',CHI(1,JGR)) + DO 900 I=1,NDG + WRITE(TEXT,'(A6,I2.2)') 'NUSIGF',I + CALL LCMLEN(KPLIST,TEXT,ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,TEXT,NUSDL(1,I,JGR)) + WRITE(TEXT,'(A3,I2.2)') 'CHI',I + CALL LCMLEN(KPLIST,TEXT,ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,TEXT,CHDL(1,I,JGR)) + 900 CONTINUE + CALL LCMLEN(KPLIST,'OVERV',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'OVERV',OVERV(1,JGR)) + CALL LCMLEN(KPLIST,'DIFF',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'DIFF',DIFFX(1,JGR)) + CALL LCMLEN(KPLIST,'DIFFX',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'DIFFX',DIFFX(1,JGR)) + CALL LCMLEN(KPLIST,'DIFFY',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'DIFFY',DIFFY(1,JGR)) + CALL LCMLEN(KPLIST,'DIFFZ',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'DIFFZ',DIFFZ(1,JGR)) + CALL LCMLEN(KPLIST,'H-FACTOR',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'H-FACTOR',H(1,JGR)) + CALL LCMLEN(KPLIST,'FIXE',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'FIXE',S(1,JGR)) + DO 30 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMLEN(KPLIST,'SCAT'//CM,ILENGT,ITYLCM) + IF(ILENGT.GT.NMIXT*NL*NGRP*NGRP) THEN + CALL XABORT('MACXSI: INVALID INPUT MACROLIB(2).') + ELSE IF(ILENGT.GT.0) THEN + CALL LCMGET(KPLIST,'SCAT'//CM,WORK) + CALL LCMGET(KPLIST,'NJJS'//CM,NJJ(1,IL,JGR)) + CALL LCMGET(KPLIST,'IJJS'//CM,IJJ(1,IL,JGR)) + IPOSDE=0 + DO 25 IBM=1,NMIXT + IJJ0=IJJ(IBM,IL,JGR) + DO 20 IGR=IJJ0,IJJ0-NJJ(IBM,IL,JGR)+1,-1 + IPOSDE=IPOSDE+1 + SCAT(IBM,IL,IGR,JGR)=WORK(IPOSDE) + 20 CONTINUE + 25 CONTINUE + ENDIF + 30 CONTINUE + 40 CONTINUE + ENDIF +* + 50 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MACXSI: CHARACTER DATA EXPECTED(1).') + IF(TEXT4.EQ.'MIX') THEN + 60 CALL REDGET(INDIC,IBM,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACXSI: INTEGER DATA EXPECTED.') + IF(IBM.GT.NMIXT) CALL XABORT('MACXSI: INVALID MIX INDEX.') + NBMIX=MAX(NBMIX,IBM) + 70 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MACXSI: CHARACTER DATA EXPECTED.') + IF((TEXT8.EQ.'TOTAL').OR.(TEXT8.EQ.'NTOT0')) THEN + LTO=.TRUE. + DO 80 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,TOTAL(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 80 CONTINUE + ELSE IF(TEXT8.EQ.'NTOT1') THEN + LT1=.TRUE. + DO 85 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,TOTA1(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 85 CONTINUE + ELSE IF(TEXT8.EQ.'NUSIGF') THEN + LFI=.TRUE. + DO 90 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,ZNUG(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 90 CONTINUE + ELSE IF(TEXT8.EQ.'CHI') THEN + LCH=.TRUE. + DO 95 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,CHI(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 95 CONTINUE + ELSE IF(TEXT8.EQ.'NUSIGD') THEN + LDI=.TRUE. + DO 896 I=1,NDG + DO 895 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,NUSDL(IBM,I,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 895 CONTINUE + 896 CONTINUE + ELSE IF(TEXT8.EQ.'CHDL') THEN + LBI=.TRUE. + DO 996 I=1,NDG + DO 995 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,CHDL(IBM,I,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 995 CONTINUE + 996 CONTINUE + ELSE IF(TEXT8.EQ.'OVERV') THEN + LOV=.TRUE. + DO 96 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,OVERV(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + IF(OVERV(IBM,IGR).EQ.0.) CALL XABORT('MACXSI: INVALID VELO' + 1 //'CITY VALUE.') + 96 CONTINUE + ELSE IF(TEXT8.EQ.'DIFF') THEN + LD=.TRUE. + DO 97 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,DIFFX(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 97 CONTINUE + ELSE IF(TEXT8.EQ.'DIFFX') THEN + LDX=.TRUE. + DO 100 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,DIFFX(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 100 CONTINUE + ELSE IF(TEXT8.EQ.'DIFFY') THEN + LDY=.TRUE. + DO 110 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,DIFFY(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 110 CONTINUE + ELSE IF(TEXT8.EQ.'DIFFZ') THEN + LDZ=.TRUE. + DO 120 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,DIFFZ(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 120 CONTINUE + ELSE IF(TEXT8.EQ.'H-FACTOR') THEN + LHF=.TRUE. + DO 130 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,H(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 130 CONTINUE + ELSE IF(TEXT8.EQ.'SCAT') THEN + LSC=.TRUE. + DO 142 IL=1,NL + DO 141 JGR=1,NGRP + CALL REDGET(INDIC,NJJ(IBM,IL,JGR),FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACXSI: INTEGER DATA EXPECTED.') + CALL REDGET(INDIC,IJJ(IBM,IL,JGR),FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACXSI: INTEGER DATA EXPECTED.') + IJJ0=IJJ(IBM,IL,JGR) + DO 140 IGR=IJJ0,IJJ0-NJJ(IBM,IL,JGR)+1,-1 +* SCAT(MIXTURE,LEGENDRE,PRIMARY,SECONDARY) + CALL REDGET(INDIC,NITMA,SCAT(IBM,IL,IGR,JGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE + ELSE IF(TEXT8.EQ.'FIXE') THEN + LSO=.TRUE. + DO 150 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,S(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 150 CONTINUE + ELSE IF(TEXT8.EQ.'MIX') THEN + GO TO 60 + ELSE IF(TEXT8.EQ.';') THEN + JND=1 + GO TO 160 + ELSE IF(TEXT8.EQ.'STEP') THEN + JND=2 + GO TO 160 + ELSE + CALL XABORT('MACXSI: INVALID KEY-WORD(1).') + ENDIF + GO TO 70 + ELSE + CALL XABORT('MACXSI: INVALID KEY-WORD(2).') + ENDIF + GO TO 50 +* + 160 JPLIST=LCMLID(IPLIST,'GROUP',NGRP) + DO 210 JGR=1,NGRP + KPLIST=LCMDIL(JPLIST,JGR) + IF(LTO) CALL LCMPUT(KPLIST,'NTOT0',NMIXT,2,TOTAL(1,JGR)) + IF(LT1) CALL LCMPUT(KPLIST,'NTOT1',NMIXT,2,TOTA1(1,JGR)) + IF(LFI) CALL LCMPUT(KPLIST,'NUSIGF',NMIXT,2,ZNUG(1,JGR)) + IF(LCH) CALL LCMPUT(KPLIST,'CHI',NMIXT,2,CHI(1,JGR)) + IF(LOV) CALL LCMPUT(KPLIST,'OVERV',NMIXT,2,OVERV(1,JGR)) + IF(LD) THEN + CALL LCMPUT(KPLIST,'DIFF',NMIXT,2,DIFFX(1,JGR)) + ELSE + IF(LDX) CALL LCMPUT(KPLIST,'DIFFX',NMIXT,2,DIFFX(1,JGR)) + IF(LDY) CALL LCMPUT(KPLIST,'DIFFY',NMIXT,2,DIFFY(1,JGR)) + IF(LDZ) CALL LCMPUT(KPLIST,'DIFFZ',NMIXT,2,DIFFZ(1,JGR)) + ENDIF + IF(LHF) CALL LCMPUT(KPLIST,'H-FACTOR',NMIXT,2,H(1,JGR)) + IF(LSO) CALL LCMPUT(KPLIST,'FIXE',NMIXT,2,S(1,JGR)) + IF(LDI) THEN + DO 170 I=1,NDG + WRITE(TEXT,'(A6,I2.2)') 'NUSIGF',I + CALL LCMPUT(KPLIST,TEXT,NMIXT,2,NUSDL(1,I,JGR)) + 170 CONTINUE + ENDIF + IF(LBI) THEN + DO 180 I=1,NDG + WRITE(TEXT,'(A3,I2.2)') 'CHI',I + CALL LCMPUT(KPLIST,TEXT,NMIXT,2,CHDL(1,I,JGR)) + 180 CONTINUE + ENDIF + IF(LSC) THEN + DO 200 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + IPOSDE=0 + DO 195 IBM=1,NMIXT + J2=JGR + J1=JGR + DO 185 IGR=1,NGRP + IF(SCAT(IBM,IL,IGR,JGR).NE.0.0) THEN + J2=MAX(J2,IGR) + J1=MIN(J1,IGR) + ENDIF + 185 CONTINUE + NJJ(IBM,IL,JGR)=J2-J1+1 + IJJ(IBM,IL,JGR)=J2 + IPOS(IBM)=IPOSDE+1 + DO 190 IGR=IJJ(IBM,IL,JGR),IJJ(IBM,IL,JGR)-NJJ(IBM,IL,JGR)+1,-1 + IPOSDE=IPOSDE+1 + WORK(IPOSDE)=SCAT(IBM,IL,IGR,JGR) + 190 CONTINUE + 195 CONTINUE + CALL LCMPUT(KPLIST,'SCAT'//CM,IPOSDE,2,WORK) + CALL LCMPUT(KPLIST,'IPOS'//CM,NMIXT,1,IPOS) + CALL LCMPUT(KPLIST,'NJJS'//CM,NMIXT,1,NJJ(1,IL,JGR)) + CALL LCMPUT(KPLIST,'IJJS'//CM,NMIXT,1,IJJ(1,IL,JGR)) + CALL LCMPUT(KPLIST,'SIGW'//CM,NMIXT,2,SCAT(1,IL,JGR,JGR)) + 200 CONTINUE + ENDIF + IF(IMPX.GT.1) CALL LCMLIB(KPLIST) + 210 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(TOTAL,TOTA1,ZNUG,CHI,NUSDL,CHDL,OVERV,DIFFX,DIFFY, + 1 DIFFZ,H,S,SCAT,WORK) + DEALLOCATE(IJJ,NJJ,IPOS) + RETURN + END |