Initial commit from Polytechnique Montreal

1 files changed, 114 insertions, 0 deletions

diff --git a/Dragon/src/LIBECT.f b/Dragon/src/LIBECT.f
new file mode 100644
index 0000000..327fc62
--- /dev/null
+++ b/Dragon/src/LIBECT.f
@@ -0,0 +1,114 @@
+*DECK LIBECT
+      SUBROUTINE LIBECT(MAXTRA,LLL,PRI,UUU,DELI,DELTA,NEXT,III,MML,STIS)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Build the elastic scattering law for neutrons with secondary energy
+* in group LLL.
+*
+*Copyright:
+* Copyright (C) 2002 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
+* MAXTRA  dimension of array PRI.
+* LLL     secondary energy group index.
+* PRI     info to rebuild the scat matrix.
+* UUU     lethargy limits of the fine groups.
+* DELI    elementary lethargy width.
+* DELTA   lethargy width of each energy group.
+* NEXT    length of x-s structure for the current isotope.
+* III     offset in PRI array for the current isotope.
+*
+*Parameters: output
+* MML     number of down-scattering groups (including group LLL).
+* STIS    values of the transfer macroscopic cross section:
+*         STIS(1):     from group LLL;
+*         STIS(2):     from group LLL-1;
+*         STIS(LLL):   from group 1.
+*
+*-----------------------------------------------------------------------
+*
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER LLL,NEXT,III,MML
+      REAL PRI(MAXTRA),UUU(LLL),DELI,DELTA(LLL),STIS(LLL)
+*----
+*  LOCAL VARIABLES
+*----
+      DOUBLE PRECISION DAUX
+*
+      STIS(:LLL)=0.0
+      MML=1
+      MM=0
+      LDELH=INT(UUU(LLL)/DELI+0.1)
+      LARGRL=INT(DELTA(LLL)/DELI+0.1)
+      LDELB=LDELH-LARGRL+1
+      IHM=III+NEXT-1
+      LTES=LDELB-NEXT
+      INDICE=1
+      INTER2=0
+      J=0
+      DO 70 MM1=1,LLL
+      MM=LLL-MM1+1
+      MDELH=INT(UUU(MM)/DELI+0.1)
+      IF(MDELH.LE.LTES) THEN
+         MM=MM+1
+         GO TO 80
+      ENDIF
+      LARGRM=INT(DELTA(MM)/DELI+0.1)
+      MDELB=MAX(MDELH-LARGRM+1,LTES+1)
+      DAUX=0.0D0
+      LARG=MIN(LARGRM,LARGRL)
+      IF(LARG.LE.4) THEN
+         DO 20 MDEL=MDELB,MDELH
+         IBAS=MAX(LDELB-MDEL+III,III)
+         IHAUT=MIN(LDELH-MDEL+III,IHM)
+         DO 10 I=IBAS,IHAUT
+         DAUX=DAUX+PRI(I)
+   10    CONTINUE
+   20    CONTINUE
+         GO TO 60
+      ENDIF
+      IHAUT=MIN(LDELH-MDELB+III,IHM)
+      IF(INDICE.EQ.1) THEN
+         INDICE=2
+         INTER2=III-1
+         J=LARG+1
+      ELSE IF(INDICE.EQ.2) THEN
+         J=0
+         IBAS=MAX(LDELB-MDELH+III,III)
+         LARGLI=ABS(LARGRM-LARGRL)
+         INTER1=MIN(IBAS+LARG-2,IHAUT)
+         DO 30 I=IBAS,INTER1
+         J=J+1
+         DAUX=DAUX+PRI(I)*REAL(J)
+   30    CONTINUE
+         INTER1=INTER1+1
+         INTER2=MIN(IHAUT,INTER1+LARGLI)
+         IF(INTER1.GT.INTER2) GO TO 60
+         J=LARG
+         DO 40 I=INTER1,INTER2
+         DAUX=DAUX+PRI(I)*REAL(LARG)
+   40    CONTINUE
+      ENDIF
+      INTER2=INTER2+1
+      IF(INTER2.GT.IHAUT) GO TO 60
+      DO 50 I=INTER2,IHAUT
+      J=J-1
+      DAUX=DAUX+PRI(I)*REAL(J)
+   50 CONTINUE
+*
+   60 STIS(MM1)=REAL(DAUX)
+      STIS(MM1)=STIS(MM1)*DELI/DELTA(MM)
+   70 CONTINUE
+   80 MML=LLL-MM+1
+      RETURN
+      END