From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Dragon/src/AUTO.f | 383 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 383 insertions(+) create mode 100644 Dragon/src/AUTO.f (limited to 'Dragon/src/AUTO.f') diff --git a/Dragon/src/AUTO.f b/Dragon/src/AUTO.f new file mode 100644 index 0000000..37f7f98 --- /dev/null +++ b/Dragon/src/AUTO.f @@ -0,0 +1,383 @@ +*DECK AUTO + SUBROUTINE AUTO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* UAutosecol self-shielding operator. +* +*Copyright: +* Copyright (C) 2023 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: +* HENTRY(1) creation or modification type(L_LIBRARY) (no +* subgroups); +* HENTRY(2) read-only type(L_LIBRARY) (with subgroups); +* HENTRY(3) read-only type(L_TRACK); +* HENTRY(4) optional 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,MAXRSS=300,IOUT=6) + TYPE(C_PTR) IPLI0,IPLIB,IPTRK + CHARACTER TEXT4*4,HSIGN*12,TEXT8*8,TEXT12*12,HSMG*131,CDOOR*12, + 1 TITR*72,HISOT*12 + DOUBLE PRECISION DFLOTT + LOGICAL LEAKSW,LDIL + INTEGER IGP(NSTATE),IPAR(NSTATE),IPAS(NSTATE),IRSS(MAXRSS) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: DIL + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: HUSED +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.2) CALL XABORT('AUTO: THREE PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('AUTO: LI' + 1 //'NKED LIST OR XSM FILE EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('AUTO: EN' + 1 //'TRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('AUTO: LINKED LIST OR XSM FILE IN READ-ONLY MODE E' + 2 //'XPECTED AT FIRST RHS.') + IF((JENTRY(3).NE.2).OR.((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2))) + 1 CALL XABORT('AUTO: LINKED LIST OR XSM FILE IN READ-ONLY MODE E' + 2 //'XPECTED AT SECOND RHS.') + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(3) + CALL XABORT('AUTO: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(3),'TRACK-TYPE',12,CDOOR) + IPLI0=KENTRY(1) + IPLIB=KENTRY(2) + IPTRK=KENTRY(3) + INDREC=0 + IF(JENTRY(1).EQ.0) THEN + INDREC=1 + HSIGN='L_LIBRARY' + CALL LCMPTC(IPLI0,'SIGNATURE',12,HSIGN) + ELSE IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(IPLI0,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + TEXT12=HENTRY(1) + CALL XABORT('AUTO: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_LIBRARY EXPECTED.') + ENDIF + INDREC=2 + ENDIF +*---- +* RECOVER TABULATED FUNCTIONS. +*---- + CALL XDRTA2 +*---- +* RECOVER TRACKING FILE INFORMATION. +*---- + IFTRAK=0 + IF(NENTRY.GE.4) THEN + IF(IENTRY(4).EQ.3) THEN + IF(JENTRY(4).NE.2) CALL XABORT('AUTO: BINARY TRACKING FILE NA' + 1 //'MED '//TEXT12//' IS NOT IN REAL-ONLY MODE.') + IFTRAK=FILUNIT(KENTRY(4)) + ENDIF + ENDIF +*---- +* RECOVER GENERAL TRACKING INFORMATION. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NREG=IGP(1) + NUN=IGP(2) + LEAKSW=IGP(3).EQ.0 + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK,'TITLE',72,TITR) + ELSE + TITR='*** NO TITLE PROVIDED ***' + ENDIF +*---- +* RECOVER INTERNAL LIBRARY PARAMETERS. +*---- + CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') THEN + TEXT12=HENTRY(2) + CALL XABORT('AUTO: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_LIBRARY EXPECTED.') + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) + NBISO=IPAR(2) + NGRP=IPAR(3) + NL=IPAR(4) + ITRANC=IPAR(5) + IGRMIN=IPAR(9)+1 + IGRMAX=IPAR(10) + NED=IPAR(13) + NBMIX=IPAR(14) + NRES=IPAR(15) + NDEL=IPAR(19) + IF(IGP(4).GT.NBMIX) THEN + WRITE(HSMG,'(45HAUTO: THE NUMBER OF MIXTURES IN THE TRACKING , + 1 1H(,I5,51H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE INT, + 2 15HERNAL LIBRARY (,I5,2H).)') IGP(4),NBMIX + CALL XABORT(HSMG) + ENDIF + IF(INDREC.EQ.2) THEN + CALL LCMGET(IPLI0,'STATE-VECTOR',IPAR) + IF(IPAR(2).NE.NBISO) CALL XABORT('AUTO: INVALID LIBRARY.') + ENDIF + ALLOCATE(DIL(NBISO),HUSED(NBISO)) + DIL(:NBISO)=0.0 + CALL LCMGTC(IPLIB,'ISOTOPESUSED',12,NBISO,HUSED) +* + IMPX=1 + LDIL=.FALSE. + CALL LCMLEN(IPLI0,'SHIBA_SG',LENLCM,ITYLCM) + IF(LENLCM.NE.0) THEN + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMGET(IPLI0,'STATE-VECTOR',IPAS) + CALL LCMSIX(IPLI0,' ',2) + IGRMIN=IPAS(1) + IGRMAX=IPAS(2) + KSPH=IPAS(3) + ITRANZ=IPAS(4) + NPASS=IPAS(5) + IPHASE=IPAS(6) + ICALC=IPAS(8) + IALTER=IPAS(11) + MAXTRA=IPAS(12) + ISEED=IPAS(14) + ELSE + KSPH=1 + ITRANZ=ITRANC + NPASS=1 + IF(CDOOR.EQ.'SYBIL') THEN + IPHASE=2 + ELSE IF(CDOOR.EQ.'EXCELL') THEN + IPHASE=2 + ELSE + IPHASE=1 + ENDIF + ICALC=0 + IALTER=0 + MAXTRA=10000 + ISEED=0 + ENDIF +* + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 70 + IF(INDIC.NE.3) CALL XABORT('AUTO: CHARACTER DATA EXPECTED(1).') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'GRMI') THEN + CALL REDGET(ITYPLU,IGRMIN,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'GRMA') THEN + CALL REDGET(ITYPLU,IGRMAX,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(3).') + IF(IGRMAX.GT.NGRP) THEN + CALL XABORT('AUTO: ILLEGAL NUMBER OF GROUP IN LIBRARY.') + ENDIF + ELSE IF(TEXT4.EQ.'NOSP') THEN + KSPH=0 + ELSE IF(TEXT4.EQ.'SPH') THEN + KSPH=1 + ELSE IF(TEXT4.EQ.'NOTR') THEN + ITRANZ=0 + ELSE IF(TEXT4.EQ.'TRAN') THEN + ITRANZ=1 + ELSE IF(TEXT4.EQ.'PASS') THEN + CALL REDGET(ITYPLU,NPASS,FLOTT,TEXT4,DFLOTT) + IF(ITYPLU.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(5).') + IF(NPASS.LE.0) CALL XABORT('AUTO: POSITIVE PASS EXPECTED.') + ELSE IF(TEXT4.EQ.'ARM') THEN + IPHASE=1 + ELSE IF(TEXT4.EQ.'PIJ') THEN + IPHASE=2 + ELSE IF(TEXT4.EQ.'CALC') THEN + ICALC=1 + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMSIX(IPLI0,'-DATA-CALC-',1) + CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYPLU.NE.3) CALL XABORT('AUTO: CHARACTER DATA EXPECTED.') + 40 IF(TEXT12.EQ.'ENDC') THEN + CALL LCMSIX(IPLI0,' ',2) + CALL LCMSIX(IPLI0,' ',2) + GO TO 10 + ENDIF + IF(TEXT12.NE.'REGI') CALL XABORT('AUTO: REGI KWORD EXPECTED.') + CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYPLU.NE.3) CALL XABORT('AUTO: CHARACTER DATA EXPECTED.') + IF(TEXT12(5:).NE.' ') CALL XABORT('AUTO: 4-CHARACTER NAME EXPE' + 1 //'CTED.') + CALL LCMSIX(IPLI0,TEXT12(:4),1) + CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYPLU.NE.3) CALL XABORT('AUTO: CHARACTER DATA EXPECTED.') + 50 IF((TEXT12.EQ.'ENDC').OR.(TEXT12.EQ.'REGI')) THEN + CALL LCMSIX(IPLI0,' ',2) + GO TO 40 + ENDIF + HISOT=TEXT12 + NRSS=0 + 60 CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYPLU.EQ.3) THEN + IF(TEXT12.EQ.'ALL') THEN + NRSS=1 + IRSS(1)=-999 + GO TO 60 + ENDIF + IF(NRSS.EQ.0) CALL XABORT('AUTO: INTEGER ARRAY EXPECTED.') + CALL LCMPUT(IPLI0,HISOT,NRSS,1,IRSS) + GO TO 50 + ENDIF + IF(ITYPLU.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(6).') + NRSS=NRSS+1 + IF(NRSS.GT.MAXRSS) CALL XABORT('AUTO: MAXRSS OVERFLOW.') + IF((NITMA.LE.0).OR.(NITMA.GT.NBMIX)) THEN + WRITE(HSMG,'(42HAUTO: REGI KEYWORD -- INVALID MIXTURE INDE, + 1 2HX=,I5,1H.)') NITMA + CALL XABORT(HSMG) + ENDIF + IRSS(NRSS)=NITMA + GO TO 60 + ELSE IF(TEXT4.EQ.'DILU') THEN + CALL REDGET(ITYPLU,NITMA,FLOTT,TEXT8,DFLOTT) + IF(ITYPLU.NE.3) CALL XABORT('AUTO: CHARACTER DATA EXPECTED.') + LDIL=.FALSE. + DO ISO=1,NBISO + IF(TEXT8.EQ.HUSED(ISO)(:8)) THEN + LDIL=.TRUE. + CALL REDGET(ITYPLU,NITMA,DIL(ISO),TEXT12,DFLOTT) + IF(ITYPLU.NE.2) CALL XABORT('AUTO: REAL DATA EXPECTED.') + ENDIF + ENDDO + IF(.NOT.LDIL) THEN + WRITE(HSMG,'(29HAUTO: CANNOT FIND ALIAS NAME=,A8,1H.)') TEXT8 + CALL XABORT(HSMG) + ENDIF + ELSE IF(TEXT4.EQ.'KERN') THEN + CALL REDGET(INDIC,IALTER,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(7).') + ELSE IF(TEXT4.EQ.'MAXT') THEN + CALL REDGET(INDIC,MAXTRA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(9).') + ELSE IF(TEXT4.EQ.'SEED') THEN +* INPUT A SEED INTEGER FOR THE UNRESOLVED ENERGY DOMAIN + CALL REDGET(INDIC,ISEED,FLOTT,TEXT4,DFLOTT) + IF (INDIC.NE.1) CALL XABORT('AUTO: INTEGER DATA EXPECTED(10).') + ELSE IF(TEXT4.EQ.';') THEN + GO TO 70 + ELSE + CALL XABORT('AUTO: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 10 +*---- +* THE NUMBER OF UNKNOWNS OF A CURRENT-BASED MULTICELL ITERATION IS +* INCREASED TO HOLD INTERFACE CURRENT COMPONENTS. +*---- + 70 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 +*---- +* CALL AUTO: DRIVER. +*---- + IF(IMPX.GT.0) THEN + IF(INDREC.EQ.1) WRITE(IOUT,100) + WRITE(IOUT,110) TITR,CDOOR(:9),IGRMIN,IGRMAX,KSPH,ITRANZ,NPASS, + 1 IPHASE,ICALC,IALTER,MAXTRA,ISEED + ENDIF + IF(LDIL.AND.(IMPX.GT.0)) THEN + DO ISO=1,NBISO + IF(DIL(ISO).NE.0.0) THEN + WRITE(6,'(/20H AUTO: SET DILUTION(,A12,2H)=,1P,E12.4,2h b)') + 1 HUSED(ISO),DIL(ISO) + ENDIF + ENDDO + ENDIF +*---- +* PERFORM SELF-SHIELDING. +*---- + IF(CDOOR.EQ.'MCCG') THEN + CALL LCMLEN(IPTRK,'KEYFLX',LKFL,ITYLCM) + NFUNL=LKFL/NREG + ELSE + NFUNL=1 + ENDIF + CALL AUTDRV(IPLI0,IPTRK,IPLIB,IFTRAK,INDREC,CDOOR,IMPX,IGRMIN, + 1 IGRMAX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,LEAKSW,ITRANZ, + 2 IPHASE,TITR,KSPH,NRES,NPASS,ICALC,IALTER,MAXTRA,ISEED,DIL, + 3 DELI) + IF(DELI.EQ.0.0) CALL XABORT('AUTO: LETHARGY WIDTH UNDEFINED.') + DEALLOCATE(HUSED,DIL) +*---- +* STORE THE GENERAL SHELF-SHIELDING PARAMETERS. +*---- + IPAS(:NSTATE)=0 + IPAS(1)=IGRMIN + IPAS(2)=IGRMAX + IPAS(3)=KSPH + IPAS(4)=ITRANZ + IPAS(5)=NPASS + IPAS(6)=IPHASE + IPAS(8)=ICALC + IPAS(11)=IALTER + IPAS(12)=MAXTRA + IPAS(14)=ISEED + CALL LCMSIX(IPLI0,'SHIBA_SG',1) + CALL LCMPUT(IPLI0,'STATE-VECTOR',NSTATE,1,IPAS) + CALL LCMSIX(IPLI0,' ',2) + RETURN +* + 100 FORMAT(1H1,32H A UU UU TTTTTTTT OOOOO ,107(1H*)/ + 1 34H AAA UU UU TTTTTTTT OOOOOOO ,63(1H*), + 2 43H AUTOSECOL SELF-SHIELDING MODEL. A. HEBERT/ + 3 33H AA AA UU UU TT OO OO/ + 4 33H AA AA UU UU TT OO OO/ + 5 33H AAAAAAA UU UU TT OO OO/ + 6 33H AAAAAAA UU UU TT OO OO/ + 7 33H AA AA UUUUUUU TT OOOOOOO/ + 8 32H AA AA UUUUU TT OOOOO/) + 110 FORMAT(/1X,A72//8H OPTIONS/8H -------/ + 1 7H CDOOR ,A9,30H (NAME OF THE SOLUTION DOOR)/ + 2 7H IGRMIN,I9,27H (FIRST GROUP TO PROCESS)/ + 3 7H IGRMAX,I9,34H (MOST THERMAL GROUP TO PROCESS)/ + 4 7H KSPH ,I9,47H (=0: NO SPH CORRECTION; =1: SPH CORRECTION I, + 5 19HN RESONANT REGIONS)/ + 6 7H ITRANZ,I9,45H (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2, + 7 57H=RECOVER FROM LIBRARY/3=WIMS-D TYPE/4=LEAKAGE CORRECTION)/ + 8 7H NPASS ,I9,31H (NUMBER OF OUTER ITERATIONS)/ + 9 7H IPHASE,I9,37H (=1: NATIVE ASSEMBLY; =2: USE PIJ)/ + 1 7H ICALC ,I9,48H (=0: NO &CALC DATA; =1: &CALC DATA AVAILABLE)/ + 2 7H IALTER,I9,47H (=0: USE EXACT KERNEL; =1: USE APPROXIMATE K, + 3 6HERNEL)/ + 4 7H MAXTRA,I9,44H (MAXIMUM NUMBER OF DOWN-SCATTERING TERMS)/ + 5 6H ISEED,I10,45H (INITIAL SEED FOR RANDOM NUMBER GENERATOR)) + END -- cgit v1.2.3