diff options
Diffstat (limited to 'Dragon/src/EDI.f')
| -rw-r--r-- | Dragon/src/EDI.f | 667 |
1 files changed, 667 insertions, 0 deletions
diff --git a/Dragon/src/EDI.f b/Dragon/src/EDI.f new file mode 100644 index 0000000..cb9ed74 --- /dev/null +++ b/Dragon/src/EDI.f @@ -0,0 +1,667 @@ +*DECK EDI + SUBROUTINE EDI(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Edition operator for Dragon. +* +*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 and G. Marleau +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file (order is arbitrary for +* objects 2,3,4): +* HENTRY(1): create or modification type(L_EDIT); +* HENTRY(2): read-only type(L_FLUX); +* HENTRY(3): read-only type(L_MACROLIB OR L_LIBRARY); +* HENTRY(4): read-only type(L_TRACK); +* The object 5 is required if the "MERG CELL" option is used. +* HENTRY(5): optional read-only type(L_GEOM) containing the +* original geometry; +* HENTRY(6): optional read-only type(L_GEOM) containing the +* macrogeometry; +* HENTRY(7): optional read-only type(L_SYS) containing the +* L_PIJ object of the original geometry in cases where a +* Selengut normalization is required. +* 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,IOUT=6,MAXED=100,MAXOUT=100) + TYPE(C_PTR) IPEDIT,IPFLUX,IPTRK1,IPLIB,JPMAC,KPMAC,IPGEO1,IPGEO2, + > JPFLUX,IPSYS,IPMRG + CHARACTER*12 TEXT12,CDOOR,OLDGEO,MACGEO,CURNAM,OLDNAM,HSIGN, + > CARISO(MAXED) + CHARACTER TITLE*72,HSMG*131,HVOUT(MAXOUT)*8 + INTEGER IGP(NSTATE),IDATA(NSTATE),ISTATE(NSTATE) + LOGICAL LNEWGE,LISO,LDEPL,LMACR,LREMIX + INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYFL,MAT,IDL,IGCOND,IMERGE, + > IACTI,IGCR,IREMIX + REAL, ALLOCATABLE, DIMENSION(:) :: VOL,FLINT,ENERG,ENERV,ECR +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LT.2) CALL XABORT('EDI: MORE RHS LCM OBJECTS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('EDI: LC' + > //'M OBJECT EXPECTED AT LHS.') + + IPEDIT=KENTRY(1) + IF(JENTRY(1) .EQ. 0) THEN + HSIGN='L_EDIT' + CALL LCMPTC(IPEDIT,'SIGNATURE',12,HSIGN) + ELSE IF(JENTRY(1) .EQ. 1) THEN + CALL LCMGTC(IPEDIT,'SIGNATURE',12,HSIGN) + IF(HSIGN .NE. 'L_EDIT') THEN + TEXT12=HENTRY(1) + CALL XABORT('EDI: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + > '. L_EDIT EXPECTED.') + ENDIF + ELSE + CALL XABORT('EDI: EDITING LCM OBJECT IN CREATE OR MODIFY MODE ' + > //'EXPECTED.') + ENDIF +*---- +* SCAN READ-ONLY MODE DATA STRUCTURE ENTRY(2) TO ENTRY(4) +* FOR FLUX, TRACK AND LIB +*---- + IF(JENTRY(2).NE.2) CALL XABORT('EDI: LCM OBJECT IN READ-ONLY MOD' + > //'E EXPECTED AT RHS.') + IPFLUX=C_NULL_PTR + IKFLUX=0 + IPTRK1=C_NULL_PTR + IKTRK1=0 + IPLIB=C_NULL_PTR + IKLIB=0 + DO 10 IEN=2,MIN(4,NENTRY) + IF((IENTRY(IEN).EQ.1).OR.(IENTRY(IEN).EQ.2)) THEN + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + IF((HSIGN.EQ.'L_FLUX').AND.(IKFLUX.EQ.0)) THEN + IPFLUX=KENTRY(IEN) + IKFLUX=IEN + ELSE IF((HSIGN.EQ.'L_TRACK').AND.(IKTRK1.EQ.0)) THEN + IPTRK1=KENTRY(IEN) + IKTRK1=IEN + ELSE IF((HSIGN.EQ.'L_LIBRARY').AND.(IKLIB.EQ.0)) THEN + IPLIB=KENTRY(IEN) + IKLIB=IEN + ELSE IF((HSIGN.EQ.'L_MACROLIB').AND.(IKLIB.EQ.0)) THEN + IPLIB=KENTRY(IEN) + IKLIB=-IEN + ENDIF + ENDIF + 10 CONTINUE +*---- +* READ MACROLIB INFORMATION +*---- + IF(IKLIB.EQ.0) CALL XABORT('EDI: NO MACROLIB OR MICROLIB LCM OBJ' + > //'ECT FOUND.') + IF(IKLIB.GT.0) THEN + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + MAXISM=ISTATE(22) + CALL LCMSIX(IPLIB,'MACROLIB',1) + ELSE + MAXISM=1 + ENDIF + CALL LCMGET(IPLIB,'STATE-VECTOR',IDATA) + NGRP=IDATA(1) + NBMIX=IDATA(2) + NL=IDATA(3) + NIFISS=IDATA(4) + NEDMAC=IDATA(5) + ITRANC=IDATA(6) + NDEL=IDATA(7) + NALBP=IDATA(8) + IDFM=IDATA(12) +*---- +* BUILD L_TRACK AND L_FLUX OBJECTS FROM EXTENDED MACROLIB +*---- + IF((IKTRK1.EQ.0).AND.(IKFLUX.EQ.0)) THEN + CALL LCMOP(IPTRK1,'PSEUDO_TRACK',0,1,0) + CALL LCMOP(IPFLUX,'PSEUDO_FLUX',0,1,0) + HSIGN='L_TRACK' + CALL LCMPTC(IPTRK1,'SIGNATURE',12,HSIGN) + HSIGN='L_FLUX' + CALL LCMPTC(IPFLUX,'SIGNATURE',12,HSIGN) + TEXT12='DUMMY' + CALL LCMPTC(IPTRK1,'TRACK-TYPE',12,TEXT12) + ALLOCATE(KEYFL(NBMIX)) + DO 20 IBM=1,NBMIX + KEYFL(IBM)=IBM + 20 CONTINUE + CALL LCMPUT(IPTRK1,'MATCOD',NBMIX,1,KEYFL) + CALL LCMPUT(IPTRK1,'KEYFLX',NBMIX,1,KEYFL) + DEALLOCATE(KEYFL) + ALLOCATE(VOL(NBMIX)) + CALL LCMLEN(IPLIB,'VOLUME',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('EDI: NO VOLUME IN MACROLIB.') + CALL LCMGET(IPLIB,'VOLUME',VOL) + CALL LCMPUT(IPTRK1,'VOLUME',NBMIX,2,VOL) + ISTATE(:NSTATE)=0 + ISTATE(1)=NBMIX + ISTATE(2)=NBMIX + ISTATE(4)=NBMIX + CALL LCMPUT(IPTRK1,'STATE-VECTOR',NSTATE,1,ISTATE) + ALLOCATE(FLINT(NBMIX)) + JPMAC=LCMGID(IPLIB,'GROUP') + JPFLUX=LCMLID(IPFLUX,'FLUX',NGRP) + DO 40 IGR=1,NGRP + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMLEN(KPMAC,'FLUX-INTG',ILONG,ITYLCM) + IF(ILONG.EQ.0) CALL XABORT('EDI: NO FLUX-INTG IN MACROLIB.') + CALL LCMGET(KPMAC,'FLUX-INTG',FLINT) + DO 30 IBM=1,NBMIX + FLINT(IBM)=FLINT(IBM)/VOL(IBM) + 30 CONTINUE + CALL LCMPDL(JPFLUX,IGR,NBMIX,2,FLINT) + 40 CONTINUE + DEALLOCATE(FLINT,VOL) + CALL LCMLEN(IPLIB,'K-EFFECTIVE',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPLIB,'K-EFFECTIVE',FLOAT) + CALL LCMPUT(IPFLUX,'K-EFFECTIVE',1,2,FLOAT) + ENDIF + CALL LCMLEN(IPLIB,'K-INFINITY',ILONG,ITYLCM) + IF(ILONG.EQ.1) THEN + CALL LCMGET(IPLIB,'K-INFINITY',FLOAT) + CALL LCMPUT(IPFLUX,'K-INFINITY',1,2,FLOAT) + ENDIF + ISTATE(:NSTATE)=0 + ISTATE(1)=NGRP + ISTATE(2)=NBMIX + CALL LCMPUT(IPFLUX,'STATE-VECTOR',NSTATE,1,ISTATE) + ENDIF + IF(IKLIB.GT.0) CALL LCMSIX(IPLIB,' ',2) + IF(.NOT.C_ASSOCIATED(IPFLUX)) THEN + CALL XABORT('EDI: NO REFERENCE FLUX AVAILABLE.') + ENDIF + CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE) + ILEAKC=ISTATE(7) +*---- +* READ GEOMETRIES AND SYSTEM +*---- + IPGEO1=C_NULL_PTR + IKGEO1=0 + IPGEO2=C_NULL_PTR + IKGEO2=0 + IPSYS=C_NULL_PTR + IKSYS=0 + OLDGEO=' ' + IFGEO=0 + IF(NENTRY.GT.4) THEN + DO 70 IEN=5,NENTRY + IF((IENTRY(IEN).EQ.1).OR.(IENTRY(IEN).EQ.2)) THEN + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_GEOM') THEN + IF(IKGEO1.EQ.0) THEN + IPGEO1=KENTRY(IEN) + OLDGEO=HENTRY(IEN) + IKGEO1=IEN + ELSE IF(IKGEO2.EQ.0) THEN + IPGEO2=KENTRY(IEN) + IKGEO2=IEN + ENDIF + ELSE IF((HSIGN.EQ.'L_PIJ').AND.(IKSYS.EQ.0)) THEN + IPSYS=KENTRY(IEN) + IKSYS=IEN + ENDIF + ELSE IF((IENTRY(IEN).EQ.4).AND.(JENTRY(IEN).EQ.2)) THEN + IFGEO=FILUNIT(KENTRY(IEN)) + ELSE + CALL XABORT('EDI: INVALID TYPE AT RHS.') + ENDIF + 70 CONTINUE + ENDIF +*---- +* RECOVER GENERAL TRACKING INFORMATION +*---- + IF(.NOT.C_ASSOCIATED(IPTRK1)) THEN + CALL XABORT('EDI: NO REFERENCE TRACKING AVAILABLE.') + ENDIF + CALL LCMGET(IPTRK1,'STATE-VECTOR',IGP) + NREG=IGP(1) + CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,CDOOR) + IF(CDOOR.EQ.'MCCG') THEN + CALL LCMLEN(IPTRK1,'KEYFLX',LKFL,ITYLCM) + NFUNL=LKFL/NREG + ELSE + NFUNL=1 + ENDIF + ALLOCATE(MAT(NREG),VOL(NREG),IDL(NREG*NFUNL)) + CALL LCMGET(IPTRK1,'MATCOD',MAT) + CALL LCMGET(IPTRK1,'VOLUME',VOL) + CALL LCMGET(IPTRK1,'KEYFLX',IDL) + CALL LCMLEN(IPTRK1,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK1,'TITLE',72,TITLE) + CALL LCMPTC(IPEDIT,'TITLE',72,TITLE) + ELSE + TITLE='*** NO TITLE PROVIDED FOR THE REFERENCE CASE ***' + ENDIF +*---- +* READ GROUP STRUCTURE +*---- + ALLOCATE(ENERG(2*NGRP+1),ENERV(NGRP)) + CALL LCMLEN(IPLIB,'ENERGY',NTENER,ITYLCM) + IF(NTENER.EQ.NGRP+1) THEN + CALL LCMGET(IPLIB,'ENERGY',ENERG) + ELSE IF(NTENER.NE.0) THEN + CALL XABORT('EDI: INVALID NUMBER OF GROUP ON MACROLIB.') + ENDIF +*---- +* READ EDITION OPTIONS PARAMETERS +*---- + ALLOCATE(IGCOND(NGRP),IMERGE(NREG),IACTI(NBMIX)) + ICALL=0 + CURNAM=' ' + MAXCND=0 + MAXISK=0 + MAXMRG=0 + ITMERG=-4 + BB2=0.0 + IF(JENTRY(1).EQ.0) THEN + HSIGN='L_EDIT' + CALL LCMPTC(IPEDIT,'SIGNATURE',12,HSIGN) + OLDNAM=' ' + MACGEO=' ' + NMERGE=NREG + NGCOND=NGRP + IHF=1 + IFFAC=0 + ILUPS=0 + NACTI=0 + NSTATS=0 + IADF=0 + NBMICR=0 + IPRINT=1 + NSAVES=0 + NW=0 + IF(ILEAKC.GE.6) NW=1 + ICURR=NW + IXEDI=0 + IADJ=0 + IEUR=0 + NOUT=0 + IEDCUR=0 + IGOVE=0 + MAXPTS=NREG + DO 90 IGROUP=1,NGRP + IGCOND(IGROUP)=IGROUP + 90 CONTINUE + DO 100 IREGIO=1,NREG + IMERGE(IREGIO)=IREGIO + 100 CONTINUE + ELSE IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(IPEDIT,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_EDIT') THEN + TEXT12=HENTRY(1) + CALL XABORT('EDI: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + > '. L_EDIT EXPECTED.') + ENDIF + CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE) + NMERGE=ISTATE(1) + NGCOND=ISTATE(2) + IFFAC=ISTATE(3) + ILUPS=ISTATE(4) + NACTI=ISTATE(5) + NSTATS=ISTATE(6) + IADF=ISTATE(7) + IEUR=ISTATE(8) + NBMICR=ISTATE(9) + IPRINT=ISTATE(10) + NSAVES=ISTATE(11) + NW=ISTATE(12) + MAXISK=ISTATE(13) + MAXCND=ISTATE(14) + MAXMRG=ISTATE(15) + IXEDI=ISTATE(16) + MAXPTS=ISTATE(17) + IHF=ISTATE(18) + IF(ISTATE(19).NE.NDEL) CALL XABORT('EDI: BAD VALUE OF NDEL') + IADJ=ISTATE(21) + ICURR=ISTATE(22) + NOUT=ISTATE(23) + IEDCUR=ISTATE(24) + IGOVE=ISTATE(25) + IF(NOUT.GT.MAXOUT) CALL XABORT('EDI: MAXOUT OVERFLOW') + CALL LCMLEN(IPEDIT,'LAST-EDIT',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPEDIT,'LAST-EDIT',12,OLDNAM) + INTLIR=0 + READ(OLDNAM,'(8X,I4)',ERR=105) INTLIR + 105 ICALL=MAX(ICALL,INTLIR) + ENDIF + CALL LCMLEN(IPEDIT,'REF:IMERGE',LENGT,ITYLCM) + IF(LENGT.EQ.NREG) THEN + CALL LCMGET(IPEDIT,'REF:IMERGE',IMERGE) + ELSE + DO 106 IREGIO=1,NREG + IMERGE(IREGIO)=IREGIO + 106 CONTINUE + ENDIF + CALL LCMLEN(IPEDIT,'REF:IGCOND',LENGT,ITYLCM) + IF(LENGT.EQ.NGCOND) THEN + CALL LCMGET(IPEDIT,'REF:IGCOND',IGCOND) + ELSE + DO 107 IGROUP=1,NGRP + IGCOND(IGROUP)=IGROUP + 107 CONTINUE + ENDIF + CALL LCMLEN(IPEDIT,'LINK.MACGEOM',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPEDIT,'LINK.MACGEOM',12,MACGEO) + ELSE + MACGEO=' ' + ENDIF + IF(NBMICR.GT.0) THEN + IF(NBMICR.GT.MAXED) CALL XABORT('EDI: CARISO OVERFLOW.') + CALL LCMGTC(IPEDIT,'CARISO',12,NBMICR,CARISO) + ENDIF + IF(NACTI.GT.0) CALL LCMGET(IPEDIT,'IACTI',IACTI) + IF(NOUT.GT.0) CALL LCMGTC(IPEDIT,'REF:HVOUT',8,NOUT,HVOUT) + ENDIF + NGCR=0 + LISO=.FALSE. + LDEPL=.TRUE. + LMACR=.TRUE. + MAXISK=MAX(MAXISK,MAXISM) + ALLOCATE(IGCR(NGRP+1),ECR(NGRP+1)) + IGCR(:NGRP+1)=NGRP + ECR(:NGRP+1)=0.0 + CALL EDIGET(IPEDIT,IFGEO,NGRP,NGCR,NREG,NBMIX,MAT,ITMERG,NMERGE, + 1 IHF,IFFAC,ILUPS,NSAVES,NSTATS,IGCR,ECR,IMERGE,CURNAM,OLDNAM,IADF, + 2 NW,ICURR,NBMICR,CARISO,NACTI,IACTI,IPRINT,MAXPTS,ICALL,ISOTXS, + 3 LISO,LDEPL,LMACR,IADJ,MACGEO,IEUR,NOUT,HVOUT,BB2,IEDCUR,IGOVE) + IF((IGOVE.EQ.1).AND.(ILEAKC.GE.6)) THEN + CALL XABORT('EDI: OPTION NOIN IS FORBIDDEN.') + ENDIF +*---- +* CALL EDIMRG TO FIND MERGE INDEX ASSOCIATED WITH THE SECOND GEOMETRY +* OR TRACK FILE (EQUIGEOM CAPABILITIES) +*---- + TEXT12=' ' + LNEWGE=.FALSE. + IF(ITMERG.EQ.-1) THEN + IF(IKGEO2.GT.0) THEN + ITM=-1 + IPMRG=IPGEO2 + TEXT12=HENTRY(IKGEO2) + ELSE IF(IKGEO1.GT.0) THEN + ITM=-1 + IPMRG=IPGEO1 + TEXT12=HENTRY(IKGEO1) + ELSE + ITM=0 + IPMRG=IPTRK1 + ENDIF + CALL EDIMRG(IPTRK1,IPMRG,IPRINT,TEXT12,ITM,NREG,NMERGE,IMERGE) +*---- +* BUILD A MACRO-GEOMETRY FROM REFERENCE GEOMETRY OLDGEO (CELL OPTION) +*---- + ELSE IF(ITMERG.EQ.-2) THEN + LREMIX=(NMERGE.NE.0) + IF(LREMIX) THEN +* REMIX option. + NMEOLD=NMERGE + NMERGE=0 + ALLOCATE(IREMIX(NMEOLD)) + IREMIX(:NMEOLD)=IMERGE(:NMEOLD) + ENDIF + IF(((CDOOR.EQ.'EXCELL').OR.(CDOOR.EQ.'MCCG')).AND. + > (IGP(7).EQ.4)) THEN + CALL EDIMRC(IPTRK1,IPRINT,NREG,NMERGE,IMERGE) + ELSE + IF(.NOT.C_ASSOCIATED(IPGEO1)) THEN + CALL XABORT('EDI: NO REFERENCE GEOMETRY AVAILABLE.') + ELSE IF(C_ASSOCIATED(IPGEO2)) THEN + CALL XABORT('EDI: INPUT MACRO-GEOMETRY NOT EXPECTED WITH ' + > //'CELL OPTION.') + ENDIF + IF(IPRINT.GT.0) WRITE(IOUT,190) OLDGEO,CDOOR + CALL LCMGET(IPGEO1,'STATE-VECTOR',ISTATE) + MAXGEO=MAX(MAXPTS,ISTATE(6)) + IF(IEUR.EQ.4) MAXGEO=8*MAXGEO + LNEWGE=.TRUE. + MACGEO='MACRO$GEO' + CALL LCMOP(IPGEO2,'MACRO$GEO',0,1,9) + MAXMER=MIN(NREG,MAXGEO) + CALL EDIGEO(MAXGEO,MAXMER,IPGEO1,IPGEO2,IPRINT,NREG,IEUR, + > NMERGE,IMERGE) +* +* COPY THE MACRO-GEOMETRY INTO THE EDITION OBJECT. + CALL LCMSIX(IPEDIT,'MACRO-GEOM',1) + CALL LCMEQU(IPGEO2,IPEDIT) + CALL LCMSIX(IPEDIT,' ',2) + ENDIF + IF(LREMIX) THEN +* REMIX option. + IF(NMERGE.NE.NMEOLD) THEN + WRITE(HSMG,'(37HEDI: INVALID NUMBER OF REMIX INDICES:, + > I5,11H ARE GIVEN;,I5,14H ARE EXPECTED.)') NMEOLD,NMERGE + CALL XABORT(HSMG) + ENDIF + NMERGE=0 + DO IREG=1,NREG + IF(IMERGE(IREG).GT.NMEOLD) CALL XABORT('EDI: NMERGE OVERF' + > //'LOW IN REMIX.') + IF(IMERGE(IREG).NE.0) IMERGE(IREG)=IREMIX(IMERGE(IREG)) + NMERGE=MAX(NMERGE,IMERGE(IREG)) + ENDDO + DEALLOCATE(IREMIX) + ENDIF + ELSE IF(ITMERG.EQ.-3) THEN +*---- +* CALL EDIMRG TO FIND MERGE INDEX ASSOCIATED WITH HMIX +*---- + IPMRG=IPTRK1 + CALL EDIHMX(IPTRK1,NREG,NMERGE,IMERGE) + ENDIF +*---- +* SET THE ANISOTROPY OF WEIGHTING FLUXES +*---- + IF((NW.GT.0).AND.(ICURR.EQ.4)) THEN + CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,TEXT12) + NANIS=1 + IF(TEXT12.EQ.'MCCG') THEN + CALL LCMGET(IPTRK1,'STATE-VECTOR',ISTATE) + NANIS=ISTATE(6) + ELSE IF(TEXT12.EQ.'SN') THEN + CALL LCMGET(IPTRK1,'STATE-VECTOR',ISTATE) + NANIS=ISTATE(16) + ELSE + CALL XABORT('EDI: MCCG OR SN TRACKING EXPECTED WITH P1W_SP ' + > //'OPTION') + ENDIF + NW=NANIS-1 + IF(IPRINT.GT.0) WRITE(IOUT,'(/15H EDI: NW SET TO,I3,1H.)') + > NW + IF(NW.EQ.0) CALL XABORT('EDI: NW>0 EXPECTED.') + ENDIF +*---- +* TEST ENERGY CONDENSATION INPUT +*---- + CALL EDIENE(NGRP,NGCR,NGCOND,NTENER,IGCR,ECR,IGCOND,ENERG,ENERV) +* + CALL LCMLEN(IPEDIT,'MACRO-GEOM',ILONG,ITYLCM) + LGEO=0 + IF((ILONG.NE.0).OR.(MACGEO.NE.' ')) LGEO=1 + IF(IPRINT.GT.0) THEN + WRITE(IOUT,200) NMERGE,NGCOND,IFFAC,ILUPS,NACTI,NSTATS,IADF, + > IEUR,NBMICR,IPRINT + WRITE(IOUT,210) NSAVES,NW,MAXPTS,IHF,NDEL,LGEO,IADJ,ICURR, + > NOUT,IEDCUR,IGOVE + WRITE(IOUT,'(//15H MERGING INDEX:/(1X,14I5))') + > (IMERGE(I),I=1,NREG) + IF(CURNAM.NE.' ') WRITE(IOUT,'(/27H EDI: SAVE MICROLIB INFO ON, + > 12H DIRECTORY '',A12,2H''.)') CURNAM + ENDIF + DEALLOCATE(ECR,IGCR) + ISTATE(:NSTATE)=0 + ISTATE(1)=NMERGE + ISTATE(2)=NGCOND + ISTATE(3)=IFFAC + ISTATE(4)=ILUPS + ISTATE(5)=NACTI + ISTATE(6)=NSTATS + ISTATE(7)=IADF + ISTATE(8)=IEUR + ISTATE(9)=NBMICR + ISTATE(10)=IPRINT + ISTATE(11)=NSAVES + ISTATE(12)=NW + ISTATE(13)=MAXISK + ISTATE(14)=MAX(NGCOND,MAXCND) + ISTATE(15)=MAX(NMERGE,MAXMRG) + ISTATE(16)=IXEDI+ISOTXS*NMERGE + ISTATE(17)=MAXPTS + ISTATE(18)=IHF + ISTATE(19)=NDEL + ISTATE(20)=LGEO + ISTATE(21)=IADJ + ISTATE(22)=ICURR + ISTATE(23)=NOUT + ISTATE(24)=IEDCUR + ISTATE(25)=IGOVE + CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(OLDGEO.NE.' ') THEN + CALL LCMPTC(IPEDIT,'LINK.GEOM',12,OLDGEO) + ENDIF + IF(NSAVES.GE.2) THEN + CALL LCMPTC(IPEDIT,'LAST-EDIT',12,CURNAM) + ENDIF + IF(NBMICR.GT.0) THEN + CALL LCMPTC(IPEDIT,'CARISO',12,NBMICR,CARISO) + ENDIF + IF(NACTI.GT.0) CALL LCMPUT(IPEDIT,'IACTI',NACTI,1,IACTI) + IF(MACGEO.NE.' ') THEN + IF(HENTRY(IKGEO1).EQ.MACGEO) THEN + IPGEO2=IPGEO1 + IKGEO2=IKGEO1 + ENDIF + IF(.NOT.C_ASSOCIATED(IPGEO2)) THEN + CALL XABORT('EDI: MISSING LCM OBJECT FOR THE MACRO-GEOMETR' + > //'Y.') + ENDIF + IF(IKGEO2.NE.0) THEN + IF(HENTRY(IKGEO2).NE.MACGEO) THEN + WRITE(HSMG,'(33HEDI: WRONG MACRO-GEOMETRY NAMED '', + > A12,17H'' FOUND ON RHS. '',A12,11H'' EXPECTED.)') + > HENTRY(IKGEO2),MACGEO + CALL XABORT(HSMG) + ENDIF + ENDIF + CALL LCMGTC(IPGEO2,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_GEOM') THEN + CALL XABORT('EDI: SIGNATURE OF '//MACGEO//' IS '//HSIGN// + > '. L_GEOM EXPECTED.') + ENDIF +* +* COPY THE MACRO-GEOMETRY INTO THE EDITION OBJECT. + CALL LCMSIX(IPEDIT,'MACRO-GEOM',1) + CALL LCMEQU(IPGEO2,IPEDIT) + CALL LCMSIX(IPEDIT,' ',2) + ENDIF +*---- +* EDITION +*---- + IF(NREG.EQ.0) CALL XABORT('EDI: NREG = 0.') + IF(NGRP.EQ.0) CALL XABORT('EDI: NGRP = 0.') + CALL EDIDRV(IPEDIT,IPTRK1,IPFLUX,IPLIB,IPSYS,NGRP,NBMIX,NREG,MAT, + 1 VOL,IDL,NIFISS,NEDMAC,NL,NDEL,NALBP,ITRANC,NGCOND,NMERGE,IADF, + 2 IDFM,NW,ICURR,IHF,IFFAC,ILUPS,NSAVES,NSTATS,IXEDI,ISOTXS,IGCOND, + 3 IMERGE,CURNAM,OLDNAM,NBMICR,CARISO,NACTI,IACTI,IPRINT,LISO,LDEPL, + 4 LMACR,IADJ,NOUT,HVOUT,BB2,IEDCUR,IGOVE) +*---- +* DESTROY THE TEMPORARY MACRO-GEOMETRY +*---- + IF(LNEWGE) THEN + CALL LCMCL(IPGEO2,1) + TEXT12='MACRO$GEO' + CALL LCMOP(IPGEO2,TEXT12,1,1,0) + CALL LCMCL(IPGEO2,2) + ENDIF +*---- +* COMPLETE THE EDITION LCM OBJECT +*---- + CALL LCMPUT(IPEDIT,'REF:IMERGE',NREG,1,IMERGE) + CALL LCMPUT(IPEDIT,'REF:MATCOD',NREG,1,MAT) + CALL LCMPUT(IPEDIT,'REF:VOLUME',NREG,2,VOL) + CALL LCMPUT(IPEDIT,'REF:IGCOND',NGCOND,1,IGCOND) + IF(NOUT.GT.0) CALL LCMPTC(IPEDIT,'REF:HVOUT',8,NOUT,HVOUT) +* + DEALLOCATE(IACTI,IMERGE,IGCOND) +*---- +* RELEASE GENERAL TRACKING INFORMATION +*---- + DEALLOCATE(IDL,VOL,MAT,ENERV,ENERG) + IF(IPRINT.GT.2) CALL LCMLIB(IPEDIT) +*---- +* RELEASE TEMPORARY L_TRACK AND L_FLUX OBJECTS +*---- + IF((IKTRK1.EQ.0).AND.(IKFLUX.EQ.0)) THEN + CALL LCMCL(IPFLUX,2) + CALL LCMCL(IPTRK1,2) + ENDIF + RETURN +* + 190 FORMAT (/16H EDI: GEOMETRY ',A12,28H' WAS PREVIOUSLY TRACKED BY , + > 7HMODULE ,A12,1H.) + 200 FORMAT(/24H EDITION-RELATED OPTIONS/1X,23(1H-)/ + 1 7H NMERGE,I8,29H (NUMBER OF MERGED REGIONS)/ + 2 7H NGCOND,I8,38H (NUMBER OF CONDENSED ENERGY GROUPS)/ + 3 7H IFFAC ,I8,40H (=1: 4 FACTORS CALCULATION REQUESTED)/ + 4 7H ILUPS ,I8,43H (=1: REMOVE UP-SCATTERING CONTRIBUTIONS)/ + 5 7H NACTI ,I8,45H (NUMBER OF MIXTURES WITH ACTIVATION EDITS)/ + 6 7H NSTATS,I8,35H (TYPE OF STATISTIC CALCULATIONS)/ + 7 7H IADF ,I8,47H (=0: DO NOT COMPUTE ADF; =1: USE ALBS INFO; , + 8 60H=-2/2: USE BOUNDARY FLUX INFO; =3: USE EURYDICE INFO; =4: US, + 9 16HE MACROLIB INFO)/ + 1 7H IEUR ,I8,47H (=1/2/3: SYBIL OR EXCELL MACRO-TRACKING/NXT , + 2 20HMACRO-TRACKING/ELSE)/ + 3 7H NBMICR,I8,47H (=-1: PROCESS ALL ISOTOPES; >1: NUMBER OF IS, + 4 18HOTOPES TO PROCESS)/ + 5 7H IPRINT,I8,16H (PRINT LEVEL)) + 210 FORMAT( + 1 7H NSAVES,I8,47H (=0: NO COMPUTE/NO SAVE; =1: COMPUTE/NO SAVE, + 2 19H; =2: COMPUTE/SAVE)/ + 3 7H NW ,I8,47H (=0: FLUX WEIGHTING FOR P1 INFO; =1: CURRENT, + 4 23H WEIGHTING FOR P1 INFO)/ + 5 7H MAXPTS,I8,47H (ALLOCATED STORAGE LENGTH FOR REGION-DEPENDE, + 6 10HNT ARRAYS)/ + 7 7H IHF ,I8,39H (=1: H-FACTOR CALCULATION REQUESTED)/ + 8 7H NDEL ,I8,39H (NUMBER OF DELAYED PRECURSOR GROUPS)/ + 9 7H LGEO ,I8,47H (=0: MACRO-GEOMETRY NOT AVAILABLE; =1: IS AV, + 1 8HAILABLE)/ + 2 7H IADJ ,I8,47H (=0: DIRECT FLUX; =1: DIRECT-ADJOINT WEIGHTI, + 3 3HNG)/ + 4 7H ICURR ,I8,47H (=1: HETEROGENEOUS BN WEIGHTING; =2: TODOROV, + 5 58HA OUTSCATTER WEIGHTING; =4: SPHERICAL HARMONICS WEIGHTING)/ + 6 7H NOUT ,I8,47H (=0: OUTPUT ALL REACTIONS; >0: NUMBER OF OUT, + 7 14HPUT REACTIONS)/ + 8 7H IEDCUR,I8,40H (=0/1: FLUX/FLUX AND CURRENT EDITION)/ + 9 7H GOLVER,I8,38H (=0/1: GOLFIER-VERGAIN FLAG OFF/ON)) + END |