From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Dragon/src/DOORAB.f | 196 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 196 insertions(+) create mode 100644 Dragon/src/DOORAB.f (limited to 'Dragon/src/DOORAB.f') 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 -- cgit v1.2.3