diff --git a/sammy/src/ang/mang1.f b/sammy/src/ang/mang1.f
index 22dc26622aefa89e49df18d05b778cefc29d4b31..b5e4ddb440d30d45845bc0414209acb238044000 100644
--- a/sammy/src/ang/mang1.f
+++ b/sammy/src/ang/mang1.f
@@ -27,6 +27,7 @@ C
use SammyGridAccess_M
use AuxGridHelper_M
use array_sizes_common_m, only : calcData
+ use normalize_and_background
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Another_Process_Will_Happen, Need_Isotopes
C
@@ -853,6 +854,7 @@ C
use ifwrit_m
use fixedr_m
use lbro_common_m
+ use normalize_and_background
use array_sizes_common_m, only : calcData
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
diff --git a/sammy/src/clm/mclm3.f b/sammy/src/clm/mclm3.f
index 560af711f5cc1406c2060edb2099c27ad5ce8590..7937275855c848cfa747c9d2e73c6685f0abc67f 100644
--- a/sammy/src/clm/mclm3.f
+++ b/sammy/src/clm/mclm3.f
@@ -33,6 +33,7 @@ C
use mfgm3_M
use Qtrap_Clm_m
use array_sizes_common_m, only : calcData, calcDataSelf
+ use convert_to_transmission_m
IMPLICIT None
LOGICAL Need_Isotopes
LOGICAL Another_Process_Will_Happen
diff --git a/sammy/src/clq/mclq1.f b/sammy/src/clq/mclq1.f
index 6a1124bfea4ee4795faa117c35bedf62d681cb8f..9421f5f7e237ae980c0c303f135e10f40d057af1 100644
--- a/sammy/src/clq/mclq1.f
+++ b/sammy/src/clq/mclq1.f
@@ -221,11 +221,6 @@ C ********* copy results if there is broadening
END DO
C *** end of do-loop on energies
C
- IF (Ywhich .OR. Maxwel.EQ.1 .OR. Knocor.EQ.1) THEN
- Kkkmin = Kkkmin - 1
- CALL Write_Cross_Sections (calcData,
- * Nnnsig, Kkkkkk, Kkkmin, 0)
- END IF
C
call grid%destroy()
call auxGrid%destroy()
diff --git a/sammy/src/cro/mcro1.f b/sammy/src/cro/mcro1.f
index 3758fd4c20efb919e56e5b7e068680725f1b51c6..2283ba4e26a452c4003f2d3386ed1065243813e5 100644
--- a/sammy/src/cro/mcro1.f
+++ b/sammy/src/cro/mcro1.f
@@ -107,8 +107,6 @@ C ********* if want Maxwellian averages or energy-averages with no
C ********* correction terms, do same as if there is broadening
C ********* except don't convert to transmission unless needed
IF (Maxwel.EQ.1 .OR. Knocor.EQ.1) THEN
- IF (Ytrans .AND. Kcros.LT.7 .AND. Ktruet.EQ.0) CALL
- * Transm (Sigxxx, Dasigx, Dbsigx, 1, Kvthck, Thick)
GO TO 90
END IF
C
@@ -116,8 +114,6 @@ C ********* if there is doppler broadening, GO TO 90
IF (Ydoppr) GO TO 90
C
C ********* if no Doppler, and this is transmission, make conversion
- IF (Ytrans .AND. Kcros.LT.7 .AND. Ktruet.EQ.0) CALL
- * Transm (Sigxxx, Dasigx, Dbsigx, 1, Kvthck, Thick)
C
C ********* if there is resolution broadening or angular
C distributions, do nothing else here
@@ -125,9 +121,6 @@ C distributions, do nothing else here
C
C ********* if ETA is being calculated and there is no broadening,
C ********* find derivative with respect to nu
- IF (Kcros.EQ.6) THEN
- CALL Fix_Eta (Iflmsc, Sigxxx, Dasigx, Dbsigx)
- END IF
C
C ********* If this is fake data, store it and move on
IF (Kfake.EQ.1) THEN
@@ -136,13 +129,6 @@ C ********* If this is fake data, store it and move on
END IF
C
C ********* if there is normalization or background, include it
- IF (Ynrmbk) THEN
- IF (Numnbk.GT.0) CALL Norm (Parnbk, Iflnbk, Sigxxx,
- * Dasigx, Dbsigx, Su, Nnnsig)
- IF (Numbgf.GT.0) CALL Bgfrpi (Parbgf, Iflbgf, Kndbgf,
- * Bgfmin, Bgfmax, Texbgf, Teabgf, Sigxxx, Dbsigx, Su,
- * Nnnsig)
- END IF
C
C ********* Write results onto theory if there is no broadening etc
IF (Jjjdop.NE.1) THEN
@@ -152,12 +138,6 @@ C ********* Write results onto theory if there is no broadening etc
! this already is the sum over all isotopes
call calcData%addCalculatedData(Kkkkkk, Nnnsig, ndasig,
* ndbsig, -1, Sigxxx, Dasigx, Dbsigx)
- do Jsig = 1,Nnnsig
- ! get cross section (position=0) at energy point
- ! Kkkkkk and section Jsig
- Theory(Jsig,Jdat) =
- * calcData%getDataNs(Kkkkkk, Jsig, 0, 1)
- end do
END IF
cycle
C
@@ -172,13 +152,8 @@ C ********* copy results if there is broadening
C ****** end of do-loop on energies
C
C
- IF (Ywhich .OR. Maxwel.EQ.1 .OR. Knocor.EQ.1) THEN
- Kkkmin = Kkkmin - 1
- CALL Write_Cross_Sections (calcData,
- * Nnnsig, numE, Kkkmin, 0)
- END IF
C
- IF (Kpiece.EQ.1) CALL Odfpcs (Dum, Pieces)
+ IF (Kpiece.EQ.1) CALL Odfpcs (Dum, Pieces)
C
call grid%destroy()
RETURN
@@ -218,40 +193,3 @@ C
END IF
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- Subroutine Fix_Eta (Iflmsc, Sigxxx, Dasigx, Dbsigx)
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Iflmsc(*), Sigxxx(Nnnsig,*), Dasigx(Nnnsig,*),
- * Dbsigx(Nnnsig,Ndbxxx,*)
-C *** Here we are generating eta = nu * (fission/absorption)
- DO Iso=1,Nnniso
- Sigma = Sigxxx(1,iso)
- F = Sigxxx(2,Iso)
- A = Sigxxx(1,Iso) - F
- Sigxxx(1,Iso) = F/Sigma*Etanuu
- IF (Ksolve.NE.2) THEN
- IF (Ndasig.GT.0) THEN ! cro and mlb only ever have one nuclide
- DO Ipar=1,Ndasig
- Dasigx(1,Ipar) = Etanuu *
- * ( Dasigx(2,Ipar)*(A/Sigma)
- * - Dasigx(1,Ipar)*(F/Sigma) )/Sigma
- END DO
- END IF
- IF (Ndbsig.GT.0) THEN
- DO Ipar=1,Ndbsig
- Dbsigx(1,Ipar,Iso) = Etanuu *
- * ( Dbsigx(2,Ipar,Iso)*(A/Sigma)
- * - Dbsigx(1,Ipar,Iso)*(F/Sigma) )/Sigma
- END DO
- END IF
- END IF
- CALL Nnneta (Iflmsc, Sigxxx, Dbsigx, Nnnsig, Nnniso)
- END DO
- RETURN
- END
diff --git a/sammy/src/cro/mnrm1.f b/sammy/src/cro/mnrm1.f
deleted file mode 100644
index d813517f7c484789cfa82731347203a46c5c5455..0000000000000000000000000000000000000000
--- a/sammy/src/cro/mnrm1.f
+++ /dev/null
@@ -1,359 +0,0 @@
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Norm (Parnbk, Iflnbk, Sig, dA, dB, Em, Nummmm)
-C
-C *** Purpose -- Add backgrounds
-C
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use broad_common_m
- use abro_common_m
- use cbro_common_m
- use lbro_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Sig(*), dA(Nummmm,*), dB(Nummmm,*), Iflnbk(6,*),
- * Parnbk(6,*)
-C DIMENSION Sig(Nummmm), dA(.,Ndasig), dB(.,Ndbsig),
-C * Iflnbk(6,Nangle), Parnbk(6,Nangle)
- DATA Zero /0.0d0/, One /1.0d0/
-C
- IF (Nnniso.NE.1) STOP '[STOP in Norm in cro/mnrm1.f]'
-C
- IF (Numnbk.GT.6) GO TO 50
-C
-C *** Here is original, with only one set of normalization/backgrounds
-C *** that work for all cross sections
- DO Nn=1,Nummmm
- Sig(Nn) = Sig(Nn)*Anorm
- END DO
- IF (Ndasig.GT.0) THEN
- DO J=1,Ndasig
- DO Nn=1,Nummmm
- IF (dA(Nn,J).NE.Zero) dA(Nn,J) = dA(Nn,J)*Anorm
- END DO
- END DO
- END IF
- IF (Ndbsig.GT.0) THEN
- DO J=1,Ndbsig
- DO Nn=1,Nummmm
- IF (dB(Nn,J).NE.Zero) dB(Nn,J) = dB(Nn,J)*Anorm
- END DO
- END DO
- END IF
-C
- Se = dSQRT(Em)
- IF (Ksolve.NE.2 .OR. Nfpnbk.GT.Nvpnbk) THEN
- N = Ndasig
- DO I=1,Nummmm
- IF (Kvnorm.GT.0) dB(I,Iflnbk(1,1)-N) = Sig(I)/Anorm
- IF (KvbckA.GT.0) dB(I,Iflnbk(2,1)-N) = One
- IF (KvbckB.GT.0) dB(I,Iflnbk(3,1)-N) = One/Se
- IF (KvbckC.GT.0) dB(I,Iflnbk(4,1)-N) = Se
- IF (KvbckD.GT.0) dB(I,Iflnbk(5,1)-N) = dEXP(-BackF/Se)
- IF (KvbckF.GT.0) dB(I,Iflnbk(6,1)-N) =-BackD*dEXP(-BackF/Se)
- END DO
- ELSE
- END IF
-C
-C
- DO I=1,Nummmm
- IF (BackA.NE.Zero) Sig(I) = Sig(I) + BackA
- IF (BackB.NE.Zero) Sig(I) = Sig(I) + BackB/Se
- IF (BackC.NE.Zero) Sig(I) = Sig(I) + BackC*Se
- IF (BackD.NE.Zero) Sig(I) = Sig(I) + BackD*dEXP(-BackF/Se)
- END DO
- RETURN
-C
-C
-C *** here is for different normalizations for different cross sections
- 50 CONTINUE
- DO Iangle=1,Nummmm
- IF (Sig(Iangle).NE.Zero) Sig(Iangle) =
- * Sig(Iangle)*Parnbk(1,Iangle)
- END DO
- IF (Ndasig.GT.0) THEN
- DO Ipar=1,Ndasig
- DO Iangle=1,Nummmm
- IF (dA(Iangle,Ipar).NE.Zero) dA(Iangle,Ipar) =
- * dA(Iangle,Ipar)*Parnbk(1,Iangle)
- END DO
- END DO
- END IF
- IF (Ndbsig.GT.0) THEN
- DO Ipar=1,Ndbsig
- DO Iangle=1,Nummmm
- IF (dB(Iangle,Ipar).NE.Zero) dB(Iangle,Ipar) =
- * dB(Iangle,Ipar)*Parnbk(1,Iangle)
- END DO
- END DO
- END IF
-C
- Se = dSQRT(Em)
- IF (Ksolve.NE.2 .OR. Nfpnbk.GT.Nvpnbk) THEN
- N = Ndasig
- DO Iangle=1,Nummmm
- IF (Iflnbk(1,Iangle).GT.N) dB(Iangle,Iflnbk(1,Iangle)-N) =
- * Sig(Iangle)/Parnbk(1,Iangle)
- IF (Iflnbk(2,Iangle).GT.N) dB(Iangle,Iflnbk(2,Iangle)-N) =
- * One
- IF (Iflnbk(3,Iangle).GT.N) dB(Iangle,Iflnbk(3,Iangle)-N) =
- * One/Se
- IF (Iflnbk(4,Iangle).GT.N) dB(Iangle,Iflnbk(4,Iangle)-N) =
- * dB(Iangle,Iflnbk(4,Iangle)-N) + Se
- IF (Iflnbk(5,Iangle).GT.N) dB(Iangle,Iflnbk(5,Iangle)-N) =
- * dEXP(-Parnbk(6,Iangle)/Se)
- IF (Iflnbk(6,Iangle).GT.N) dB(Iangle,Iflnbk(6,Iangle)-N) =
- * - Parnbk(5,Iangle)*dEXP(-Parnbk(6,Iangle)/Se)
- END DO
- END IF
-C
-C
- DO Iangle=1,Nummmm
- IF (Parnbk(2,Iangle).NE.Zero) Sig(Iangle) = Sig(Iangle) +
- * Parnbk(2,Iangle)
- IF (Parnbk(3,Iangle).NE.Zero) Sig(Iangle) = Sig(Iangle) +
- * Parnbk(3,Iangle)/Se
- IF (Parnbk(4,Iangle).NE.Zero) Sig(Iangle) = Sig(Iangle) +
- * Parnbk(4,Iangle)*Se
- IF (Parnbk(5,Iangle).NE.Zero) Sig(Iangle) = Sig(Iangle) +
- * Parnbk(5,Iangle)*EXP(-Parnbk(6,Iangle)/Se)
- END DO
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Bgfrpi (Parbgf, Iflbgf, Kndbgf, Bgfmin, Bgfmax,
- * Texbgf, Teabgf, Sig, dB, Em, Nummmm)
-C
-C *** Purpose -- Add background functions
-C
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use broad_common_m
- use abro_common_m
- use cbro_common_m
- use lbro_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Sig(*), db(Nummmm,*), Iflbgf(*),
- * Parbgf(*), Kndbgf(*), Bgfmin(*), Bgfmax(*),
- * Texbgf(Ntepnt,*), Teabgf(Ntepnt,*)
-C DIMENSION Sig(Nummmm), dB(.,Ndbsig), Parbgf(Numbgf),
-C Iflbgf(Numbgf), Kndbgf(Numbgf), Bgfmin(Numbgf), Bgfmax(Numbgf),
-C Texbgf(Ntepnt,Ntefil), Teabgf(Ntepnt,Ntefil)
- DATA Zero /0.0d0/, One /1.0d0/
-C
- N = Ndasig
- IF (Nnniso.NE.1) STOP '[STOP in Bgfrpi in cro/mnrm1.f]'
-C
- DO I=1,Numbgf
-C
- IF (Kndbgf(I).EQ.1) THEN
-C *** constant
- IF (Bgfmin(I).EQ.Zero .OR. Em.GT.Bgfmin(I)) THEN
- IF (Bgfmax(I).EQ.Zero .OR. Em.LE.Bgfmax(I)) THEN
- Exx = Parbgf(I)
- Sig(1) = Sig(1) + Exx
- IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
- IF (Iflbgf(I).GT.N) dB(1,Iflbgf(I)-N) = One
- END IF
- END IF
- END IF
-C
- ELSE IF (Kndbgf(I).EQ.2) THEN
-C *** exponential
- IF (Bgfmin(I).EQ.Zero .OR. Em.GE.Bgfmin(I)) THEN
- IF (Bgfmax(I).EQ.Zero .OR. Em.LT.Bgfmax(I)) THEN
- Exx = dEXP(-Parbgf(I+1)*Ttoe/dSQRT(Em))
- Sig(1) = Sig(1) + Parbgf(I)*Exx
- IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
- IF (Iflbgf(I ).GT.N) dB(1,Iflbgf(I )-N) = Exx
- IF (Iflbgf(I+1).GT.N) dB(1,Iflbgf(I+1)-N) =
- * -Parbgf(I)*Exx*(Ttoe/dSQRT(Em))
- END IF
- END IF
- END IF
-C
- ELSE IF (Kndbgf(I).EQ.3) THEN
-C *** power function
- IF (Bgfmin(I).EQ.Zero .OR. Em.GE.Bgfmin(I)) THEN
- IF (Bgfmax(I).EQ.Zero .OR. Em.LT.Bgfmax(I)) THEN
- T = Ttoe/dSQRT(Em)
- Exx = T**Parbgf(I+1)
- Sig(1) = Sig(1) + Parbgf(I)*Exx
- IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
- IF (Iflbgf(I ).GT.N) dB(1,Iflbgf(I )-N) = Exx
- IF (Iflbgf(I+1).GT.N) dB(1,Iflbgf(I+1)-N) =
- * Parbgf(I)*Exx*dLOG(T)
- END IF
- END IF
- END IF
-C
- ELSE IF (Kndbgf(I).EQ.4) THEN
-C *** exponential of logarithmic function
- IF (Bgfmin(I).EQ.Zero .OR. Em.GE.Bgfmin(I)) THEN
- IF (Bgfmax(I).EQ.Zero .OR. Em.LT.Bgfmax(I)) THEN
- T = Ttoe/dSQRT(Em)
- Exx = Parbgf(I) + T*Parbgf(I+1) + Parbgf(I+2)/dLOG(T)
- Exx = dEXP(Exx)
- Sig(1) = Sig(1) + Exx
- IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
- IF (Iflbgf(I ).GT.N) dB(1,Iflbgf(I )-N) = Exx
- IF (Iflbgf(I+1).GT.N) dB(1,Iflbgf(I+1)-N) = Exx*T
- IF (Iflbgf(I+2).GT.N) dB(1,Iflbgf(I+2)-N) = Exx/
- * dLOG(T)
- END IF
- END IF
- END IF
-C
- ELSE IF (Kndbgf(I).EQ.5 .AND. Kndbgf(I+1).EQ.5) THEN
-C *** point-wise function in time
- T = Ttoe/dSQRT(Em)
- IF (T.GE.Bgfmin(I)) THEN
- IF (T.LT.Bgfmin(I+1)) THEN
- D = Bgfmin(I+1) - Bgfmin(I)
- A = (Bgfmin(I+1)-T)/D
- B = (T-Bgfmin(I))/D
- Sig(1) = Sig(1) + A*Parbgf(I) + B*Parbgf(I+1)
- IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
- IF (Iflbgf(I ).GT.N) dB(1,Iflbgf(I )-N) =
- * dB(1,Iflbgf(I )-N) + A
- IF (Iflbgf(I+1).GT.N) dB(1,Iflbgf(I+1)-N) =
- * dB(1,Iflbgf(I+1)-N) + B
- END IF
- END IF
- END IF
-C
- ELSE IF (Kndbgf(I).EQ.6 .AND. Kndbgf(I+1).EQ.6) THEN
-C *** point-wise function in Energy
- IF (Em.GE.Bgfmin(I)) THEN
- IF (Em.LT.Bgfmin(I+1)) THEN
- D = Bgfmin(I+1) - Bgfmin(I)
- A = (Bgfmin(I+1)-Em)/D
- B = (Em-Bgfmin(I))/D
- Sig(1) = Sig(1) + A*Parbgf(I) + B*Parbgf(I+1)
- IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
- IF (Iflbgf(I ).GT.N) dB(1,Iflbgf(I )-N) =
- * dB(1,Iflbgf(I )-N) + A
- IF (Iflbgf(I+1).GT.N) dB(1,Iflbgf(I+1)-N) =
- * dB(1,Iflbgf(I+1)-N) + B
- END IF
- END IF
- END IF
-C
- ELSE IF (Kndbgf(I).GT.1000 .AND. Kndbgf(I).LE.2000) THEN
-C *** point-wise function in time, multiplier is variable
- T = Ttoe/dSQRT(Em)
- Itefil = Kndbgf(I) - 1000
- CALL Find_Te (T, Texbgf(1,Itefil), Ntepnt, Nte)
- IF (Nte.EQ.0) THEN
- S = Zero
- ELSE IF (Nte.LT.0) THEN
- S = Teabgf(-Nte,Itefil)
- Sig(1) = Sig(1) + Parbgf(I)*S
- ELSE
- D = Texbgf(Nte+1,Itefil) - Texbgf(Nte,Itefil)
- A = (Texbgf(Nte+1,Itefil)-T)/D
- B = (T-Texbgf(Nte,Itefil))/D
- S = A*Teabgf(Nte,Itefil) + B*Teabgf(Nte+1,Itefil)
- END IF
- Sig(1) = Sig(1) + Parbgf(I)*S
- IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
- IF (Iflbgf(I).GT.N) dB(1,Iflbgf(I)-N) =
- * dB(1,Iflbgf(I)-N) + S
- END IF
-C
- ELSE IF (Kndbgf(I).GT.2000) THEN
-C *** point-wise function in energy, multiplier is variable
- Itefil = Kndbgf(I) - 2000
- CALL Find_Te (Em, Texbgf(1,Itefil), Ntepnt, Nte)
- IF (Nte.EQ.0) THEN
- S = Zero
- ELSE IF (Nte.LT.0) THEN
- S = Teabgf(-Nte,Itefil)
- Sig(1) = Sig(1) + Parbgf(I)*S
- ELSE
- D = Texbgf(Nte+1,Itefil) - Texbgf(Nte,Itefil)
- A = (Texbgf(Nte+1,Itefil)-Em)/D
- B = (Em-Texbgf(Nte,Itefil))/D
- S = A*Teabgf(Nte,Itefil) + B*Teabgf(Nte+1,Itefil)
- END IF
- Sig(1) = Sig(1) + Parbgf(I)*S
- IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
- IF (Iflbgf(I).GT.N) dB(1,Iflbgf(I)-N) =
- * dB(1,Iflbgf(I)-N) + S
- END IF
-C
- ELSE IF (Kndbgf(I).EQ.9) THEN
-C *** A*E^(-B)
- IF (Bgfmin(I).EQ.Zero .OR. Em.GE.Bgfmin(I)) THEN
- IF (Bgfmax(I).EQ.Zero .OR. Em.LT.Bgfmax(I)) THEN
- Exx = Em**(-Parbgf(I+1))
- Sig(1) = Sig(1) + Parbgf(I)*Exx
- IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
- IF (Iflbgf(I ).GT.N) dB(1,Iflbgf(I )-N) = Exx
- IF (Iflbgf(I+1).GT.N) dB(1,Iflbgf(I+1)-N) =
- * - dLOG(Em)*Sig(1)
- END IF
- END IF
- END IF
-C
- END IF
- END DO
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Nnneta (Iflmsc, Sig, Dbsig, Na, Niso)
-C
-C *** Purpose -- Generate derivative with respect to NU
-C
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Sig(Na,*), Dbsig(Na,Ndbxxx,*), Iflmsc(*)
-C
- IF (Kjetan.LE.0) RETURN
- IF (Iflmsc(Kjetan).EQ.0) RETURN
- N = Iflmsc(Kjetan)
- IF (N.LE.Ndasig) THEN
- STOP '[STOP in Nnneta in cro/mnrm1.f]'
- ELSE
- DO Iso=1,Niso
- Dbsig(1,N,Iso) = Sig(1,Iso)/Etanuu
- END DO
- END IF
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Find_Te (T, Tt, Ntepnt, Nte)
-C *** Purpose -- Find position Nte such that Tt(Nte).LE.T.LT.Tt(Nte+1)
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- DIMENSION Tt(*)
- DATA Zero /0.0d0/
- Nte = 0
- DO I=1,Ntepnt
- IF (I.GT.1 .AND. Tt(I).EQ.Zero) RETURN
- IF (T.LT.Tt(I)) THEN
- Nte = I - 1
- RETURN
- ELSE IF (T.EQ.Tt(I)) THEN
- Nte = - I
- END IF
- END DO
- RETURN
- END
diff --git a/sammy/src/cro/mnrm1.f90 b/sammy/src/cro/mnrm1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..299f38160e7ecbb6d2e0af72db5ccd74a758403d
--- /dev/null
+++ b/sammy/src/cro/mnrm1.f90
@@ -0,0 +1,727 @@
+module normalize_and_background
+contains
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Norm (Parnbk, Iflnbk, Sig, dA, dB, Em, Nummmm)
+!
+! *** Purpose -- Add backgrounds
+!
+ use fixedi_m, only : Ndasig, Ndbsig, Nfpnbk, Numbgf, Numnbk, Nvpnbk, Nnniso
+ use ifwrit_m, only : KvbckA, KvbckB, KvbckC, KvbckD, KvbckF, Kvnorm, Ksolve
+ use fixedr_m, only : Anorm, BackA, BackB, BackC, BackD, BackF
+ IMPLICIT None
+!
+ real(kind=8)::Sig(*), dA(Nummmm,*), dB(Nummmm,*), Parnbk(6,*)
+ integer:: Iflnbk(6,*)
+ integer::Nummmm
+ real(kind=8)::Em
+! DIMENSION Sig(Nummmm), dA(.,Ndasig), dB(.,Ndbsig),
+! * Iflnbk(6,Nangle), Parnbk(6,Nangle)
+ real(kind=8),parameter::Zero=0.0d0, One=1.0d0
+ integer::I, Iangle, J, N, Nn, Ipar
+ real(kind=8)::Se
+
+!
+ IF (Nnniso.NE.1) STOP '[STOP in Norm in cro/mnrm1.f]'
+!
+ IF (Numnbk.GT.6) GO TO 50
+!
+! *** Here is original, with only one set of normalization/backgrounds
+! *** that work for all cross sections
+ DO Nn=1,Nummmm
+ Sig(Nn) = Sig(Nn)*Anorm
+ END DO
+ IF (Ndasig.GT.0) THEN
+ DO J=1,Ndasig
+ DO Nn=1,Nummmm
+ IF (dA(Nn,J).NE.Zero) dA(Nn,J) = dA(Nn,J)*Anorm
+ END DO
+ END DO
+ END IF
+ IF (Ndbsig.GT.0) THEN
+ DO J=1,Ndbsig
+ DO Nn=1,Nummmm
+ IF (dB(Nn,J).NE.Zero) dB(Nn,J) = dB(Nn,J)*Anorm
+ END DO
+ END DO
+ END IF
+!
+ Se = dSQRT(Em)
+ IF (Ksolve.NE.2 .OR. Nfpnbk.GT.Nvpnbk) THEN
+ N = Ndasig
+ DO I=1,Nummmm
+ IF (Kvnorm.GT.0) dB(I,Iflnbk(1,1)-N) = Sig(I)/Anorm
+ IF (KvbckA.GT.0) dB(I,Iflnbk(2,1)-N) = One
+ IF (KvbckB.GT.0) dB(I,Iflnbk(3,1)-N) = One/Se
+ IF (KvbckC.GT.0) dB(I,Iflnbk(4,1)-N) = Se
+ IF (KvbckD.GT.0) dB(I,Iflnbk(5,1)-N) = dEXP(-BackF/Se)
+ IF (KvbckF.GT.0) dB(I,Iflnbk(6,1)-N) =-BackD*dEXP(-BackF/Se)
+ END DO
+ ELSE
+ END IF
+!
+!
+ DO I=1,Nummmm
+ IF (BackA.NE.Zero) Sig(I) = Sig(I) + BackA
+ IF (BackB.NE.Zero) Sig(I) = Sig(I) + BackB/Se
+ IF (BackC.NE.Zero) Sig(I) = Sig(I) + BackC*Se
+ IF (BackD.NE.Zero) Sig(I) = Sig(I) + BackD*dEXP(-BackF/Se)
+ END DO
+ RETURN
+!
+!
+! *** here is for different normalizations for different cross sections
+ 50 CONTINUE
+ DO Iangle=1,Nummmm
+ IF (Sig(Iangle).NE.Zero) Sig(Iangle) = &
+ Sig(Iangle)*Parnbk(1,Iangle)
+ END DO
+ IF (Ndasig.GT.0) THEN
+ DO Ipar=1,Ndasig
+ DO Iangle=1,Nummmm
+ IF (dA(Iangle,Ipar).NE.Zero) dA(Iangle,Ipar) = &
+ dA(Iangle,Ipar)*Parnbk(1,Iangle)
+ END DO
+ END DO
+ END IF
+ IF (Ndbsig.GT.0) THEN
+ DO Ipar=1,Ndbsig
+ DO Iangle=1,Nummmm
+ IF (dB(Iangle,Ipar).NE.Zero) dB(Iangle,Ipar) = &
+ dB(Iangle,Ipar)*Parnbk(1,Iangle)
+ END DO
+ END DO
+ END IF
+!
+ Se = dSQRT(Em)
+ IF (Ksolve.NE.2 .OR. Nfpnbk.GT.Nvpnbk) THEN
+ N = Ndasig
+ DO Iangle=1,Nummmm
+ IF (Iflnbk(1,Iangle).GT.N) dB(Iangle,Iflnbk(1,Iangle)-N) = &
+ Sig(Iangle)/Parnbk(1,Iangle)
+ IF (Iflnbk(2,Iangle).GT.N) dB(Iangle,Iflnbk(2,Iangle)-N) = &
+ One
+ IF (Iflnbk(3,Iangle).GT.N) dB(Iangle,Iflnbk(3,Iangle)-N) = &
+ One/Se
+ IF (Iflnbk(4,Iangle).GT.N) dB(Iangle,Iflnbk(4,Iangle)-N) = &
+ dB(Iangle,Iflnbk(4,Iangle)-N) + Se
+ IF (Iflnbk(5,Iangle).GT.N) dB(Iangle,Iflnbk(5,Iangle)-N) = &
+ dEXP(-Parnbk(6,Iangle)/Se)
+ IF (Iflnbk(6,Iangle).GT.N) dB(Iangle,Iflnbk(6,Iangle)-N) = &
+ - Parnbk(5,Iangle)*dEXP(-Parnbk(6,Iangle)/Se)
+ END DO
+ END IF
+!
+!
+ DO Iangle=1,Nummmm
+ IF (Parnbk(2,Iangle).NE.Zero) Sig(Iangle) = Sig(Iangle) + &
+ Parnbk(2,Iangle)
+ IF (Parnbk(3,Iangle).NE.Zero) Sig(Iangle) = Sig(Iangle) + &
+ Parnbk(3,Iangle)/Se
+ IF (Parnbk(4,Iangle).NE.Zero) Sig(Iangle) = Sig(Iangle) + &
+ Parnbk(4,Iangle)*Se
+ IF (Parnbk(5,Iangle).NE.Zero) Sig(Iangle) = Sig(Iangle) + &
+ Parnbk(5,Iangle)*EXP(-Parnbk(6,Iangle)/Se)
+ END DO
+ RETURN
+ END
+
+ SUBROUTINE Norm_new (Parnbk, Iflnbk, Em, irow, calcData, wantDeriv, itot)
+!
+! *** Purpose -- Add backgrounds
+!
+ use fixedi_m, only : Numbgf, Numnbk
+ use ifwrit_m, only : KvbckA, KvbckB, KvbckC, KvbckD, KvbckF, Kvnorm
+ use fixedr_m, only : Anorm, BackA, BackB, BackC, BackD, BackF
+ use DerivativeHandler_M
+ use, intrinsic :: ISO_C_BINDING
+
+ IMPLICIT None
+!
+ real(kind=8)::Parnbk(6,*)
+ integer:: Iflnbk(6,*)
+ integer::Nummmm, irow, itot
+ logical::wantDeriv
+ type(DerivativeHandler)::calcData
+ real(kind=8)::Em
+! DIMENSION Iflnbk(6,Nangle), Parnbk(6,Nangle)
+ real(kind=8),parameter::Zero=0.0d0, One=1.0d0
+ integer::I, Iangle, J, Nn, Ipar, ourItot
+ logical(C_BOOL)::accumulate, empty
+ real(kind=8)::Se, val, Sig
+
+ accumulate = .false.
+ call calcData%setAccumulate(accumulate)
+ empty = .true.
+ call calcData%setNotSetReturnsZero(empty)
+
+ ourItot = itot
+ if (.not.wantDeriv) ourItot = 1
+ Nummmm = calcData%getNnnsig()
+
+!
+ IF (Numnbk.GT.6) GO TO 50
+!
+! *** Here is original, with only one set of normalization/backgrounds
+! *** that work for all cross sections
+ DO Nn=1,Nummmm
+ do I = 0, ourItot
+ val = calcData%getSharedValNs(irow, Nn, I) * Anorm
+ if (val.ne.Zero) then
+ call calcData%setSharedValNs(irow, Nn, I, val)
+ end if
+ end do
+ END DO
+
+ Se = dSQRT(Em)
+ IF (wantDeriv) THEN
+ DO I=1,Nummmm
+ Sig = calcData%getSharedValNs(irow, I, 0)
+ IF (Kvnorm.GT.0) call calcData%setSharedValNs(irow, I, Iflnbk(1,1), Sig/Anorm)
+ IF (KvbckA.GT.0) call calcData%setSharedValNs(irow, I, Iflnbk(2,1), One)
+ IF (KvbckB.GT.0) call calcData%setSharedValNs(irow, I, Iflnbk(3,1), One/Se)
+ IF (KvbckC.GT.0) call calcData%setSharedValNs(irow, I, Iflnbk(4,1), Se)
+ IF (KvbckD.GT.0) call calcData%setSharedValNs(irow, I, Iflnbk(5,1), dEXP(-BackF/Se))
+ IF (KvbckF.GT.0) call calcData%setSharedValNs(irow, I, Iflnbk(6,1), -BackD*dEXP(-BackF/Se))
+ END DO
+ ELSE
+ END IF
+!
+!
+ accumulate = .true.
+ call calcData%setAccumulate(accumulate)
+ DO I=1,Nummmm
+ IF (BackA.NE.Zero) call calcData%setSharedValNs(irow, I, 0, BackA)
+ IF (BackB.NE.Zero) call calcData%setSharedValNs(irow, I, 0, BackB/Se)
+ IF (BackC.NE.Zero) call calcData%setSharedValNs(irow, I, 0, BackC*Se)
+ IF (BackD.NE.Zero) call calcData%setSharedValNs(irow, I, 0, BackD*dEXP(-BackF/Se))
+ END DO
+ accumulate = .false.
+ call calcData%setAccumulate(accumulate)
+ empty = .false.
+ call calcData%setNotSetReturnsZero(empty)
+ RETURN
+!
+!
+! *** here is for different normalizations for different cross sections
+ 50 CONTINUE
+ DO Iangle=1,Nummmm
+ do I = 0, ourItot
+ val = calcData%getSharedValNs(irow, Iangle, I)
+ if (val.ne.Zero) then
+ val = val * Parnbk(1,Iangle)
+ call calcData%setSharedValNs(irow, Iangle, I, val)
+ end if
+ end do
+ END DO
+!
+ Se = dSQRT(Em)
+ IF (wantDeriv) THEN
+ DO Iangle=1,Nummmm
+ Sig = calcData%getSharedValNs(irow, Iangle, 0)
+ IF (Iflnbk(1,Iangle).GT.0) then
+ call calcData%setSharedValNs(irow, Iangle, Iflnbk(1,Iangle), Sig/Parnbk(1,Iangle))
+ end if
+ IF (Iflnbk(2,Iangle).GT.0) then
+ call calcData%setSharedValNs(irow, Iangle, Iflnbk(2,Iangle), One)
+ end if
+ IF (Iflnbk(3,Iangle).GT.0) then
+ call calcData%setSharedValNs(irow, Iangle, Iflnbk(3,Iangle), One/Se)
+ end if
+ IF (Iflnbk(4,Iangle).GT.0) then
+ val = calcData%getSharedValNs(irow, Iangle, Iflnbk(4,Iangle)) + Se
+ call calcData%setSharedValNs(irow, Iangle, Iflnbk(4,Iangle), val)
+ end if
+ IF (Iflnbk(5,Iangle).GT.0) then
+ call calcData%setSharedValNs(irow, Iangle, Iflnbk(5,Iangle), dEXP(-Parnbk(6,Iangle)/Se))
+ end if
+ IF (Iflnbk(6,Iangle).GT.0) then
+ call calcData%setSharedValNs(irow, Iangle, Iflnbk(6,Iangle), - Parnbk(5,Iangle)*dEXP(-Parnbk(6,Iangle)/Se))
+ end if
+ END DO
+ END IF
+!
+!
+ accumulate = .true.
+ call calcData%setAccumulate(accumulate)
+ DO Iangle=1,Nummmm
+ IF (Parnbk(2,Iangle).NE.Zero) call calcData%setSharedValNs(irow, Iangle, 0, Parnbk(2,Iangle))
+ IF (Parnbk(3,Iangle).NE.Zero) call calcData%setSharedValNs(irow, Iangle, 0, Parnbk(3,Iangle)/Se)
+ IF (Parnbk(4,Iangle).NE.Zero) call calcData%setSharedValNs(irow, Iangle, 0, Parnbk(4,Iangle)*Se)
+ IF (Parnbk(5,Iangle).NE.Zero) call calcData%setSharedValNs(irow, Iangle, 0, Parnbk(5,Iangle)*EXP(-Parnbk(6,Iangle)/Se))
+ END DO
+ accumulate = .false.
+ call calcData%setAccumulate(accumulate)
+ empty = .false.
+ call calcData%setNotSetReturnsZero(empty)
+ RETURN
+ END
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Bgfrpi (Parbgf, Iflbgf, Kndbgf, Bgfmin, Bgfmax, &
+ Texbgf, Teabgf, Sig, dB, Em, Nummmm)
+!
+! *** Purpose -- Add background functions
+!
+ use fixedi_m, only : Ntepnt, Ndasig, Nfpbgf, Nnniso, Numbgf, Nvpbgf
+ use ifwrit_m, only : Ksolve
+ use fixedr_m, only : Ttoe
+ IMPLICIT NONE
+!
+ real(kind=8)::Sig(*), db(Nummmm,*), &
+ Parbgf(*), Bgfmin(*), Bgfmax(*), &
+ Texbgf(Ntepnt,*), Teabgf(Ntepnt,*)
+ integer::Iflbgf(*), Kndbgf(*)
+
+! DIMENSION Sig(Nummmm), dB(.,Ndbsig), Parbgf(Numbgf),
+! Iflbgf(Numbgf), Kndbgf(Numbgf), Bgfmin(Numbgf), Bgfmax(Numbgf),
+! Texbgf(Ntepnt,Ntefil), Teabgf(Ntepnt,Ntefil)
+ real(kind=8),parameter::Zero=0.0d0, One=1.0d0
+ real(kind=8)::Em
+ integer::Nummmm
+ real(kind=8)::A, B, D, Exx, S, T
+ integer::I, Itefil, N, Nte
+!
+ N = Ndasig
+ IF (Nnniso.NE.1) STOP '[STOP in Bgfrpi in cro/mnrm1.f]'
+!
+ DO I=1,Numbgf
+!
+ IF (Kndbgf(I).EQ.1) THEN
+! *** constant
+ IF (Bgfmin(I).EQ.Zero .OR. Em.GT.Bgfmin(I)) THEN
+ IF (Bgfmax(I).EQ.Zero .OR. Em.LE.Bgfmax(I)) THEN
+ Exx = Parbgf(I)
+ Sig(1) = Sig(1) + Exx
+ IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
+ IF (Iflbgf(I).GT.N) dB(1,Iflbgf(I)-N) = One
+ END IF
+ END IF
+ END IF
+!
+ ELSE IF (Kndbgf(I).EQ.2) THEN
+! *** exponential
+ IF (Bgfmin(I).EQ.Zero .OR. Em.GE.Bgfmin(I)) THEN
+ IF (Bgfmax(I).EQ.Zero .OR. Em.LT.Bgfmax(I)) THEN
+ Exx = dEXP(-Parbgf(I+1)*Ttoe/dSQRT(Em))
+ Sig(1) = Sig(1) + Parbgf(I)*Exx
+ IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
+ IF (Iflbgf(I ).GT.N) dB(1,Iflbgf(I )-N) = Exx
+ IF (Iflbgf(I+1).GT.N) dB(1,Iflbgf(I+1)-N) = &
+ -Parbgf(I)*Exx*(Ttoe/dSQRT(Em))
+ END IF
+ END IF
+ END IF
+!
+ ELSE IF (Kndbgf(I).EQ.3) THEN
+! *** power function
+ IF (Bgfmin(I).EQ.Zero .OR. Em.GE.Bgfmin(I)) THEN
+ IF (Bgfmax(I).EQ.Zero .OR. Em.LT.Bgfmax(I)) THEN
+ T = Ttoe/dSQRT(Em)
+ Exx = T**Parbgf(I+1)
+ Sig(1) = Sig(1) + Parbgf(I)*Exx
+ IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
+ IF (Iflbgf(I ).GT.N) dB(1,Iflbgf(I )-N) = Exx
+ IF (Iflbgf(I+1).GT.N) dB(1,Iflbgf(I+1)-N) = &
+ Parbgf(I)*Exx*dLOG(T)
+ END IF
+ END IF
+ END IF
+!
+ ELSE IF (Kndbgf(I).EQ.4) THEN
+! *** exponential of logarithmic function
+ IF (Bgfmin(I).EQ.Zero .OR. Em.GE.Bgfmin(I)) THEN
+ IF (Bgfmax(I).EQ.Zero .OR. Em.LT.Bgfmax(I)) THEN
+ T = Ttoe/dSQRT(Em)
+ Exx = Parbgf(I) + T*Parbgf(I+1) + Parbgf(I+2)/dLOG(T)
+ Exx = dEXP(Exx)
+ Sig(1) = Sig(1) + Exx
+ IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
+ IF (Iflbgf(I ).GT.N) dB(1,Iflbgf(I )-N) = Exx
+ IF (Iflbgf(I+1).GT.N) dB(1,Iflbgf(I+1)-N) = Exx*T
+ IF (Iflbgf(I+2).GT.N) dB(1,Iflbgf(I+2)-N) = Exx/dLOG(T)
+ END IF
+ END IF
+ END IF
+!
+ ELSE IF (Kndbgf(I).EQ.5 .AND. Kndbgf(I+1).EQ.5) THEN
+! *** point-wise function in time
+ T = Ttoe/dSQRT(Em)
+ IF (T.GE.Bgfmin(I)) THEN
+ IF (T.LT.Bgfmin(I+1)) THEN
+ D = Bgfmin(I+1) - Bgfmin(I)
+ A = (Bgfmin(I+1)-T)/D
+ B = (T-Bgfmin(I))/D
+ Sig(1) = Sig(1) + A*Parbgf(I) + B*Parbgf(I+1)
+ IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
+ IF (Iflbgf(I ).GT.N) dB(1,Iflbgf(I )-N) = &
+ dB(1,Iflbgf(I )-N) + A
+ IF (Iflbgf(I+1).GT.N) dB(1,Iflbgf(I+1)-N) = &
+ dB(1,Iflbgf(I+1)-N) + B
+ END IF
+ END IF
+ END IF
+!
+ ELSE IF (Kndbgf(I).EQ.6 .AND. Kndbgf(I+1).EQ.6) THEN
+! *** point-wise function in Energy
+ IF (Em.GE.Bgfmin(I)) THEN
+ IF (Em.LT.Bgfmin(I+1)) THEN
+ D = Bgfmin(I+1) - Bgfmin(I)
+ A = (Bgfmin(I+1)-Em)/D
+ B = (Em-Bgfmin(I))/D
+ Sig(1) = Sig(1) + A*Parbgf(I) + B*Parbgf(I+1)
+ IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
+ IF (Iflbgf(I ).GT.N) dB(1,Iflbgf(I )-N) = &
+ dB(1,Iflbgf(I )-N) + A
+ IF (Iflbgf(I+1).GT.N) dB(1,Iflbgf(I+1)-N) = &
+ dB(1,Iflbgf(I+1)-N) + B
+ END IF
+ END IF
+ END IF
+!
+ ELSE IF (Kndbgf(I).GT.1000 .AND. Kndbgf(I).LE.2000) THEN
+! *** point-wise function in time, multiplier is variable
+ T = Ttoe/dSQRT(Em)
+ Itefil = Kndbgf(I) - 1000
+ CALL Find_Te (T, Texbgf(1,Itefil), Ntepnt, Nte)
+ IF (Nte.EQ.0) THEN
+ S = Zero
+ ELSE IF (Nte.LT.0) THEN
+ S = Teabgf(-Nte,Itefil)
+ Sig(1) = Sig(1) + Parbgf(I)*S
+ ELSE
+ D = Texbgf(Nte+1,Itefil) - Texbgf(Nte,Itefil)
+ A = (Texbgf(Nte+1,Itefil)-T)/D
+ B = (T-Texbgf(Nte,Itefil))/D
+ S = A*Teabgf(Nte,Itefil) + B*Teabgf(Nte+1,Itefil)
+ END IF
+ Sig(1) = Sig(1) + Parbgf(I)*S
+ IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
+ IF (Iflbgf(I).GT.N) dB(1,Iflbgf(I)-N) = &
+ dB(1,Iflbgf(I)-N) + S
+ END IF
+!
+ ELSE IF (Kndbgf(I).GT.2000) THEN
+! *** point-wise function in energy, multiplier is variable
+ Itefil = Kndbgf(I) - 2000
+ CALL Find_Te (Em, Texbgf(1,Itefil), Ntepnt, Nte)
+ IF (Nte.EQ.0) THEN
+ S = Zero
+ ELSE IF (Nte.LT.0) THEN
+ S = Teabgf(-Nte,Itefil)
+ Sig(1) = Sig(1) + Parbgf(I)*S
+ ELSE
+ D = Texbgf(Nte+1,Itefil) - Texbgf(Nte,Itefil)
+ A = (Texbgf(Nte+1,Itefil)-Em)/D
+ B = (Em-Texbgf(Nte,Itefil))/D
+ S = A*Teabgf(Nte,Itefil) + B*Teabgf(Nte+1,Itefil)
+ END IF
+ Sig(1) = Sig(1) + Parbgf(I)*S
+ IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
+ IF (Iflbgf(I).GT.N) dB(1,Iflbgf(I)-N) = &
+ dB(1,Iflbgf(I)-N) + S
+ END IF
+!
+ ELSE IF (Kndbgf(I).EQ.9) THEN
+! *** A*E^(-B)
+ IF (Bgfmin(I).EQ.Zero .OR. Em.GE.Bgfmin(I)) THEN
+ IF (Bgfmax(I).EQ.Zero .OR. Em.LT.Bgfmax(I)) THEN
+ Exx = Em**(-Parbgf(I+1))
+ Sig(1) = Sig(1) + Parbgf(I)*Exx
+ IF (Ksolve.NE.2 .OR. Nfpbgf.GT.Nvpbgf) THEN
+ IF (Iflbgf(I ).GT.N) dB(1,Iflbgf(I )-N) = Exx
+ IF (Iflbgf(I+1).GT.N) dB(1,Iflbgf(I+1)-N) = &
+ - dLOG(Em)*Sig(1)
+ END IF
+ END IF
+ END IF
+!
+ END IF
+ END DO
+ RETURN
+ END
+!
+ SUBROUTINE Bgfrpi_new (Parbgf, Iflbgf, Kndbgf, Bgfmin, Bgfmax, &
+ Texbgf, Teabgf, Em, calcData, irow, wantDeriv)
+!
+! *** Purpose -- Add background functions
+!
+ use fixedi_m, only : Ntepnt, Numbgf
+ use ifwrit_m, only : Ksolve
+ use fixedr_m, only : Ttoe
+ use DerivativeHandler_M
+ IMPLICIT NONE
+!
+ real(kind=8):: Parbgf(*), Bgfmin(*), Bgfmax(*), &
+ Texbgf(Ntepnt,*), Teabgf(Ntepnt,*)
+ integer::Iflbgf(*), Kndbgf(*)
+ type(DerivativeHandler)::calcData
+ integer::irow, itot
+ logical::wantDeriv
+
+! DIMENSION Parbgf(Numbgf),
+! Iflbgf(Numbgf), Kndbgf(Numbgf), Bgfmin(Numbgf), Bgfmax(Numbgf),
+! Texbgf(Ntepnt,Ntefil), Teabgf(Ntepnt,Ntefil)
+ real(kind=8),parameter::Zero=0.0d0, One=1.0d0
+ real(kind=8)::Em, val, sig
+ real(kind=8)::A, B, D, Exx, S, T
+ integer::I, Itefil, Nte
+!
+! ! for this routine isig = 1 always
+!
+ DO I=1,Numbgf
+!
+ IF (Kndbgf(I).EQ.1) THEN
+! *** constant
+ IF (Bgfmin(I).EQ.Zero .OR. Em.GT.Bgfmin(I)) THEN
+ IF (Bgfmax(I).EQ.Zero .OR. Em.LE.Bgfmax(I)) THEN
+ Exx = calcData%getSharedValNs(irow, 1, 0) + Parbgf(I)
+ call calcData%setSharedValNs(irow, 1, 0, Exx)
+ IF (wantDeriv) THEN
+ IF (Iflbgf(I).GT.0) then
+ call calcData%setSharedValNs(irow, 1, Iflbgf(I), One)
+ end if
+ END IF
+ END IF
+ END IF
+!
+ ELSE IF (Kndbgf(I).EQ.2) THEN
+! *** exponential
+ IF (Bgfmin(I).EQ.Zero .OR. Em.GE.Bgfmin(I)) THEN
+ IF (Bgfmax(I).EQ.Zero .OR. Em.LT.Bgfmax(I)) THEN
+ Exx = dEXP(-Parbgf(I+1)*Ttoe/dSQRT(Em))
+ val = calcData%getSharedValNs(irow, 1, 0) + Parbgf(I)*Exx
+ call calcData%setSharedValNs(irow, 1, 0, val)
+ IF (wantDeriv) THEN
+ IF (Iflbgf(I ).GT.0) then
+ call calcData%setSharedValNs(irow, 1, Iflbgf(I ), Exx)
+ end if
+ IF (Iflbgf(I+1).GT.0) then
+ val = -Parbgf(I)*Exx*(Ttoe/dSQRT(Em))
+ call calcData%setSharedValNs(irow, 1, Iflbgf(I+1), val)
+ end if
+ END IF
+ END IF
+ END IF
+!
+ ELSE IF (Kndbgf(I).EQ.3) THEN
+! *** power function
+ IF (Bgfmin(I).EQ.Zero .OR. Em.GE.Bgfmin(I)) THEN
+ IF (Bgfmax(I).EQ.Zero .OR. Em.LT.Bgfmax(I)) THEN
+ T = Ttoe/dSQRT(Em)
+ Exx = T**Parbgf(I+1)
+ val = calcData%getSharedValNs(irow, 1, 0) + Parbgf(I)*Exx
+ call calcData%setSharedValNs(irow, 1, 0, val)
+ IF (wantDeriv) THEN
+ IF (Iflbgf(I ).GT.0) then
+ call calcData%setSharedValNs(irow, 1, Iflbgf(I ), Exx)
+ end if
+ IF (Iflbgf(I+1).GT.0) then
+ val = Parbgf(I)*Exx*dLOG(T)
+ call calcData%setSharedValNs(irow, 1, Iflbgf(I+1), val)
+ end if
+ END IF
+ END IF
+ END IF
+!
+ ELSE IF (Kndbgf(I).EQ.4) THEN
+! *** exponential of logarithmic function
+ IF (Bgfmin(I).EQ.Zero .OR. Em.GE.Bgfmin(I)) THEN
+ IF (Bgfmax(I).EQ.Zero .OR. Em.LT.Bgfmax(I)) THEN
+ T = Ttoe/dSQRT(Em)
+ Exx = Parbgf(I) + T*Parbgf(I+1) + Parbgf(I+2)/dLOG(T)
+ Exx = dEXP(Exx)
+ val = Exx + calcData%getSharedValNs(irow, 1, 0)
+ call calcData%setSharedValNs(irow, 1, 0, val)
+ IF (wantDeriv) THEN
+ IF (Iflbgf(I ).GT.0) then
+ call calcData%setSharedValNs(irow, 1,Iflbgf(I ), Exx)
+ end if
+ IF (Iflbgf(I+1).GT.0) then
+ call calcData%setSharedValNs(irow, 1,Iflbgf(I+1), Exx*T)
+ end if
+ IF (Iflbgf(I+2).GT.0) then
+ val = Exx/dLOG(T)
+ call calcData%setSharedValNs(irow, 1,Iflbgf(I+2), val)
+ end if
+ END IF
+ END IF
+ END IF
+!
+ ELSE IF (Kndbgf(I).EQ.5 .AND. Kndbgf(I+1).EQ.5) THEN
+! *** point-wise function in time
+ T = Ttoe/dSQRT(Em)
+ IF (T.GE.Bgfmin(I)) THEN
+ IF (T.LT.Bgfmin(I+1)) THEN
+ D = Bgfmin(I+1) - Bgfmin(I)
+ A = (Bgfmin(I+1)-T)/D
+ B = (T-Bgfmin(I))/D
+ val = calcData%getSharedValNs(irow, 1, 0) + A*Parbgf(I) + B*Parbgf(I+1)
+ call calcData%setSharedValNs(irow, 1, 0, val)
+ IF (wantDeriv) THEN
+ IF (Iflbgf(I ).GT.0) then
+ val = calcData%getSharedValNs(irow, 1, Iflbgf(I)) + A
+ call calcData%setSharedValNs(irow, 1, Iflbgf(I), val)
+ end if
+ IF (Iflbgf(I+1).GT.0) then
+ val = calcData%getSharedValNs(irow, 1, Iflbgf(I+1)) + B
+ call calcData%setSharedValNs(irow, 1, Iflbgf(I+1), val)
+ end if
+ END IF
+ END IF
+ END IF
+!
+ ELSE IF (Kndbgf(I).EQ.6 .AND. Kndbgf(I+1).EQ.6) THEN
+! *** point-wise function in Energy
+ IF (Em.GE.Bgfmin(I)) THEN
+ IF (Em.LT.Bgfmin(I+1)) THEN
+ D = Bgfmin(I+1) - Bgfmin(I)
+ A = (Bgfmin(I+1)-Em)/D
+ B = (Em-Bgfmin(I))/D
+ val = calcData%getSharedValNs(irow, 1, 0) + A*Parbgf(I) + B*Parbgf(I+1)
+ call calcData%setSharedValNs(irow, 1, 0, val)
+ IF (wantDeriv) THEN
+ IF (Iflbgf(I ).GT.0) then
+ val = calcData%getSharedValNs(irow, 1, Iflbgf(I)) + A
+ call calcData%setSharedValNs(irow, 1, Iflbgf(I), val)
+ end if
+ IF (Iflbgf(I+1).GT.0) then
+ val = calcData%getSharedValNs(irow, 1, Iflbgf(I+1)) + B
+ call calcData%setSharedValNs(irow, 1, Iflbgf(I+1), val)
+ end if
+ END IF
+ END IF
+ END IF
+!
+ ELSE IF (Kndbgf(I).GT.1000 .AND. Kndbgf(I).LE.2000) THEN
+! *** point-wise function in time, multiplier is variable
+ T = Ttoe/dSQRT(Em)
+ Itefil = Kndbgf(I) - 1000
+ CALL Find_Te (T, Texbgf(1,Itefil), Ntepnt, Nte)
+ IF (Nte.EQ.0) THEN
+ S = Zero
+ ELSE IF (Nte.LT.0) THEN
+ S = Teabgf(-Nte,Itefil)
+ val = calcData%getSharedValNs(irow, 1, 0) + Parbgf(I)*S
+ call calcData%setSharedValNs(irow, 1, 0, val)
+ ELSE
+ D = Texbgf(Nte+1,Itefil) - Texbgf(Nte,Itefil)
+ A = (Texbgf(Nte+1,Itefil)-T)/D
+ B = (T-Texbgf(Nte,Itefil))/D
+ S = A*Teabgf(Nte,Itefil) + B*Teabgf(Nte+1,Itefil)
+ END IF
+ val = calcData%getSharedValNs(irow, 1, 0) + Parbgf(I)*S
+ call calcData%setSharedValNs(irow, 1, 0, val)
+ IF (wantDeriv) THEN
+ IF (Iflbgf(I).GT.0) then
+ val = calcData%getSharedValNs(irow, 1, Iflbgf(I)) + S
+ call calcData%setSharedValNs(irow, 1, Iflbgf(I), val)
+ end if
+ END IF
+!
+ ELSE IF (Kndbgf(I).GT.2000) THEN
+! *** point-wise function in energy, multiplier is variable
+ Itefil = Kndbgf(I) - 2000
+ CALL Find_Te (Em, Texbgf(1,Itefil), Ntepnt, Nte)
+ IF (Nte.EQ.0) THEN
+ S = Zero
+ ELSE IF (Nte.LT.0) THEN
+ S = Teabgf(-Nte,Itefil)
+ val = calcData%getSharedValNs(irow, 1, 0) + Parbgf(I)*S
+ call calcData%setSharedValNs(irow, 1, 0, val)
+ ELSE
+ D = Texbgf(Nte+1,Itefil) - Texbgf(Nte,Itefil)
+ A = (Texbgf(Nte+1,Itefil)-Em)/D
+ B = (Em-Texbgf(Nte,Itefil))/D
+ S = A*Teabgf(Nte,Itefil) + B*Teabgf(Nte+1,Itefil)
+ END IF
+ val = calcData%getSharedValNs(irow, 1, 0) + Parbgf(I)*S
+ call calcData%setSharedValNs(irow, 1, 0, val)
+ IF (wantDeriv) THEN
+ IF (Iflbgf(I).GT.0) then
+ val = calcData%getSharedValNs(irow, 1, Iflbgf(I)) + S
+ call calcData%setSharedValNs(irow, 1, Iflbgf(I), val)
+ end if
+ END IF
+!
+ ELSE IF (Kndbgf(I).EQ.9) THEN
+! *** A*E^(-B)
+ IF (Bgfmin(I).EQ.Zero .OR. Em.GE.Bgfmin(I)) THEN
+ IF (Bgfmax(I).EQ.Zero .OR. Em.LT.Bgfmax(I)) THEN
+ Exx = Em**(-Parbgf(I+1))
+ sig = calcData%getSharedValNs(irow, 1, 0) + Parbgf(I)*Exx
+ call calcData%setSharedValNs(irow, 1, 0, sig)
+ IF (wantDeriv) THEN
+ IF (Iflbgf(I ).GT.0) then
+ call calcData%setSharedValNs(irow, 1, Iflbgf(I ), Exx)
+ end if
+ IF (Iflbgf(I+1).GT.0) then
+ call calcData%setSharedValNs(irow, 1,Iflbgf(I+1), - dLOG(Em)*Sig)
+ end if
+ END IF
+ END IF
+ END IF
+!
+ END IF
+ END DO
+ RETURN
+ END
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Nnneta (Iflmsc, Sig, Dbsig, Na, Niso)
+!
+! *** Purpose -- Generate derivative with respect to NU
+!
+ use fixedi_m, only : Ndbxxx, Ndasig
+ use ifwrit_m, only : Kjetan
+ use fixedr_m, only : Etanuu
+ IMPLICIT None
+!
+ integer::Na, Niso
+ real(kind=8)::Sig(Na,*), Dbsig(Na,Ndbxxx,*)
+ integer::Iflmsc(*)
+
+ integer::Iso, N
+!
+ IF (Kjetan.LE.0) RETURN
+ IF (Iflmsc(Kjetan).EQ.0) RETURN
+ N = Iflmsc(Kjetan)
+ IF (N.LE.Ndasig) THEN
+ STOP '[STOP in Nnneta in cro/mnrm1.f]'
+ ELSE
+ DO Iso=1,Niso
+ Dbsig(1,N,Iso) = Sig(1,Iso)/Etanuu
+ END DO
+ END IF
+ RETURN
+ END
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Find_Te (T, Tt, Ntepnt, Nte)
+! *** Purpose -- Find position Nte such that Tt(Nte).LE.T.LT.Tt(Nte+1)
+ IMPLICIT None
+ real(kind=8):: Tt(*), T
+ integer::Ntepnt, Nte
+ real(kind=8),parameter::Zero=0.0d0
+ integer::I
+
+ Nte = 0
+ DO I=1,Ntepnt
+ IF (I.GT.1 .AND. Tt(I).EQ.Zero) RETURN
+ IF (T.LT.Tt(I)) THEN
+ Nte = I - 1
+ RETURN
+ ELSE IF (T.EQ.Tt(I)) THEN
+ Nte = - I
+ END IF
+ END DO
+ RETURN
+ END
+end module normalize_and_background
diff --git a/sammy/src/cro/mnrm2.f b/sammy/src/cro/mnrm2.f
deleted file mode 100755
index 89069e0959098b524e1eedb541fd80a6d0c54475..0000000000000000000000000000000000000000
--- a/sammy/src/cro/mnrm2.f
+++ /dev/null
@@ -1,152 +0,0 @@
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Transm (Sig, Dasig, Dbsig, Jjtrns, Kkkthc, Ttthck)
-C
-C *** Purpose -- Transform from total cross section to transmission.
-C *** Note that this routine is called only if summation
-C *** over isotopes has already occurred.
-C
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Sig(*), Dasig(Nnnsig,*), Dbsig(Nnnsig,*)
- DATA Zero /0.0d0/
-C
- Xxx = dEXP(-Sig(Jjtrns)*Ttthck)
-C
- IF (Ksolve.NE.2) THEN
- A = -Ttthck*Xxx
-C
-C *** modify the derivatives to be in terms of transmission
- N = Jjtrns
- IF (Ndasig.GT.0) THEN
- DO Ipar=1,Ndasig
- IF (Dasig(N,Ipar).NE.Zero) Dasig(N,Ipar) =A*Dasig(N,Ipar)
- END DO
- END IF
- IF (Ndbsig.GT.0) THEN
- DO Ipar=1,Ndbsig
- IF (Dbsig(N,Ipar).NE.Zero) Dbsig(N,Ipar) =A*Dbsig(N,Ipar)
- END DO
- END IF
-C
- IF (Kkkthc.GT.0) THEN
-C *** generate derivative wrt thickness
- Ipar = Kkkthc
- IF (Ipar.LE.Ndasig) THEN
- WRITE (6,10000) Ipar, Ndasig, Kkkthc, 0
-10000 FORMAT ('In Transm, Ipar,Ndasig=', 10I5)
- STOP '[STOP in Transm in cro/mnrm2.f]'
- ELSE
- X = - Sig(Jjtrns)*Xxx
- Dbsig(N,Ipar-Ndasig) = X
- END IF
- END IF
-C
- END IF
-C *** modify cross section to be transmission
- Sig(Jjtrns) = Xxx
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Trans_Non (Anonu, Bnonu, Rnonu, Znonu, Sig, Dasig,
- * Dbsig, Jjtrns, Kkkthc)
-C
-C *** Purpose -- Transform from total cross section to transmission,
-C *** in the case where sample thickness is not uniform.
-C
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use abcexp_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Anonu(*), Bnonu(*), Rnonu(*), Znonu(*)
- DIMENSION Sig(*), Dasig(Nnnsig,*), Dbsig(Nnnsig,*)
- DATA Zero /0.0d0/, One/1.0d0/, Two /2.0d0/, Small /0.3d0/
-C
- Total = Sig(Jjtrns)*Thick
- R2 = Rnonu(1)
- Z2 = Znonu(1)
- E2 = dEXP(-Total*Z2)
- Q = Zero
- dQ = Zero
- DO I=2,Nonu
- E1 = E2
- R1 = R2
- Z1 = Z2
- A2 = Anonu(I)
- B2 = Bnonu(I)
- R2 = Rnonu(I)
- C2 = B2*R2
- C1 = B2*R1
- Z2 = Znonu(I)
- E2 = dEXP(-Total*Z2)
- Dd = Total*(C2-C1)
- IF (dABS(Dd).GT.Small) THEN
- A = E1*(Total*C1+One) - E2*(Total*C2+One)
- F = (Total*B2)**2
- Q = Q + A/F
- IF (Ksolve.NE.2) THEN
- A = One + Total*Z1
- B = Total*C1*A + One + A
- C = E1*B
- A = One + Total*Z2
- B = Total*C2*A + One + A
- C = E2*B - C
- dQ = dQ + C/F
- END IF
- ELSE
- R = R2 - R1
- F = Abcexp (Dd, Aa, Bb, Cc, Ddd, Ijklmn)
- A = R*(R1*Aa+R*Bb)
- Q = Q + A*E2
- IF (Ksolve.NE.2) THEN
- A = Aa*(Two+Total*Z1)*R1 + Bb*(Two+Total*A2)*R
- A = R2**2 - R1**2 - R*A
- dQ = dQ + A*E2
- END IF
- END IF
- END DO
- Fix = Rnonu(Nonu)**2/Two
- X = dQ/Fix
- Deriv = X/Sig(Jjtrns)
- X = X/Thick
- Sig(Jjtrns) = Q/Fix
-C
- IF (Ksolve.NE.2) THEN
- A = Deriv
-C
-C *** Modify the derivatives to be in terms of transmission
- N = Jjtrns
- IF (Ndasig.GT.0) THEN
- DO Ipar=1,Ndasig
- IF (Dasig(N,Ipar).NE.Zero) Dasig(N,Ipar) =A*Dasig(N,Ipar)
- END DO
- END IF
- IF (Ndbsig.GT.0) THEN
- DO Ipar=1,Ndbsig
- IF (Dbsig(N,Ipar).NE.Zero) Dbsig(N,Ipar) =A*Dbsig(N,Ipar)
- END DO
- END IF
-C
- IF (Kkkthc.GT.0) THEN
-C *** Generate derivative wrt thickness
- Ipar = Kkkthc
- IF (Ipar.LE.Ndasig) THEN
- WRITE (6,10000) Ipar, Ndasig, Kkkthc, 0
-10000 FORMAT ('In Transm, Ipar,Ndasig=', 10I5)
- STOP '[STOP in Transm in cro/mnrm2.f]'
- ELSE
- Dbsig(N,Ipar-Ndasig) = X
- END IF
- END IF
-C
- END IF
- RETURN
- END
diff --git a/sammy/src/cro/mnrm2.f90 b/sammy/src/cro/mnrm2.f90
new file mode 100755
index 0000000000000000000000000000000000000000..18a98d021335fa83ae4c078bc582b8bc69254a17
--- /dev/null
+++ b/sammy/src/cro/mnrm2.f90
@@ -0,0 +1,300 @@
+module convert_to_transmission_m
+contains
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Transm (Sig, Dasig, Dbsig, Jjtrns, Kkkthc, Ttthck)
+!
+! *** Purpose -- Transform from total cross section to transmission.
+! *** Note that this routine is called only if summation
+! *** over isotopes has already occurred.
+!
+ use fixedi_m, only : Ndbsig,Ndasig,Nnnsig
+ use ifwrit_m, only : Ksolve
+ IMPLICIT None
+ real(kind=8)::Sig(*), Dasig(Nnnsig,*), Dbsig(Nnnsig,*)
+ integer::Jjtrns, Kkkthc
+ real(kind=8)::Ttthck
+ real(kind=8)::Zero
+ real(kind=8)::Xxx, X, A
+ integer::N, Ipar
+ DATA Zero /0.0d0/
+!
+ Xxx = dEXP(-Sig(Jjtrns)*Ttthck)
+!
+ IF (Ksolve.NE.2) THEN
+ A = -Ttthck*Xxx
+!
+! *** modify the derivatives to be in terms of transmission
+ N = Jjtrns
+ IF (Ndasig.GT.0) THEN
+ DO Ipar=1,Ndasig
+ IF (Dasig(N,Ipar).NE.Zero) Dasig(N,Ipar) =A*Dasig(N,Ipar)
+ END DO
+ END IF
+ IF (Ndbsig.GT.0) THEN
+ DO Ipar=1,Ndbsig
+ IF (Dbsig(N,Ipar).NE.Zero) Dbsig(N,Ipar) =A*Dbsig(N,Ipar)
+ END DO
+ END IF
+!
+ IF (Kkkthc.GT.0) THEN
+! *** generate derivative wrt thickness
+ Ipar = Kkkthc
+ IF (Ipar.LE.Ndasig) THEN
+ WRITE (6,10000) Ipar, Ndasig, Kkkthc, 0
+10000 FORMAT ('In Transm, Ipar,Ndasig=', 10I5)
+ STOP '[STOP in Transm in cro/mnrm2.f]'
+ ELSE
+ X = - Sig(Jjtrns)*Xxx
+ Dbsig(N,Ipar-Ndasig) = X
+ END IF
+ END IF
+!
+ END IF
+! *** modify cross section to be transmission
+ Sig(Jjtrns) = Xxx
+ RETURN
+ END
+
+ SUBROUTINE Transm_new (calcData, irow, isig, itot, wantDerivs, Kkkthc, Ttthck)
+!
+! *** Purpose -- Transform from total cross section to transmission.
+! *** Note that this routine is called only if summation
+! *** over isotopes has already occurred.
+!
+ use DerivativeHandler_M
+ IMPLICIT None
+ class(DerivativeHandler)::calcData
+ integer::Jjtrns, Kkkthc
+ real(kind=8)::Ttthck
+ real(kind=8)::Zero
+ logical::wantDerivs
+ real(kind=8)::Xxx, X, A, sig
+ integer::N, Ipar, itot, irow, isig
+ DATA Zero /0.0d0/
+!
+ sig = calcData%getSharedValNs(irow, isig, 0)
+ Xxx = dEXP(-sig*Ttthck)
+! *** modify cross section to be transmission
+ call calcData%setSharedValNs(irow, isig, 0, Xxx)
+ if( .not.wantDerivs) return
+
+ A = -Ttthck*Xxx
+ DO Ipar=1,itot
+ X = calcData%getSharedValNs(irow, isig, ipar)
+ if (X.ne.0.0d0) then
+ X = A * X
+ call calcData%setSharedValNs(irow, isig, ipar, X)
+ end if
+ end do
+!
+ IF (Kkkthc.GT.0) THEN
+! *** generate derivative wrt thickness
+ Ipar = Kkkthc
+ X = - sig*Xxx
+ call calcData%setSharedValNs(irow, isig, Ipar, X)
+ END IF
+ RETURN
+ END
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Trans_Non (Anonu, Bnonu, Rnonu, Znonu, Sig, Dasig, &
+ Dbsig, Jjtrns, Kkkthc)
+!
+! *** Purpose -- Transform from total cross section to transmission,
+! *** in the case where sample thickness is not uniform.
+!
+ use fixedi_m
+ use ifwrit_m
+ use fixedr_m
+ use abcexp_m
+ IMPLICIT None
+ real(kind=8)::Anonu(*), Bnonu(*), Rnonu(*), Znonu(*)
+ real(kind=8)::Sig(*), Dasig(Nnnsig,*), Dbsig(Nnnsig,*)
+ real(kind=8)::Zero, One, Two, Small
+ integer::Jjtrns, Kkkthc
+ real(kind=8)::A, A2, F, Aa, B, B2, Bb, C, Cc, C1, C2, Dd
+ real(kind=8)::Ddd, Deriv, dQ, E1, E2, Fix
+ integer::Ipar, N, I, Ijklmn
+ real(kind=8)::Q, R, R1, R2, Total, X, Z1, Z2
+ DATA Zero /0.0d0/, One/1.0d0/, Two /2.0d0/, Small /0.3d0/
+!
+ Total = Sig(Jjtrns)*Thick
+ R2 = Rnonu(1)
+ Z2 = Znonu(1)
+ E2 = dEXP(-Total*Z2)
+ Q = Zero
+ dQ = Zero
+ DO I=2,Nonu
+ E1 = E2
+ R1 = R2
+ Z1 = Z2
+ A2 = Anonu(I)
+ B2 = Bnonu(I)
+ R2 = Rnonu(I)
+ C2 = B2*R2
+ C1 = B2*R1
+ Z2 = Znonu(I)
+ E2 = dEXP(-Total*Z2)
+ Dd = Total*(C2-C1)
+ IF (dABS(Dd).GT.Small) THEN
+ A = E1*(Total*C1+One) - E2*(Total*C2+One)
+ F = (Total*B2)**2
+ Q = Q + A/F
+ IF (Ksolve.NE.2) THEN
+ A = One + Total*Z1
+ B = Total*C1*A + One + A
+ C = E1*B
+ A = One + Total*Z2
+ B = Total*C2*A + One + A
+ C = E2*B - C
+ dQ = dQ + C/F
+ END IF
+ ELSE
+ R = R2 - R1
+ F = Abcexp (Dd, Aa, Bb, Cc, Ddd, Ijklmn)
+ A = R*(R1*Aa+R*Bb)
+ Q = Q + A*E2
+ IF (Ksolve.NE.2) THEN
+ A = Aa*(Two+Total*Z1)*R1 + Bb*(Two+Total*A2)*R
+ A = R2**2 - R1**2 - R*A
+ dQ = dQ + A*E2
+ END IF
+ END IF
+ END DO
+ Fix = Rnonu(Nonu)**2/Two
+ X = dQ/Fix
+ Deriv = X/Sig(Jjtrns)
+ X = X/Thick
+ Sig(Jjtrns) = Q/Fix
+!
+ IF (Ksolve.NE.2) THEN
+ A = Deriv
+!
+! *** Modify the derivatives to be in terms of transmission
+ N = Jjtrns
+ IF (Ndasig.GT.0) THEN
+ DO Ipar=1,Ndasig
+ IF (Dasig(N,Ipar).NE.Zero) Dasig(N,Ipar) =A*Dasig(N,Ipar)
+ END DO
+ END IF
+ IF (Ndbsig.GT.0) THEN
+ DO Ipar=1,Ndbsig
+ IF (Dbsig(N,Ipar).NE.Zero) Dbsig(N,Ipar) =A*Dbsig(N,Ipar)
+ END DO
+ END IF
+!
+ IF (Kkkthc.GT.0) THEN
+! *** Generate derivative wrt thickness
+ Ipar = Kkkthc
+ IF (Ipar.LE.Ndasig) THEN
+ WRITE (6,10000) Ipar, Ndasig, Kkkthc, 0
+10000 FORMAT ('In Transm, Ipar,Ndasig=', 10I5)
+ STOP '[STOP in Transm in cro/mnrm2.f]'
+ ELSE
+ Dbsig(N,Ipar-Ndasig) = X
+ END IF
+ END IF
+!
+ END IF
+ RETURN
+ END
+ SUBROUTINE Trans_Non_new (calcData, irow, isig, itot, wantDerivs, &
+ Anonu, Bnonu, Rnonu, Znonu, Kkkthc, &
+ Nonu, Thick )
+!
+! *** Purpose -- Transform from total cross section to transmission,
+! *** in the case where sample thickness is not uniform.
+!
+ use abcexp_m
+ use DerivativeHandler_M
+ IMPLICIT None
+ type(DerivativeHandler)::calcData
+ integer::irow, isig, itot
+ logical::wantDerivs
+ real(kind=8)::Anonu(*), Bnonu(*), Rnonu(*), Znonu(*)
+ real(kind=8)::Zero, One, Two, Small, Thick
+ integer::Kkkthc, Nonu
+ real(kind=8)::A, A2, F, Aa, B, B2, Bb, C, Cc, C1, C2, Dd
+ real(kind=8)::Ddd, Deriv, dQ, E1, E2, Fix, Sig, val
+ integer::Ipar, N, I, Ijklmn
+ real(kind=8)::Q, R, R1, R2, Total, X, Z1, Z2
+ DATA Zero /0.0d0/, One/1.0d0/, Two /2.0d0/, Small /0.3d0/
+!
+ Sig = calcData%getSharedValNs(irow, Isig, 0)
+ Total = Sig *Thick
+ R2 = Rnonu(1)
+ Z2 = Znonu(1)
+ E2 = dEXP(-Total*Z2)
+ Q = Zero
+ dQ = Zero
+ DO I=2,Nonu
+ E1 = E2
+ R1 = R2
+ Z1 = Z2
+ A2 = Anonu(I)
+ B2 = Bnonu(I)
+ R2 = Rnonu(I)
+ C2 = B2*R2
+ C1 = B2*R1
+ Z2 = Znonu(I)
+ E2 = dEXP(-Total*Z2)
+ Dd = Total*(C2-C1)
+ IF (dABS(Dd).GT.Small) THEN
+ A = E1*(Total*C1+One) - E2*(Total*C2+One)
+ F = (Total*B2)**2
+ Q = Q + A/F
+ IF (wantDerivs) THEN
+ A = One + Total*Z1
+ B = Total*C1*A + One + A
+ C = E1*B
+ A = One + Total*Z2
+ B = Total*C2*A + One + A
+ C = E2*B - C
+ dQ = dQ + C/F
+ END IF
+ ELSE
+ R = R2 - R1
+ F = Abcexp (Dd, Aa, Bb, Cc, Ddd, Ijklmn)
+ A = R*(R1*Aa+R*Bb)
+ Q = Q + A*E2
+ IF (wantDerivs) THEN
+ A = Aa*(Two+Total*Z1)*R1 + Bb*(Two+Total*A2)*R
+ A = R2**2 - R1**2 - R*A
+ dQ = dQ + A*E2
+ END IF
+ END IF
+ END DO
+ Fix = Rnonu(Nonu)**2/Two
+ X = dQ/Fix
+ Deriv = X/Sig
+ X = X/Thick
+ Sig = Q/Fix
+ call calcData%setSharedValNs(irow, isig, 0, Sig)
+!
+ IF (wantDerivs) THEN
+ A = Deriv
+!
+! *** Modify the derivatives to be in terms of transmission
+ do ipar = 1, itot
+ val = calcData%getSharedValNs(irow, isig, Ipar)
+ if (val.ne.Zero) then
+ val = val * A
+ call calcData%setSharedValNs(irow, Isig, Ipar, val)
+ end if
+ end do
+!
+ IF (Kkkthc.GT.0) THEN
+! *** Generate derivative wrt thickness
+ Ipar = Kkkthc
+ call calcData%setSharedValNs(irow, Isig, Ipar, X)
+ END IF
+!
+ END IF
+ RETURN
+ END
+end module convert_to_transmission_m
diff --git a/sammy/src/dbd/mdbd1.f b/sammy/src/dbd/mdbd1.f
index 6143406b8faf8740a21567b8d625cdd144e8a67b..3a75fbb0018c214b46ba8e0ac5ff61c023ef9383 100644
--- a/sammy/src/dbd/mdbd1.f
+++ b/sammy/src/dbd/mdbd1.f
@@ -25,6 +25,8 @@ C
* setAuxGridRowMax, getNumAuxGridPoints
use SammyGridAccess_M
use array_sizes_common_m, only : calcData
+ use convert_to_transmission_m
+ use normalize_and_background
IMPLICIT none
logical Need_isotopes
logical Another_Process_will_Happen
diff --git a/sammy/src/dbd/mdbd2.f b/sammy/src/dbd/mdbd2.f
index e783281fe5e2265a74f55a7397c084ed34065bae..4cc8d22fc53f7e124866d30b797acf4fc846727a 100644
--- a/sammy/src/dbd/mdbd2.f
+++ b/sammy/src/dbd/mdbd2.f
@@ -116,6 +116,8 @@ C
use lbro_common_m
use xct2_m
use array_sizes_common_m, only : calcData
+ use normalize_and_background
+ use convert_to_transmission_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
DIMENSION Parnbk(*), Iflnbk(*), Parbgf(*), Iflbgf(*),
diff --git a/sammy/src/dex/mdex1.f b/sammy/src/dex/mdex1.f
index 0edb58500247cf4f400fb727eea29a65f2459ae1..f3334c99711dbd22e292454f6466a6eff0bfcfc9 100644
--- a/sammy/src/dex/mdex1.f
+++ b/sammy/src/dex/mdex1.f
@@ -24,6 +24,7 @@ C
use rsl2_m
use array_sizes_common_m, only : calcData
use EndfData_common_m, only : expData
+ use normalize_and_background
use AuxGridHelper_M, only : getAuxGridOffset,
* setAuxGridRowMax,
* getNumAuxGridPoints
@@ -36,7 +37,7 @@ C
* Weight(*), Wts(*), Theory(*),
* Sigxxx(*), Dasigx(Nnnsig,*),
* Dbsigx(Nnnsig,*), Dum(1)
- real(kind=8)::Iflmsc(*), Iflnbk(*), Iflbgf(*),
+ integer::Iflmsc(*), Iflnbk(*), Iflbgf(*),
* Kndbgf(*)
real(kind=8)::Half
diff --git a/sammy/src/dop/mdop1.f90 b/sammy/src/dop/mdop1.f90
index 411b65d7119f671ce6bcdd4bafa11c3fd7f53e4c..eb1396188aae3556c35398c5ab190e5fabd9ac1f 100644
--- a/sammy/src/dop/mdop1.f90
+++ b/sammy/src/dop/mdop1.f90
@@ -1,5 +1,6 @@
!
module dop1_m
+ use convert_to_transmission_m
contains
!
! ____________________________________________________________________
diff --git a/sammy/src/fgm/mfgm1.f b/sammy/src/fgm/mfgm1.f
index e2045d05471deeb84407feb52a8cf3a9442cb91c..5e30e49a4167138673d1a30269b31fe1dac304dc 100644
--- a/sammy/src/fgm/mfgm1.f
+++ b/sammy/src/fgm/mfgm1.f
@@ -75,6 +75,7 @@ C
use mfgm3_M
use mfgm4_m
use EndfData_common_m, only : resParData
+ use convert_to_transmission_m
IMPLICIT None
LOGICAL Need_isotopes
LOGICAL Another_Process_Will_Happen
diff --git a/sammy/src/mlb/mmlb1.f b/sammy/src/mlb/mmlb1.f
index 842afcc0ad8a9d9b97a779ce8aacd7317892100d..e9d13eab7950f13504d5b871cd76a0c75037e0d7 100644
--- a/sammy/src/mlb/mmlb1.f
+++ b/sammy/src/mlb/mmlb1.f
@@ -118,8 +118,6 @@ C ********* If want Maxwellian averages or energy-averages with no
C ********* correction terms, do same as if there is broadening
C ********* except don't convert to transmission unless needed
IF (Maxwel.EQ.1 .OR. Knocor.EQ.1) THEN
- IF (Ytrans .AND. Kcros.LT.7 .AND. Ktruet.EQ.0) CALL
- * Transm (Sigxxx, Dasigx, Dbsigx, 1, Kvthck, Thick)
Iskip = 1
END IF
C
@@ -127,9 +125,6 @@ C ********* If there is Doppler broadening, skip the rest of this loop
IF (Ydoppr) Iskip = 1
C
C ********* If no Doppler, and this is transmission, make conversion
- IF (.NOT.Ydoppr .AND. Ytrans .AND. Kcros.LT.7
- * .AND. Ktruet.EQ.0) CALL
- * Transm (Sigxxx, Dasigx, Dbsigx, 1, Kvthck, Thick)
C
C ********* If there is resolution, we're done here
IF (Yresol) Iskip = 1
@@ -140,17 +135,8 @@ C
C
C ********* If ETA is being calculated and there is no broadening,
C ********* find derivative with respect to nu
- IF (Kcros.EQ.6) CALL Fix_Eta (Iflmsc, Sigxxx, Dasigx,
- * Dbsigx)
C
C ********* If there is normalization or background ...
- IF (Ynrmbk) THEN
- IF (Numnbk.GT.0) CALL Norm (Parnbk, Iflnbk,
- * Sigxxx, Dasigx, Dbsigx, Su, Nnnsig)
- IF (Numbgf.GT.0) CALL Bgfrpi (Parbgf, Iflbgf,
- * Kndbgf, Bgfmin, Bgfmax, Texbgf, Teabgf, Sigxxx,
- * Dbsigx, Su, Nnnsig)
- END IF
C
C ********* Write results onto Theory if there is no broadening etc
IF (Jjjdop.NE.1) THEN
@@ -179,11 +165,6 @@ C
END DO
C *** End of do-loop on energies
C
- IF (Ywhich .OR. Maxwel.EQ.1 .OR. Knocor.EQ.1) THEN
- Kkkmin = Kkkmin - 1
- CALL Write_Cross_Sections (calcData,
- * Nnnsig, Kkkkkk, Kkkmin, 0)
- END IF
C
IF (Kpiece.EQ.1) CALL Odfpcs (Pieces, Dum)
C
diff --git a/sammy/src/mso/mmso2.f b/sammy/src/mso/mmso2.f
index b3b2b8993d32f36b08fbffae1a5a46c9d3ae1d55..1e33b9122b5a948b5749a6e540dcdfe850c46d8e 100644
--- a/sammy/src/mso/mmso2.f
+++ b/sammy/src/mso/mmso2.f
@@ -38,6 +38,7 @@ C
use SammyGridAccess_M
use ssssss_common_m, only : Area, Rb, Rs, Sthick, Dthick, Fffdbl
use array_sizes_common_m, only : calcData
+ use normalize_and_background
IMPLICIT None
LOGICAL Another_Process_will_Happen
C
@@ -67,10 +68,11 @@ C
real(kind=8)::Asensn,Dddyy0, Ee, Elastic, Em, Exp1
real(kind=8)::R0, Ratio_Sensin, Rd, Total, Y0, Y2bbbb, Y2bbbq
real(kind=8)::Yyy1, Yyy2, Yyy2q
- integer::Idone, Iflbgf, Nnnxxx, Nsen, Nxtptvn, Nxtptwm
+ integer::Idone, Nnnxxx, Nsen, Nxtptvn, Nxtptwm
integer::Iiso, Imin, Iso, Istop, Itimes, Iv, Iw
integer::Kdatmn, Kdatmx, Kk, Kkkdat, Kkkmin, Kkknew, nauxStart
integer::Knthet, Kountr, ksolve_save, N, Nn, Nnn
+ integer::Iflbgf(1) ! DAW: why is this not passed in?
DATA Zero /0.0d0/, One /1.0d0/
call grid%initialize()
diff --git a/sammy/src/orr/morr1.f90 b/sammy/src/orr/morr1.f90
index fee38a24ea7d9875ff9add8aba7b3ef4cfbc099c..511c63e3db5fdca34c6b2273d5074f7fe1aea283 100644
--- a/sammy/src/orr/morr1.f90
+++ b/sammy/src/orr/morr1.f90
@@ -26,6 +26,7 @@ module orr1_m
use rsl6_m
use AllocateFunctions_m
use DerivativeHandler_M
+ use normalize_and_background
!
type(SammyGridAccess)::expGrid
real(kind=8):: Parnbk(*), Parbgf(*), Bgfmin(*), Bgfmax(*), &
diff --git a/sammy/src/rpi/mrpi1.f90 b/sammy/src/rpi/mrpi1.f90
index 3496ec203c5e6fe5d5abe89f4e57721354991c0c..2ea03d9c596db2f9f8bb5f1444023ee15b2cbb71 100644
--- a/sammy/src/rpi/mrpi1.f90
+++ b/sammy/src/rpi/mrpi1.f90
@@ -28,6 +28,7 @@ module rpi1_m
use rsl2_m
use rsl3_m
use rsl6_m
+ use normalize_and_background
use EndfData_common_m, only : expData
use AuxGridHelper_M, only : getNumAuxGridPoints
use SammyGridAccess_M
diff --git a/sammy/src/rsl/mrsl1.f90 b/sammy/src/rsl/mrsl1.f90
index 0f85289cc349a922386c2adb19fb616899d50f7d..dbd772ab3cdd413d7f24002389f1193b1393ca30 100644
--- a/sammy/src/rsl/mrsl1.f90
+++ b/sammy/src/rsl/mrsl1.f90
@@ -31,6 +31,7 @@ module rsl1_m
use rsl6_m, only : Kount_Points
use SammyGridAccess_M
use DerivativeHandler_M
+ use normalize_and_background
use EndfData_common_m, only : expData
use AuxGridHelper_M, only : getAuxGridOffset, setAuxGridRowMax, &
getNumAuxGridPoints
diff --git a/sammy/src/sammy/CMakeLists.txt b/sammy/src/sammy/CMakeLists.txt
index f10f89e2507f550ba2f00e667dcc30888e167c4f..d4e228547fdea32c4f658395f497bb4610c020fd 100644
--- a/sammy/src/sammy/CMakeLists.txt
+++ b/sammy/src/sammy/CMakeLists.txt
@@ -76,8 +76,8 @@ APPEND_SET(SAMMY_SOURCES
../cro/mcro6.f
../cro/mcro7.f
../cro/mcro8.f
- ../cro/mnrm1.f
- ../cro/mnrm2.f
+ ../cro/mnrm1.f90
+ ../cro/mnrm2.f90
../cro/CroCrossCalc_M.f90
../dat/mdat0.f90
diff --git a/sammy/src/ssm/mssm22.f90 b/sammy/src/ssm/mssm22.f90
index dacb4de6521ccfb243f8a06e8e9767180fcafb8e..682923ebcd10c8ff022526ba2df8fe6ce905d73a 100644
--- a/sammy/src/ssm/mssm22.f90
+++ b/sammy/src/ssm/mssm22.f90
@@ -13,6 +13,7 @@ use fixedr_m
use logic_ssm_common_m
use lbro_common_m
use DerivativeHandler_M
+use normalize_and_background
IMPLICIT none
real(8), intent(in):: Ee, Em, Y0
diff --git a/sammy/src/the/ZeroKCrossCorrections_M.f90 b/sammy/src/the/ZeroKCrossCorrections_M.f90
index 53705908cdfae38c96b418e923d779db4a00152a..c68da6af74dec1464e7f89cf925588253c1612cf 100644
--- a/sammy/src/the/ZeroKCrossCorrections_M.f90
+++ b/sammy/src/the/ZeroKCrossCorrections_M.f90
@@ -88,44 +88,259 @@ contains
end subroutine
subroutine ZeroKCrossCorrections_writeMCData(this)
+ use mxct27_m, only : Write_Cross_Sections ! this function uses SAMMY global parameters
class(ZeroKCrossCorrections)::this
+ integer::If_W_Selfin
+ integer::Kkkkkk, Kkkmin, Nnnsss, length
+
+
+ if (.not.this%moreCorrections) return ! don't need to write the data
+ Kkkkkk = this%dataEnd
+ Kkkmin = this%dataStart - 1
+ if (Kkkmin.lt.0) Kkkmin = 0
+ Nnnsss = this%driver%calcData%getNnnsig()
+
+ If_W_Selfin = 0
+ length = this%dataEnd - this%dataStart
+ if (this%driver%calcDataSelf%getLength().ge.length) If_W_Selfin = 1
+
+ call Write_Cross_Sections (this%driver%calcData, &
+ Nnnsss, Kkkkkk, Kkkmin, &
+ If_W_Selfin, this%driver%calcDataSelf)
+
end subroutine
subroutine ZeroKCrossCorrections_setTheory(this, Theory, nnsig)
class(ZeroKCrossCorrections)::this
integer::nnsig
real(kind=8)::Theory(nnsig,*)
+ integer::is, id
+
+ if (this%moreCorrections) return ! don't need to set theory yet
+ !if (.not.this%summedOverIsotopes) then
+ ! write(0,*)" Expected only one istope or sum over isotopes completed"
+ ! stop
+ !end if
+ if (nnsig.ne.this%driver%calcData%getNnnsig()) then
+ write(0,*)" Number of cross sections do not agree "
+ stop
+ end if
+ do id = 1, this%dataStart -1
+ do is = 1, nnsig
+ Theory(is, id) = 0.0d0
+ end do
+ end do
+ do id = this%dataStart, this%dataEnd
+ do is = 1, nnsig
+ Theory(is, id) = this%driver%calcData%getDataNs(id, is, 0, 1)
+ end do
+ end do
end subroutine
subroutine ZeroKCrossCorrections_applyNorm(this, grid, expData, covariance)
+ use lbro_common_m, only : Ynrmbk
+ use fixedi_m, only : Numnbk, Numbgf
use ifwrit_m, only : Ksolve
use CovarianceData_M
+ use normalize_and_background
+ use exploc_common_m, only : A_Iprnbk, I_Iflnbk, A_Iprbgf, I_Iflbgf, I_Indbgf, &
+ A_Ibgfmi, A_Ibgfma, A_Itexbg , A_Iteabg
+
use GridData_M
class(ZeroKCrossCorrections)::this
type(SammyGridAccess)::grid
type(GridDataList)::expData
type(CovarianceData)::covariance
+
+ integer::numEl
+ integer::ipos, iel, itot, in
+ real(kind=8)::ener
+
+ logical::wantDeriv
+
+
+ if (.not.Ynrmbk) return ! no correction to apply
+ if ( Numnbk.eq.0.and.Numbgf.eq.0) return ! no normalization to apply
+ if (this%moreCorrections) return ! don't need apply normalization and background yet
+
+ !if (.not.this%summedOverIsotopes) then
+ ! write(0,*)" Expected only one istope or sum over isotopes completed"
+ ! stop
+ !end if
+
+ numEl = grid%getNumEnergies(expData)
+ ipos = 0
+ wantDeriv = this%driver%getWantDerivs()
+ if (.not.wantDeriv) then
+ if (ksolve.ne.2) then
+ if (allocated(I_Iflnbk)) then
+ if (sum(I_Iflnbk).gt.0) wantDeriv = .true.
+ end if
+ if (allocated(I_Iflbgf)) then
+ if (sum(I_Iflbgf).gt.0) wantDeriv = .true.
+ end if
+ else
+ if (allocated(I_Iflnbk)) then
+ do in = 1, size(I_Iflnbk)
+ if ( I_Iflnbk(in).le.0) cycle
+ if ( covariance%isPupedParameter(I_Iflnbk(in))) then
+ wantDeriv = .true.
+ exit
+ end if
+ end do
+ end if
+ if (allocated(I_Iflbgf)) then
+ do in = 1, size(I_Iflbgf)
+ if ( I_Iflbgf(in).le.0) cycle
+ if ( covariance%isPupedParameter(I_Iflbgf(in))) then
+ wantDeriv = .true.
+ exit
+ end if
+ end do
+ end if
+ end if
+ end if
+ itot = 0
+ if (wantDeriv) itot = covariance%getNumTotalParam()
+
+ do iel = 1, numEl
+ ener = grid%getEnergy(iel, expData)
+ if (ener.lt.0.0d0.and..not.this%wantNeg) cycle
+ ipos = ipos + 1
+
+ if (Numnbk.gt.0) then
+ CALL Norm_new (A_Iprnbk , I_Iflnbk, ener, ipos, this%driver%calcData, wantDeriv, itot)
+ end if
+ IF (Numbgf.GT.0) then
+ CALL Bgfrpi_new (A_Iprbgf, I_Iflbgf, I_Indbgf, A_Ibgfmi, A_Ibgfma, &
+ A_Itexbg, A_Iteabg, &
+ ener, this%driver%calcData, ipos, wantDeriv)
+ end if
+ end do
end subroutine
+
subroutine ZeroKCrossCorrections_convertToTrans(this, grid, expData, covariance)
use CovarianceData_M
use GridData_M
+ use convert_to_transmission_m
+ use exploc_common_m, only : A_Ianonu, A_Ibnonu, A_Irnonu, A_Iznonu
+ use ifwrit_m, only : Ksolve, Nonu, Kvthck
+ use fixedr_m, only : Thick
class(ZeroKCrossCorrections)::this
type(SammyGridAccess)::grid
type(GridDataList)::expData
type(CovarianceData)::covariance
+ integer::iel, numEl, itot, ipos
+ real(kind=8)::ener
+ logical::wantDeriv
+
+ if (.not.this%wantTrans) return ! don't need to do transformation to transmission yet
+
+ numEl = grid%getNumEnergies(expData)
+ ipos = 0
+ itot = 0
+
+ wantDeriv = this%driver%getWantDerivs()
+ if (.not.wantDeriv.and.Kvthck.gt.0) then
+ if (ksolve.ne.2) then
+ wantDeriv = .true.
+ else
+ if ( covariance%isPupedParameter(Kvthck)) then
+ wantDeriv = .true.
+ end if
+ end if
+ end if
+ itot = 0
+ if (wantDeriv) itot = covariance%getNumTotalParam()
+
+ do iel = 1, numEl
+ ener = grid%getEnergy(iel, expData)
+ if (ener.lt.0.0d0.and..not.this%wantNeg) cycle
+ ipos = ipos + 1
+ IF (Nonu.EQ.0) THEN
+ CALL Transm_new (this%driver%calcData, ipos, 1, itot, wantDeriv, Kvthck, Thick)
+ ELSE
+ CALL Trans_Non_new (this%driver%calcData, ipos, 1,itot, wantDeriv, &
+ A_Ianonu , A_Ibnonu , A_Irnonu , A_Iznonu , &
+ Kvthck, Nonu, Thick)
+ END IF
+ end do
end subroutine
subroutine ZeroKCrossCorrections_Fix_Eta(this, grid, expData, covariance)
use CovarianceData_M
use GridData_M
+ use exploc_common_m, only : I_Iflmsc
+ use ifwrit_m, only : Ksolve, Kjetan
+ use fixedr_m, only : Etanuu
class(ZeroKCrossCorrections)::this
type(SammyGridAccess)::grid
type(GridDataList)::expData
type(CovarianceData)::covariance
+ integer::iel, numEl, itot, ipos
+ real(kind=8)::ener
+ logical::wantDeriv
+ integer::niso, is, id
+ real(kind=8)::Sigma, F, A, v1, v2
+ integer::iflKjetan
+
+
+
+ numEl = grid%getNumEnergies(expData)
+ ipos = 0
+ itot = 0
+ niso = this%driver%calcData%getNumberIsotopes()
+
+ if (this%driver%calcData%getNnnsig().lt.2) then
+ write(0,*)" Need Nnnsig=2 if calculating eta"
+ stop
+ end if
+
+ wantDeriv = this%driver%getWantDerivs()
+ iflKjetan = Kjetan
+ if (iflKjetan.ne.0) then
+ iflKjetan = I_Iflmsc(Kjetan)
+ end if
+ if (.not.wantDeriv.and.iflKjetan.gt.0) then
+ if (ksolve.ne.2) then
+ wantDeriv = .true.
+ else
+ if ( covariance%isPupedParameter(iflKjetan)) then
+ wantDeriv = .true.
+ end if
+ end if
+ end if
+
+ if (wantDeriv) itot = covariance%getNumTotalParam()
+
+ do iel = 1, numEl
+ ener = grid%getEnergy(iel, expData)
+ if (ener.lt.0.0d0.and..not.this%wantNeg) cycle
+ ipos = ipos + 1
+
+ do is = 1, niso
+ Sigma = this%driver%calcData%getDataNs(ipos, 1, 0 , is)
+ F = this%driver%calcData%getDataNs(ipos, 2, 0 , is)
+ A = Sigma - F
+ do id = 1, itot
+ v1 = this%driver%calcData%getDataNs(ipos, 1, id , is)
+ v2 = this%driver%calcData%getDataNs(ipos, 2, id , is)
+ v1 = Etanuu * ( v2*(A/Sigma) - v1*(F/Sigma) )/Sigma
+ if (v1.ne.0.0d0) then
+ call this%driver%calcData%addDataNs(ipos, 1, id, is, v1)
+ end if
+ end do
+
+ if (wantDeriv.and.iflKjetan.gt.0) then
+ v1 = Sigma/Etanuu
+ call this%driver%calcData%addDataNs(ipos, 1, iflKjetan, is, v1)
+ end if
+ end do
+ end do
end subroutine
diff --git a/sammy/src/udr/mudr1.f b/sammy/src/udr/mudr1.f
index f014f825545032098a95bbae7341ac3d6931de5a..f4f73ced0af1edf82f772d721a1f518537bcd65d 100644
--- a/sammy/src/udr/mudr1.f
+++ b/sammy/src/udr/mudr1.f
@@ -14,7 +14,7 @@ C *** AND DERIVATIVES
C
use fixedi_m, only : Nudeng, Nudtim, Nnnsig, Ndasig, Ndbsig,
* Ndaxxx, Ndbxxx, Nnniso, Numbgf, Numbgf,
- * Numnbk, Nudwhi, numcro
+ * Numnbk, Nudwhi, numcro, Ntepnt
use ifwrit_m, only : ktzero, Jjjdop, Kdebug
use brdd_common_m, only : Ipk, Ipnts, Kc, Iup
use lbro_common_m, only : Ynrmbk, Ytotrs
@@ -25,6 +25,7 @@ C
use AuxGridHelper_M, only : getNumAuxGridPoints
use SammyGridAccess_M
use array_sizes_common_m, only : calcData
+ use normalize_and_background
IMPLICIT None
C
type(SammyGridAccess)::grid
@@ -40,7 +41,7 @@ C
* UdR_E(Nudtim,*), UdT_E(Nudtim,*), UdR_x(*),
* UdT_x(*), Dum_R(*), Dum_t(*)
integer::Nud_E(*), Nud_t(*), Ieb_x(*)
- real(kind=8)::Texbgf, Teabgf
+ real(kind=8)::Texbgf(Ntepnt,*), Teabgf(Ntepnt,*)
real(kind=8)::Elow, Em, Eup
integer::I, Ienpk, Igbpk, Itime, J, Jcro, nauxMax
diff --git a/sammy/src/xct/mxct02.f90 b/sammy/src/xct/mxct02.f90
index 96969d90f0cd51f49125c180c6af38a64bc3fbd3..c22f55d6a40c2f543c54f7067601b41b8ef5e11d 100644
--- a/sammy/src/xct/mxct02.f90
+++ b/sammy/src/xct/mxct02.f90
@@ -226,15 +226,6 @@ module xct2_m
! ********* correction terms, do same as if there were broadening
! ********* except don't convert to transmission unless needed
IF (Maxwel.EQ.1 .OR. Knocor.EQ.1) THEN
- IF (Ytrans .AND. Kcros.LT.7 .AND. Ktruet.EQ.0) THEN
- IF (Nonu.EQ.0) THEN
- CALL Transm (Sigxxx, Dasigx, Dbsigx, 1, Kvthck, &
- Thick)
- ELSE
- CALL Ztrans (Sigxxx, Dasigx, Dbsigx, 1, &
- Kvthck)
- END IF
- END IF
Iskip = 1
END IF
!
@@ -250,9 +241,6 @@ module xct2_m
IF (Yssmsc) Iskip = 1
!
! ********* If no Doppler, and this is transmission, make conversion
- IF (.NOT.Ydoppr .AND. Ytrans .AND. Kcros.LT.7 &
- .AND. Ktruet.EQ.0) CALL &
- Transm (Sigxxx, Dasigx, Dbsigx, 1, Kvthck, Thick)
!
! ********* If there is resolution, we're done here.
IF (Yresol) Iskip = 1
@@ -267,13 +255,6 @@ module xct2_m
!x * Nnnsig, Nnniso)
!
! ********* If there is normalization or background, include it
- IF (Ynrmbk) THEN
- IF (Numnbk.GT.0) CALL Norm (Parnbk, Ifl_Nbk, &
- Sigxxx, Dasigx, Dbsigx, Su, Nnnsig)
- IF (Numbgf.GT.0) CALL Bgfrpi (Parbgf, Ifl_bgf, &
- Kndbgf, Bgfmin, Bgfmax, Texbgf, Teabgf, &
- Sigxxx, Dbsigx, Su, Nnnsig)
- END IF
!
! ********* write results onto theory if there is no broadening etc
IF (Jjjdop.NE.1) THEN
@@ -299,12 +280,6 @@ module xct2_m
end do
call derivs%addCalculatedData(Kkkkkk, Nnnsig, ndasig, &
ndbsig, -1, Sigxxx(1:Nnnsig,1), Dasigx, Dbsigx(1:Nnnsig,1:Ndbxxx,1))
- do Jsig = 1,Nnnsig
- Jcount = (Kkkkkk-1)*Nnnsig + Jsig
- ! get the cross section (Ipar=0 in Derivs) for section Nnsig
- ! and isotope 1
- Theory(Jsig,Jjdat) = derivs%getData(Jcount, 0, 1)
- end do
END IF
!
ELSE IF (Iskip.EQ.1) THEN
@@ -351,11 +326,6 @@ module xct2_m
! *** end of do-loop on energies (Jdat)
!
- IF (Ywhich .OR. Maxwel.EQ.1 .OR. Knocor.EQ.1) THEN
- Kkkmin = Kkkmin - 1
- CALL Write_Cross_Sections (derivs, &
- Nnnsig, numEl, Kkkmin, Iw, derivsSelf)
- END IF
!
IF (Kpiece.EQ.1) CALL Odfpcs (Pieces, Dum)
call grid%destroy()
@@ -634,6 +604,7 @@ module xct2_m
! *** sample
use oops_common_m
use exploc_common_m
+ use convert_to_transmission_m
IMPLICIT none
real(8), intent(inout)::Sig