*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