Initial commit from Polytechnique Montreal

1 files changed, 297 insertions, 0 deletions

diff --git a/Dragon/src/CHAB01.f b/Dragon/src/CHAB01.f
new file mode 100644
index 0000000..59a3810
--- /dev/null
+++ b/Dragon/src/CHAB01.f
@@ -0,0 +1,297 @@
+*DECK CHAB01
+      SUBROUTINE CHAB01(IPLIB,IMPX,IRHS,NGRP,NLEG,IMOD,TYPSEC,HISOT,
+     1 VALUE,IGM,IGP,VAL)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Modify a specific isotope and reaction in a microlib.
+*
+*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): A. Hebert
+*
+*Parameters: input
+* IPLIB   LCM pointer to the Microlib or Draglib.
+* IMPX    print index.
+* IRHS    type of IPLIB: =1: Microlib; =2: Draglib.
+* NGRP    number of energy groups.
+* NLEG    max Legendre order of scattering anisotropy (1=isotropic,
+*         etc.).
+* 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.
+* VAL     array of values used if IMOD=1.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPLIB
+      INTEGER IMPX,IRHS,NGRP,NLEG,IMOD,IGM,IGP
+      CHARACTER TYPSEC*8,HISOT*12
+      REAL VALUE,VAL(NGRP)
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER (IOUT=6,NCAPT=5)
+      CHARACTER AJUS(4)*4,HCAPT(NCAPT)*8,CM*2
+      REAL, ALLOCATABLE, DIMENSION(:) :: XSECT,DELTA,FMULT,GAR1
+*----
+*  DATA STATEMENTS
+*----
+      DATA AJUS/'VALE','CONS','PLUS','MULT'/
+      DATA HCAPT/'NG','NP','NA','ND','NT'/
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(XSECT(NGRP),DELTA(NGRP),FMULT(NGRP),GAR1(NGRP))
+*
+      IF(IMPX.GT.0) WRITE(IOUT,'(/17H CHAB01: MODIFY (,A,11H) REACTION ,
+     1 A,12H OF ISOTOPE ,A,1H.)') AJUS(IMOD),TYPSEC,HISOT
+      CALL LCMLEN(IPLIB,TYPSEC,ILONG,ITYLCM)
+      IF((ILONG.EQ.0.).AND.(TYPSEC(:4).NE.'CAPT')
+     1 .AND.(TYPSEC(:2).NE.'NU')) THEN
+         CALL XABORT('CHAB01: MISSING REACTION '//TYPSEC//'.')
+      ENDIF
+*----
+*  MODIFY CROSS SECTION
+*----
+      XSECT(:NGRP)=0.0
+      GAR1(:NGRP)=0.0
+      IF(TYPSEC.EQ.'NTOT0') THEN
+         CALL LCMGET(IPLIB,TYPSEC,XSECT)
+         CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,XSECT,DELTA,FMULT)
+         CALL LCMPUT(IPLIB,TYPSEC,NGRP,2,XSECT)
+      ELSE IF(TYPSEC.EQ.'NG'.OR.TYPSEC.EQ.'NP'.OR.TYPSEC.EQ.'NA'.OR.
+     1 TYPSEC.EQ.'ND'.OR.TYPSEC.EQ.'NT') THEN
+
+*        application of the perturbation
+
+         CALL LCMGET(IPLIB,TYPSEC,XSECT)
+         CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,XSECT,DELTA,FMULT)
+         CALL LCMPUT(IPLIB,TYPSEC,NGRP,2,XSECT)
+         XSECT(:NGRP)=0.0
+         CALL LCMGET(IPLIB,'NTOT0',XSECT)
+         DO 10 IG1=1,NGRP
+         XSECT(IG1)=XSECT(IG1)+DELTA(IG1)
+   10    CONTINUE
+         CALL LCMPUT(IPLIB,'NTOT0',NGRP,2,XSECT)
+      ELSE IF(TYPSEC.EQ.'CAPT') THEN
+         IF(IMOD.NE.4) CALL XABORT('CHAB01: ONLY MULT ALLOWED.')
+         DO 320 ICAPT=1,NCAPT
+         TYPSEC=HCAPT(ICAPT)
+         CALL LCMLEN(IPLIB,TYPSEC,ILONG,ITYLCM)
+         IF(ILONG.NE.0.0) THEN
+*           application of the perturbation
+            WRITE(IOUT,*) 'CHAB01: REACTION CAPTURE INCLUDES ',TYPSEC
+            XSECT(:NGRP)=0.0
+            CALL LCMGET(IPLIB,TYPSEC,XSECT)
+            CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,XSECT,DELTA,FMULT)
+            CALL LCMPUT(IPLIB,TYPSEC,NGRP,2,XSECT)
+            XSECT(:NGRP)=0.0
+            CALL LCMGET(IPLIB,'NTOT0',XSECT)
+            DO 310 IG1=1,NGRP
+            XSECT(IG1)=XSECT(IG1)+DELTA(IG1)
+  310       CONTINUE
+            CALL LCMPUT(IPLIB,'NTOT0',NGRP,2,XSECT)
+         ENDIF
+  320    CONTINUE
+         TYPSEC='CAPT'
+      ELSE IF(TYPSEC.EQ.'NELAS'.OR.TYPSEC.EQ.'NINEL') THEN
+         CALL LCMGET(IPLIB,TYPSEC,XSECT)
+         CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,XSECT,DELTA,FMULT)
+         CALL LCMPUT(IPLIB,TYPSEC,NGRP,2,XSECT)
+*
+*        additive modification of P0 scattering information
+         JMOD=3
+         CALL CHAB04(IPLIB,IMPX,IRHS,NGRP,NLEG,JMOD,0,IGM,IGP,DELTA,
+     1   DELTA,FMULT)
+*
+*        multiplicative modification of transport correction
+         CALL LCMLEN(IPLIB,'TRANC',ILONG,ITYLCM)
+         IF(ILONG.GT.0) THEN
+            XSECT(:NGRP)=0.0
+            CALL LCMGET(IPLIB,'TRANC',XSECT)
+            DO 20 IG1=1,NGRP
+            XSECT(IG1)=XSECT(IG1)*FMULT(IG1)
+   20       CONTINUE
+            CALL LCMPUT(IPLIB,'TRANC',NGRP,2,XSECT)
+         ENDIF
+*
+*        multiplicative modification of Pn scattering information with
+*        n>0
+         DO 30 JL=1,NLEG-1
+            WRITE(CM,'(I2.2)') JL
+            CALL LCMLEN(IPLIB,'SCAT'//CM,ILONG,ITYLCM)
+            IF(ILONG.GT.0) THEN
+               JMOD=4
+               CALL CHAB04(IPLIB,IMPX,IRHS,NGRP,NLEG,JMOD,JL,IGM,IGP,
+     1         FMULT,DELTA,FMULT)
+            ENDIF
+   30    CONTINUE
+*
+*        additive modification of total cross section
+         XSECT(:NGRP)=0.0
+         CALL LCMGET(IPLIB,'NTOT0',XSECT)
+         DO 40 IG1=1,NGRP
+         XSECT(IG1)=XSECT(IG1)+DELTA(IG1)
+   40    CONTINUE
+         CALL LCMPUT(IPLIB,'NTOT0',NGRP,2,XSECT)
+      ELSE IF((TYPSEC.EQ.'N2N').OR.(TYPSEC.EQ.'N3N').OR.
+     1        (TYPSEC.EQ.'N4N')) THEN
+
+         CALL LCMGET(IPLIB,TYPSEC,GAR1)
+         CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,GAR1,DELTA,FMULT)
+         CALL LCMPUT(IPLIB,TYPSEC,NGRP,2,GAR1)
+*
+*        additive modification of total cross section
+         CALL LCMGET(IPLIB,'NTOT0',XSECT)
+         DO 50 IG1=1,NGRP
+         XSECT(IG1)=XSECT(IG1)+DELTA(IG1)
+   50    CONTINUE
+         CALL LCMPUT(IPLIB,'NTOT0',NGRP,2,XSECT)
+*
+*        additive modification of P0 scattering information
+         IF (TYPSEC.EQ.'N2N') THEN
+            DO 60 IG1=1,NGRP
+            DELTA(IG1)=2.0*DELTA(IG1)
+   60      CONTINUE
+         ELSE IF (TYPSEC.EQ.'N3N') THEN
+            DO 70 IG1=1,NGRP
+            DELTA(IG1)=3.0*DELTA(IG1)
+   70       CONTINUE
+         ELSE IF (TYPSEC.EQ.'N4N') THEN
+            DO 80 IG1=1,NGRP
+            DELTA(IG1)=4.0*DELTA(IG1)
+   80       CONTINUE
+         ENDIF
+         JMOD=3
+         CALL CHAB04(IPLIB,IMPX,IRHS,NGRP,NLEG,JMOD,0,IGM,IGP,DELTA,
+     1   DELTA,FMULT)
+*
+*        multiplicative modification of Pn scattering information with
+*        n>0
+         DO 90 JL=1,NLEG-1
+            WRITE(CM,'(I2.2)') JL
+            CALL LCMLEN(IPLIB,'SCAT'//CM,ILONG,ITYLCM)
+            IF(ILONG.GT.0) THEN
+               JMOD=4
+               CALL CHAB04(IPLIB,IMPX,IRHS,NGRP,NLEG,JMOD,JL,IGM,IGP,
+     1         FMULT,DELTA,FMULT)
+            ENDIF
+   90    CONTINUE
+      ELSE IF((TYPSEC(:4).EQ.'SIGS').OR.(TYPSEC(:4).EQ.'SCAT')) THEN
+         READ(TYPSEC(5:6),'(I2)') IL
+*        additive or multiplicative modification of Pn scattering
+*        information
+         XSECT(:NGRP)=0.0
+         IF(IMOD.EQ.1) THEN
+            DO 100 IG=IGM,IGP
+            XSECT(IG)=VAL(IG)
+  100       CONTINUE
+         ELSE
+            DO 110 IG=IGM,IGP
+            XSECT(IG)=VALUE
+  110       CONTINUE
+         ENDIF
+         CALL CHAB04(IPLIB,IMPX,IRHS,NGRP,NLEG,IMOD,IL,IGM,IGP,XSECT,
+     1   DELTA,FMULT)
+*
+*        multiplicative modification of transport correction
+         CALL LCMLEN(IPLIB,'TRANC',ILONG,ITYLCM)
+         IF((IL.LE.1).AND.(ILONG.GT.0)) THEN
+         XSECT(:NGRP)=0.0
+            CALL LCMGET(IPLIB,'TRANC',XSECT)
+            DO 120 IG1=1,NGRP
+            XSECT(IG1)=XSECT(IG1)*FMULT(IG1)
+  120       CONTINUE
+            CALL LCMPUT(IPLIB,'TRANC',NGRP,2,XSECT)
+         ENDIF
+*
+*        additive modification of total cross-section
+         IF(IL.EQ.0) THEN
+            XSECT(:NGRP)=0.0
+            CALL LCMGET(IPLIB,'NTOT0',XSECT)
+            DO 130 IG1=1,NGRP
+            XSECT(IG1)=XSECT(IG1)+DELTA(IG1)
+  130    CONTINUE
+            CALL LCMPUT(IPLIB,'NTOT0',NGRP,2,XSECT)
+         ENDIF
+*
+*        multiplicative modification of Pn scattering information with
+*        n>IL
+         DO 140 JL=IL+1,NLEG-1
+            WRITE(CM,'(I2.2)') JL
+            CALL LCMLEN(IPLIB,'SCAT'//CM,ILONG,ITYLCM)
+            IF(ILONG.GT.0) THEN
+               JMOD=4
+               CALL CHAB04(IPLIB,IMPX,IRHS,NGRP,NLEG,JMOD,JL,IGM,IGP,
+     1         FMULT,DELTA,FMULT)
+            ENDIF
+  140    CONTINUE
+      ELSE IF((TYPSEC.EQ.'NFTOT').OR.(TYPSEC.EQ.'NUSIGF')) THEN
+         CALL LCMGET(IPLIB,'NFTOT',GAR1)
+         CALL LCMGET(IPLIB,'NUSIGF',XSECT)
+         DO 180 IG1=1,NGRP
+         IF(GAR1(IG1).NE.0.0) THEN
+            XSECT(IG1)=XSECT(IG1)/GAR1(IG1)
+         ENDIF
+  180    CONTINUE
+         CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,GAR1,DELTA,FMULT)
+         DO 190 IG1=1,NGRP
+         XSECT(IG1)=GAR1(IG1)*XSECT(IG1)
+  190    CONTINUE
+         CALL LCMPUT(IPLIB,'NFTOT',NGRP,2,GAR1)
+         CALL LCMPUT(IPLIB,'NUSIGF',NGRP,2,XSECT)
+         XSECT(:NGRP)=0.0
+         CALL LCMGET(IPLIB,'NTOT0',XSECT)
+         DO 200 IG1=1,NGRP
+         XSECT(IG1)=XSECT(IG1)+DELTA(IG1)
+  200    CONTINUE
+         CALL LCMPUT(IPLIB,'NTOT0',NGRP,2,XSECT)
+      ELSE IF(TYPSEC.EQ.'NU') THEN
+         CALL LCMGET(IPLIB,'NFTOT',GAR1)
+         CALL LCMGET(IPLIB,'NUSIGF',XSECT)
+         DO 210 IG1=1,NGRP
+         IF(GAR1(IG1).NE.0.0) THEN
+            XSECT(IG1)=XSECT(IG1)/GAR1(IG1)
+         ENDIF
+  210    CONTINUE
+         CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,XSECT,DELTA,FMULT)
+         DO 220 IG1=1,NGRP
+         XSECT(IG1)=GAR1(IG1)*XSECT(IG1)
+  220    CONTINUE
+         CALL LCMPUT(IPLIB,'NUSIGF',NGRP,2,XSECT)
+      ELSE IF(TYPSEC.EQ.'CHI') THEN
+         CALL LCMGET(IPLIB,TYPSEC,GAR1)
+         CALL CHAB02(NGRP,IMOD,VALUE,IGM,IGP,VAL,GAR1,DELTA,FMULT)
+         SUM=0.0
+         DO 230 IG1=1,NGRP
+         SUM=SUM+GAR1(IG1)
+  230    CONTINUE
+         DO 240 IG1=1,NGRP
+         GAR1(IG1)=GAR1(IG1)/SUM
+  240    CONTINUE
+         CALL LCMPUT(IPLIB,TYPSEC,NGRP,2,GAR1)
+      ELSE
+         CALL XABORT('CHAB01: UNKNOWN REACTION '//TYPSEC//'.')
+      ENDIF
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(GAR1,FMULT,DELTA,XSECT)
+      RETURN
+      END