summaryrefslogtreecommitdiff
path: root/Dragon/src/DOORFV.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/DOORFV.f')
-rw-r--r--Dragon/src/DOORFV.f336
1 files changed, 336 insertions, 0 deletions
diff --git a/Dragon/src/DOORFV.f b/Dragon/src/DOORFV.f
new file mode 100644
index 0000000..eaa1098
--- /dev/null
+++ b/Dragon/src/DOORFV.f
@@ -0,0 +1,336 @@
+*DECK DOORFV
+ SUBROUTINE DOORFV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRP,NMAT,
+ 1 IDIR,NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUNKNO,FUNKNO,
+ 2 IPMACR,IPSOU,REBFLG,FLUXC,EVALRHO)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Calculation of the flux. Vectorial version. Multigroup rebalancing
+* option.
+*
+*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): R. Le Tellier
+*
+*Parameters: input
+* CDOOR name of the geometry/solution operator.
+* IPSYS pointer to the assembly LCM object (L_PIJ signature). IPSYS is
+* a list of directories.
+* NPSYS index array pointing to the IPSYS list component corresponding
+* to each energy group. Set to zero if a group is not to be
+* processed. Usually, NPSYS(I)=I.
+* IPTRK pointer to the tracking (L_TRACK signature).
+* IFTRAK unit of the sequential binary tracking file.
+* IMPX print flag (equal to zero for no print).
+* NGRP number of energy groups.
+* NMAT number of mixtures in the internal library.
+* IDIR directional collision probability flag:
+* =0 for pij or wij;
+* =k for pijk or wijk k=1,2,3.
+* direction of fundamental current for TIBERE with MoC
+* (=0,1,2,3).
+* NREG total number of merged blocks for which specific values
+* of the neutron flux and reactions rates are required.
+* NUN total number of unknowns in vectors SUNKNO and FUNKNO.
+* IPHASE type of flux solution (=1: use a native flux solution door;
+* =2: use collision probabilities).
+* LEXAC type of exponential function calculation (=.false. to compute
+* exponential functions using tables).
+* MAT index-number of the mixture type assigned to each volume.
+* VOL volumes.
+* KEYFLX index of L-th order flux components in unknown vector.
+* TITR title.
+* SUNKNO input source vector. Depending on the solution technique
+* used, sources may oy may not include volumes.
+* FUNKNO unknown vector.
+* IPMACR pointer to the macrolib LCM object.
+* IPSOU pointer to the fixed source LCM object.
+* REBFLG ACA or SCR rebalancing flag.
+* FLUXC flux at the cutoff energy.
+* EVALRHO dominance ratio.
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPSYS,IPTRK,IPMACR,IPSOU
+ CHARACTER CDOOR*12,TITR*72
+ INTEGER NPSYS(NGRP),IFTRAK,IMPX,NGRP,NMAT,IDIR,NREG,NUN,IPHASE,
+ > MAT(NREG),KEYFLX(NREG)
+ REAL VOL(NREG)
+ REAL, TARGET, INTENT(IN) :: SUNKNO(NUN,NGRP)
+ REAL, TARGET, INTENT(INOUT) :: FUNKNO(NUN,NGRP)
+ LOGICAL LEXAC,REBFLG
+ REAL,OPTIONAL :: FLUXC(NREG)
+ REAL,OPTIONAL :: EVALRHO
+*----
+* LOCAL VARIABLES
+*----
+ PARAMETER (IUNOUT=6,NSTATE=40)
+ INTEGER IPAR(NSTATE)
+ LOGICAL LBIHET
+ CHARACTER CNFDIR(0:3)*9
+ TYPE(C_PTR) JPSOU,JPSOU1,JPSOU2
+ SAVE CNFDIR
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: NGIND,NBS,NBS2
+ LOGICAL, ALLOCATABLE, DIMENSION(:) :: INCONV
+ REAL, ALLOCATABLE, DIMENSION(:) :: FGAR
+ REAL, POINTER, DIMENSION(:,:) :: SUNKN,SUNKNO2,FUNKNO2
+ TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: JPSYS,KPSYS,KPSOU1,
+ 1 KPSOU2
+*----
+* DATA STATEMENTS
+*----
+ DATA CNFDIR /'F L U X ','C U R - X','C U R - Y','C U R - Z'/
+*----
+* RECOVER FIXED SOURCES FROM IPSOU LCM OBJECT
+*----
+ ALLOCATE(NBS(NGRP))
+ ISBS=0
+ NBS(:)=0
+ JPSOU1=C_NULL_PTR
+ JPSOU2=C_NULL_PTR
+ IF(C_ASSOCIATED(IPSOU)) THEN
+ CALL LCMLEN(IPSOU,'NBS',ILEN,ITYLCM)
+ IF(ILEN.GT.0) THEN
+ ISBS=1
+ CALL LCMGET(IPSOU,'NBS',NBS)
+ JPSOU=LCMGID(IPSOU,'BS')
+ JPSOU1=JPSOU
+ JPSOU=LCMGID(IPSOU,'BSINFO')
+ JPSOU2=JPSOU
+ IF(.NOT.C_ASSOCIATED(JPSOU1)) THEN
+ CALL LCMLIB(IPSOU)
+ CALL XABORT('DOORFV: BS DIRECTORY IS MISSING.')
+ ELSE IF(.NOT.C_ASSOCIATED(JPSOU2)) THEN
+ CALL LCMLIB(IPSOU)
+ CALL XABORT('DOORFV: BSINFO DIRECTORY IS MISSING.')
+ ENDIF
+ ENDIF
+ ENDIF
+*----
+* GATHER INITIAL FLUXES AND SOURCES FOR PARALLEL PROCESSING
+*----
+ NGEFF=0
+ JJ=0
+ IIG=0
+ DO IG=1,NGRP
+ IF(NPSYS(IG).NE.0) THEN
+ NGEFF=NGEFF+1
+ IIG=IG
+ ENDIF
+ ENDDO
+ IF(NGEFF.EQ.0) RETURN
+ ALLOCATE(NGIND(NGEFF),JPSYS(NGEFF),NBS2(NGEFF),KPSOU1(NGEFF),
+ 1 KPSOU2(NGEFF))
+ NBS2(:)=0
+ KPSOU1(:)=C_NULL_PTR
+ KPSOU2(:)=C_NULL_PTR
+ IF(NGEFF.EQ.1) THEN
+ NGIND(1)=IIG
+ SUNKNO2=>SUNKNO(1:NUN,IIG:IIG)
+ FUNKNO2=>FUNKNO(1:NUN,IIG:IIG)
+ IF(ISBS.EQ.1) NBS2(1)=NBS(IIG)
+ JPSYS(1)=LCMGIL(IPSYS,NPSYS(IIG))
+ IF(NBS2(1).NE.0) THEN
+ KPSOU1(1)=LCMGIL(JPSOU1,IIG)
+ KPSOU2(1)=LCMGIL(JPSOU2,IIG)
+ ENDIF
+ ELSE IF(NGEFF.EQ.NGRP) THEN
+ SUNKNO2=>SUNKNO
+ FUNKNO2=>FUNKNO
+ IF(ISBS.EQ.1) NBS2(:)=NBS(:)
+ DO IG=1,NGRP
+ NGIND(IG)=IG
+ JPSYS(IG)=LCMGIL(IPSYS,NPSYS(IG))
+ IF(NBS2(IG).NE.0) THEN
+ KPSOU1(IG)=LCMGIL(JPSOU1,IG)
+ KPSOU2(IG)=LCMGIL(JPSOU2,IG)
+ ENDIF
+ ENDDO
+ ELSE
+ ALLOCATE(SUNKNO2(NUN,NGEFF),FUNKNO2(NUN,NGEFF))
+ JJ=0
+ DO IG=1,NGRP
+ IF(NPSYS(IG).NE.0) THEN
+ JJ=JJ+1
+ NGIND(JJ)=IG
+ SUNKNO2(:NUN,JJ)=SUNKNO(:NUN,IG)
+ FUNKNO2(:NUN,JJ)=FUNKNO(:NUN,IG)
+ IF(ISBS.EQ.1) NBS2(JJ)=NBS(IG)
+ JPSYS(JJ)=LCMGIL(IPSYS,NPSYS(IG))
+ IF(NBS2(JJ).NE.0) THEN
+ KPSOU1(JJ)=LCMGIL(JPSOU1,IG)
+ KPSOU2(JJ)=LCMGIL(JPSOU2,IG)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+*
+ IF(IMPX.GT.3) THEN
+ WRITE(IUNOUT,'(//11H DOORFV: **,A,3H** ,A72)') CDOOR,TITR
+ ALLOCATE(FGAR(NREG))
+ DO II=1,NGEFF
+ FGAR(:NREG)=0.0
+ DO I=1,NREG
+ IF(KEYFLX(I).NE.0) FGAR(I)=SUNKNO(KEYFLX(I),II)
+ ENDDO
+ WRITE(IUNOUT,'(/33H N E U T R O N S O U R C E S (,I5,
+ 1 3H ):,4X,A9)') NGIND(II),CNFDIR(IDIR)
+ WRITE(IUNOUT,'(1P,6(5X,E15.7))') (FGAR(I),I=1,NREG)
+ ENDDO
+ DEALLOCATE(FGAR)
+ ENDIF
+*---
+* RECOVER FLUXES FROM A PREVIOUS SELF-SHIELDING CALCULATION IF AVAILABLE
+*---
+ DO JJ=1,NGEFF
+ CALL LCMLEN(JPSYS(JJ),'FUNKNO$USS',ILENG,ITYLCM)
+ IF(ILENG.EQ.NUN) THEN
+ CALL LCMGET(JPSYS(JJ),'FUNKNO$USS',FUNKNO2(1,JJ))
+ ENDIF
+ ENDDO
+*----
+* RECOVER STATE VECTOR INFORMATION
+*----
+ CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR)
+ LBIHET=IPAR(40).NE.0
+ IF(NREG.NE.IPAR(1)) CALL XABORT('DOORFV: INVALID NREG ON LCM.')
+*----
+* DOUBLE HETEROGENEITY TREATMENT. REDEFINE THE SOURCE.
+*----
+ NMATG=0
+ NREGG=0
+ IF(LBIHET) THEN
+ ALLOCATE(SUNKN(NUN,NGEFF))
+ NMATG=NMAT
+ NREGG=NREG
+ DO II=1,NGEFF
+ SUNKN(:NUN,II)=SUNKNO2(:NUN,II)
+ IF(CDOOR.EQ.'MCCG') THEN
+ CALL DOORFB2(JPSYS(II),IPTRK,IMPX,NMAT,NREG,NUN,KEYFLX,
+ 1 NMAT2,NREG2,SUNKNO2(1,II))
+ ELSE
+ CALL DOORFB2(JPSYS(II),IPTRK,IMPX,NMAT,NREG,NUN,KEYFLX,
+ 1 NMAT2,NREG2,SUNKNO2(1,II))
+ ENDIF
+ ENDDO
+ NMAT=NMAT2
+ NREG=NREG2
+ ELSE
+ ALLOCATE(SUNKN(1,1))
+ ENDIF
+*---
+* RECOVER POINTERS TO EACH GROUP PROPERTIES
+*---
+ ALLOCATE(KPSYS(NGEFF))
+ DO II=1,NGEFF
+ IF(LBIHET) THEN
+ KPSYS(II)=LCMGID(JPSYS(II),'BIHET')
+ ELSE
+ KPSYS(II)=JPSYS(II)
+ ENDIF
+ ENDDO
+*----
+* COMPUTE NEW FLUXES
+*----
+ IF(IPHASE.EQ.1) THEN
+* USE A NATIVE DOOR
+ IF ((CDOOR.EQ.'EXCELL').AND.(IPAR(7).EQ.5)) THEN
+ CALL MUSF(KPSYS,IPTRK,IMPX,NGEFF,NGIND,IDIR,NREG,NUN,MAT,
+ > VOL,FUNKNO2,SUNKNO2,TITR)
+ ELSE IF(CDOOR.EQ.'SYBIL') THEN
+ CALL SYBILF(KPSYS,IPTRK,IFTRAK,IMPX,NGEFF,NGIND,IDIR,NREG,
+ > NUN,MAT,VOL,FUNKNO2,SUNKNO2,TITR)
+ ELSE IF(CDOOR.EQ.'BIVAC') THEN
+ NLF=IPAR(14)
+ IF(NLF.EQ.0) THEN
+ CALL BIVAF(KPSYS,IPTRK,IFTRAK,IMPX,NGEFF,NGIND,IDIR,NREG,
+ > NUN,MAT,VOL,KEYFLX,FUNKNO2,SUNKNO2,TITR)
+ ELSE
+ IF(IDIR.NE.0) CALL XABORT('DOORFV: EXPECTING IDIR=0')
+ IF(IFTRAK.NE.0) CALL XABORT('DOORFV: EXPECTING IFTRAK=0')
+ ALLOCATE(INCONV(NGEFF))
+ INCONV(:NGEFF)=.TRUE.
+ MAXIT=20
+ CALL PNFLV(KPSYS,INCONV,NGIND,IPTRK,IMPX,MAXIT,NGEFF,
+ > NREG,NMAT,NUN,MAT,VOL,KEYFLX,FUNKNO2,SUNKNO2)
+ DEALLOCATE(INCONV)
+ ENDIF
+ ELSE IF(CDOOR.EQ.'TRIVAC') THEN
+ IF(IDIR.NE.0) CALL XABORT('DOORFV: EXPECTING IDIR=0')
+ IF(IFTRAK.NE.0) CALL XABORT('DOORFV: EXPECTING IFTRAK=0')
+ ALLOCATE(INCONV(NGEFF))
+ INCONV(:NGEFF)=.TRUE.
+ MAXIT=20
+ CALL TRIFLV(KPSYS,INCONV,NGIND,IPTRK,IMPX,MAXIT,NGEFF,NREG,
+ > NUN,KEYFLX,FUNKNO2,SUNKNO2)
+ DEALLOCATE(INCONV)
+ ELSE IF(CDOOR.EQ.'SN') THEN
+ CALL SNF(KPSYS,IPTRK,IFTRAK,IMPX,NGEFF,NGIND,IDIR,NREG,
+ > NMAT,NUN,MAT,VOL,KEYFLX,FUNKNO2,SUNKNO2,TITR,NBS2,
+ > KPSOU1,KPSOU2,FLUXC,EVALRHO)
+ ELSE IF(CDOOR.EQ.'MCCG') THEN
+ CALL MCCGF(KPSYS,IPTRK,IFTRAK,IPMACR,IMPX,NGRP,NGEFF,NGIND,
+ > IDIR,NREG,NMAT,NUN,LEXAC,MAT,VOL,KEYFLX,FUNKNO2,
+ > SUNKNO2,TITR,REBFLG)
+ ENDIF
+ ELSE IF(IPHASE.EQ.2) THEN
+ CALL TRFICF(KPSYS,IFTRAK,IMPX,NGEFF,NGIND,IDIR,NREG,NUN,MAT,
+ > VOL,KEYFLX,FUNKNO2,SUNKNO2,TITR)
+ ENDIF
+*----
+* DOUBLE HETEROGENEITY TREATMENT
+*----
+ IF(LBIHET) THEN
+ NMAT=NMATG
+ NREG=NREGG
+ DO II=1,NGEFF
+ SUNKNO2(:NUN,II)=SUNKN(:NUN,II)
+ CALL DOORFB3(JPSYS(II),IPTRK,IMPX,NMAT,NREG,NUN,KEYFLX,
+ 1 SUNKNO2(1,II),FUNKNO2(1,II))
+ ENDDO
+ ENDIF
+ DEALLOCATE(SUNKN)
+*
+ IF(IMPX.GT.3) THEN
+ ALLOCATE(FGAR(NREG))
+ DO II=1,NGEFF
+ FGAR(:NREG)=0.0
+ DO I=1,NREG
+ IF(KEYFLX(I).NE.0) FGAR(I)=FUNKNO(KEYFLX(I),II)
+ ENDDO
+ IF(IMPX.GT.4) THEN
+ WRITE(IUNOUT,'(/31H U N K N O W N F L U X E S (,I5,
+ 1 3H ):,6X,A9)') NGIND(II),CNFDIR(IDIR)
+ WRITE(IUNOUT,300) (FUNKNO2(I,II),I=1,NUN)
+ ELSE
+ WRITE(IUNOUT,'(/31H N E U T R O N F L U X E S (,I5,
+ 1 3H ):,6X,A9)') NGIND(II),CNFDIR(IDIR)
+ WRITE(IUNOUT,300) (FGAR(I),I=1,NREG)
+ ENDIF
+ ENDDO
+ DEALLOCATE(FGAR)
+ ENDIF
+*----
+* SCATTER NEW FLUXES
+*----
+ DO JJ=1,NGEFF
+ FUNKNO(:NUN,NGIND(JJ))=FUNKNO2(:NUN,JJ)
+ ENDDO
+ IF((NGEFF.GT.1).AND.(NGEFF.LT.NGRP)) DEALLOCATE(FUNKNO2,SUNKNO2)
+ DEALLOCATE(KPSYS,JPSYS,NGIND,NBS)
+ RETURN
+ 300 FORMAT(1P,6(5X,E15.7))
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 11:33:40 +0000