diff options
Diffstat (limited to 'Dragon/src/BIVAF.f')
| -rw-r--r-- | Dragon/src/BIVAF.f | 164 |
1 files changed, 164 insertions, 0 deletions
diff --git a/Dragon/src/BIVAF.f b/Dragon/src/BIVAF.f new file mode 100644 index 0000000..1fdd09c --- /dev/null +++ b/Dragon/src/BIVAF.f @@ -0,0 +1,164 @@ +*DECK BIVAF + SUBROUTINE BIVAF(KPSYS,IPTRK,IFTRAK,IMPX,NGEFF,NGIND,IDIR,NREG, + 1 NUN,MAT,VOL,KEYFLX,FUNKNO,SUNKNO,TITR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solve N-group transport equation for fluxes using the diffusion +* approximation. +* +*Copyright: +* Copyright (C) 2004 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 +* KPSYS pointer to the assembly LCM object (L_PIJ signature). KPSYS is +* an array of directories. +* IPTRK pointer to the tracking (L_TRACK signature). +* IFTRAK not used. +* IMPX print flag (equal to zero for no print). +* NGEFF number of energy groups processed in parallel. +* NGIND energy group indices assign to the NGEFF set. +* IDIR not used. +* NREG total number of regions for which specific values of the +* neutron flux and reactions rates are required. +* NUN total number of unknowns in vectors SUNKNO and FUNKNO. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* KEYFLX position of averaged flux elements in FUNKNO vector. +* SUNKNO input source vector. +* TITR title. +* +*Parameters: input/output +* FUNKNO unknown vector. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER TITR*72 + TYPE(C_PTR) KPSYS(NGEFF),IPTRK + INTEGER NGEFF,NGIND(NGEFF),IFTRAK,IMPX,IDIR,NREG,NUN, + 1 MAT(NREG),KEYFLX(NREG) + REAL VOL(NREG),FUNKNO(NUN,NGEFF),SUNKNO(NUN,NGEFF) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6,NSTATE=40) + INTEGER IPAR(NSTATE) + LOGICAL CYLIND +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MU,KN + REAL, ALLOCATABLE, DIMENSION(:) :: XX,YY,DD,QFR,BFR,SYS,T,TS,RH, + 1 RT,IPERT +*---- +* RECOVER BIVAC SPECIFIC PARAMETERS. +*---- + IF(IMPX.GT.2) WRITE(IUNOUT,'(//8H BIVAF: ,A72)') TITR + IF(IDIR.NE.0) CALL XABORT('BIVAF: EXPECTING IDIR=0') + IF(IFTRAK.NE.0) CALL XABORT('BIVAF: EXPECTING IFTRAK=0') + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + IF(NREG.NE.IPAR(1)) CALL XABORT('BIVAF: INVALID VALUE OF NREG.') + IF(NUN.NE.IPAR(2)) CALL XABORT('BIVAF: INVALID VALUE OF NUN.') + ITYPE=IPAR(6) + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6) + IELEM=IPAR(8) + ICOL=IPAR(9) + ISPLH=IPAR(10) + LL4=IPAR(11) + LX=IPAR(12) + LY=IPAR(13) + NLF=IPAR(14) + ISPN=IPAR(15) + ISCAT=IPAR(16) + IF(NLF.GT.0) CALL XABORT('BIVAF: LIMITED TO DIFFUSION THEORY.') + IF(IDIR.NE.0) CALL XABORT('BIVAF: EXPECTING IDIR=0') + IF(IFTRAK.NE.0) CALL XABORT('BIVAF: EXPECTING IFTRAK=0') +*---- +* RECOVER TRACKING INFORMATION. +*---- + ALLOCATE(XX(LX*LY),YY(LX*LY),DD(LX*LY)) + IF(ITYPE.EQ.8) THEN + CALL LCMGET(IPTRK,'SIDE',SIDE) + ELSE + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'YY',YY) + CALL LCMGET(IPTRK,'DD',DD) + ENDIF + ALLOCATE(MU(LL4)) + CALL LCMGET(IPTRK,'MU',MU) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM) + ALLOCATE(KN(MAXKN),QFR(MAXQF),BFR(MAXQF)) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'QFR',QFR) + CALL LCMGET(IPTRK,'BFR',BFR) + IIMAX=MU(LL4) + ALLOCATE(SYS(IIMAX)) +*---- +* MAIN LOOP OVER ENERGY GROUPS. +*---- + DO 40 II=1,NGEFF + IF(IMPX.GT.1) WRITE(IUNOUT,'(/24H BIVAF: PROCESSING GROUP,I5, + 1 6H WITH ,A,1H.)') NGIND(II),'BIVAC/DIFFUSION' +*---- +* COMPUTE THE NEUTRON FLUX +*---- + CALL LCMGET(KPSYS(II),'IA001001',SYS) + IF((IELEM.LT.0).AND.(ITYPE.NE.8)) THEN + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(T(LC),TS(LC)) + CALL LCMGET(IPTRK,'T',T) + CALL LCMGET(IPTRK,'TS',TS) + CALL LCMSIX(IPTRK,' ',2) + CALL BIVS01(MAXKN,CYLIND,NREG,NUN,LL4,IIMAX,XX,DD,MAT,KN,BFR, + 1 VOL,KEYFLX,MU,SUNKNO(1,II),LC,T,TS,SYS,FUNKNO(1,II)) + DEALLOCATE(TS,T) + ELSE IF((IELEM.GT.0).AND.(ITYPE.NE.8)) THEN + CALL BIVS02(CYLIND,IELEM,ICOL,NREG,NUN,LL4,IIMAX,MAT,KN,BFR, + 1 VOL,MU,SUNKNO(1,II),SYS,FUNKNO(1,II)) + ELSE IF((IELEM.LT.0).AND.(ITYPE.EQ.8)) THEN + CALL LCMSIX(IPTRK,'BIVCOL',1) + ALLOCATE(RH(36),RT(9)) + CALL LCMGET(IPTRK,'RH',RH) + CALL LCMGET(IPTRK,'RT',RT) + CALL LCMSIX(IPTRK,' ',2) + IF(ISPLH.EQ.1) THEN + NELEM=MAXKN/7 + ELSE + NELEM=MAXKN/4 + ENDIF + CALL BIVS03(MAXKN,MAXQF,NREG,NUN,LL4,ISPLH,NELEM,IIMAX,SIDE, + 1 KN,QFR,BFR,VOL,KEYFLX,MU,SUNKNO(1,II),RH,RT,SYS,FUNKNO(1,II)) + DEALLOCATE(RT,RH) + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8).AND.(ICOL.EQ.4)) THEN + CALL BIVS04(MAXKN,MAXQF,NREG,NUN,LL4,ISPLH,IIMAX,SIDE,KN,QFR, + 1 BFR,VOL,KEYFLX,MU,SUNKNO(1,II),SYS,FUNKNO(1,II)) + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8)) THEN + NBLOS=LX/3 + ALLOCATE(IPERT(LX*ISPLH**2)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL BIVS05(IELEM,NBLOS,NUN,LL4,IIMAX,IPERT,KN,BFR,MU, + 1 SUNKNO(1,II),SYS,FUNKNO(1,II)) + DEALLOCATE(IPERT) + ELSE + CALL XABORT('BIVAF: UNKNOWN TYPE OF GEOMETRY.') + ENDIF +*---- +* END OF LOOP OVER ENERGY GROUPS. +*---- + 40 CONTINUE + DEALLOCATE(SYS,BFR,QFR,KN,MU,DD,YY,XX) + RETURN + END |