Initial commit from Polytechnique Montreal

1 files changed, 110 insertions, 0 deletions

diff --git a/Dragon/src/INFAPL.f b/Dragon/src/INFAPL.f
new file mode 100644
index 0000000..7587d8c
--- /dev/null
+++ b/Dragon/src/INFAPL.f
@@ -0,0 +1,110 @@
+*DECK INFAPL
+      SUBROUTINE INFAPL(CFILNA,IPRINT,NBISO,HNAMIS,AWR)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* To recover mass for isotopes of APOLIB libraries.
+*
+*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
+* CFILNA  APOLIB1 file name.
+* IPRINT  print flag.
+* NBISO   number of isotopes.
+* HNAMIS  isotope names.
+*
+*Parameters: output
+* AWR     isotope weights.
+*
+*-----------------------------------------------------------------------
+*
+      IMPLICIT NONE
+*----
+* PARAMETERS
+*----
+      INTEGER    IOUT,MAXIT
+      PARAMETER (IOUT=6,MAXIT=1000)
+*----
+* FUNCTIONS
+*----
+      INTEGER    KDROPN,KDRCLS
+      DOUBLE PRECISION XDRCST
+*----
+* LOCAL VARIABLES
+*----
+      INTEGER    NBISO,IPRINT,IUNIT,IISO,INDLOR,NR,NIT,I,K,IMX,NISB,
+     1           NRST,ICC,NS1,IC,NRSTR,NN,IER
+      INTEGER    IT(MAXIT)
+*
+      REAL       AA
+      REAL       AWR(NBISO)
+      CHARACTER  CFILNA*64,HNAMIS(NBISO)*8,HNISOR*8,FORM*4
+      EQUIVALENCE(AA,NN)
+      REAL       CONVM
+*----
+* OPEN APOLIB
+*----
+      CONVM=REAL(XDRCST('Neutron mass','amu'))
+      IF( IPRINT.GT.0 ) THEN
+        WRITE(IOUT,6000) CFILNA
+      ENDIF
+      IUNIT=KDROPN(CFILNA,2,2,0)
+      IF( IUNIT.LE.0 )THEN
+        WRITE(IOUT,9000) CFILNA
+        CALL XABORT('INFAPL: APOL LIBRARY CANNOT BE OPENED')
+      ENDIF
+      IISO= 0
+      REWIND(IUNIT)
+   50 READ(IUNIT) INDLOR,NR,NIT,(IT(I),I=1,NIT)
+      IF( NIT.GT.MAXIT ) CALL XABORT('INFAPL: MAXIT IS TOO SMALL')
+      IF(INDLOR.EQ.9999) GO TO 700
+      DO 70 IMX=1,NBISO
+         HNISOR= HNAMIS(IMX)
+         I=INDEX(HNISOR,' ')
+         IF(I.EQ.0) THEN
+            READ(HNISOR,'(I8)') NISB
+         ELSE
+            WRITE(FORM,'(2H(I,I1,1H))') I-1
+            READ(HNISOR,FORM) NISB
+         ENDIF
+         IF( NISB.EQ.INDLOR )THEN
+            IF( IPRINT.GT.0 ) WRITE(IOUT,6001) HNISOR
+            IISO= IISO + 1
+            NRST= IT(4)
+            NS1= 0
+            IF( IT(5).LT.0 ) NS1= -IT(5)
+            IC=5+NS1+NRST
+            NRSTR=IT(IC)
+            ICC=IC+6*NRSTR+1
+            NN=IT(ICC)
+            AWR(IMX)=AA*CONVM
+         ENDIF
+   70 CONTINUE
+      DO 80 K=1,NR
+      READ(IUNIT)
+   80 CONTINUE
+      GO TO 50
+*
+*     CHECK IF ALL NBISO ISOTOPES HAVE BEEN PROCESSED.
+  700 IF( IISO.NE.NBISO )THEN
+         CALL XABORT('INFAPL: SOME ISOTOPES WERE NOT RECOVERED')
+      ENDIF
+*
+*     CLOSE APOLIB FILE.
+      IER=KDRCLS(IUNIT,1)
+      IF(IER.LT.0) CALL XABORT(
+     > 'INFAPL: Impossible to close library '//CFILNA)
+      RETURN
+*
+ 9000 FORMAT(/' ERROR IN PROCESSING APOL LIBRARY:',A8)
+ 6000 FORMAT(/' PROCESSING APOL LIBRARY NAME ',A8)
+ 6001 FORMAT(/'    PROCESSING ISOTOPE/MATERIAL = ',A12)
+      END