Initial commit from Polytechnique Montreal

1 files changed, 120 insertions, 0 deletions

diff --git a/Dragon/src/INFWIM.f b/Dragon/src/INFWIM.f
new file mode 100644
index 0000000..eab4bbf
--- /dev/null
+++ b/Dragon/src/INFWIM.f
@@ -0,0 +1,120 @@
+*DECK INFWIM
+      SUBROUTINE INFWIM(CFILNA,IPRINT,NBISO,HNAMIS,AWR)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* To recover mass for isotopes of WIMS-AECL 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): G. Marleau
+*
+*Parameters: input
+* CFILNA  WIMS file name.
+* IPRINT  print flag.
+* NBISO   number of isotopes.
+* HNAMIS  isotope names.
+*
+*Parameters: output
+* AWR     isotope weights
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER    IOUT,IUTYPE,IACTO,LRIND,MAXISO,MAXTEM,NCT,
+     >           LPZ,LMASTB,LMASIN,LGENTB,LGENIN,LSUBTB,LSUBIN
+      PARAMETER (IOUT=6,IUTYPE=4,IACTO=2,LRIND=256,
+     >           MAXISO=246,MAXTEM=20,
+     >           NCT=10,LPZ=9,LMASTB=MAXISO+9,
+     >           LMASIN=LMASTB-4,LGENTB=6,LGENIN=LGENTB,
+     >           LSUBTB=6*MAXTEM+28,LSUBIN=LSUBTB-12)
+      INTEGER    MASTER(LMASTB),GENINX(LGENTB),SUBINX(LSUBTB),
+     >           IWISO(MAXISO),IPRINT,NBISO,NPZ(LPZ),
+     >           ITITLE(2*NCT)
+      CHARACTER  CFILNA*64,HNAMIS(NBISO)*8,
+     >           CWISO(MAXISO)*8,CTITLE(NCT)*8
+      REAL       ZUBINX(LSUBTB),AWR(NBISO)
+      INTEGER    IUNIT,IRISO,ISO,JSO,II,KDROPN
+      EXTERNAL   KDROPN
+      EQUIVALENCE (SUBINX(1),ZUBINX(1))
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: ICISO
+*
+      IF( CFILNA.EQ.' ' )THEN
+        CALL XABORT('INFWIM: WIMS LIBRARY HAS NOT BEEN SET')
+      ENDIF
+*----
+*  OPEN WIMSLIB AND READ TITLE
+*----
+      IRISO=0
+      IUNIT=KDROPN(CFILNA,IACTO,IUTYPE,LRIND)
+      IF(IUNIT.LE.0) CALL XABORT(
+     > 'INFWIM: WIMS-AECL LIBRARY CANNOT BE OPENED FOR MIXS :'//CFILNA)
+      CALL OPNIND(IUNIT,MASTER,LMASTB)
+      CALL REDIND(IUNIT,MASTER,LMASIN,GENINX,LGENTB,1)
+      IF(IPRINT.GT.0) THEN
+        CALL REDIND(IUNIT,MASTER,LMASIN,ITITLE,2*NCT,2)
+        CALL UPCKIC(ITITLE(1),CTITLE(1),NCT)
+        WRITE(IOUT,6000) CFILNA
+        WRITE(IOUT,'(1X,10A8)') (CTITLE(II),II=1,NCT)
+      ENDIF
+*----
+*  READ GENERAL INDEX, ISOTOPES NAMES AND GROUP STRUCTURE
+*----
+      CALL REDIND(IUNIT,GENINX,LGENIN,NPZ,LPZ,1)
+      CALL REDIND(IUNIT,GENINX,LGENIN,IWISO,NPZ(1),2)
+      ALLOCATE(ICISO(2*NPZ(1)))
+      CALL REDIND(IUNIT,GENINX,LGENIN,ICISO,2*NPZ(1),3)
+      CALL UPCKIC(ICISO(1),CWISO(1),NPZ(1))
+      IF(IPRINT.GE.100) THEN
+        WRITE(IOUT,6200) (CWISO(II),II=1,NPZ(1))
+      ENDIF
+      DEALLOCATE(ICISO)
+*----
+* READ THROUGH DRAGON FILE AND ACCUMULATE WEIGHTS.
+*----
+      DO 120 ISO=1,NBISO
+        DO 130 JSO=1,NPZ(1)
+          IF(CWISO(JSO).EQ.HNAMIS(ISO)) THEN
+            IRISO=JSO
+            GO TO 131
+          ENDIF
+ 130    CONTINUE
+        WRITE(IOUT,9002) HNAMIS(ISO),CFILNA
+        CALL XABORT('INFWIM: ISOTOPE NOT FOUND ON LIBRARY')
+ 131    CONTINUE
+        IF(IPRINT.GT.0) THEN
+          WRITE(IOUT,6001) HNAMIS(ISO)
+        ENDIF
+*----
+*  READ SUB INDEX ASSOCIATED WITH ISOTOPE
+*----
+        CALL REDIND(IUNIT,MASTER,LMASIN,SUBINX,LSUBTB,IRISO+4)
+        AWR(ISO)=ZUBINX(LSUBIN+3)
+ 120  CONTINUE
+      CALL CLSIND(IUNIT)
+*----
+*  RETURN
+*----
+      RETURN
+*----
+*  FORMAT
+*----
+ 9002 FORMAT(/' INFWIM: MATERIAL/ISOTOPE ',A8,' IS MISSING ON WIMS',
+     >        ' FILE NAME ',A64)
+ 6000 FORMAT(/' PROCESSING WIMS LIBRARY NAME ',A64)
+ 6001 FORMAT(/'    PROCESSING ISOTOPE/MATERIAL = ',A12)
+ 6200 FORMAT(1X,'ISOTOPES ON LIBRARY'/6(4X,A8))
+      END