Initial commit from Polytechnique Montreal

1 files changed, 260 insertions, 0 deletions

diff --git a/Dragon/src/CPOMIC.f b/Dragon/src/CPOMIC.f
new file mode 100644
index 0000000..9bd25b6
--- /dev/null
+++ b/Dragon/src/CPOMIC.f
@@ -0,0 +1,260 @@
+*DECK CPOMIC
+      SUBROUTINE CPOMIC(IPCPO ,IPEDIT,IPRINT,NGROUP,NMERGE,NBMICR,
+     >                  NL    ,IMRG  ,ISOR  ,NPROC ,ISOTMP,IDIMIX,
+     >                  INDPRO,ITYPRO,DENCPO,DENTMP,DXSMIC,DSCMIC,
+     >                  DMJCPO,DFLUX )
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Compute microscopic cross sections for the Compo file.
+*
+*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 (L_COMPO signature).
+* IPEDIT  pointer to edit information (L_EDIT signature).
+* IPRINT  print parameter. Equal to zero for no print.
+* NGROUP  number of groups condensed .
+* NMERGE  number of regions merged.
+* NBMICR  maximum number of isotopes.
+* NL      number of Legendre orders.
+* IMRG    merge region indices.
+* ISOR    Compo isotope number.
+* NPROC   number of isotopes.
+* ISOTMP  name of isotopes in EDIT.
+* IDIMIX  isotopes identifier in each Compo material.
+* INDPRO  identifier for xs processing.
+* ITYPRO  identifier for xs processed.
+* DENCPO  Compo isotopes concentration.
+* DENTMP  Dragon isotopes concentration.
+*
+*Parameters: input/output
+* DXSMIC  micro vector xs.
+* DSCMIC  micro scat matrix xs.
+* DFLUX   flux.
+* DMJCPO  fission energy for macro.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT  NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR)      IPCPO,IPEDIT
+      INTEGER          IPRINT,NGROUP,NMERGE,NBMICR,NL,IMRG,ISOR,NPROC,
+     >                 ISOTMP(3,NBMICR),IDIMIX(NMERGE,NBMICR),
+     >                 INDPRO(NPROC),ITYPRO(NPROC)
+      REAL             DENTMP(NBMICR)
+      DOUBLE PRECISION DENCPO(NBMICR),DXSMIC(NGROUP,NPROC),
+     >                 DSCMIC(NGROUP,NGROUP,NL),DMJCPO(2,NBMICR),
+     >                 DFLUX(NGROUP)
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      REAL, ALLOCATABLE, DIMENSION(:) :: HFACT
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: XSREC
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XSCAT
+      TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO
+*----
+*  LOCAL PARAMETERS
+*----
+      INTEGER          IOUT,NDPROC,IORD
+      PARAMETER       (IOUT=6,NDPROC=20)
+      TYPE(C_PTR)      KPEDIT
+      INTEGER          NBISOE,ISOE,IADDXS,ITC,IXSR,JXSR,KXSR,IL,
+     >                 IGR,JGR,ILCMLN,ITYLCM
+      CHARACTER        NAMISO*12
+      DOUBLE PRECISION DSCPO,DNUFI,FACDEN,FACAXS
+*----
+*  SCRATCH STORAGE ALLOCATION
+*   XSREC   fission energy for macro.
+*   XSCAT   compress scattering.
+*----
+      ALLOCATE(XSREC(NGROUP,NPROC),XSCAT(NGROUP,NGROUP,NL),
+     > IPISO(NBMICR))
+*----
+*  FIND ISOTOPE POINTERS IN INPUT MICROLIB
+*----
+      CALL LIBIPS(IPEDIT,NBMICR,IPISO)
+*----
+*  COMPUTE FINAL DENSITY OF ISOTOPE ISOR IN MIXTURE IMRG
+*----
+      NBISOE=0
+      DO 100 ISOE=1,NBMICR
+        IF(IDIMIX(IMRG,ISOE).EQ.ISOR) THEN
+          NBISOE=NBISOE+1
+          DENCPO(ISOR)=DENCPO(ISOR)+DENTMP(ISOE)
+        ENDIF
+ 100  CONTINUE
+      IF(DENCPO(ISOR).EQ.0.0D0) THEN
+        FACDEN=1.0D0/DBLE(NBISOE)
+        IADDXS=0
+      ELSE
+        FACDEN=1.0D0/DENCPO(ISOR)
+        IADDXS=1
+      ENDIF
+*----
+*  SCAN ALL ISOTOPES FOR THIS MERGE REGION AND
+*  LOCATE ADD XS FOR THOSE ASSOCIATED WITH ISOR
+*----
+      DSCPO=0.0D0
+      DO 110 ISOE=1,NBMICR
+        IF(IDIMIX(IMRG,ISOE).EQ.ISOR) THEN
+          IF(IADDXS.EQ.0) THEN
+            FACAXS=FACDEN
+          ELSE
+            FACAXS=FACDEN*DBLE(DENTMP(ISOE))
+          ENDIF
+*----
+*  READ MICRO XS
+*----
+          WRITE(NAMISO,'(3A4)') (ISOTMP(ITC,ISOE),ITC=1,3)
+          IF(IPRINT.GE.10) WRITE(IOUT,6000) NAMISO
+          KPEDIT=IPISO(ISOE) ! set ISOE-th isotope
+          IORD=1
+          CALL XDRLGS(KPEDIT,-1,IPRINT,0,NL-1,IORD,NGROUP,
+     >                XSREC(1,NDPROC+1),XSCAT,ITYPRO(NDPROC+1))
+          CALL CPOLGX(KPEDIT,-1,IPRINT,IORD,NGROUP,INDPRO,XSREC(1,1),
+     >                ITYPRO)
+*----
+*  ADD MICRO XS TO CPO ISOTOPE
+*----
+          DO 120 IXSR=1,4
+            IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+              DO 121 IGR=1,NGROUP
+                DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR)
+     >            +FACAXS*DBLE(XSREC(IGR,IXSR))
+ 121          CONTINUE
+            ENDIF
+ 120      CONTINUE
+          IXSR=4
+          IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+*----
+*  COMPUTE TOTAL NEUTRON PRODUCED AND TOTAL ENERGY GENERATED
+*----
+            CALL LCMLEN(KPEDIT,'H-FACTOR',ILCMLN,ITYLCM)
+            IF(ILCMLN.EQ.NGROUP) THEN
+               ALLOCATE(HFACT(NGROUP))
+               CALL LCMGET(KPEDIT,'H-FACTOR',HFACT)
+               DO 122 IGR=1,NGROUP
+                 DMJCPO(1,ISOR)=DMJCPO(1,ISOR)+DENTMP(ISOE)
+     >               *DFLUX(IGR)*DBLE(HFACT(IGR))*1.0E18
+                 DMJCPO(2,ISOR)=DMJCPO(2,ISOR)+DENTMP(ISOE)
+     >               *DFLUX(IGR)*DBLE(XSREC(IGR,IXSR))
+ 122           CONTINUE
+               DEALLOCATE(HFACT)
+            ENDIF
+          ENDIF
+          IXSR=5
+          IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+            JXSR=3
+            DNUFI=0.0D0
+            DO 130 IGR=1,NGROUP
+              DNUFI=DNUFI+DFLUX(IGR)*DBLE(XSREC(IGR,JXSR))
+ 130        CONTINUE
+            DNUFI=DNUFI*FACAXS
+            DSCPO=DSCPO+DNUFI
+            DO 140 IGR=1,NGROUP
+              DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR)
+     >          +DNUFI*DBLE(XSREC(IGR,IXSR))
+ 140        CONTINUE
+          ENDIF
+          DO 150 IXSR=7,NDPROC
+            IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+              DO 151 IGR=1,NGROUP
+                DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR)
+     >            +FACAXS*DBLE(XSREC(IGR,IXSR))
+ 151          CONTINUE
+            ENDIF
+ 150      CONTINUE
+          IL=0
+          DO 160 IXSR=NDPROC+1,NDPROC+NL
+            IL=IL+1
+            IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+              DO 170 IGR=1,NGROUP
+                DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR)
+     >            +FACAXS*DBLE(XSREC(IGR,IXSR))
+                DO 171 JGR=1,NGROUP
+                  DSCMIC(IGR,JGR,IL)=DSCMIC(IGR,JGR,IL)
+     >              +FACAXS*DBLE(XSCAT(IGR,JGR,IL))
+ 171            CONTINUE
+ 170          CONTINUE
+            ENDIF
+ 160      CONTINUE
+        ENDIF
+ 110  CONTINUE
+*----
+*   SAVE AVERAGE XS
+*----
+      XSREC(:NGROUP,:NPROC)=0.0
+      XSCAT(:NGROUP,:NGROUP,:NL)=0.0
+      DO 180 IXSR=1,4
+        IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+          DO 181 IGR=1,NGROUP
+            XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR))
+ 181      CONTINUE
+        ENDIF
+ 180  CONTINUE
+      IXSR=5
+      IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+        IF(DSCPO.NE.0.0D0) THEN
+          DO 190 IGR=1,NGROUP
+            XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR)/DSCPO)
+ 190      CONTINUE
+        ENDIF
+      ENDIF
+      IXSR=6
+      IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+        JXSR=4
+        KXSR=3
+        DO 191 IGR=1,NGROUP
+          IF(DXSMIC(IGR,JXSR).GT.0.0) THEN
+            XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,KXSR)/DXSMIC(IGR,JXSR))
+          ENDIF
+ 191    CONTINUE
+      ENDIF
+      DO 200 IXSR=7,NDPROC
+        IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+          DO 201 IGR=1,NGROUP
+            XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR))
+ 201      CONTINUE
+        ENDIF
+ 200  CONTINUE
+      IL=0
+      DO 210 IXSR=NDPROC+1,NDPROC+NL
+        IL=IL+1
+        IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
+          DO 220 IGR=1,NGROUP
+            XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR))
+            DO 221 JGR=1,NGROUP
+              XSCAT(IGR,JGR,IL)=REAL(DSCMIC(IGR,JGR,IL))
+ 221        CONTINUE
+ 220      CONTINUE
+        ENDIF
+ 210  CONTINUE
+*----
+*  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)
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(IPISO,XSCAT,XSREC)
+      RETURN
+*----
+*  PRINT FORMAT
+*----
+ 6000 FORMAT(' CPOMIC: INCLUDE ISOTOPE          = ',A12)
+      END