Initial commit from Polytechnique Montreal

1 files changed, 180 insertions, 0 deletions

diff --git a/Dragon/src/LIBLIB.f b/Dragon/src/LIBLIB.f
new file mode 100644
index 0000000..53abc67
--- /dev/null
+++ b/Dragon/src/LIBLIB.f
@@ -0,0 +1,180 @@
+*DECK LIBLIB
+      SUBROUTINE LIBLIB (IPLIB,NBISO,MASKI,IMPX)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Transcription of the useful interpolated microscopic cross section
+* data from various format of libraries to LCM. A two dimensional
+* interpolation in temperature and dilution is performed (Part A).
+*
+*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
+* IPLIB   pointer to the lattice microscopic cross section library
+*         (L_LIBRARY signature).
+* NBISO   number of isotopes present in the calculation domain.
+* MASKI   isotopic masks. An isotope with index I is process if
+*         MASKI(I)=.true.
+* IMPX    print flag.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPLIB
+      INTEGER NBISO,IMPX
+      LOGICAL MASKI(*)
+*----
+*  INTERNAL PARAMETERS
+*----
+      INTEGER IOUT,MAXED,NSTATE
+      PARAMETER (IOUT=6,MAXED=50,NSTATE=40)
+*----
+*  LOCAL VARIABLES
+*----
+      TYPE(C_PTR) JPLIB,KPLIB
+      INTEGER IPAR(NSTATE),NGRO,NL,ITRANC,ITIME,NLIB,NGF,IGRMAX,NED,
+     > NDEL,IPROC,ILENG,ITYLCM,IVOID,NBESP,ISOT,NPART,IOF
+      CHARACTER HVECT(MAXED)*8,TEXT4*4,NAMLBT*8,TEXT12*12
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: NTFG,NIR,LSHI,ILLIB
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONA,ISONR,NAME,ISHIN
+      INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: IHLIB
+      REAL, ALLOCATABLE, DIMENSION(:) :: TMPIS,GIR
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: SN,SB
+      TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO
+*----
+*  RECOVER INFORMATION FROM THE /MICROLIB/ DIRECTORY.
+*----
+      CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR)
+      IF(NBISO.NE.IPAR(2)) CALL XABORT('LIBLIB: INCONSISTENT LIBRARY.')
+      NGRO=IPAR(3)
+      NL=IPAR(4)
+      ITRANC=IPAR(5)
+      ITIME=IPAR(7)
+      NLIB=IPAR(8)
+      NGF=IPAR(9)
+      IGRMAX=IPAR(10)
+      NED=IPAR(13)
+      IF(NED.GT.MAXED) CALL XABORT('LIBLIB: MAXED OVERFLOW.')
+      NBESP=IPAR(16)
+      IPROC=IPAR(17)
+      NDEL=IPAR(19)
+      CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT)
+*----
+*  MEMORY ALLOCATION.
+*----
+      ALLOCATE(ISONA(3,NBISO),ISONR(3,NBISO),IPISO(NBISO),TMPIS(NBISO),
+     > IHLIB(2,NBISO,4),ILLIB(NBISO),NAME(16,NLIB),NTFG(NBISO),
+     > ISHIN(3,NBISO),LSHI(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO),
+     > NIR(NBISO),GIR(NBISO))
+*----
+*  RECOVER ARRAYS.
+*----
+      CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONA)
+      CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONR)
+      JPLIB=LCMLID(IPLIB,'ISOTOPESLIST',NBISO)
+      CALL LCMGET(IPLIB,'ISOTOPESTEMP',TMPIS)
+      CALL LCMGET(IPLIB,'ILIBRARYTYPE',IHLIB(1,1,1))
+      CALL LCMGET(IPLIB,'ILIBRARYINDX',ILLIB)
+      CALL LCMGET(IPLIB,'ILIBRARYNAME',NAME)
+      CALL LCMLEN(IPLIB,'ISOTOPESNTFG',ILENG,ITYLCM)
+      IF(ILENG.GT.0) THEN
+         CALL LCMGET(IPLIB,'ISOTOPESNTFG',NTFG)
+         CALL LCMGET(IPLIB,'ISOTOPESCOH',IHLIB(1,1,2))
+         CALL LCMGET(IPLIB,'ISOTOPESINC',IHLIB(1,1,3))
+      ELSE
+         NTFG(:NBISO)=0
+      ENDIF
+      CALL LCMLEN(IPLIB,'ISOTOPESRESK',ILENG,ITYLCM)
+      IF(ILENG.GT.0) THEN
+         CALL LCMGET(IPLIB,'ISOTOPESRESK',IHLIB(1,1,4))
+      ELSE
+         NAMLBT=','
+         DO ISOT=1,NBISO
+            IOF=6*NBISO+(ISOT-1)*2
+            READ(NAMLBT,'(2A4)') IHLIB(:2,1,4)
+         ENDDO
+      ENDIF
+      CALL LCMLEN(IPLIB,'ISOTOPESHIN',ILENG,ITYLCM)
+      IF(ILENG.GT.0) THEN
+         CALL LCMGET(IPLIB,'ISOTOPESHIN',ISHIN)
+      ELSE
+         TEXT4=' '
+         READ(TEXT4,'(A4)') IVOID
+         ISHIN(:2,:NBISO)=IVOID
+      ENDIF
+      CALL LCMLEN(IPLIB,'ISOTOPESSHI',ILENG,ITYLCM)
+      IF(ILENG.GT.0) THEN
+         CALL LCMGET(IPLIB,'ISOTOPESSHI',LSHI)
+      ELSE
+         LSHI(:NBISO)=0
+      ENDIF
+      CALL LCMLEN(IPLIB,'ISOTOPESDSN',ILENG,ITYLCM)
+      IF(ILENG.GT.0) THEN
+         CALL LCMGET(IPLIB,'ISOTOPESDSN',SN)
+         CALL LCMGET(IPLIB,'ISOTOPESDSB',SB)
+      ELSE
+         SN(:NGRO,:NBISO)=1.0E10
+         SB(:NGRO,:NBISO)=1.0E10
+      ENDIF
+      CALL LCMLEN(IPLIB,'ISOTOPESNIR',ILENG,ITYLCM)
+      IF(ILENG.GT.0) THEN
+         CALL LCMGET(IPLIB,'ISOTOPESNIR',NIR)
+         CALL LCMGET(IPLIB,'ISOTOPESGIR',GIR)
+      ELSE
+         NIR(:NBISO)=0
+         GIR(:NBISO)=0.0
+      ENDIF
+      DO ISOT=1,NBISO
+        IF(MASKI(ISOT).AND.(ILLIB(ISOT).NE.0)) THEN
+          IPISO(ISOT)=LCMDIL(JPLIB,ISOT) ! set ISOT-th isotope
+        ELSE
+          IPISO(ISOT)=C_NULL_PTR
+        ENDIF
+      ENDDO
+*----
+*  RECOVER AND INTERPOLATE MICROSCOPIC CROSS SECTIONS.
+*----
+      CALL LIBLIC (IPLIB,NBISO,MASKI,IMPX,NGRO,NL,ITRANC,ITIME,NLIB,
+     1 NED,HVECT,ISONA,ISONR,IPISO,ISHIN,TMPIS,IHLIB,ILLIB,NAME,NTFG,
+     2 LSHI,SN,SB,NIR,GIR,NGF,IGRMAX,NDEL,NBESP,NPART,IPROC)
+*----
+*  RESET ISOTOPE ALIAS.
+*----
+      DO ISOT=1,NBISO
+        KPLIB=IPISO(ISOT)
+        IF(C_ASSOCIATED(KPLIB)) THEN
+          WRITE(TEXT12,'(3A4)') ISONA(:3,ISOT)
+          CALL LCMPTC(KPLIB,'ALIAS',12,TEXT12)
+        ENDIF
+      ENDDO
+*
+      DEALLOCATE(GIR,NIR,SB,SN,LSHI,NTFG,NAME,ILLIB,IHLIB,TMPIS,ISHIN,
+     1 IPISO,ISONR,ISONA)
+*
+      IPAR(9)=NGF
+      IPAR(10)=IGRMAX
+      IPAR(16)=NBESP
+      IPAR(19)=NDEL
+      IPAR(26)=NPART-1
+      CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,IPAR)
+      IF(IMPX.GT.9) THEN
+         WRITE (IOUT,'(36H LIBLIB: VALIDATION OF MICROLIB DATA)')
+         CALL LCMVAL(IPLIB,' ')
+      ENDIF
+      RETURN
+      END