Initial commit from Polytechnique Montreal

1 files changed, 115 insertions, 0 deletions

diff --git a/Dragon/src/CHAB03.f b/Dragon/src/CHAB03.f
new file mode 100644
index 0000000..e26368e
--- /dev/null
+++ b/Dragon/src/CHAB03.f
@@ -0,0 +1,115 @@
+*DECK CHAB03
+      SUBROUTINE CHAB03(IPLIB,IMPX,NGRP,NBIN,IMOD,TYPSEC,HISOT,VALUE,
+     1 IGM,IGP,NFS,VAL)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Modify a specific isotope and Autolib reaction in a Draglib.
+*
+*Copyright:
+* Copyright (C) 2011 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
+* IPLIB   LCM pointer to the Draglib.
+* IMPX    print index.
+* NGRP    number of coarse energy groups.
+* NBIN    number of fine energy groups.
+* IMOD    type of modification: =1: complete replacement; =2: replace
+*         specific values by VALUE; =3: increase by VALUE; =4: multiply
+*         by VALUE.
+* TYPSEC  name of reaction to modify.
+* HISOT   name of isotope to modify.
+* VALUE   value used in modification operation.
+* IGM     first energy group to modify.
+* IGP     last energy group to modify.
+* NFS     number of fine groups per coarse group.
+* VAL     array of values used if IMOD=1.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPLIB
+      INTEGER IMPX,NGRP,NBIN,IMOD,IGM,IGP,NFS(NGRP)
+      CHARACTER TYPSEC*8,HISOT*12
+      REAL VALUE,VAL(NGRP)
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER (IOUT=6)
+      CHARACTER AJUS(4)*4
+      REAL, ALLOCATABLE, DIMENSION(:) :: GAR1,DELTA,FMULT,VALB
+*----
+*  DATA STATEMENTS
+*----
+      DATA AJUS/'VALE','CONS','PLUS','MULT'/
+*----
+*   CORRESPONDENCE BETWEEN BIN AND COARSE ENERGT GROUPS
+*----
+      IGMBIN=NBIN+1
+      IGPBIN=0
+      IBIN=0
+      DO 10 IG=1,NGRP
+      IF(IG.EQ.IGM) IGMBIN=IBIN+1
+      IBIN=IBIN+NFS(IG)
+      IF(IG.EQ.IGP) IGPBIN=IBIN
+   10 CONTINUE
+      IF(IGPBIN.LT.IGMBIN) RETURN
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(GAR1(NBIN),DELTA(NBIN),FMULT(NBIN),VALB(NBIN))
+*
+      IF(IMOD.EQ.1) THEN
+         IBIN=0
+         DO 25 IG=1,NGRP
+         DO 20 J=1,NFS(IG)
+         IBIN=IBIN+1
+         VALB(IBIN)=VAL(IG)
+   20    CONTINUE
+   25    CONTINUE
+      ENDIF
+*----
+*   APPLY CORRECTION
+*----
+      IF(TYPSEC.EQ.'NTOT0') THEN
+         CALL LCMLEN(IPLIB,'BIN-NTOT0',ILONG,ITYLCM)
+         IF(ILONG.EQ.NBIN) THEN
+            IF(IMPX.GT.0) WRITE(IOUT,'(/17H CHAB03: MODIFY (,A,5H) BIN,
+     1      27H-NTOT0 REACTION OF ISOTOPE ,A,1H.)') AJUS(IMOD),HISOT
+            CALL LCMGET(IPLIB,'BIN-NTOT0',GAR1)
+            CALL CHAB02(NBIN,IMOD,VALUE,IGMBIN,IGPBIN,VALB,GAR1,DELTA,
+     1      FMULT)
+            CALL LCMPUT(IPLIB,'BIN-NTOT0',NBIN,2,GAR1)
+         ENDIF
+      ELSE IF((TYPSEC(:4).EQ.'SIGS').OR.(TYPSEC(:4).EQ.'SCAT')) THEN
+         CALL LCMLEN(IPLIB,'BIN-SIGS00',ILONG,ITYLCM)
+         IF(ILONG.EQ.NBIN) THEN
+            IF(IMPX.GT.0) WRITE(IOUT,'(/17H CHAB03: MODIFY (,A,5H) BIN,
+     1      28H-SIGS00 REACTION OF ISOTOPE ,A,1H.)') AJUS(IMOD),HISOT
+            CALL LCMGET(IPLIB,'BIN-SIGS00',GAR1)
+            CALL CHAB02(NBIN,IMOD,VALUE,IGMBIN,IGPBIN,VALB,GAR1,DELTA,
+     1      FMULT)
+            CALL LCMPUT(IPLIB,'BIN-SIGS00',NBIN,2,GAR1)
+            CALL LCMGET(IPLIB,'BIN-NTOT0',GAR1)
+            DO 30 IBIN=1,NBIN
+            GAR1(IBIN)=GAR1(IBIN)+DELTA(IBIN)
+   30       CONTINUE
+            CALL LCMPUT(IPLIB,'BIN-NTOT0',NBIN,2,GAR1)
+         ENDIF
+      ENDIF
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(VALB,FMULT,DELTA,GAR1)
+      RETURN
+      END