summaryrefslogtreecommitdiff
path: root/Dragon/src/DOORAB.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/DOORAB.f')
-rw-r--r--Dragon/src/DOORAB.f196
1 files changed, 196 insertions, 0 deletions
diff --git a/Dragon/src/DOORAB.f b/Dragon/src/DOORAB.f
new file mode 100644
index 0000000..940cef1
--- /dev/null
+++ b/Dragon/src/DOORAB.f
@@ -0,0 +1,196 @@
+*DECK DOORAB
+ SUBROUTINE DOORAB (CDOOR,JPSYS,NPSYS,IPTRK,IMPX,NGRP,NREG,NBMIX,
+ 1 NANI,MAT,VOL)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Double heterogeneity treatment (part 1). Vectorial version.
+*
+*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
+* CDOOR name of the geometry/solution operator.
+* JPSYS pointer to the PIJ LCM object (L_PIJ signature). JPSYS is a
+* list of NGRP directories.
+* NPSYS index array pointing to the JPSYS 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).
+* IMPX print flag (equal to zero for no print).
+* NGRP number of energy groups.
+* NBMIX number of mixtures (NBMIX=max(MAT(i))).
+* NANI number of Legendre orders (usually equal to one).
+*
+*Parameters: input/output
+* NREG total number of regions for which specific values of the
+* neutron flux and reaction rates are required on input and
+* number of regions in the macro-geometry at output.
+* MAT index-number of the mixture type assigned to each volume
+* on input and index-number of the mixture type assigned
+* to each macro-volume at output.
+* VOL volume on input and macro-volumes at output.
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ CHARACTER CDOOR*12
+ TYPE(C_PTR) JPSYS,IPTRK
+ INTEGER NPSYS(NGRP)
+ INTEGER IMPX,NGRP,NREG,NBMIX,NANI,MAT(NREG)
+ REAL VOL(NREG)
+*----
+* LOCAL VARIABLES
+*----
+ PARAMETER(IOUT=6)
+ INTEGER IPAR(8)
+ TYPE(C_PTR) KPSYS,KPBIH
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: NS,IDIL,MIXGR,IBI,NCO
+ REAL, ALLOCATABLE, DIMENSION(:) :: RS,FRACT,VOLK,VOL2,SGAR,SGAS,
+ > RRRR,QKDEL,QKOLD,PKL,P1I,P1DI,P1KI,SIGA1
+ DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: COEF
+*---
+* RECOVER DOUBLE HETEROGENEITY DATA
+*----
+ CALL LCMSIX(IPTRK,'BIHET',1)
+ CALL LCMGET(IPTRK,'PARAM',IPAR)
+ IR1=IPAR(1)
+ IR2=IPAR(2)
+ NREG2=IPAR(3)
+ NG=IPAR(4)
+ NSMAX=IPAR(5)
+ IBIHET=IPAR(6)
+ MICRO=IPAR(7)
+ IQUA10=IPAR(8)
+ IF(IR1.NE.NBMIX) CALL XABORT('DOORAB: INVALID DATA IN TRACKING.')
+ IF(IBIHET.EQ.0) CALL XABORT('DOORAB: BIHET MODEL NOT SET.')
+ NMILG=IR2-IR1
+ ALLOCATE(NS(NG),IDIL(NMILG),MIXGR(NSMAX*NG*NMILG),IBI(NREG2))
+ ALLOCATE(RS(NG*(1+NSMAX)),FRACT(NG*IR2),VOLK(NG*NSMAX),
+ 1 VOL2(NREG2))
+ CALL LCMGET(IPTRK,'NS',NS)
+ CALL LCMGET(IPTRK,'RS',RS)
+ CALL LCMGET(IPTRK,'FRACT',FRACT)
+ CALL LCMGET(IPTRK,'VOLK',VOLK)
+ CALL LCMGET(IPTRK,'IDIL',IDIL)
+ CALL LCMGET(IPTRK,'MIXGR',MIXGR)
+ CALL LCMGET(IPTRK,'VOLUME',VOL2)
+ CALL LCMGET(IPTRK,'IBI',IBI)
+ CALL LCMGET(IPTRK,'FRTM',FRTM)
+ CALL LCMSIX(IPTRK,' ',2)
+ IF(IMPX.GT.1) THEN
+ WRITE(IOUT,'(/43H DOORAB: RECOVER DOUBLE-HETEROGENEITY DATA.)')
+ WRITE(IOUT,'(35H NUMBER OF ORDINARY MIXTURES ,I4)') IR1
+ WRITE(IOUT,'(35H NUMBER OF COMPOSITE MIXTURES ,I4)') NMILG
+ WRITE(IOUT,'(35H NUMBER OF KIND OF GRAINS ,I4)') NG
+ WRITE(IOUT,'(35H NUMBER OF ORDINARY VOLUMES ,I4)') NREG2
+ WRITE(IOUT,'(35H NUMBER OF COMPOSITE VOLUMES ,I4)') NREG
+ WRITE(IOUT,'(35H TYPE OF MICRO VOLUMES (3 OR 4) ,I4)') MICRO
+ WRITE(IOUT,'(35H MAX. NUMBER OF VOLUMES PER GRAIN,I4)') NSMAX
+ WRITE(IOUT,'(35H QUADRATURE PARAMETER FOR GRAINS ,I4)') IQUA10
+ WRITE(IOUT,'(35H DOUBLE HETEROGENEITY MODEL ,I4)') IBIHET
+ IF(IBIHET.EQ.3.OR.IBIHET.EQ.4) THEN
+ WRITE(IOUT,'(35H MINIMUM GRAINS FRACTION ,F8.4)')
+ > FRTM
+ ENDIF
+ ENDIF
+*----
+* COMPUTE THE EQUIVALENT CROSS SECTIONS IN COMPOSITE REGIONS
+*----
+ NB1=NBMIX+1
+ ALLOCATE(SGAR((NB1+NMILG)),SGAS((NB1+NMILG)*NANI))
+ SGAS(:(NB1+NMILG)*NANI)=0.0
+ DO 100 IGR=1,NGRP
+ IOFSET=NPSYS(IGR)
+ IF(IOFSET.NE.0) THEN
+ IF(IMPX.GT.10) WRITE(IOUT,'(/25H DOORAB: PROCESSING GROUP,I5,
+ > 6H WITH ,A,1H.)') IGR,CDOOR
+ KPSYS=LCMGIL(JPSYS,IOFSET)
+ CALL LCMGET(KPSYS,'DRAGON-TXSC',SGAR)
+ CALL LCMGET(KPSYS,'DRAGON-S0XSC',SGAS)
+*----
+* MORE MEMORY ALLOCATION
+*----
+ IF((IBIHET.EQ.1).OR.(IBIHET.EQ.2)) THEN
+ ALLOCATE(NCO(NMILG))
+ ALLOCATE(RRRR(NMILG),QKDEL(NG*NSMAX*NMILG),
+ > QKOLD(NG*NSMAX*NMILG),PKL(NG*NSMAX*NSMAX*NMILG))
+ ALLOCATE(COEF(NMILG*(1+NG*NSMAX)**2))
+ ELSEIF ((IBIHET.EQ.3).OR.(IBIHET.EQ.4)) THEN
+ ALLOCATE(P1I(NG*NMILG),P1KI(NSMAX*NG*NMILG),
+ > P1DI(NG*NMILG),SIGA1(NG*NMILG))
+ P1I(:)=0
+ P1DI(:)=0
+ P1KI(:)=0
+ SIGA1(:)=0
+ ENDIF
+*----
+* DOUBLE HETEROGENEITY TREATMENT -- PART 1
+*----
+ IF(IBIHET.EQ.1) THEN
+* SANCHEZ-POMRANING MODEL.
+ CALL XDRH11(NBMIX,NMILG,NG,NSMAX,MICRO,IQUA10,NS,IDIL,
+ > MIXGR,RS,FRACT,VOLK,SGAR,SGAS,NCO,RRRR,QKOLD,QKDEL,PKL,
+ > COEF)
+ ELSEIF(IBIHET.EQ.2) THEN
+* HEBERT MODEL.
+ CALL XDRH12(NBMIX,NMILG,NG,NSMAX,MICRO,IQUA10,NS,IDIL,
+ > MIXGR,RS,FRACT,VOLK,SGAR,SGAS,NCO,RRRR,QKDEL,PKL,COEF)
+ ELSEIF((IBIHET.EQ.3).OR.(IBIHET.EQ.4)) THEN
+* SHE-LIU-SHI MODEL.
+ CALL XDRH13(NBMIX,NMILG,NG,NSMAX,IQUA10,FRTM,NS,IDIL,
+ > MIXGR,RS,FRACT,SGAR,SGAS,P1I,P1DI,P1KI,SIGA1)
+ ELSE
+ CALL XABORT('DOORAB: INVALID DOUBLE HETEROGENEITY MODEL.')
+ ENDIF
+*
+ KPBIH=LCMDID(KPSYS,'BIHET')
+ CALL LCMPUT(KPBIH,'DRAGON-TXSC',1+IR2,2,SGAR)
+ CALL LCMPUT(KPBIH,'DRAGON-S0XSC',(1+IR2)*NANI,2,SGAS)
+*
+ IF((IBIHET.EQ.1).OR.(IBIHET.EQ.2)) THEN
+ CALL LCMPUT(KPSYS,'NCO',NMILG,1,NCO)
+ CALL LCMPUT(KPSYS,'RRRR',NMILG,2,RRRR)
+ CALL LCMPUT(KPSYS,'QKOLD',NG*NSMAX*NMILG,2,QKOLD)
+ CALL LCMPUT(KPSYS,'QKDEL',NG*NSMAX*NMILG,2,QKDEL)
+ CALL LCMPUT(KPSYS,'PKL',NG*NSMAX*NSMAX*NMILG,2,PKL)
+ CALL LCMPUT(KPSYS,'COEF',NMILG*(1+NG*NSMAX)**2,4,COEF)
+ DEALLOCATE(NCO)
+ DEALLOCATE(COEF)
+ DEALLOCATE(PKL,QKOLD,QKDEL,RRRR)
+ ELSEIF((IBIHET.EQ.3).OR.(IBIHET.EQ.4)) THEN
+ CALL LCMPUT(KPSYS,'P1I',NG*NMILG,2,P1I)
+ CALL LCMPUT(KPSYS,'P1DI',NG*NMILG,2,P1DI)
+ CALL LCMPUT(KPSYS,'P1KI',NG*NSMAX*NMILG,2,P1KI)
+ CALL LCMPUT(KPSYS,'SIGA1',NG*NMILG,2,SIGA1)
+ DEALLOCATE(P1I,P1DI,P1KI,SIGA1)
+ ENDIF
+ ENDIF
+ 100 CONTINUE
+ DEALLOCATE(SGAS,SGAR)
+*----
+* SET MACRO-GEOMETRY.
+*----
+ NREG=NREG2
+ NBMIX=NBMIX+NMILG
+ DO I=1,NREG2
+ MAT(I)=IBI(I)
+ VOL(I)=VOL2(I)
+ ENDDO
+ DEALLOCATE(RS,FRACT,VOLK,VOL2)
+ DEALLOCATE(NS,IDIL,MIXGR,IBI)
+ RETURN
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 11:33:50 +0000