summaryrefslogtreecommitdiff
path: root/Dragon/src/MACUPD.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/MACUPD.f')
-rw-r--r--Dragon/src/MACUPD.f295
1 files changed, 295 insertions, 0 deletions
diff --git a/Dragon/src/MACUPD.f b/Dragon/src/MACUPD.f
new file mode 100644
index 0000000..8efd97c
--- /dev/null
+++ b/Dragon/src/MACUPD.f
@@ -0,0 +1,295 @@
+*DECK MACUPD
+ SUBROUTINE MACUPD(NENTRY,KENTRY,IPRINT,NTOTMX,NBMIX ,NGROUP,
+ > NANISO,NIFISS,NEDMAC,ITRANC)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Update Dragon macrolib with other Dragon macrolib.
+*
+*Copyright:
+* Copyright (C) 2007 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): G. Marleau
+*
+*Parameters: input
+* NENTRY number of structures.
+* KENTRY pointer to structures.
+* IPRINT print level.
+* NTOTMX maximum number of mixtures in input macrolibs.
+* NBMIX number of mixtures on output macrolib.
+* NGROUP number of groups.
+* NANISO maximun scattering anisotropy.
+* NIFISS number fissile isotopes per mixture.
+* NEDMAC number of aditional edition x-s.
+* ITRANC type of transport correction.
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+ IMPLICIT NONE
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) KENTRY(NENTRY)
+ INTEGER NENTRY,IPRINT,NTOTMX,NBMIX,NGROUP,NANISO,NIFISS,
+ > NEDMAC,ITRANC
+*----
+* LOCAL VARIABLES
+*----
+ INTEGER IOUT,NSTATE,MAXPAR
+ PARAMETER (IOUT=6,NSTATE=40,MAXPAR=10)
+*----
+* INPUT
+*----
+ CHARACTER CARLIR*12
+ INTEGER ITYPLU,INTLIR
+ REAL REALIR
+ DOUBLE PRECISION DBLLIR
+*----
+* LOCAL PARAMETERS
+*----
+ TYPE(C_PTR) IPMACR
+ INTEGER ISTATE(NSTATE),ITEXT4,IMIX,IEN,NUMNEW,NUMOLD,NBMIXF,
+ > NIFISF,NGROF,NEDF,NDELF,NBMIXO,NIFISO,NEDO,NDELO,
+ > ILCMLN,ILCMTY,ITC,NPART,I
+ CHARACTER TEXT4*4,HGROUP*12,HPART0*1,HPART(MAXPAR)*1
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: NAMEN,NUMFN,NUMPX
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IMLOC
+ REAL, ALLOCATABLE, DIMENSION(:) :: ENERN
+*----
+* SCRATCH STORAGE ALLOCATION
+* IMLOC mixture location
+*----
+ ALLOCATE(IMLOC(2,NTOTMX))
+*----
+* INITIALIZE IMLOC FOR MIXTURE ALREADY PRESENT ON OUTPUT MACROLIB
+*----
+ TEXT4=' '
+ READ(TEXT4,'(A4)') ITEXT4
+ IMLOC(:2,:NTOTMX)=0
+ DO 100 IMIX=1,NBMIX
+ IMLOC(1,IMIX)=1
+ IMLOC(2,IMIX)=IMIX
+ 100 CONTINUE
+ IF(IPRINT.GE.5) WRITE(IOUT,6000)
+*----
+* READ INPUT DATA
+* TYPICAL FORMAT:
+* EDIT iprint
+* CTRA { ON | OFF }
+* MIX numnew numold [{ UPDL | OLDL }]
+* WHERE
+* iprint = PRINT LEVEL
+* numnew = NEW MIXTURE NUMBER
+* numold = OLD MIXTURE NUMBER
+* UPDL = TAKE numold FORM LIBRARY TO UPDATE
+* OLDL = TAKE numold FORM OLD LIBRARY
+*----
+ ITYPLU = 3
+ CARLIR = 'MIX'
+ 1000 CONTINUE
+ IF(ITYPLU.NE.3) CALL XABORT('MACUPD: CHARACTER KEYWORD EXPECTED.')
+*----
+* CHECK FOR STOP/RETURN
+*----
+ IF(CARLIR .EQ. ';') THEN
+ GO TO 1005
+ ELSE IF(CARLIR(1:3).EQ.'MIX') THEN
+*----
+* READ MIX CARD
+*----
+ CALL REDGET(ITYPLU,NUMNEW,REALIR,CARLIR,DBLLIR)
+ IF(ITYPLU.NE.1) CALL XABORT('MACUPD: NEW MIXTURE NUMBER IS NOT'
+ > //' AN INTEGER.')
+ CALL REDGET(ITYPLU,NUMOLD,REALIR,CARLIR,DBLLIR)
+ IF(ITYPLU.NE.1) CALL XABORT('MACUPD: OLD MIXTURE NUMBER IS NOT'
+ > //' AN INTEGER.')
+ CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
+ IF(ITYPLU.NE.3) CALL XABORT('MACUPD: STRUCTURE TYPE IS NOT CHA'
+ > //'RACTER.')
+*---
+* TEST IF NUMNEW IS VALID
+*----
+ IF(NUMNEW.GT.NTOTMX) CALL XABORT('MACUPD: NEW MATERIAL NUMBER '
+ > //'IS TOO LARGE.')
+*----
+* BY DEFAULT CARLIR IS ASSUMED TO BE OLDL
+* IF CARLIR IS UPDL STORE INFORMATION IN IMLOC
+* KEYWORD OLDL NOT PROCESSED IF PRESENT
+* PROCESS KEYWORD OLDL ACCORDING TO USER'S GUIDE IN THE
+* CASE WHERE IT IS PRESENT
+*----
+ IF(CARLIR(1:4).EQ.'UPDL') THEN
+ IMLOC(1,NUMNEW)=1
+ IMLOC(2,NUMNEW)=NUMOLD
+ ELSE IF(CARLIR(1:4).EQ.'OLDL') THEN
+ IMLOC(1,NUMNEW)=2
+ IMLOC(2,NUMNEW)=NUMOLD
+ ELSE
+ IMLOC(1,NUMNEW)=2
+ IMLOC(2,NUMNEW)=NUMOLD
+ GO TO 1000
+ ENDIF
+ ELSE
+ CALL XABORT('MACUPD: KEYWORD '//CARLIR//' NOT PERMITTED.')
+ ENDIF
+ CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
+ GO TO 1000
+ 1005 CONTINUE
+*----
+* RECOVER CRITICITY PARAMETERS
+*----
+ CALL LCMLEN(KENTRY(2),'K-EFFECTIVE',ILCMLN,ILCMTY)
+ IF(ILCMLN.EQ.1) THEN
+ CALL LCMGET(KENTRY(2),'K-EFFECTIVE',REALIR)
+ CALL LCMPUT(KENTRY(1),'K-EFFECTIVE',1,2,REALIR)
+ ENDIF
+ CALL LCMLEN(KENTRY(2),'K-INFINITY',ILCMLN,ILCMTY)
+ IF(ILCMLN.EQ.1) THEN
+ CALL LCMGET(KENTRY(2),'K-INFINITY',REALIR)
+ CALL LCMPUT(KENTRY(1),'K-INFINITY',1,2,REALIR)
+ ENDIF
+ CALL LCMLEN(KENTRY(2),'B2 B1HOM',ILCMLN,ILCMTY)
+ IF(ILCMLN.EQ.1) THEN
+ CALL LCMGET(KENTRY(2),'B2 B1HOM',REALIR)
+ CALL LCMPUT(KENTRY(1),'B2 B1HOM',1,2,REALIR)
+ ENDIF
+*----
+* FIND TOTAL NUMBER OF MIXTURES CREATED
+*----
+ DO 120 IMIX=NTOTMX,1,-1
+ IF(IMLOC(2,IMIX).NE.0) THEN
+ NBMIXF=IMIX
+ GO TO 125
+ ENDIF
+ 120 CONTINUE
+ CALL XABORT('MACUPD: NO MIXTURES FOUND.')
+ 125 CONTINUE
+*----
+* TEST FOR ENERGY
+* FIND ADDITIONAL XS NAME
+* FIND TOTAL NUMBER OF FISSILE ISOTOPES AND THEIR NAME
+*----
+ ALLOCATE(NAMEN(2*NEDMAC),NUMFN(NBMIXF*NIFISS),
+ > NUMPX(NBMIXF*NIFISS),ENERN(2*NGROUP+1))
+ NAMEN(:2*NEDMAC)=ITEXT4
+*----
+* INITIALIZE VECTOR
+*----
+ NUMFN(:NBMIXF*NIFISS)=0
+ NUMPX(:NBMIXF*NIFISS)=0
+ NIFISF=0
+ NGROF =0
+ NEDF =0
+ NDELF =0
+ DO 130 IEN=1,NENTRY
+ IPMACR=KENTRY(IEN)
+ DO 131 IMIX=1,NTOTMX
+ IF(IMLOC(1,IMIX).EQ.IEN) THEN
+ ISTATE(:NSTATE)=0
+ CALL LCMGET(IPMACR,'STATE-VECTOR',ISTATE)
+ NBMIXO=ISTATE(2)
+ NIFISO=ISTATE(4)
+ NEDO=ISTATE(5)
+ NDELO=ISTATE(7)
+ CALL MACNFI(IPMACR,IPRINT,IEN ,NTOTMX,NGROUP,NIFISS,
+ > NEDMAC,NBMIXF,NGROF ,NIFISF,NEDF ,NDELF ,
+ > NBMIXO,NIFISO,NEDO ,NDELO ,IMLOC ,ENERN ,
+ > NAMEN ,NUMFN ,NUMPX )
+ GO TO 135
+ ENDIF
+ 131 CONTINUE
+ 135 CONTINUE
+ 130 CONTINUE
+*----
+* SAVE ENERGY, ADDITIONAL XS NAME AND FISSILE ISOTOPES INFORMATION
+* ON FINAL MACROLIB
+*----
+ IPMACR=KENTRY(1)
+ IF(NGROF.GT.0) THEN
+ CALL LCMPUT(IPMACR,'ENERGY',NGROF+1,2,ENERN)
+ CALL LCMPUT(IPMACR,'DELTAU',NGROF,2,ENERN(NGROF+2))
+ IF(IPRINT.GE.5) THEN
+ WRITE(IOUT,6010) 'ENERGY '
+ WRITE(IOUT,6013) (ENERN(ITC),ITC=1,NGROF+1)
+ WRITE(IOUT,6010) 'DELTAU '
+ WRITE(IOUT,6013) (ENERN(ITC),ITC=NGROF+2,2*NGROF+1)
+ ENDIF
+ ENDIF
+ IF(NEDF.GT.0) THEN
+ CALL LCMPUT(IPMACR,'ADDXSNAME-P0',2*NEDF,3,NAMEN)
+ IF(IPRINT.GE.5) THEN
+ WRITE(IOUT,6010) 'ADDXSNAME-P0'
+ WRITE(IOUT,6011) (NAMEN(ITC),ITC=1,2*NEDO)
+ ENDIF
+ ENDIF
+ IF(NIFISF.GT.0) THEN
+ IF(IPRINT.GE.5) THEN
+ WRITE(IOUT,6010) 'FISSIONINDEX'
+ WRITE(IOUT,6012) (NUMFN(ITC),ITC=1,NBMIXF*NIFISF)
+ ENDIF
+ ENDIF
+ DEALLOCATE(ENERN)
+*----
+* CROSS SECTION PROCESSING IN GROUP LIST DIRECTORY WITH UPDATE.
+*----
+ HGROUP='GROUP'
+ CALL MACUPG(KENTRY,HGROUP,NENTRY,NIFISF,NDELF,NEDF,NGROUP,NBMIXF,
+ > NIFISS,NANISO,NEDMAC,NTOTMX,ITRANC,IPRINT,NAMEN,NUMPX,IMLOC)
+*----
+* RESET NUMFFN TO ONE FOR TERMS WHICH ARE NOT 0 AND SAVE
+*----
+ IF(NIFISF.GT.0) THEN
+ CALL LCMPUT(IPMACR,'FISSIONINDEX',NBMIXF*NIFISF,1,NUMFN)
+ ENDIF
+*----
+* CCROSS SECTION PROCESSING IN COMPANION GROUP LIST DIRECTORY WITH
+* UPDATE.
+*----
+ NPART=0
+ DO 140 IEN=1,NENTRY
+ IPMACR=KENTRY(IEN)
+ CALL LCMLEN(IPMACR,'STATE-VECTOR',ILCMLN,ILCMTY)
+ IF(ILCMLN.EQ.0) GO TO 140
+ CALL LCMGET(IPMACR,'STATE-VECTOR',ISTATE)
+ IF(ISTATE(17).GT.0) THEN
+ NPART=ISTATE(17)+1
+ IF(NPART.GT.MAXPAR) CALL XABORT('MAXUPD: MAXPAR OVERFLOW.')
+ CALL LCMGTC(IPMACR,'PARTICLE',1,HPART0)
+ CALL LCMGTC(IPMACR,'PARTICLE-NAM',1,NPART,HPART)
+ GO TO 150
+ ENDIF
+ 140 CONTINUE
+ 150 DO I=1,NPART
+ IF(HPART(I).EQ.HPART0) CYCLE
+ HGROUP='GROUP-'//HPART(I)
+ CALL MACUPG(KENTRY,HGROUP,NENTRY,NIFISF,NDELF,NEDF,NGROUP,
+ > NBMIXF,NIFISS,NANISO,NEDMAC,NTOTMX,ITRANC,IPRINT,NAMEN,NUMPX,
+ > IMLOC)
+ ENDDO
+ DEALLOCATE(NUMPX,NUMFN,NAMEN)
+ NBMIX=NBMIXF
+ NIFISS=NIFISF
+ NEDMAC=NEDF
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ DEALLOCATE(IMLOC)
+ RETURN
+*----
+* EDIT FORMATS
+*----
+ 6000 FORMAT(1X,'MACUPD - UPDATING MACROLIB ')
+ 6010 FORMAT(7X, ' PRECESSING RECORD : ',A12)
+ 6011 FORMAT(10(2A4,4X))
+ 6012 FORMAT(10(I8,4X))
+ 6013 FORMAT(1P,8E15.7)
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:17:28 +0000