Initial commit from Polytechnique Montreal

1 files changed, 147 insertions, 0 deletions

diff --git a/Dragon/src/DOORFB3.f b/Dragon/src/DOORFB3.f
new file mode 100644
index 0000000..0ded44f
--- /dev/null
+++ b/Dragon/src/DOORFB3.f
@@ -0,0 +1,147 @@
+*DECK DOORFB3
+      SUBROUTINE DOORFB3(IPSYS,IPTRK,IMPX,NBMIX,NREG,NUN,KEYFLX,SUNKNO,
+     1 FUNKNO)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Double heterogeneity treatment (part 3). 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.
+* SUNKNO  equivalent macro-sources.
+*
+*Parameters: input/output
+* FUNKNO  equivalent macro-fluxes on input and 
+*         composite fluxes on output.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPSYS,IPTRK
+      INTEGER IMPX,NBMIX,NREG,NUN,KEYFLX(NREG)
+      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,RRRR,QKOLD,QKDEL,PKL,
+     > P1I,P1DI,P1KI,SIGA1
+      REAL, DIMENSION(:), ALLOCATABLE :: SGAR,SGAS
+      DOUBLE PRECISION, DIMENSION(:), POINTER :: COEF
+*----
+*  RECOVER DOUBLE HETEROGENEITY DATA
+*----
+      IF(IMPX.GT.50) THEN
+         WRITE(6,'(/38H DOORFB3: 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) CALL XABORT('DOORFB3: INVALID DATA IN TRACKING.')
+      IF(NREG2.GT.NUN) CALL XABORT('DOORFB3: 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
+      CALL LCMLEN(IPSYS,'DRAGON-S0XSC',ILONG,ITYLCM)
+      NANI=ILONG/(NB1+NMILG)
+      ALLOCATE(SGAR(NB1+NMILG),SGAS((NB1+NMILG)*NANI))
+      SGAS(:(NB1+NMILG)*NANI)=0.0
+      CALL LCMGET(IPSYS,'DRAGON-TXSC',SGAR)
+      CALL LCMGET(IPSYS,'DRAGON-S0XSC',SGAS)
+      CALL LCMSIX(IPSYS,' ',2)
+*----
+*   DOUBLE HETEROGENEITY TREATMENT -- PART 2
+*----
+      IF((IBIHET.EQ.1) .OR. (IBIHET.EQ.2)) THEN
+      CALL XDRH30(IBIHET,NUN,NBMIX,NMILG,NREG,NREG2,NG,NSMAX,KEYFLX,
+     > NS,IDIL,MIXGR,IBI,FRACT,VOLK,SGAR,SGAS,NCO,RRRR,QKOLD,QKDEL,
+     > PKL,COEF,SUNKNO,FUNKNO)
+      ELSE IF((IBIHET.EQ.3) .OR. (IBIHET.EQ.4)) THEN
+      CALL XDRH33(IBIHET,NUN,NBMIX,NMILG,NREG,NREG2,NG,NSMAX,KEYFLX,
+     > NS,IDIL,MIXGR,IBI,FRACT,VOLK,SGAR,P1I,P1DI,P1KI,SIGA1,FUNKNO)
+      ENDIF
+*----
+*   MEMORY RELEASE
+*----
+      DEALLOCATE(SGAS,SGAR)
+      RETURN
+      END