Initial commit from Polytechnique Montreal

1 files changed, 178 insertions, 0 deletions

diff --git a/Dragon/src/MACPRM.f b/Dragon/src/MACPRM.f
new file mode 100644
index 0000000..36470f6
--- /dev/null
+++ b/Dragon/src/MACPRM.f
@@ -0,0 +1,178 @@
+*DECK MACPRM
+      SUBROUTINE MACPRM(IPMACR,IPRINT,NGROUP,NANISO,NBMIXF,NIFISF,
+     >                  NEDF  ,NDELF ,NREACD,NTREA ,IGR   ,NAMREA,
+     >                  NAMEDN,IXSPRO,XSGEN ,XSIGS ,XSSCAT)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Save a new macrolib created from old macrolibs.
+*
+*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
+* IPMACR  pointer to structures.
+* IPRINT  print level.
+* NGROUP  number of groups.
+* NANISO  maximun scattering anisotropy.
+* NBMIXF  final number of mixtures.
+* NIFISF  final number fissile isotopes.
+* NEDF    final number of aditional x-s.
+* NDELF   final number of precursor groups.
+* NREACD  number of default x-s.
+* NTREA   total number of x-s types.
+* IGR     current group being processed.
+* NAMREA  name of default x-s.
+* NAMEDN  name of edit x-s.
+* IXSPRO  flag for cross section processing.
+* XSGEN   general x-s vector.
+* XSIGS   scattering x-s vector.
+* XSSCAT  general scattering matrix.
+*
+*-----------------------------------------------------------------------
+*
+      USE          GANLIB
+      IMPLICIT     NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR)  IPMACR
+      INTEGER      IPRINT,NGROUP,NANISO,NBMIXF,NIFISF,NEDF,NDELF,NREACD,
+     >             NTREA,IGR,NAMEDN(2,NEDF),IXSPRO(NTREA+2*NANISO+1)
+      CHARACTER    NAMREA(NREACD)*12
+      REAL         XSGEN(NBMIXF,NTREA+2),XSIGS(NBMIXF,NANISO),
+     >             XSSCAT(NGROUP,NBMIXF,NANISO)
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER      IOUT
+      PARAMETER   (IOUT=6)
+      INTEGER      IDEL,IMIX,IREA,IREAF,IREAP,IREAA,IED,IANIS,IGD,IGF,
+     >             JGR,ITC,NELEM,IOF
+      CHARACTER    NAMADD*12,CANISO*2,CHID*12,NUSIGD*12
+*----
+* ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISCAT
+      REAL, ALLOCATABLE, DIMENSION(:) :: SCTMP
+*----
+*  SCRATCH STORAGE ALLOCATION
+*   SCTMP   temporary scattering matrix
+*   ISCAT   scattering pointer
+*----
+      ALLOCATE(ISCAT(NBMIXF,3))
+      ALLOCATE(SCTMP(NGROUP*NBMIXF))
+*----
+*  PRINT HEADER
+*----
+      IF(IPRINT.GE.10) WRITE(IOUT,6000)
+*----
+*  1) DEFAULT XS
+*----
+      DO 100 IREA=1,NREACD
+        IF(IXSPRO(IREA).EQ.1) THEN
+          IF(IPRINT.GE.10) WRITE(IOUT,6010) NAMREA(IREA)
+          CALL LCMPUT(IPMACR,NAMREA(IREA),NBMIXF,2,XSGEN(1,IREA))
+        ENDIF
+ 100  CONTINUE
+*----
+*  2) CHI AND NUSIGF
+*----
+      IF(NIFISF.GT.0) THEN
+        IREAF=NREACD+1
+        IREAP=NREACD+NIFISF+1
+        IF(IXSPRO(IREAF).EQ.1) THEN
+          IF(IPRINT.GE.10) WRITE(IOUT,6010) 'NUSIGF      '
+          CALL LCMPUT(IPMACR,'NUSIGF',NBMIXF*NIFISF,2,XSGEN(1,IREAF))
+        ENDIF
+        IF(IXSPRO(IREAP).EQ.1) THEN
+          IF(IPRINT.GE.10) WRITE(IOUT,6010) 'CHI         '
+          CALL LCMPUT(IPMACR,'CHI',NBMIXF*NIFISF,2,XSGEN(1,IREAP))
+        ENDIF
+        DO 110 IDEL=1,NDELF
+          WRITE(NUSIGD,'(A6,I2.2)') 'NUSIGF',IDEL
+          IF(IPRINT.GE.10) WRITE(IOUT,6010) NUSIGD
+          IOF=IREAF+2*IDEL*NIFISF
+          CALL LCMPUT(IPMACR,NUSIGD,NBMIXF*NIFISF,2,XSGEN(1,IOF))
+          WRITE(CHID,'(A3,I2.2)') 'CHI',IDEL
+          IF(IPRINT.GE.10) WRITE(IOUT,6010) CHID
+          IOF=IREAP+2*IDEL*NIFISF
+          CALL LCMPUT(IPMACR,CHID,NBMIXF*NIFISF,2,XSGEN(1,IOF))
+ 110    CONTINUE
+      ENDIF
+*----
+*  3) ADDITIONAL EDIT XS
+*----
+      IF(NEDF.GT.0) THEN
+        IREAA=NREACD+2*NIFISF*(NDELF+1)
+        DO 120 IED=1,NEDF
+          IF(IXSPRO(IREAA+IED).EQ.1) THEN
+            WRITE(NAMADD,'(A4,A2)') (NAMEDN(ITC,IED),ITC=1,2)
+            IF(IPRINT.GE.10) WRITE(IOUT,6010) NAMADD
+            CALL LCMPUT(IPMACR,NAMADD,NBMIXF,2,XSGEN(1,IREAA+IED))
+          ENDIF
+ 120    CONTINUE
+      ENDIF
+*----
+*  4) SCATTERING XS
+*----
+      DO 130 IANIS=1,NANISO
+        IF(IXSPRO(NTREA+IANIS).EQ.1) THEN
+          WRITE(CANISO,'(I2.2)') IANIS-1
+          IF(IPRINT.GE.10) WRITE(IOUT,6010) 'SCATTERING'//CANISO
+          XSGEN(:NBMIXF,1)=0.0
+*----
+*  4.3) TREAT SCAT
+*----
+          NELEM=0
+          DO 140 IMIX=1,NBMIXF
+            IGD=IGR
+            IGF=IGR
+            XSGEN(IMIX,1)=XSSCAT(IGR,IMIX,IANIS)
+            DO 141 JGR=1,NGROUP
+              IF(XSSCAT(JGR,IMIX,IANIS).NE.0.0) THEN
+                IGD=MAX(IGD,JGR)
+                IGF=MIN(IGF,JGR)
+              ENDIF
+ 141        CONTINUE
+            ISCAT(IMIX,1)=IGD
+            ISCAT(IMIX,2)=IGD-IGF+1
+            ISCAT(IMIX,3)=NELEM+1
+            DO 142 JGR=IGD,IGF,-1
+              NELEM=NELEM+1
+              SCTMP(NELEM)=XSSCAT(JGR,IMIX,IANIS)
+ 142        CONTINUE
+ 140      CONTINUE
+          CALL LCMPUT(IPMACR,'SIGW'//CANISO,NBMIXF,2,XSGEN(1,1))
+          CALL LCMPUT(IPMACR,'IJJS'//CANISO,NBMIXF,1,ISCAT(1,1))
+          CALL LCMPUT(IPMACR,'NJJS'//CANISO,NBMIXF,1,ISCAT(1,2))
+          CALL LCMPUT(IPMACR,'IPOS'//CANISO,NBMIXF,1,ISCAT(1,3))
+          CALL LCMPUT(IPMACR,'SCAT'//CANISO,NELEM,2,SCTMP)
+        ENDIF
+        IF(IXSPRO(NTREA+NANISO+IANIS).EQ.1) THEN
+          CALL LCMPUT(IPMACR,'SIGS'//CANISO,NBMIXF,2,XSIGS(1,IANIS))
+        ENDIF
+ 130  CONTINUE
+      DEALLOCATE(SCTMP)
+      DEALLOCATE(ISCAT)
+*----
+*  6) STOPPING POWER
+*----
+      IF(IXSPRO(NTREA+2*NANISO+1).EQ.1) THEN
+        IF(IPRINT.GE.10) WRITE(IOUT,6010) 'ESTOPW'
+        CALL LCMPUT(IPMACR,'ESTOPW',2*NBMIXF,2,XSGEN(1,NTREA+1))
+      ENDIF
+      RETURN
+*----
+*  EDIT FORMATS
+*----
+ 6000 FORMAT(1X,'MACPRM - SAVING CROSS SECTIONS '/)
+ 6010 FORMAT(7X,   '   SAVING RECORD         : ',A12)
+      END