Initial commit from Polytechnique Montreal

1 files changed, 163 insertions, 0 deletions

diff --git a/Dragon/src/INFTR1.f b/Dragon/src/INFTR1.f
new file mode 100644
index 0000000..84fce62
--- /dev/null
+++ b/Dragon/src/INFTR1.f
@@ -0,0 +1,163 @@
+*DECK INFTR1
+      SUBROUTINE INFTR1(CFILNA,IPRINT,NBISO,HNAMIS,AWRISO)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* To recover mass for isotopes of MATXS type libraries
+* use MATXS format from NJOY-II or NJOY89.
+*
+*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  file name.
+* IPRINT  print flag.
+* NBISO   number of isotopes.
+* HNAMIS  isotope names.
+*
+*Parameters: output
+* AWRISO  isotope weights.
+*
+*Reference:
+* R. E. MACFARLANE, TRANSX-CTR: A code for interfacing
+* MATXS cross-section libraries to nuclear transport codes for
+* fusion systems analysis, Los Alamos National Laboratory,
+* Report LA-9863-MS, New Mexico, February 1984.
+*
+*-----------------------------------------------------------------------
+*
+      USE XDRMOD
+      IMPLICIT         NONE
+      INTEGER          IPRINT,NBISO
+      CHARACTER        CFILNA*64,HNAMIS(NBISO)*8
+      REAL             AWRISO(NBISO)
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER          IOUT,MULT,MAXA
+      CHARACTER        FORM*4
+      PARAMETER       (IOUT=6,MULT=2,MAXA=1000,FORM='(A6)')
+*----
+* FUNCTIONS
+*----
+      INTEGER          KDROPN,KDRCLS
+      DOUBLE PRECISION XDRCST
+      INTEGER          NIN,IREC,NWDS,NPART,NTYPE,L2,L2H,IRZT,IT,
+     >                 NDEX,NMAT,NINP,NING,NOUTP,NOUTG,LOCT,LMC,
+     >                 IRZM,IM,ISO,LOC,IER,IA(MAXA)
+      CHARACTER        HSMG*131,HTYPE*6,HMAT*6
+      REAL             RA(MAXA)
+      DOUBLE PRECISION DA(MAXA/2)
+      REAL             CONVM
+      EQUIVALENCE     (RA(1),IA(1),DA(1))
+*----
+*  OPEN MATXS FILE AND INITIALIZE LIBRARY
+*----
+      CONVM=REAL(XDRCST('Neutron mass','amu'))
+      NIN=KDROPN(CFILNA,2,2,0)
+      IF(NIN.LE.0) THEN
+        WRITE(HSMG,9000) CFILNA
+        CALL XABORT(HSMG)
+      ENDIF
+      IREC=2
+      NWDS=3
+*-------FILE CONTROL---------------
+      CALL XDREED(NIN,IREC,RA,NWDS)
+*----------------------------------
+      NPART=IA(1)
+      NTYPE=IA(2)
+      IREC=4
+      NWDS=(NPART+NTYPE)*MULT+6*NTYPE+NPART
+      IF(NWDS.GT.MAXA) CALL XABORT
+     >  ('INFTR1: LENGTH OF RECORD 4 > MAXA ')
+*-------FILE DATA------------------
+      CALL XDREED(NIN,IREC,RA,NWDS)
+*----------------------------------
+      IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1
+      L2=1+NWDS
+      L2H=(L2-1)/MULT+1
+      IRZT=5+NPART
+*----
+*  DATA TYPE LOOP
+*----
+      DO 100 IT=1,NTYPE
+        WRITE(HTYPE,FORM) DA(NPART+IT)
+        CALL XDRCAS('LOWTOUP',HTYPE)
+        IF(HTYPE.NE.'NSCAT'.AND.HTYPE.NE.'NTHERM') GO TO 105
+        NDEX=(NPART+NTYPE)*MULT+IT
+        NMAT=IA(NDEX)
+        NDEX=NDEX+NTYPE
+        NINP=IA(NDEX)
+        NDEX=NDEX+NTYPE
+        NING=IA(NDEX)
+        NDEX=NDEX+NTYPE
+        NOUTP=IA(NDEX)
+        NDEX=NDEX+NTYPE
+        NOUTG=IA(NDEX)
+        NDEX=NDEX+NTYPE
+        LOCT=IA(NDEX)
+*----
+*  DATA TYPE CONTROL
+*----
+        IREC=LOCT+IRZT
+        NWDS=(2+MULT)*NMAT+NINP+NOUTP+1
+        IF(L2+NWDS-1.GT.MAXA)  CALL XABORT
+     >    ('INFTR1: LENGTH OF CURRENT RECORD > MAXA ')
+*----------------------------------------
+        CALL XDREED(NIN,IREC,RA(L2),NWDS)
+*----------------------------------------
+        IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1
+        LMC=L2+NWDS
+        IRZM=IREC+1
+*----
+*  READ THROUGH MATXS FILE AND GET AWR FOR ISOTOPES
+*----
+        DO 110 IM=1,NMAT
+          WRITE(HMAT,FORM) DA(L2H-1+IM)
+          DO 120 ISO=1,NBISO
+            IF(HMAT.EQ.HNAMIS(ISO)(:6)) THEN
+              LOC=L2-1+MULT*NMAT+IM
+              IREC=IA(LOC+NMAT)+IRZM
+              NWDS=MULT+1+6*IA(LOC)
+              IF(LMC+NWDS-1.GT.MAXA) CALL XABORT
+     >          ('INFTR1: LENGTH OF CURRENT RECORD > MAXA ')
+*-------------------------------------------
+              CALL XDREED(NIN,IREC,RA(LMC),NWDS)
+*-------------------------------------------
+              AWRISO(ISO)=RA(LMC+MULT)*CONVM
+              IF(IPRINT.GE.100) THEN
+                WRITE(IOUT,6000) HNAMIS(ISO),AWRISO(ISO)
+              ENDIF
+            ENDIF
+ 120      CONTINUE
+ 110    CONTINUE
+ 105    CONTINUE
+ 100  CONTINUE
+*----
+*  CLOSE MATXS FILE.
+*----
+      CALL XDRCLS(NIN)
+      IER=KDRCLS(NIN,1)
+      IF(IER.LT.0) THEN
+        WRITE(HSMG,9001) CFILNA
+        CALL XABORT(HSMG)
+      ENDIF
+      RETURN
+*----
+*  PRINT FORMATS
+*----
+ 6000 FORMAT(' MATXS ISOTOPE =',A8,
+     >       ' HAS ATOMIC WEIGHT RATIO = ',F10.3)
+*----
+*  ABORT FORMATS
+*----
+ 9000 FORMAT('INFTR1: UNABLE TO OPEN MATXS LIBRARY FILE ',A64)
+ 9001 FORMAT('INFTR1: UNABLE TO CLOSE MATXS LIBRARY FILE ',A64)
+      END