Initial commit from Polytechnique Montreal

1 files changed, 276 insertions, 0 deletions

diff --git a/Dragon/src/TONE.f b/Dragon/src/TONE.f
new file mode 100644
index 0000000..e5c3faa
--- /dev/null
+++ b/Dragon/src/TONE.f
@@ -0,0 +1,276 @@
+*DECK TONE
+      SUBROUTINE TONE(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Interpolation of nuclear properties in a lattice code library using
+* the Tone's method.
+*
+*Copyright:
+* Copyright (C) 2017 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/output
+* NENTRY  number of LCM objects or files used by the operator.
+* HENTRY  name of each LCM object or file. When 3 object are present:
+*         HENTRY(1) modification type(L_LIBRARY);
+*         HENTRY(2) read-only type(L_TRACK);
+*         HENTRY(3) read-only sequential binary tracking file.
+*         When 4 object are present:
+*         HENTRY(1) creation type(L_LIBRARY);
+*         HENTRY(2) read-only type(L_LIBRARY);
+*         HENTRY(3) read-only type(L_TRACK);
+*         HENTRY(4) read-only sequential binary tracking file.
+* IENTRY  type of each LCM object or file:
+*         =1 LCM memory object; =2 XSM file; =3 sequential binary file;
+*         =4 sequential ascii file.
+* JENTRY  access of each LCM object or file:
+*         =0 the LCM object or file is created;
+*         =1 the LCM object or file is open for modifications;
+*         =2 the LCM object or file is open in read-only mode.
+* KENTRY  LCM object address or file unit number.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER      NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
+      TYPE(C_PTR)  KENTRY(NENTRY)
+      CHARACTER    HENTRY(NENTRY)*12
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER(NSTATE=40)
+      CHARACTER HSMG*131,TEXT12*12,HSIGN*12,TEXT4*4,CDOOR*12,TITLE*72
+      INTEGER IPAR(NSTATE),IGP(NSTATE)
+      DOUBLE PRECISION DFLOTT
+      LOGICAL LEAKSW
+      TYPE(C_PTR) IPLIB,IPTRK
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT,IDL,MIX,LSHI,ISONR,ISONA
+      REAL, ALLOCATABLE, DIMENSION(:) :: VOL,DEN,SNGAR
+*----
+*  PARAMETER VALIDATION
+*----
+      IENT=1
+      IF(NENTRY.LE.1) CALL XABORT('TONE: TWO PARAMETERS EXPECTED.')
+      IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('TONE: LCM '
+     1 //'OBJECT EXPECTED AT LHS.')
+      IF(JENTRY(1).EQ.0) THEN
+*        INTERNAL LIBRARY CREATION. COPY THE FIRST RHS ON THIS LHS.
+         IF(NENTRY.LE.2) CALL XABORT('TONE: THREE PARAMETERS EXPECTED.')
+         IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.
+     1   (IENTRY(2).NE.2)))  CALL XABORT('TONE: LCM OBJECT IN READ-ONLY'
+     2   //'MODE EXPECTED AT FIRST RHS.')
+         CALL LCMEQU(KENTRY(2),KENTRY(1))
+         IENT=3
+      ELSE IF(JENTRY(1).EQ.1) THEN
+*        INTERNAL LIBRARY MODIFICATION.
+         IENT=2
+      ELSE
+         CALL XABORT('TONE: INTERNAL LIBRARY IN CREATE OR MODIFICATION '
+     1   //'MODE EXPECTED.')
+      ENDIF
+      IPLIB=KENTRY(1)
+*----
+*  RECOVER THE TRACKING OBJECT
+*----
+      DO 10 I=IENT,NENTRY
+      IF((JENTRY(I).EQ.2).AND.(IENTRY(I).LE.2)) THEN
+         CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN)
+         IF(HSIGN.EQ.'L_TRACK') THEN
+            IPTRK=KENTRY(I)
+            GO TO 20
+         ENDIF
+      ENDIF
+   10 CONTINUE
+      CALL XABORT('TONE: UNABLE TO FIND A TRACKING OBJECT.')
+   20 CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CDOOR)
+*----
+*  RECOVER TRACKING FILE INFORMATION
+*----
+      IFTRAK=0
+      DO 40 I=IENT+1,NENTRY
+      IF(IENTRY(I).EQ.3) THEN
+         IFTRAK=FILUNIT(KENTRY(I))
+         TEXT12=HENTRY(I)
+         IF(JENTRY(I).NE.2) CALL XABORT('TONE: TRACKING FILE '//TEXT12//
+     1   ' NOT IN READ-ONLY MODE.')
+         GO TO 50
+      ENDIF
+   40 CONTINUE
+*----
+*  RECOVER TABULATED FUNCTIONS
+*----
+   50 CALL XDRTA2
+*----
+*  RECOVER GENERAL TRACKING INFORMATION
+*----
+      CALL LCMGET(IPTRK,'STATE-VECTOR',IGP)
+      NREG=IGP(1)
+      NUN=IGP(2)
+      LEAKSW=IGP(3).EQ.0
+      IF(CDOOR.EQ.'MCCG') THEN
+         CALL LCMLEN(IPTRK,'KEYFLX',LKFL,ITYLCM)
+         NFUNL=LKFL/NREG
+      ELSE
+         NFUNL=1
+      ENDIF
+      ALLOCATE(MAT(NREG),VOL(NREG),IDL(NREG*NFUNL))
+      CALL LCMGET(IPTRK,'MATCOD',MAT)
+      CALL LCMGET(IPTRK,'VOLUME',VOL)
+      CALL LCMGET(IPTRK,'KEYFLX',IDL)
+      CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM)
+      IF(LENGT.GT.0) THEN
+         CALL LCMGTC(IPTRK,'TITLE',72,TITLE)
+      ELSE
+         TITLE='*** NO TITLE PROVIDED ***'
+      ENDIF
+*----
+*  RECOVER GENERAL INTERNAL LIBRARY INFORMATION
+*----
+      CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN)
+      IF(HSIGN.NE.'L_LIBRARY') THEN
+         TEXT12=HENTRY(1)
+         CALL XABORT('TONE: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
+     1   '. L_LIBRARY EXPECTED.')
+      ENDIF
+      CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR)
+      NBISO=IPAR(2)
+      NGRO=IPAR(3)
+      ITRANC=IPAR(5)
+      IPROB=IPAR(6)
+      IGRMIN=IPAR(9)+1
+      IGRMAX=IPAR(10)
+      NBMIX=IPAR(14)
+      NRES=IPAR(15)
+      IF(NGRO.LT.250) THEN
+        WRITE(6,'(/48H TONE: *** WARNING*** THIS SIMPLIFIED SELF-SHIEL,
+     1  48HDING MODEL REQUIRES MORE THAN 250 ENERGY GROUPS.)')
+      ENDIF
+      IF(IGP(4).GT.NBMIX) THEN
+         WRITE(HSMG,'(44HTONE: THE NUMBER OF MIXTURES IN THE TRACKING,
+     1   2H (,I5,50H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE IN,
+     2   16HTERNAL LIBRARY (,I5,2H).)') IGP(4),NBMIX
+         CALL XABORT(HSMG)
+      ENDIF
+      ALLOCATE(MIX(NBISO),DEN(NBISO),LSHI(NBISO),SNGAR(NGRO*NBISO))
+      CALL LCMGET(IPLIB,'ISOTOPESMIX',MIX)
+      CALL LCMGET(IPLIB,'ISOTOPESDENS',DEN)
+      CALL LCMGET(IPLIB,'ISOTOPESSHI',LSHI)
+      CALL LCMGET(IPLIB,'ISOTOPESDSN',SNGAR)
+*----
+*  RECOVER REFERENCE AND ALIAS ISOTOPES NAMES
+*----
+      ALLOCATE(ISONR(3*NBISO),ISONA(3*NBISO))
+      CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONR)
+      CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONA)
+*----
+*  READ THE INPUT DATA
+*----
+*     DEFAULT OPTIONS:
+      IMPX=1
+      CALL LCMLEN(IPLIB,'SHIBA',LENLCM,ITYLCM)
+      IF(LENLCM.NE.0) THEN
+         CALL LCMSIX(IPLIB,'SHIBA',1)
+         CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR)
+         CALL LCMGET(IPLIB,'EPS-SHIBA',EPS)
+         CALL LCMSIX(IPLIB,' ',2)
+         IGRMIN=IPAR(1)
+         IGRMAX=IPAR(2)
+         MAXX0=IPAR(3)
+         KSPH=IPAR(4)
+         ITRANZ=IPAR(6)
+         LEVEL=IPAR(7)
+         IPHASE=IPAR(8)
+      ELSE
+         MAXX0=20
+         KSPH=1
+         ITRANZ=ITRANC
+         LEVEL=0
+         EPS=1.0E-4
+         IF(CDOOR.EQ.'SYBIL') THEN
+            IPHASE=2
+         ELSE IF(CDOOR.EQ.'EXCELL') THEN
+            IPHASE=2
+         ELSE
+            IPHASE=1
+         ENDIF
+      ENDIF
+*----
+*  READ LIBRARY DATA
+*----
+   60 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+      IF(INDIC.EQ.10) GO TO 100
+      IF(INDIC.NE.3) CALL XABORT('TONE: CHARACTER DATA EXPECTED.')
+      IF(TEXT4.EQ.'EDIT') THEN
+*        READ THE PRINT INDEX.
+         CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('TONE: INTEGER DATA EXPECTED(1).')
+      ELSE IF(TEXT4.EQ.'GRMI') THEN
+         CALL REDGET(ITYPLU,IGRMIN,FLOTT,TEXT4,DFLOTT)
+         IF(ITYPLU.NE.1) CALL XABORT('TONE: INTEGER DATA EXPECTED(2).')
+      ELSE IF(TEXT4.EQ.'GRMA') THEN
+         CALL REDGET(ITYPLU,IGRMAX,FLOTT,TEXT4,DFLOTT)
+         IF(ITYPLU.NE.1) CALL XABORT('TONE: INTEGER DATA EXPECTED(3).')
+         IF(IGRMAX.GT.NGRO) THEN
+            CALL XABORT('TONE: ILLEGAL NUMBER OF GROUP IN LIBRARY.')
+         ENDIF
+      ELSE IF(TEXT4.EQ.'MXIT') THEN
+         CALL REDGET(ITYPLU,MAXX0,FLOTT,TEXT4,DFLOTT)
+         IF(ITYPLU.NE.1) CALL XABORT('TONE: INTEGER DATA EXPECTED(4).')
+      ELSE IF(TEXT4.EQ.'EPS') THEN
+         CALL REDGET(ITYPLU,NITMA,EPS,TEXT4,DFLOTT)
+         IF(ITYPLU.NE.2) CALL XABORT('TONE: REAL DATA EXPECTED.')
+      ELSE IF(TEXT4.EQ.'NOTR') THEN
+         ITRANZ=0
+      ELSE IF(TEXT4.EQ.'TRAN') THEN
+         ITRANZ=ITRANC
+      ELSE IF(TEXT4.EQ.'ARM') THEN
+         IPHASE=1
+      ELSE IF(TEXT4.EQ.'PIJ') THEN
+         IPHASE=2
+      ELSE IF(TEXT4.EQ.'NOSP') THEN
+         KSPH=0
+      ELSE IF(TEXT4.EQ.'SPH') THEN
+         KSPH=1
+      ELSE IF(TEXT4.EQ.';') THEN
+         GO TO 100
+      ELSE
+         CALL XABORT('TONE: '//TEXT4//' IS AN INVALID KEY-WORD.')
+      ENDIF
+      GO TO 60
+*----
+*  THE NUMBER OF UNKNOWNS OF A CURRENT-BASED MULTICELL ITERATION IS
+*  INCREASED TO HOLD INTERFACE CURRENT COMPONENTS.
+*----
+  100 IF(IPHASE.EQ.1) THEN
+        IF(CDOOR.EQ.'SYBIL') NUN=NUN+IGP(9)
+        IF((CDOOR.EQ.'EXCELL').AND.(IGP(7).EQ.5)) NUN=NUN+IGP(28)
+      ENDIF
+      IF(NBMIX.EQ.0) CALL XABORT('TONE: NBMIX NOT YET DEFINED.')
+      IF(NRES.EQ.0) CALL XABORT('TONE: THERE IS NO RESONANT ISOTOPES.')
+      IF(NREG.EQ.0) CALL XABORT('TONE: NREG = 0')
+      CALL TONDRV(IPLIB,IPTRK,IFTRAK,NGRO,NBISO,NBMIX,NREG,NUN,CDOOR,
+     1 NRES,IMPX,ISONR,ISONA,MIX,DEN,SNGAR,LSHI,IPHASE,KSPH,IPROB,MAT,
+     2 VOL,IDL,LEAKSW,TITLE,IGRMIN,IGRMAX,MAXX0,ITRANZ,EPS)
+*----
+*  RELEASE GENERAL TRACKING INFORMATION
+*----
+      DEALLOCATE(IDL,VOL,MAT)
+*----
+*  RELEASE GENERAL INTERNAL LIBRARY INFORMATION
+*----
+      DEALLOCATE(ISONA,ISONR,SNGAR,LSHI,DEN,MIX)
+      RETURN
+      END