Initial commit from Polytechnique Montreal

1 files changed, 123 insertions, 0 deletions

diff --git a/Dragon/src/LIBDI4.f b/Dragon/src/LIBDI4.f
new file mode 100644
index 0000000..457bc82
--- /dev/null
+++ b/Dragon/src/LIBDI4.f
@@ -0,0 +1,123 @@
+*DECK LIBDI4
+      SUBROUTINE LIBDI4 (MAXDIL,NAMFIL,HSHI,NDIL,DILUT)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Find the dilutions corresponding to a resonant isotope within a
+* library in Apolib-1 format.
+*
+*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
+* MAXDIL  maximum number of dilutions.
+* NAMFIL  name of the Apolib file.
+* HSHI    library name of the self-shielding data.
+*
+*Parameters: output
+* NDIL    number of finite dilutions.
+* DILUT   dilutions.
+*
+*-----------------------------------------------------------------------
+*
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER MAXDIL,NDIL
+      CHARACTER NAMFIL*(*),HSHI*12
+      REAL DILUT(MAXDIL)
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER (MAXIT=1000)
+      CHARACTER FORM*4,HSMG*131
+      INTEGER IT(MAXIT),NTETA(3)
+      REAL, ALLOCATABLE, DIMENSION(:) :: WORK
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(WORK(MAXDIL))
+*
+      NIN=KDROPN(NAMFIL,2,2,0)
+      IF(NIN.LE.0) THEN
+         WRITE (HSMG,'(35HLIBDI4: UNABLE TO OPEN LIBRARY FILE,1X,A16,
+     1   6H. NIN=,I4,1H.)') NAMFIL,NIN
+         CALL XABORT(HSMG)
+      ENDIF
+      I=INDEX(HSHI,' ')
+      IF(HSHI.EQ.' ') THEN
+         NISBEF=0
+      ELSE IF(I.EQ.0) THEN
+         READ(HSHI,'(I8)') NISBEF
+      ELSE
+         WRITE(FORM,'(2H(I,I1,1H))') I-1
+         READ(HSHI,FORM) NISBEF
+      ENDIF
+   10 READ(NIN) INDLOR,NR,NIT,(IT(I),I=1,NIT),(DUMMY,I=1,18)
+      IF(NIT.GT.MAXIT) CALL XABORT('LIBDI4: INVALID MAXIT.')
+      IF(INDLOR.EQ.9999) THEN
+         CALL XABORT('LIBDI4: UNABLE TO FIND ISOTOPE '//HSHI//'.')
+      ELSE IF(INDLOR.EQ.NISBEF) THEN
+         NTYPE=0
+         JTYSEC=0
+         DO 20 IK=1,IT(4)
+         IF(IT(IK+4).NE.JTYSEC) THEN
+            NTYPE=NTYPE+1
+            NTETA(NTYPE)=1
+            JTYSEC=IT(IK+4)
+         ELSE
+            NTETA(NTYPE)=NTETA(NTYPE)+1
+         ENDIF
+   20    CONTINUE
+         DO 55 I=1,NTYPE
+         READ (NIN) TEMP,NSEI,(WORK(K),K=1,NSEI)
+         IF(NSEI.GT.MAXDIL) CALL XABORT('LIBDI4: INVALID MAXDIL.')
+         IF(I.EQ.1) THEN
+            NDIL=NSEI
+            DO 30 K=NSEI,1,-1
+            IF(WORK(K).GE.1.0E10) THEN
+               NDIL=NDIL-1
+            ELSE
+               DILUT(K)=WORK(K)
+            ENDIF
+   30       CONTINUE
+            DILUT(NDIL+1)=1.0E10
+         ELSE
+            DO 40 K=NSEI,1,-1
+            IF((WORK(K).LT.1.0E10).AND.(WORK(K).NE.DILUT(K))) THEN
+               WRITE(HSMG,'(26HLIBDI4: INVALID DILUTION (,1P,E12.4,
+     1         9H) ON TYPE,I2,11H REACTIONS.,E12.4,10H EXPECTED.)')
+     2         WORK(K),I,DILUT(K)
+               CALL XABORT(HSMG)
+            ENDIF
+   40       CONTINUE
+         ENDIF
+         DO 50 ITET=2,NTETA(I)
+         READ(NIN)
+   50    CONTINUE
+   55    CONTINUE
+      ELSE
+         DO 60 K=1,NR
+         READ(NIN)
+   60    CONTINUE
+         GO TO 10
+      ENDIF
+      IER=KDRCLS(NIN,1)
+      IF(IER.LT.0) THEN
+         WRITE (HSMG,'(36HLIBDI4: UNABLE TO CLOSE LIBRARY FILE,1X,A16,
+     1   1H.)') NAMFIL
+         CALL XABORT(HSMG)
+      ENDIF
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(WORK)
+      RETURN
+      END