1 files changed, 105 insertions, 0 deletions
diff --git a/Dragon/src/EDIENE.f b/Dragon/src/EDIENE.f
new file mode 100644
index 0000000..b0bf359
--- /dev/null
+++ b/Dragon/src/EDIENE.f
@@ -0,0 +1,105 @@
+*DECK EDIENE
+      SUBROUTINE EDIENE(NGROUP,NGCR  ,NGCOND,NTENER,
+     >                  IGCR  ,EGCR  ,IGCOND,ENERGY,ENERV )
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Evaluate energy limits for condensation.
+*
+*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): G. Marleau
+*
+*Parameters: input/output
+* NGROUP  number of energy groups.
+* NGCR    number of condensed groups read on input.
+* NGCOND  number of condensed groups read on EDI.
+* NTENER  number of energy found on library.
+* IGCR    new group limits.
+* EGCR    new energy limits.
+* IGCOND  old group limits.
+* ENERGY  energy/lethargy/average energy.
+* ENERV   average group energy.
+*
+*-----------------------------------------------------------------------
+*
+      IMPLICIT    NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER     NGROUP,NGCR,NGCOND,NTENER
+      INTEGER     IGCR(NGROUP+1),IGCOND(NGROUP+1)
+      REAL        EGCR(NGROUP+1),ENERGY(2*NGROUP+1),ENERV(NGROUP)
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER     IOUT
+      CHARACTER   NAMSBR*6
+      PARAMETER  (IOUT=6,NAMSBR='EDIENE')
+      INTEGER     IGC,KDGRP,IGRP,JGRP,IGLIM
+*----
+*  FIND IF NEW ENERGY OR GROUP SPECIFICATIONS FROM INPUT
+*----
+      IF(NGCR .GT. 0) THEN
+        IGC=0
+        IF(EGCR(1) .NE. 0.0) THEN
+          IF(NTENER .EQ. 0)  CALL XABORT(NAMSBR//
+     >    ': CONDENSATION NOT PERMITTED - NO GROUP STRUCTURE')
+          KDGRP=1
+          DO 100 IGRP=1,NGROUP+1
+            IF(EGCR(IGRP) .LT. ENERGY(NGROUP+1)) THEN
+              KDGRP=NGROUP
+              IGC=IGC+1
+              IGCOND(IGC)=KDGRP
+            ELSE IF(EGCR(IGRP) .LT. ENERGY(KDGRP)) THEN
+              DO 110 JGRP=KDGRP,NGROUP
+                IF(EGCR(IGRP) .GE. ENERGY(JGRP+1)) THEN
+                  KDGRP=JGRP
+                  IGC=IGC+1
+                  IGCOND(IGC)=KDGRP
+                  GO TO 115
+                ENDIF
+ 110          CONTINUE
+ 115          CONTINUE
+            ENDIF
+            IF(KDGRP .EQ. NGROUP) GO TO 105
+ 100      CONTINUE
+ 105      CONTINUE
+        ELSE
+          DO 120 IGRP=1,NGROUP+1
+            IGCOND(IGRP)=IGCR(IGRP)
+            IF(IGCR(IGRP) .EQ. NGROUP) THEN
+              IGC=IGRP
+              GO TO 125
+            ENDIF
+ 120      CONTINUE
+ 125      CONTINUE
+        ENDIF
+        NGCOND=IGC
+      ENDIF
+      IF(NTENER .GT. 0) THEN
+*----
+*  FIND ENERGY LIMITS, LETHARGY AND AVERAGE ENERGY
+*----
+        DO 130 IGRP=1,NGROUP
+          ENERV(IGRP)=SQRT(ENERGY(IGRP)*ENERGY(IGRP+1))
+ 130    CONTINUE
+        DO 140 IGC=1,NGCOND
+          IGLIM=IGCOND(IGC)+1
+          ENERGY(IGC+1)=ENERGY(IGLIM)
+ 140    CONTINUE
+        IGLIM=NGCOND+1
+        IF(ENERGY(IGLIM) .EQ. 0.0) ENERGY(IGLIM)=1.0E-5
+        DO 150 IGC=1,NGCOND
+          IGLIM=IGLIM+1
+          ENERGY(IGLIM)=LOG(ENERGY(IGC)/ENERGY(IGC+1))
+ 150    CONTINUE
+      ENDIF
+      RETURN
+      END