diff options
Diffstat (limited to 'Dragon/src/DOORFB2.f')
| -rw-r--r-- | Dragon/src/DOORFB2.f | 160 |
1 files changed, 160 insertions, 0 deletions
diff --git a/Dragon/src/DOORFB2.f b/Dragon/src/DOORFB2.f new file mode 100644 index 0000000..3659fbe --- /dev/null +++ b/Dragon/src/DOORFB2.f @@ -0,0 +1,160 @@ +*DECK DOORFB2 + SUBROUTINE DOORFB2(IPSYS,IPTRK,IMPX,NBMIX,NREG,NUN,KEYFLX,NBMIX2, + 1 NREG2,SUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Double heterogeneity treatment (part 2). One-group 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 +* IPSYS pointer to the assembly LCM object (L_PIJ signature). IPSYS is +* a list of directories. +* IPTRK pointer to the tracking (L_TRACK signature). +* IMPX print flag (equal to zero for no print). +* NBMIX number of composite mixtures in the domain. Equal to the +* number of mixtures in the internal library. +* NREG number of volumes in the composite geometry. +* NUN total number of unknowns in vector SUNKNO. +* KEYFLX index of flux components in unknown vector. +* +*Parameters: input/output +* SUNKNO sources defined in the composite geometry on input and +* equivalent macro-sources at output. +* +*Parameters: output +* NBMIX2 number of mixtures in the internal library, including +* double-heterogeneity mixtures. +* NREG2 number of volumes in the macro geometry. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS,IPTRK + INTEGER IMPX,NBMIX,NREG,NUN,KEYFLX(NREG),NBMIX2,NREG2 + REAL SUNKNO(NUN) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(IOUT=6) + INTEGER IPAR(8) +*---- +* ALLOCATABLE ARRAYS +*---- + TYPE(C_PTR) NS_PTR,IBI_PTR,FRACT_PTR,VOLK_PTR,IDIL_PTR,MIXGR_PTR, + > NCO_PTR,RRRR_PTR,QKOLD_PTR,QKDEL_PTR,PKL_PTR,COEF_PTR,P1I_PTR, + > P1DI_PTR,P1KI_PTR,SIGA1_PTR + INTEGER, DIMENSION(:), POINTER :: NS,IBI,IDIL,MIXGR,NCO + REAL, DIMENSION(:), POINTER :: FRACT,VOLK,SGAR,RRRR,QKOLD, + > QKDEL,PKL,P1I,P1DI,P1KI,SIGA1 + REAL, DIMENSION(:), ALLOCATABLE :: FLUAS + DOUBLE PRECISION, DIMENSION(:), POINTER :: COEF +*---- +* RECOVER DOUBLE HETEROGENEITY DATA +*---- + IF(IMPX.GT.50) THEN + WRITE(6,'(/38H DOORFB2: DOUBLE HETEROGENEITY OPTION.)') + ENDIF + 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) + IF(IR1.NE.NBMIX) THEN + WRITE(6,'(/13HDOORFB2: IR1=,I6,7H NBMIX=,I6)') IR1,NBMIX + CALL XABORT('DOORFB2: INVALID DATA IN TRACKING.') + ENDIF + IF(NREG2.GT.NUN) CALL XABORT('DOORFB2: NUN OVERFLOW.') + NMILG=IR2-IR1 + CALL LCMGPD(IPTRK,'NS',NS_PTR) + CALL LCMGPD(IPTRK,'IBI',IBI_PTR) + CALL LCMGPD(IPTRK,'FRACT',FRACT_PTR) + CALL LCMGPD(IPTRK,'VOLK',VOLK_PTR) + CALL LCMGPD(IPTRK,'IDIL',IDIL_PTR) + CALL LCMGPD(IPTRK,'MIXGR',MIXGR_PTR) + CALL LCMSIX(IPTRK,' ',2) +* + CALL C_F_POINTER(NS_PTR,NS,(/ NG /)) + CALL C_F_POINTER(IBI_PTR,IBI,(/ NREG2 /)) + CALL C_F_POINTER(FRACT_PTR,FRACT,(/ NG*(NBMIX+NMILG) /)) + CALL C_F_POINTER(VOLK_PTR,VOLK,(/ NG*NSMAX /)) + CALL C_F_POINTER(IDIL_PTR,IDIL,(/ NMILG /)) + CALL C_F_POINTER(MIXGR_PTR,MIXGR,(/ NSMAX*NG*NMILG /)) +*---- +* RECOVER GROUP-DEPENDENT BIHET INFORMATION +*---- + IF((IBIHET.EQ.1) .OR. (IBIHET.EQ.2)) THEN + CALL LCMGPD(IPSYS,'NCO',NCO_PTR) + CALL LCMGPD(IPSYS,'RRRR',RRRR_PTR) + CALL LCMGPD(IPSYS,'QKOLD',QKOLD_PTR) + CALL LCMGPD(IPSYS,'QKDEL',QKDEL_PTR) + CALL LCMGPD(IPSYS,'PKL',PKL_PTR) + CALL LCMGPD(IPSYS,'COEF',COEF_PTR) +* + CALL C_F_POINTER(NCO_PTR,NCO,(/ NMILG /)) + CALL C_F_POINTER(RRRR_PTR,RRRR,(/ NMILG /)) + CALL C_F_POINTER(QKOLD_PTR,QKOLD,(/ NG*NSMAX*NMILG /)) + CALL C_F_POINTER(QKDEL_PTR,QKDEL,(/ NG*NSMAX*NMILG /)) + CALL C_F_POINTER(PKL_PTR,PKL,(/ NG*NSMAX*NSMAX*NMILG /)) + CALL C_F_POINTER(COEF_PTR,COEF,(/ NMILG*(1+NG*NSMAX)**2 /)) + ELSE IF((IBIHET.EQ.3) .OR. (IBIHET.EQ.4)) THEN + CALL LCMGPD(IPSYS,'P1I',P1I_PTR) + CALL LCMGPD(IPSYS,'P1DI',P1DI_PTR) + CALL LCMGPD(IPSYS,'P1KI',P1KI_PTR) + CALL LCMGPD(IPSYS,'SIGA1',SIGA1_PTR) +* + CALL C_F_POINTER(P1I_PTR,P1I,(/ NG*NMILG /)) + CALL C_F_POINTER(P1DI_PTR,P1DI,(/ NG*NMILG /)) + CALL C_F_POINTER(P1KI_PTR,P1KI,(/ NSMAX*NG*NMILG /)) + CALL C_F_POINTER(SIGA1_PTR,SIGA1,(/ NG*NMILG /)) + ENDIF +*---- +* COMPUTE THE EQUIVALENT CROSS SECTIONS IN COMPOSITE REGIONS +*---- + CALL LCMSIX(IPSYS,'BIHET',1) + NB1=NBMIX+1 + ALLOCATE(SGAR(NB1+NMILG)) + CALL LCMGET(IPSYS,'DRAGON-TXSC',SGAR) + CALL LCMSIX(IPSYS,' ',2) +*---- +* DOUBLE HETEROGENEITY TREATMENT -- PART 2 +*---- + ALLOCATE(FLUAS(NREG2)) + IF((IBIHET.EQ.1) .OR. (IBIHET.EQ.2)) THEN + CALL XDRH20(IBIHET,NUN,NBMIX,NMILG,NREG,NREG2,NG,NSMAX,KEYFLX, + > NS,IDIL,MIXGR,IBI,FRACT,VOLK,SGAR,NCO,RRRR,QKOLD,QKDEL,PKL, + > COEF,SUNKNO,FLUAS) + ELSE IF((IBIHET.EQ.3) .OR. (IBIHET.EQ.4)) THEN + CALL XDRH23(IBIHET,NUN,NBMIX,NMILG,NREG,NREG2,NG,NSMAX,KEYFLX, + > NS,IDIL,MIXGR,IBI,FRACT,SGAR,P1I,P1DI,P1KI,SIGA1,SUNKNO,FLUAS) + ENDIF +*---- +* SET MACRO-INFORMATION +*---- + SUNKNO(:NUN)=0.0 + DO 10 I=1,NREG2 + SUNKNO(KEYFLX(I))=FLUAS(I) + 10 CONTINUE + DEALLOCATE(FLUAS) + NBMIX2=NBMIX+NMILG +*---- +* MEMORY RELEASE +*---- + DEALLOCATE(SGAR) + RETURN + END |