summaryrefslogtreecommitdiff
path: root/Dragon/src/CHAB.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/CHAB.f')
-rw-r--r--Dragon/src/CHAB.f247
1 files changed, 247 insertions, 0 deletions
diff --git a/Dragon/src/CHAB.f b/Dragon/src/CHAB.f
new file mode 100644
index 0000000..fbb7c48
--- /dev/null
+++ b/Dragon/src/CHAB.f
@@ -0,0 +1,247 @@
+*DECK CHAB
+ SUBROUTINE CHAB(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Modify data contained in the microlib and renormalize the fission
+* and scattering information.
+*
+*Copyright:
+* Copyright (C) 2007 Ecole Polytechnique de Montreal
+*
+*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): create or modification type(L_MICROLIB);
+* HENTRY(2): optional read-only type(L_MICROLIB or L_DRAGLIB).
+* 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)
+ TYPE(C_PTR) IPLIB,KPLIB
+ CHARACTER TEXT4*4,TYPSEC*8,HISOT*12,HSIGN*12,NAM1*12,CD*4,HSMG*131
+ DOUBLE PRECISION DFLOTT
+ INTEGER ISTATE(NSTATE),IMOD
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: NFS
+ REAL, ALLOCATABLE, DIMENSION(:) :: VAL
+ CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: HNAMIS
+ TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO
+*----
+* PARAMETER VALIDATION
+*----
+ IF(NENTRY.LT.1) CALL XABORT('CHAB: MIN OF 1 OBJECT EXPECTED.')
+ IF(NENTRY.GT.2) CALL XABORT('CHAB: MAX OF 2 OBJECTS EXPECTED.')
+ IPLIB=KENTRY(1)
+ IF(NENTRY.EQ.1) THEN
+ IF(JENTRY(1).NE.1) CALL XABORT('CHAB: OBJECT IN MODIFICATION '
+ 1 //'MODE EXPECTED NAME=.'//HENTRY(1))
+ CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN)
+ IF(HSIGN.EQ.'L_LIBRARY') THEN
+ IRHS=1
+ ELSE IF(HSIGN.EQ.'L_DRAGLIB') THEN
+ CALL XABORT('CHAB: WE DO NOT ALLOW THE IN-PLACE MODIFICATI'
+ 1 //'ON OF A DRAGLIB. USE A DIFFERENT LHS.')
+ ELSE
+ CALL XABORT('CHAB: MICROLIB OBJECT EXPECTED AT RHS.')
+ ENDIF
+ ELSE IF(NENTRY.EQ.2) THEN
+ IF(JENTRY(1).NE.0) CALL XABORT('CHAB: OBJECT IN CREATE MODE E'
+ 1 //'XPECTED.')
+ IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) CALL XABORT('CHAB: '
+ 1 //'LCM OBJECT EXPECTED AT RHS.')
+ IF(JENTRY(2).NE.2) CALL XABORT('CHAB: LCM OBJECT IN READ-ONLY'
+ 1 //'MODE EXPECTED AT RHS.')
+ CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN)
+ IF(HSIGN.EQ.'L_LIBRARY') THEN
+ IRHS=1
+ ELSE IF(HSIGN.EQ.'L_DRAGLIB') THEN
+ IRHS=2
+ ELSE
+ CALL XABORT('CHAB: MICROLIB OR DRAGLIB OBJECT EXPECTED AT '
+ 1 //'RHS.')
+ ENDIF
+ CALL LCMEQU(KENTRY(2),IPLIB)
+ ENDIF
+ IF(IRHS.EQ.1) THEN
+ CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE)
+ NBISO=ISTATE(2)
+ NGRP=ISTATE(3)
+ NLEG=ISTATE(4)
+ ELSE IF(IRHS.EQ.2) THEN
+ CALL LCMLEN(IPLIB,'ENERGY',NGRP,ITYLCM)
+ NGRP=NGRP-1
+ NLEG=100
+ ENDIF
+ ALLOCATE(VAL(NGRP))
+*----
+* READ THE INPUT DATA
+*----
+ VAL(:NGRP)=0.0
+ IMPX=1
+ 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+ IF(INDIC.NE.3) CALL XABORT('CHAB: CHARACTER DATA EXPECTED(1).')
+ IF(TEXT4.EQ.'EDIT') THEN
+* READ THE PRINT INDEX.
+ CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT)
+ IF(INDIC.NE.1) CALL XABORT('CHAB: INTEGER DATA EXPECTED(1).')
+ ELSE IF(TEXT4.EQ.'MODI') THEN
+* MODIFY/ADD AN ENTRY (CROSS SECTION, SPECTRA, ETC).
+ CALL REDGET(INDIC,NITMA,FLOTT,TYPSEC,DFLOTT)
+ IF(INDIC.NE.3) CALL XABORT('CHAB: CHARACTER DATA EXPECTED(2).')
+ CALL REDGET(INDIC,IGM,FLOTT,TEXT4,DFLOTT)
+ IF(INDIC.NE.1) CALL XABORT('CHAB: INTEGER DATA EXPECTED(2).')
+ IF((IGM.LT.1).OR.(IGM.GT.NGRP)) CALL XABORT('CHAB: WRONG IGM.')
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+ IF(INDIC.NE.3) CALL XABORT('CHAB: CHARACTER DATA EXPECTED(3).')
+ IF(TEXT4.NE.'TO') CALL XABORT('CHAB: TO KEYWORD EXPECTED.')
+ CALL REDGET(INDIC,IGP,FLOTT,TEXT4,DFLOTT)
+ IF(INDIC.NE.1) CALL XABORT('CHAB: INTEGER DATA EXPECTED(3).')
+ IF((IGP.LT.1).OR.(IGP.GT.NGRP)) CALL XABORT('CHAB: WRONG IGP.')
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+ IF(INDIC.NE.3) CALL XABORT('CHAB: CHARACTER DATA EXPECTED(4).')
+ IF(TEXT4.EQ.'VALE') THEN
+ DO 20 IGR=IGM,IGP
+ CALL REDGET(INDIC,NITMA,VAL(IGR),TEXT4,DFLOTT)
+ IF(INDIC.NE.2) CALL XABORT('CHAB: REAL DATA EXPECTED(1).')
+ 20 CONTINUE
+ IMOD=1
+ ELSE IF(TEXT4.EQ.'CONS') THEN
+ CALL REDGET(INDIC,NITMA,VALUE,TEXT4,DFLOTT)
+ IF(INDIC.NE.2) CALL XABORT('CHAB: REAL DATA EXPECTED(2).')
+ IMOD=2
+ ELSE IF(TEXT4.EQ.'PLUS') THEN
+ CALL REDGET(INDIC,NITMA,VALUE,TEXT4,DFLOTT)
+ IF(INDIC.NE.2) CALL XABORT('CHAB: REAL DATA EXPECTED(3).')
+ IMOD=3
+ ELSE IF(TEXT4.EQ.'MULT') THEN
+ CALL REDGET(INDIC,NITMA,VALUE,TEXT4,DFLOTT)
+ IF(INDIC.NE.2) CALL XABORT('CHAB: REAL DATA EXPECTED(4).')
+ IMOD=4
+ ELSE
+ CALL XABORT('CHAB: VALE/CONS/PLUS/MULT KEYWORD EXPECTED.')
+ ENDIF
+ CALL REDGET(INDIC,NITMA,FLOTT,HISOT,DFLOTT)
+ IF(INDIC.NE.3) CALL XABORT('CHAB: CHARACTER DATA EXPECTED(5).')
+ IF((IRHS.EQ.1).AND.(HISOT(9:).EQ.' ')) THEN
+* MODIFY MANY INSTANCES OF AN ISOTOPE IN A MICROLIB
+ ALLOCATE(HNAMIS(NBISO),IPISO(NBISO))
+ CALL LCMGTC(IPLIB,'ISOTOPESUSED',12,NBISO,HNAMIS)
+ CALL LIBIPS(IPLIB,NBISO,IPISO)
+ DO 30 ISO=1,NBISO
+ NAM1=HNAMIS(ISO)
+ IF(NAM1(:8).EQ.HISOT) THEN
+ KPLIB=IPISO(ISO) ! set ISO-th isotope
+ IF(.NOT.C_ASSOCIATED(KPLIB)) THEN
+ WRITE(HSMG,'(15HCHAB: ISOTOPE '',A12,7H'' (ISO=,I8,
+ 1 34H IS NOT AVAILABLE IN THE MICROLIB.)') NAM1,ISO
+ CALL XABORT(HSMG)
+ ENDIF
+ CALL CHAB01(KPLIB,IMPX,IRHS,NGRP,NLEG,IMOD,TYPSEC,NAM1,
+ 1 VALUE,IGM,IGP,VAL)
+ ENDIF
+ 30 CONTINUE
+ DEALLOCATE(IPISO,HNAMIS)
+ ELSE IF(IRHS.EQ.1) THEN
+* MODIFY A UNIQUE INSTANCE OF AN ISOTOPE IN A MICROLIB
+ ALLOCATE(HNAMIS(NBISO),IPISO(NBISO))
+ CALL LCMGTC(IPLIB,'ISOTOPESUSED',12,NBISO,HNAMIS)
+ CALL LIBIPS(IPLIB,NBISO,IPISO)
+ DO 35 ISO=1,NBISO
+ IF(HNAMIS(ISO).EQ.HISOT) THEN
+ KPLIB=IPISO(ISO) ! set ISO-th isotope
+ IF(.NOT.C_ASSOCIATED(KPLIB)) THEN
+ WRITE(HSMG,'(15HCHAB: ISOTOPE '',A12,7H'' (ISO=,I8,
+ 1 34H IS NOT AVAILABLE IN THE MICROLIB.)') HISOT,ISO
+ CALL XABORT(HSMG)
+ ENDIF
+ CALL CHAB01(KPLIB,IMPX,IRHS,NGRP,NLEG,IMOD,TYPSEC,HISOT,
+ 1 VALUE,IGM,IGP,VAL)
+ ENDIF
+ 35 CONTINUE
+ DEALLOCATE(IPISO,HNAMIS)
+ ELSE IF(IRHS.EQ.2) THEN
+* MODIFY AN ISOTOPE IN A DRAGLIB
+ CALL LCMLEN(IPLIB,HISOT,ILONG,ITYLCM)
+ IF(ILONG.EQ.0) CALL XABORT('CHAB: MISSING ISOTOPE '//
+ 1 HISOT//'.')
+ ALLOCATE(NFS(NGRP))
+ CALL LCMSIX(IPLIB,HISOT,1)
+ CALL LCMLEN(IPLIB,'TEMPERATURE',NTMP,ITYLCM)
+ CALL LCMLEN(IPLIB,'BIN-NFS',ILONG,ITYLCM)
+ NBIN=0
+ IF(ILONG.EQ.NGRP) THEN
+ CALL LCMGET(IPLIB,'BIN-NFS',NFS)
+ DO 40 IG=1,NGRP
+ NBIN=NBIN+NFS(IG)
+ 40 CONTINUE
+ IF(NBIN.EQ.0) CALL XABORT('CHAB: INVALID NBIN')
+ ENDIF
+ DO 60 ITMP=1,NTMP
+ WRITE (CD,'(I4.4)') ITMP
+ IF(IMPX.GT.0) WRITE(IOUT,'(/23H CHAB: PROCESS ISOTOPE ,A,
+ 1 22H AT TEMPERATURE SUBTMP,A4,1H.)') HISOT,CD
+ CALL LCMSIX (IPLIB,'SUBTMP'//CD,1)
+ CALL CHAB01(IPLIB,IMPX,IRHS,NGRP,NLEG,IMOD,TYPSEC,
+ 1 HISOT,VALUE,IGM,IGP,VAL)
+ IF(NBIN.GT.0) THEN
+ CALL CHAB03(IPLIB,IMPX,NGRP,NBIN,IMOD,TYPSEC,HISOT,
+ 1 VALUE,IGM,IGP,NFS,VAL)
+ ENDIF
+ IF(TYPSEC.NE.'CHI') THEN
+ CALL LCMLEN(IPLIB,'DILUTION',NDIL,ITYLCM)
+ DO 50 IDIL=1,NDIL
+ WRITE (CD,'(I4.4)') IDIL
+ IF(IMPX.GT.0) WRITE(IOUT,'(/23H CHAB: PROCESS ISOTOPE ,A,
+ 1 19H AT DILUTION SUBMAT,A4,1H.)') HISOT,CD
+ CALL LCMSIX(IPLIB,'SUBMAT'//CD,1)
+ IF(IMOD.LE.2) THEN
+ CALL CHAB01(IPLIB,IMPX,IRHS,NGRP,NLEG,1,TYPSEC,HISOT,
+ 1 0.0,IGM,IGP,VAL)
+ ELSE IF(IMOD.EQ.4) THEN
+ CALL CHAB01(IPLIB,IMPX,IRHS,NGRP,NLEG,IMOD,TYPSEC,
+ 1 HISOT,VALUE,IGM,IGP,VAL)
+ ENDIF
+ CALL LCMSIX (IPLIB,' ',2)
+ 50 CONTINUE
+ ENDIF
+ CALL LCMSIX (IPLIB,' ',2)
+ 60 CONTINUE
+ IF(NBIN.GT.0) DEALLOCATE(NFS)
+ CALL LCMSIX(IPLIB,' ',2)
+ ENDIF
+ ELSE IF(TEXT4.EQ.';') THEN
+ GO TO 70
+ ELSE
+ CALL XABORT('CHAB: '//TEXT4//' IS AN INVALID KEYWORD.')
+ ENDIF
+ GO TO 10
+*----
+* RECOVER INFORMATION
+*----
+ 70 DEALLOCATE(VAL)
+ RETURN
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:20:49 +0000