*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