Initial commit from Polytechnique Montreal

1 files changed, 205 insertions, 0 deletions

diff --git a/Dragon/src/CPOMAW.f b/Dragon/src/CPOMAW.f
new file mode 100644
index 0000000..bc2980e
--- /dev/null
+++ b/Dragon/src/CPOMAW.f
@@ -0,0 +1,205 @@
+*DECK CPOMAW
+      SUBROUTINE CPOMAW(IPCPO ,IPRINT,NGROUP,NL    ,NPROC ,INDPRO,
+     >                  ITYPRO,DXSMAC,DSCMAC,DXSREM,DSCREM,DISFC ,
+     >                  DMJMAC,IFCDIS,DISFAC)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Put macroscopic cross section on Compo.
+*
+*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): G. Marleau
+*
+*Parameters: input
+* IPCPO   pointer to the Compo.
+* IPRINT  print parameter. Equal to zero for no print.
+* NGROUP  number of groups condensed.
+* NL      number of Legendre orders.
+* NPROC   number of microscopic xs to process.
+* INDPRO  identifier for xs processing.
+* ITYPRO  identifier for xs processed .
+* DXSMAC  macroscopic averaged region/group x-s.
+* DSCMAC  macroscopic scattering.
+* DXSREM  removed averaged region/group x-s.
+* DSCREM  removed scattering rates.
+* DISFC   disadvantage factor.
+* DMJMAC  energy.
+* IFCDIS  discontinuity factor present (1) or absent.
+* DISFAC  discontinuity factors.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR)      IPCPO
+      INTEGER          IPRINT,NGROUP,NL,NPROC,INDPRO(NPROC),
+     >                 ITYPRO(NPROC)
+      REAL             DISFC(NGROUP)
+      DOUBLE PRECISION DXSMAC(NGROUP,NPROC),
+     >                 DSCMAC(NGROUP,NGROUP,NL),
+     >                 DXSREM(NGROUP,NPROC),
+     >                 DSCREM(NGROUP,NGROUP,NL),
+     >                 DMJMAC
+      INTEGER          IFCDIS
+      DOUBLE PRECISION DISFAC(2,NGROUP,3)
+*----
+*  LOCAL PARAMETERS
+*----
+      INTEGER          NDPROC
+      REAL             CUTOFF
+      PARAMETER       (NDPROC=20,CUTOFF=1.0E-7)
+      INTEGER          IXSR,JXSR,KXSR,IL,IGR,JGR,IORD
+      REAL             CUTLIM
+      DOUBLE PRECISION DNUFI,DNUFT
+*----
+*  ALLOCATABLE ARRAYS
+*   XSREC   micro vector xs
+*   XSCAT   compress scattering data
+*   DISTMP  temporary storage for discontinuity factors              
+*----
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: XSREC,DISTMP
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XSCAT
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(XSREC(NGROUP,NPROC),XSCAT(NGROUP,NGROUP,NL),
+     > DISTMP(2,NGROUP))
+*----
+*   SAVE AVERAGE XS
+*----
+      ITYPRO(:NPROC)=1
+      CALL LCMSIX(IPCPO,'MACR',1)
+      XSREC(:NGROUP,:NPROC)=0.0
+      XSCAT(:NGROUP,:NGROUP,:NL)=0.0
+      DO 100 IXSR=1,4
+        IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+          DO 101 IGR=1,NGROUP
+            XSREC(IGR,IXSR)=REAL(DXSMAC(IGR,IXSR)-DXSREM(IGR,IXSR))
+            CUTLIM=ABS(REAL(DXSMAC(IGR,IXSR))*CUTOFF)
+            IF(XSREC(IGR,IXSR).LT.CUTLIM)  XSREC(IGR,IXSR)=0.0
+ 101      CONTINUE
+        ENDIF
+ 100  CONTINUE
+      IXSR=5
+      IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+        JXSR=3
+        KXSR=16
+        DNUFI=0.0D0
+        DNUFT=0.0D0
+        DO 120 IGR=1,NGROUP
+          DNUFT=DNUFT+DXSMAC(IGR,KXSR)*DXSMAC(IGR,JXSR)
+          DNUFI=DNUFI+(DXSMAC(IGR,KXSR)-DXSREM(IGR,KXSR))
+     >      *(DXSMAC(IGR,JXSR)-DXSREM(IGR,JXSR))
+ 120    CONTINUE
+        CUTLIM=ABS(REAL(DNUFT)*CUTOFF)
+        IF(REAL(DNUFI).GT.CUTLIM) THEN
+          DNUFI=1.0D0/DNUFI
+          DNUFT=1.0D0/DNUFT
+          DO 130 IGR=1,NGROUP
+            XSREC(IGR,IXSR)=REAL(DNUFI*(DXSMAC(IGR,IXSR)
+     >        -DXSREM(IGR,IXSR)))
+ 130      CONTINUE
+        ENDIF
+      ENDIF
+      IXSR=6
+      IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+        JXSR=4
+        KXSR=3
+        DO 140 IGR=1,NGROUP
+          DNUFI=DXSMAC(IGR,JXSR)-DXSREM(IGR,JXSR)
+          CUTLIM=ABS(REAL(DXSMAC(IGR,JXSR))*CUTOFF)
+          IF(REAL(DNUFI).GT.CUTLIM) THEN
+            XSREC(IGR,IXSR)=REAL((DXSMAC(IGR,KXSR)
+     >        -DXSREM(IGR,KXSR))/DNUFI)
+          ENDIF
+ 140    CONTINUE
+      ENDIF
+      DO 150 IXSR=7,NDPROC
+        IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+          DO 160 IGR=1,NGROUP
+            XSREC(IGR,IXSR)=REAL(DXSMAC(IGR,IXSR)-DXSREM(IGR,IXSR))
+            CUTLIM=ABS(REAL(DXSMAC(IGR,IXSR))*CUTOFF)
+            IF(XSREC(IGR,IXSR).LT.CUTLIM)  XSREC(IGR,IXSR)=0.0
+ 160      CONTINUE
+        ENDIF
+ 150  CONTINUE
+      IL=0
+      DO 170 IXSR=NDPROC+1,NDPROC+NL
+        IL=IL+1
+        IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+          DO 180 IGR=1,NGROUP
+            XSREC(IGR,IXSR)=REAL(DXSMAC(IGR,IXSR)-DXSREM(IGR,IXSR))
+            CUTLIM=ABS(REAL(DXSMAC(IGR,IXSR))*CUTOFF)
+            IF(ABS(XSREC(IGR,IXSR)).LT.CUTLIM)
+     >         XSREC(IGR,IXSR)=0.0
+            DO 190 JGR=1,NGROUP
+              XSCAT(IGR,JGR,IL)=REAL(DSCMAC(IGR,JGR,IL)
+     >          -DSCREM(IGR,JGR,IL))
+              CUTLIM=ABS(REAL(DSCMAC(IGR,JGR,IL))*CUTOFF)
+              IF(ABS(XSCAT(IGR,JGR,IL)).LT.CUTLIM)
+     >          XSCAT(IGR,JGR,IL)=0.0
+ 190        CONTINUE
+ 180      CONTINUE
+        ENDIF
+ 170  CONTINUE
+*----
+*  COMPUTE AVERAGED ENERGY PER FISSION
+*----
+      JXSR=4
+      KXSR=16
+      DNUFI=0.0D0
+      DNUFT=0.0D0
+      DO 200 IGR=1,NGROUP
+        DNUFT=DNUFT+DXSMAC(IGR,KXSR)*DXSMAC(IGR,JXSR)
+        DNUFI=DNUFI+(DXSMAC(IGR,KXSR)-DXSREM(IGR,KXSR))
+     >    *(DXSMAC(IGR,JXSR)-DXSREM(IGR,JXSR))
+ 200  CONTINUE
+      CUTLIM=ABS(REAL(DNUFT)*CUTOFF)
+      IF(REAL(DNUFI).GT.CUTLIM) THEN
+        DMJMAC=DMJMAC/DNUFI
+      ELSE
+        DMJMAC=0.0D0
+      ENDIF
+*----
+*  SAVE CPO MICRO
+*----
+      IORD=1
+      CALL XDRLGS(IPCPO,1,IPRINT,0,NL-1,IORD,NGROUP,XSREC(1,NDPROC+1),
+     >            XSCAT,ITYPRO(NDPROC+1))
+      CALL CPOLGX(IPCPO,1,IPRINT,IORD,NGROUP,INDPRO,XSREC(1,1),ITYPRO)
+      CALL LCMSIX(IPCPO,'MACR',2)
+      IXSR=NDPROC+NL+1
+      DO 210 IGR=1,NGROUP
+        XSREC(IGR,1)=REAL(DXSMAC(IGR,IXSR))
+ 210  CONTINUE
+      CALL LCMPUT(IPCPO,'OVERV',NGROUP,2,XSREC)
+      IXSR=16
+      DO 220 IGR=1,NGROUP
+        XSREC(IGR,1)=REAL(DXSMAC(IGR,IXSR))
+ 220  CONTINUE
+      CALL LCMPUT(IPCPO,'FLUX-INTG',NGROUP,2,XSREC)
+      CALL LCMPUT(IPCPO,'FLUXDISAFACT',NGROUP,2,DISFC)
+      IF(IFCDIS .EQ. 1) THEN
+        CALL XDRSDB(2*NGROUP,DISTMP,DISFAC(1,1,1),1)
+        CALL LCMPUT(IPCPO,'DISFACX',2*NGROUP,2,DISTMP)
+        CALL XDRSDB(2*NGROUP,DISTMP,DISFAC(1,1,2),1)
+        CALL LCMPUT(IPCPO,'DISFACY',2*NGROUP,2,DISTMP)
+        CALL XDRSDB(2*NGROUP,DISTMP,DISFAC(1,1,3),1)
+        CALL LCMPUT(IPCPO,'DISFACZ',2*NGROUP,2,DISTMP)
+      ENDIF
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(DISTMP,XSCAT,XSREC)
+      RETURN
+      END