diff --git a/sammy/samtry/tr066/answers/rc5.lpt b/sammy/samtry/tr066/answers/rc5.lpt
index e689fb6713242055887a8f2a7993ca7f204f47e2..3b8df9583cabfdcf8bf51911b4647fded5d2f84d 100755
--- a/sammy/samtry/tr066/answers/rc5.lpt
+++ b/sammy/samtry/tr066/answers/rc5.lpt
@@ -1,3 +1,4 @@
+
**********************************************************
*** ***
*** SAMMY Version 8.1.0 ***
@@ -62,7 +63,7 @@ Adjusted Itmax Icorr Nxtra Iptdop Iptwid Ixxchn
**** end of Alphanumeric Control Information *********
- ### Estimated array size for SAMMY-INP is 264 ###
+ ### Estimated array size for SAMMY-INP is 5214 ###
Target Thickness= 0.000
@@ -90,12 +91,8 @@ __________________________
Number of spin groups is 2
Number of flagged parametrs is 3
Number of varied parameters is 3
- If fitting gamma width for spin-group= 1 together, all need to be fitted
- The fit flags have been adjusted!
- If fitting gamma width for spin-group= 2 together, all need to be fitted
- The fit flags have been adjusted!
- ### Array size used for SAMMY-PAR is 3 ###
- ### Estimated array size for SAMMY-NEW is 21 ###
+ ### Array size used for SAMMY-PAR is 0 ###
+ ### Estimated array size for SAMMY-NEW is 18 ###
@@ -143,23 +140,23 @@ __________________________
STD. DEV. STD. DEV. STD. DEV.
( 1) 4.1298E-04 ( 2) 9.6043E-04 ( 3) 1.3736E-03
- ### Array size used for SAMMY-NEW is 19 ###
+ ### Array size used for SAMMY-NEW is 0 ###
Emind Emins Eminr Emin
0.1000000000 0.1000000000 0.1000000000 0.1000000000
Emax Emaxr Emaxs Emaxd
0.1050000000 0.1050000000 0.1050000000 0.1050000000
- ### Estimated array size for SAMMY-DAT is 145 ###
+ ### Estimated array size for SAMMY-DAT is 142 ###
Energy range of data is from 1.00000E-01 to 1.05000E-01 eV.
Number of experimental data points = 10
- ### Array size used for SAMMY-DAT is 93 ###
- ### Estimated array size for SAMMY-THE is 63 ###
+ ### Array size used for SAMMY-DAT is 0 ###
+ ### Estimated array size for SAMMY-THE is 60 ###
Number of parameters affected by this data set= 3
- ### Array size used for SAMMY-THE is 26 ###
- ### Estimated array size for SAMMY-XCT is 923 ###
- ### Array size used for SAMMY-XCT is 862 ###
- ### Estimated array size for SAMMY-INT is 143 ###
+ ### Array size used for SAMMY-THE is 0 ###
+ ### Estimated array size for SAMMY-XCT is 0 ###
+ ### Array size used for SAMMY-XCT is 1 ###
+ ### Estimated array size for SAMMY-INT is 23 ###
***** THEORETICAL VALUES (broadnd,normed,...as required)
@@ -184,17 +181,17 @@ __________________________
8 0.103700 368.72 2.9525 16.670
9 0.104200 369.59 2.9470 16.643
10 0.104700 370.48 2.9416 16.615
- ### Array size used for SAMMY-INT is 144 ###
- ### Estimated array size for SAMMY-SQU is 135 ###
- ### Array size used for SAMMY-SQU is 120 ###
- ### Estimated array size for SAMMY-IPQ is 120 ###
+ ### Array size used for SAMMY-INT is 2 ###
+ ### Estimated array size for SAMMY-SQU is 15 ###
+ ### Array size used for SAMMY-SQU is 0 ###
+ ### Estimated array size for SAMMY-IPQ is 0 ###
CUSTOMARY CHI SQUARED = 58.2594
CUSTOMARY CHI SQUARED DIVIDED BY NDAT = 5.82594
BAYESIAN CHI SQUARED = 55.8055
BAYESIAN CHI SQUARED DIVIDED BY NDAT = 5.58055
- ### Array size used for SAMMY-IPQ is 107 ###
+ ### Array size used for SAMMY-IPQ is 0 ###
### Estimated array size for SAMMY-FIN is 30000000 ###
@@ -233,13 +230,13 @@ __________________________
Gamma-width for spin group # 1 = 4.0000E+01
Gamma-width for spin group # 2 = 3.0000E+01
- ### Array size used for SAMMY-FIN is 49 ###
- ### Estimated array size for SAMMY-THE is 87 ###
+ ### Array size used for SAMMY-FIN is 0 ###
+ ### Estimated array size for SAMMY-THE is 60 ###
Number of parameters affected by this data set= 3
- ### Array size used for SAMMY-THE is 50 ###
- ### Estimated array size for SAMMY-XCT is 947 ###
- ### Array size used for SAMMY-XCT is 886 ###
- ### Estimated array size for SAMMY-INT is 167 ###
+ ### Array size used for SAMMY-THE is 0 ###
+ ### Estimated array size for SAMMY-XCT is 0 ###
+ ### Array size used for SAMMY-XCT is 1 ###
+ ### Estimated array size for SAMMY-INT is 23 ###
***** THEORETICAL VALUES (broadnd,normed,...as required)
@@ -264,12 +261,12 @@ __________________________
8 0.103700 396.22 2.9560 16.738
9 0.104200 397.16 2.9505 16.710
10 0.104700 398.11 2.9451 16.683
- ### Array size used for SAMMY-INT is 146 ###
- ### Estimated array size for SAMMY-IPQ is 144 ###
+ ### Array size used for SAMMY-INT is 2 ###
+ ### Estimated array size for SAMMY-IPQ is 0 ###
CUSTOMARY CHI SQUARED = 53.2803
CUSTOMARY CHI SQUARED DIVIDED BY NDAT = 5.32803
- ### Array size used for SAMMY-IPQ is 131 ###
+ ### Array size used for SAMMY-IPQ is 0 ###
### Estimated array size for SAMMY-FIN is 16 + 30000000 ###
@@ -341,7 +338,7 @@ __________________________
NEW/OLD NEW/OLD NEW/OLD
( 1) 0.9756 ( 2) 1.000 ( 3) 0.9999
- ### Array size used for SAMMY-FIN is 89 ###
+ ### Array size used for SAMMY-FIN is 0 ###
*****************************************************************************
@@ -386,7 +383,7 @@ Adjusted Itmax Icorr Nxtra Iptdop Iptwid Ixxchn
Name of initial parameter covariance file is:
>>> SAMMY.COV <<<
- ### Estimated array size for SAMMY-INP is 325 ###
+ ### Estimated array size for SAMMY-INP is 4920 ###
Target Thickness= 0.000
@@ -395,20 +392,16 @@ Adjusted Itmax Icorr Nxtra Iptdop Iptwid Ixxchn
Spin of incident particle is 0.5
__________________________
- ### Array size used for SAMMY-INP is 61 ###
- ### Estimated array size for SAMMY-PAR is 172 ###
+ ### Array size used for SAMMY-INP is 0 ###
+ ### Estimated array size for SAMMY-PAR is 111 ###
Total number of resonances is 5
Number of particle channels is 3
Number of spin groups is 2
Number of flagged parametrs is 3
Number of varied parameters is 3
- If fitting gamma width for spin-group= 1 together, all need to be fitted
- The fit flags have been adjusted!
- If fitting gamma width for spin-group= 2 together, all need to be fitted
- The fit flags have been adjusted!
- ### Array size used for SAMMY-PAR is 64 ###
- ### Estimated array size for SAMMY-OLD is 79 ###
+ ### Array size used for SAMMY-PAR is 0 ###
+ ### Estimated array size for SAMMY-OLD is 15 ###
Number of non-zero off-diagonal cov matrix elements is 3
@@ -421,23 +414,23 @@ __________________________
DeltaL = 0.00000
DeltaG = 0.00000
DeltaE = 0.00000
- ### Array size used for SAMMY-OLD is 82 ###
+ ### Array size used for SAMMY-OLD is 0 ###
Emind Emins Eminr Emin
0.1000000000 0.1000000000 0.1000000000 0.1000000000
Emax Emaxr Emaxs Emaxd
0.1050000000 0.1050000000 0.1050000000 0.1050000000
- ### Estimated array size for SAMMY-DAT is 221 ###
+ ### Estimated array size for SAMMY-DAT is 142 ###
Energy range of data is from 1.00000E-01 to 1.05000E-01 eV.
Number of experimental data points = 10
- ### Array size used for SAMMY-DAT is 169 ###
- ### Estimated array size for SAMMY-THE is 139 ###
+ ### Array size used for SAMMY-DAT is 0 ###
+ ### Estimated array size for SAMMY-THE is 60 ###
Number of parameters affected by this data set= 3
- ### Array size used for SAMMY-THE is 102 ###
- ### Estimated array size for SAMMY-XCT is 999 ###
- ### Array size used for SAMMY-XCT is 938 ###
- ### Estimated array size for SAMMY-INT is 219 ###
+ ### Array size used for SAMMY-THE is 0 ###
+ ### Estimated array size for SAMMY-XCT is 0 ###
+ ### Array size used for SAMMY-XCT is 1 ###
+ ### Estimated array size for SAMMY-INT is 23 ###
***** THEORETICAL VALUES (broadnd,normed,...as required)
@@ -462,18 +455,17 @@ __________________________
8 0.103700 398.12 2.9561 16.738
9 0.104200 399.07 2.9506 16.710
10 0.104700 400.03 2.9452 16.683
- ### Array size used for SAMMY-INT is 220 ###
- ### Estimated array size for SAMMY-SQU is 211 ###
- ### Array size used for SAMMY-SQU is 196 ###
- ### Estimated array size for SAMMY-IPQ is 196 ###
+ ### Array size used for SAMMY-INT is 2 ###
+ ### Estimated array size for SAMMY-SQU is 15 ###
+ ### Array size used for SAMMY-SQU is 0 ###
+ ### Estimated array size for SAMMY-IPQ is 0 ###
CUSTOMARY CHI SQUARED = 52.9316
CUSTOMARY CHI SQUARED DIVIDED BY NDAT = 5.29316
BAYESIAN CHI SQUARED = 50.4704
BAYESIAN CHI SQUARED DIVIDED BY NDAT = 5.04704
- ### Array size used for SAMMY-IPQ is 183 ###
- ### Estimated array size for SAMMY-FIN is 113 ###
- ### Array size used for SAMMY-FIN is 113 ###
- Total time = 0.01 seconds
+ ### Array size used for SAMMY-IPQ is 0 ###
+ ### Estimated array size for SAMMY-FIN is 0 ###
+ ### Array size used for SAMMY-FIN is 0 ###
Normal finish to SAMMY
diff --git a/sammy/src/amr/mamr1.f b/sammy/src/amr/mamr1.f
index abe8cfc86c1bd4f72c0f65d9bc842add15436fcf..54bf09572bc4dd99884d0064bb9b6282c1afdda4 100755
--- a/sammy/src/amr/mamr1.f
+++ b/sammy/src/amr/mamr1.f
@@ -12,9 +12,9 @@ C
use fxxxdx_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
-C *** store LLF (from B51ZYX) into LF (from fixedi_m) as well
+C *** store LLF (from B51ZYX) into LFdim (from fixedi_m) as well
DO I=1,300
- Lf(I) = Llf(I)
+ Lfdim(I) = Llf(I)
END DO
C
C
diff --git a/sammy/src/amr/mamr2.f b/sammy/src/amr/mamr2.f
index 963a73b606d10035bb588ffde272b2ff2aa5ba46..4bba65f8cc5f7c9630623cc677b7ab833af31d1b 100644
--- a/sammy/src/amr/mamr2.f
+++ b/sammy/src/amr/mamr2.f
@@ -208,10 +208,10 @@ C
COMMON /Keep/ Lllf(300)
C
DO I=1,300
- Lllf(I) = Lf(I)
+ Lllf(I) = Lfdim(I)
END DO
DO I=1,300
- Lf(I) = Llf(I)
+ Lfdim(I) = Llf(I)
END DO
C
CALL Keepx
@@ -261,7 +261,7 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
COMMON /Keep/ Lllf(300)
DO I=1,300
- Lf(I) = Lllf(I)
+ Lfdim(I) = Lllf(I)
END DO
RETURN
END
diff --git a/sammy/src/amx/mamx1.f b/sammy/src/amx/mamx1.f
index d436455b7388f8138f2467cae39faea23fce0434..c66122aeee60dada2bc25bc3d192277b38222389 100644
--- a/sammy/src/amx/mamx1.f
+++ b/sammy/src/amx/mamx1.f
@@ -12,9 +12,9 @@ C
use fxxxdx_common_m
IMPLICIT DOUBLE PRECISION (A-h,o-z)
C
-C *** store Llf (from fxxxdx_common_m) into LF (from fixedi_m) as well
+C *** store Llf (from fxxxdx_common_m) into LFdim (from fixedi_m) as well
DO I=1,300
- Lf(I) = Llf(I)
+ Lfdim(I) = Llf(I)
END DO
C
C
diff --git a/sammy/src/ang/mang2.f b/sammy/src/ang/mang2.f
index e9efa6a2a601e9f929cec94f55bd508196410c3a..0d4fee893b4808973724bc311a28ae791f9b0caf 100644
--- a/sammy/src/ang/mang2.f
+++ b/sammy/src/ang/mang2.f
@@ -21,7 +21,7 @@ C
K = Kjatti - 1
DO Iangle=1,Nangle
K = K + 1
- Kkk = Iflmsc(K) - Nvadif - Ndasig
+ Kkk = Iflmsc(K) - Ndasig
C *** attenuate the cross sections
IF (Sigxxx(Iangle).NE.Zero) THEN
A = dEXP(-Parmsc(K)*Totalx)
@@ -47,7 +47,7 @@ C
C *** finally, generate derivs of the [modified] cross section
C *** wrt the attenuation thickness
IF (Iflmsc(K).GT.0) THEN
- Kkk = Iflmsc(K) - Nvadif - Ndasig
+ Kkk = Iflmsc(K) - Ndasig
Dbsigx(Iangle,Kkk) = - Totalx*Sigxxx(Iangle)
* + Dbsigx(Iangle,Kkk)
END IF
@@ -119,7 +119,7 @@ C *** here (above) use unbroadened derivs so not really right
END DO
END IF
IF (Iflmsc(Kkk).GT.0) THEN
- Kx = Iflmsc(Kkk) - Nvadif - Ndasig
+ Kx = Iflmsc(Kkk) - Ndasig
Dbsigx(Iangle,Kx) = Dbsigx(Iangle,Kx) -
* Totbrd*Sigxxx(Iangle)
END IF
diff --git a/sammy/src/blk/AllocateFunctions.f90 b/sammy/src/blk/AllocateFunctions.f90
index f419fbb0f7416e760ec634c56b7e24bc135cd331..510eb1fe5327e786cf0e6ffebded8376f6663b5d 100644
--- a/sammy/src/blk/AllocateFunctions.f90
+++ b/sammy/src/blk/AllocateFunctions.f90
@@ -13,17 +13,21 @@ module AllocateFunctions_m
!!
subroutine allocate_real_data(array, want)
real(kind=8),allocatable,dimension(:)::array
- integer::want
+ integer,intent(in)::want
+ integer::local_want
+
+ local_want = want
+ if (want.eq.0) local_want = 1
if (allocated(array)) then
if( size(array).lt.want) deallocate(array)
end if
if (.not.allocated(array)) then
- allocate(array(want))
+ allocate(array(local_want))
end if
- array(1:want) = 0.0d0
+ array(1:local_want) = 0.0d0
end subroutine allocate_real_data
!!
@@ -41,7 +45,7 @@ module AllocateFunctions_m
!!
subroutine reallocate_real_data(array, want, nextra)
real(kind=8),allocatable,dimension(:)::array
- integer::want, nextra
+ integer,intent(in)::want, nextra
real(kind=8),allocatable,dimension(:)::tmp
@@ -49,17 +53,17 @@ module AllocateFunctions_m
optional nextra
- if( .not.allocated(array)) then
- nsize = want
- if (present(nextra)) nsize = nsize + nextra
+ nsize = want
+ if (present(nextra)) nsize = nsize + nextra
+ if (nsize.eq.0) nsize = 1
+
+ if( .not.allocated(array)) then
call allocate_real_data(array, nsize)
return
end if
if (size(array).ge.want) return
- current = size(array)
- nsize = want
- if (present(nextra)) nsize = nsize + nextra
+ current = size(array)
allocate(tmp(current))
tmp(1:current) = array(1:current)
deallocate(array)
@@ -69,6 +73,49 @@ module AllocateFunctions_m
deallocate(tmp)
end subroutine reallocate_real_data
+ !!
+ !! Make sure an array can take at
+ !! least want data. If the array size is smaller than
+ !! want, than re-allocate it so that it can take
+ !! (want+nextra) data. Previous data of the
+ !! array are preserved, newly allocated data are
+ !! set to zero.
+ !!
+ !! @param array to allocate
+ !! @param want the desired length
+ !! @param nextra, if we need to reallocate, we make sure
+ !! capacity is (want + nextra)
+ !!
+ subroutine reallocate_integer_data(array, want, nextra)
+ integer,allocatable,dimension(:)::array
+ integer, intent(in)::want, nextra
+
+
+ integer,allocatable,dimension(:)::tmp
+ integer::current, nsize
+
+ optional nextra
+
+ nsize = want
+ if (present(nextra)) nsize = nsize + nextra
+ if (nsize.eq.0) nsize = 1
+
+ if( .not.allocated(array)) then
+ call allocate_integer_data(array, nsize)
+ return
+ end if
+ if (size(array).ge.want) return
+
+ current = size(array)
+ allocate(tmp(current))
+ tmp(1:current) = array(1:current)
+ deallocate(array)
+ allocate(array(nsize))
+ array(1:current) = tmp(1:current)
+ array(current+1:nsize) = 0
+ deallocate(tmp)
+ end subroutine reallocate_integer_data
+
!!
!! Make sure an 2-dim array of can take at
@@ -88,21 +135,25 @@ module AllocateFunctions_m
!!
subroutine reallocate_real_data_2d(array, want1, nextra1, want2, nextra2)
real(kind=8),allocatable,dimension(:,:)::array
- integer::want1, want2, nextra1, nextra2
+ integer,intent(in)::want1, want2, nextra1, nextra2
real(kind=8),allocatable,dimension(:,:)::tmp
integer::current1,current2, nsize1, nsize2
+ nsize1 = want1 + nextra1
+ if (nsize1.eq.0) nsize1 = 1
+ nsize2 = want2 + nextra2
+ if (nsize2.eq.0) nsize2 = 1
+
+
if( .not.allocated(array)) then
- allocate(array(want1+nextra1, want2+nextra2))
+ allocate(array(nsize1, nsize2))
return
end if
if (size(array,dim=1).ge.want1.and. size(array,dim=2).ge.want2) return
current1 = size(array,dim=1)
- current2 = size(array,dim=2)
- nsize1 = want1 + nextra1
- nsize2 = want2 + nextra2
+ current2 = size(array,dim=2)
allocate(tmp(current1, current2))
tmp(1:current1, 1:current2) = array(1:current1, 1:current2)
deallocate(array)
@@ -123,17 +174,21 @@ module AllocateFunctions_m
!!
subroutine allocate_integer_data(array, want)
integer,allocatable,dimension(:)::array
- integer::want
+ integer,intent(in)::want
+ integer::local_want
+
+ local_want = want
+ if (want.eq.0) local_want = 1
if (allocated(array)) then
if( size(array).lt.want) deallocate(array)
end if
if (.not.allocated(array)) then
- allocate(array(want))
+ allocate(array(local_want))
end if
- array(1:want) = 0.0d0
+ array(1:local_want) = 0
end subroutine allocate_integer_data
end module AllocateFunctions_m
diff --git a/sammy/src/blk/Exploc_common.f90 b/sammy/src/blk/Exploc_common.f90
index 024a5f77521df6892228d2036e21c26c507f653c..6bb6eb0b417413cc36b2d5fdf729dc2701e3f2ff 100644
--- a/sammy/src/blk/Exploc_common.f90
+++ b/sammy/src/blk/Exploc_common.f90
@@ -110,14 +110,11 @@ module exploc_common_m
integer,allocatable,dimension(:)::I_Ifzkte
integer,allocatable,dimension(:)::I_Ifzkfe
real(kind=8),allocatable,dimension(:)::A_Izeta
- real(kind=8),allocatable,dimension(:)::A_Idcov
! old group 6
- real(kind=8),allocatable,dimension(:)::A_Iddcov
real(kind=8),allocatable,dimension(:),target::A_Ith
! old group 7
- integer,allocatable,dimension(:)::I_Iiuif
real(kind=8),allocatable,dimension(:)::A_Idifma
real(kind=8),allocatable,dimension(:)::A_Idatb
integer :: Noffv ! not an array index
@@ -570,22 +567,6 @@ module exploc_common_m
call allocate_real_data(A_Izeta,want)
end subroutine make_A_Izeta
- subroutine make_A_Idcov(want)
- integer::want
- call allocate_real_data(A_Idcov,want)
- end subroutine make_A_Idcov
-
-
- subroutine make_A_Iddcov(want)
- integer::want
- call allocate_real_data(A_Iddcov,want)
- end subroutine make_A_Iddcov
-
- subroutine make_I_Iiuif(want)
- integer::want
- call allocate_integer_data(I_Iiuif, want)
- end subroutine make_I_Iiuif
-
subroutine make_A_Idatb(want)
integer::want
call allocate_real_data(A_Idatb,want)
diff --git a/sammy/src/blk/Fixedi_common.f90 b/sammy/src/blk/Fixedi_common.f90
index 92155075256c567daef95949cde5a01b44887c47..fdda73e2f2ad797577de8c4dbd228757115e2094 100644
--- a/sammy/src/blk/Fixedi_common.f90
+++ b/sammy/src/blk/Fixedi_common.f90
@@ -15,265 +15,274 @@ module fixedi_m
! fin/mfin5.f
!
! Note:
- ! ndatmn (lf(122)), lower limit for auxillary grid is no longer used
+ ! ndatmn (lfdim(122)), lower limit for auxillary grid is no longer used
! covariance file will now always contain 0 for that value
- ! ndatmx (lf(123)), upper limit for auxillary grid is no longer used
+ ! ndatmx (lfdim(123)), upper limit for auxillary grid is no longer used
! covariance file will now always contain 0 for that value
- integer, target,save ::lf(300)
+ ! Nyyres ( lfdim(107)) no longer used, was equal to new definition of Napres
+ ! covariance file will now always contain 0 for that value
+ ! Nxxres ( lfdim(106)) no longer needed
+ ! covariance file will now always contain 0 for that value
+ ! Nvadif (lfdim(54)) Historically it was used to allow for a smaller array size in the derivivates
+ ! covariance file will now always contain 0 for that value
+ ! Numpup (lfdim(56)) Historically the number of pup'ed parameters
+ ! covariance file will now always contain 0 for that value
+ ! Napthe (lfdim(52)) Historically the number of adjusted parameters minus data parameters
+ ! covariance file will now always contain 0 for that value
+ integer, target,save ::lfdim(300)
! old group 1
- integer, pointer :: Nvpall => lf(1)
- integer, pointer :: Nvprmt => lf(2)
- integer, pointer :: Nvpres => lf(3)
- integer, pointer :: Nvprad => lf(4)
- integer, pointer :: Nvpext => lf(5)
- integer, pointer :: Nvpbrd => lf(6)
- integer, pointer :: Nvpiso => lf(7)
- integer, pointer :: Nvpexp => lf(8)
- integer, pointer :: Nvpdet => lf(9)
- integer, pointer :: Nvpmsc => lf(10)
- integer, pointer :: Nvppmc => lf(11)
- integer, pointer :: Nvporr => lf(12)
- integer, pointer :: Nvprpi => lf(13)
- integer, pointer :: Nvpudr => lf(14)
- integer, pointer :: Nvpnbk => lf(15)
- integer, pointer :: Nvpbgf => lf(16)
- integer, pointer :: Nvpdtp => lf(17)
- ! indexer on lf covers up to 17 (next should be 18)
+ integer, pointer :: Nvpall => lfdim(1)
+ integer, pointer :: Nvprmt => lfdim(2)
+ integer, pointer :: Nvpres => lfdim(3)
+ integer, pointer :: Nvprad => lfdim(4)
+ integer, pointer :: Nvpext => lfdim(5)
+ integer, pointer :: Nvpbrd => lfdim(6)
+ integer, pointer :: Nvpiso => lfdim(7)
+ integer, pointer :: Nvpexp => lfdim(8)
+ integer, pointer :: Nvpdet => lfdim(9)
+ integer, pointer :: Nvpmsc => lfdim(10)
+ integer, pointer :: Nvppmc => lfdim(11)
+ integer, pointer :: Nvporr => lfdim(12)
+ integer, pointer :: Nvprpi => lfdim(13)
+ integer, pointer :: Nvpudr => lfdim(14)
+ integer, pointer :: Nvpnbk => lfdim(15)
+ integer, pointer :: Nvpbgf => lfdim(16)
+ integer, pointer :: Nvpdtp => lfdim(17)
+ ! indexer on lfdim covers up to 17 (next should be 18)
! old group 2
- integer, pointer :: Nfpall => lf(18)
- integer, pointer :: Nfprmt => lf(19)
- integer, pointer :: Nfpres => lf(20)
- integer, pointer :: Nfprad => lf(21)
- integer, pointer :: Nfpext => lf(22)
- integer, pointer :: Nfpbrd => lf(23)
- integer, pointer :: Nfpiso => lf(24)
- integer, pointer :: Nfpexp => lf(25)
- integer, pointer :: Nfpdet => lf(26)
- integer, pointer :: Nfpmsc => lf(27)
- integer, pointer :: Nfppmc => lf(28)
- integer, pointer :: Nfporr => lf(29)
- integer, pointer :: Nfprpi => lf(30)
- integer, pointer :: Nfpudr => lf(31)
- integer, pointer :: Nfpnbk => lf(32)
- integer, pointer :: Nfpbgf => lf(33)
- integer, pointer :: Nfpdtp => lf(34)
- ! indexer on lf covers up to 34 (next should be 35
+ integer, pointer :: Nfpall => lfdim(18)
+ integer, pointer :: Nfprmt => lfdim(19)
+ integer, pointer :: Nfpres => lfdim(20)
+ integer, pointer :: Nfprad => lfdim(21)
+ integer, pointer :: Nfpext => lfdim(22)
+ integer, pointer :: Nfpbrd => lfdim(23)
+ integer, pointer :: Nfpiso => lfdim(24)
+ integer, pointer :: Nfpexp => lfdim(25)
+ integer, pointer :: Nfpdet => lfdim(26)
+ integer, pointer :: Nfpmsc => lfdim(27)
+ integer, pointer :: Nfppmc => lfdim(28)
+ integer, pointer :: Nfporr => lfdim(29)
+ integer, pointer :: Nfprpi => lfdim(30)
+ integer, pointer :: Nfpudr => lfdim(31)
+ integer, pointer :: Nfpnbk => lfdim(32)
+ integer, pointer :: Nfpbgf => lfdim(33)
+ integer, pointer :: Nfpdtp => lfdim(34)
+ ! indexer on lfdim covers up to 34 (next should be 35
! old group 3
- integer, pointer :: Numres => lf(35)
- integer, pointer :: Numrad => lf(36)
- integer, pointer :: Numext => lf(37)
- integer, pointer :: Numbrd => lf(38)
- integer, pointer :: Numiso => lf(39)
- integer, pointer :: Numdet => lf(40)
- integer, pointer :: Nummsc => lf(41)
- integer, pointer :: Numpmc => lf(42)
- integer, pointer :: Numorr => lf(43)
- integer, pointer :: Numrpi => lf(44)
- integer, pointer :: Numudr => lf(45)
- integer, pointer :: Numnbk => lf(46)
- integer, pointer :: Numbgf => lf(47)
- integer, pointer :: Numdtp => lf(48)
- integer, pointer :: Numusd => lf(49)
- integer, pointer :: Numbag => lf(50)
- ! indexer on lf covers up to 50 (next should be 51
+ integer, pointer :: Numres => lfdim(35)
+ integer, pointer :: Numrad => lfdim(36)
+ integer, pointer :: Numext => lfdim(37)
+ integer, pointer :: Numbrd => lfdim(38)
+ integer, pointer :: Numiso => lfdim(39)
+ integer, pointer :: Numdet => lfdim(40)
+ integer, pointer :: Nummsc => lfdim(41)
+ integer, pointer :: Numpmc => lfdim(42)
+ integer, pointer :: Numorr => lfdim(43)
+ integer, pointer :: Numrpi => lfdim(44)
+ integer, pointer :: Numudr => lfdim(45)
+ integer, pointer :: Numnbk => lfdim(46)
+ integer, pointer :: Numbgf => lfdim(47)
+ integer, pointer :: Numdtp => lfdim(48)
+ integer, pointer :: Numusd => lfdim(49)
+ integer, pointer :: Numbag => lfdim(50)
+ ! indexer on lfdim covers up to 50 (next should be 51
! old group 4
- integer, pointer :: Nvpthe => lf(51)
- integer, pointer :: Napthe => lf(52)
- integer, pointer :: Napres => lf(53)
- integer, pointer :: Nvadif => lf(54)
- integer, pointer :: Nppall => lf(55)
- integer, pointer :: Numpup => lf(56)
- integer, pointer :: Npar => lf(57)
- ! indexer on lf covers up to 57 (next should be 58
+ integer, pointer :: Nvpthe => lfdim(51)
+ ! usually the same as Nfpres (number of varied resonance parameters
+ ! except if gamma width data are fitted together
+ ! in that case Napres counts the each of the combined gamma width
+ ! and Nfpres counts none of them
+ logical::needResDerivs
+ integer, pointer :: Nppall => lfdim(55)
+ integer, pointer :: Npar => lfdim(57)
+ ! indexer on lfdim covers up to 57 (next should be 58
! old group 5
- integer, pointer :: Kipdet => lf(58)
- integer, pointer :: Kipmsc => lf(59)
- integer, pointer :: Kippmc => lf(60)
- integer, pointer :: Kiporr => lf(61)
- integer, pointer :: Kiprpi => lf(62)
- integer, pointer :: Kipudr => lf(63)
- integer, pointer :: Kipnbk => lf(64)
- integer, pointer :: Kipbgf => lf(65)
- integer, pointer :: Kipdtp => lf(66)
- ! indexer on lf covers up to 66 (next should be 67
+ integer, pointer :: Kipdet => lfdim(58)
+ integer, pointer :: Kipmsc => lfdim(59)
+ integer, pointer :: Kippmc => lfdim(60)
+ integer, pointer :: Kiporr => lfdim(61)
+ integer, pointer :: Kiprpi => lfdim(62)
+ integer, pointer :: Kipudr => lfdim(63)
+ integer, pointer :: Kipnbk => lfdim(64)
+ integer, pointer :: Kipbgf => lfdim(65)
+ integer, pointer :: Kipdtp => lfdim(66)
+ ! indexer on lfdim covers up to 66 (next should be 67
! old group 6
- integer, pointer :: Nnniso => lf(67)
- integer, pointer :: Nnnsig => lf(68)
- integer,pointer :: Nnnsii => lf(69)
- integer,pointer :: Niniso => lf(70)
+ integer, pointer :: Nnniso => lfdim(67)
+ integer, pointer :: Nnnsig => lfdim(68)
+ integer,pointer :: Nnnsii => lfdim(69)
+ integer,pointer :: Niniso => lfdim(70)
- ! indexer on lf covers up to 70 (next should be 71
+ ! indexer on lfdim covers up to 70 (next should be 71
! restart group counts
! old group 1
- integer,pointer :: Ngroup => lf(71)
- integer,pointer :: Ntotc => lf(72)
- integer,pointer :: Ntotc2 => lf(73)
- integer,pointer :: Ntriag => lf(74)
- integer,pointer :: Nres => lf(75)
- integer,pointer :: Nrext => lf(76)
- integer,pointer :: Nlfsiz => lf(77)
- integer,pointer :: Kjjjjj => lf(78)
- integer,pointer :: K2pls1 => lf(79)
- integer,pointer :: Ngtvv => lf(80)
- integer,pointer :: Nxtra => lf(81)
- integer,pointer :: Jwwwww => lf(82)
- integer,pointer :: Nntype => lf(83)
- integer,pointer :: Jcros => lf(84)
- integer,pointer :: Jtrans => lf(85)
+ integer,pointer :: Ngroup => lfdim(71)
+ integer,pointer :: Ntotc => lfdim(72)
+ integer,pointer :: Ntotc2 => lfdim(73)
+ integer,pointer :: Ntriag => lfdim(74)
+ integer,pointer :: Nres => lfdim(75)
+ integer,pointer :: Nrext => lfdim(76)
+ integer,pointer :: Nlfdimsiz => lfdim(77)
+ integer,pointer :: Kjjjjj => lfdim(78)
+ integer,pointer :: K2pls1 => lfdim(79)
+ integer,pointer :: Ngtvv => lfdim(80)
+ integer,pointer :: Nxtra => lfdim(81)
+ integer,pointer :: Jwwwww => lfdim(82)
+ integer,pointer :: Nntype => lfdim(83)
+ integer,pointer :: Jcros => lfdim(84)
+ integer,pointer :: Jtrans => lfdim(85)
- ! indexer on lf covers up to 85 (next should be 86
+ ! indexer on lfdim covers up to 85 (next should be 86
! old group 2
- integer,pointer :: Napthx => lf(86)
- integer,pointer :: Nsiggb => lf(87)
- integer,pointer :: Nmdets => lf(88)
- integer,pointer :: Kvpbrd => lf(89)
- integer,pointer :: Iu2627 => lf(90)
- integer,pointer :: Iu16 => lf(91)
- integer,pointer :: Iu22 => lf(92)
- integer,pointer :: Iu32 => lf(93)
- integer,pointer :: Iu62 => lf(94)
- integer,pointer :: Iu64 => lf(95)
- integer,pointer :: Numcro => lf(96)
- integer,pointer :: Numder => lf(97)
- integer,pointer :: Nsgbin => lf(98)
- integer,pointer :: Nsgbou => lf(99)
- integer,pointer :: Ngbinx => lf(100)
+ integer,pointer :: Napthx => lfdim(86)
+ integer,pointer :: Nsiggb => lfdim(87)
+ integer,pointer :: Nmdets => lfdim(88)
+ integer,pointer :: Kvpbrd => lfdim(89)
+ integer,pointer :: Iu2627 => lfdim(90)
+ integer,pointer :: Iu16 => lfdim(91)
+ integer,pointer :: Iu22 => lfdim(92)
+ integer,pointer :: Iu32 => lfdim(93)
+ integer,pointer :: Iu62 => lfdim(94)
+ integer,pointer :: Iu64 => lfdim(95)
+ integer,pointer :: Numcro => lfdim(96)
+ integer,pointer :: Numder => lfdim(97)
+ integer,pointer :: Nsgbin => lfdim(98)
+ integer,pointer :: Nsgbou => lfdim(99)
+ integer,pointer :: Ngbinx => lfdim(100)
- ! indexer on lf covers up to 100 (next should be 101
+ ! indexer on lfdim covers up to 100 (next should be 101
! old group 3
- integer,pointer :: Ngbout => lf(101)
- integer,pointer :: Ncrsss => lf(102)
- integer,pointer :: Lllmax => lf(103)
- integer,pointer :: Nangle => lf(104)
- integer,pointer :: Kangmn => lf(105)
- integer,pointer :: Nxxres => lf(106)
- integer,pointer :: Nyyres => lf(107)
- integer,pointer :: Ntheta => lf(108)
- integer,pointer :: Ngausz => lf(109)
- integer,pointer :: Ngaus => lf(110)
- integer,pointer :: Nzzz => lf(111)
- integer,pointer :: Nxtptw => lf(112)
- integer,pointer :: Kpolar => lf(113)
- integer,pointer :: Ndatd => lf(114)
- integer,pointer :: Ndats => lf(115)
+ integer,pointer :: Ngbout => lfdim(101)
+ integer,pointer :: Ncrsss => lfdim(102)
+ integer,pointer :: Lllmax => lfdim(103)
+ integer,pointer :: Nangle => lfdim(104)
+ integer,pointer :: Kangmn => lfdim(105)
+ integer,pointer :: Ntheta => lfdim(108)
+ integer,pointer :: Ngausz => lfdim(109)
+ integer,pointer :: Ngaus => lfdim(110)
+ integer,pointer :: Nzzz => lfdim(111)
+ integer,pointer :: Nxtptw => lfdim(112)
+ integer,pointer :: Kpolar => lfdim(113)
+ integer,pointer :: Ndatd => lfdim(114)
+ integer,pointer :: Ndats => lfdim(115)
- ! indexer on lf covers up to 115 (next should be 116
+ ! indexer on lfdim covers up to 115 (next should be 116
! old group 4
- integer,pointer :: Ndatr => lf(116)
- integer,pointer :: Ndatx => lf(117)
- integer,pointer :: Ndatxx => lf(118)
- integer,pointer :: Ndatrx => lf(119)
- integer,pointer :: Ndatsx => lf(120)
- integer,pointer :: Ndatdx => lf(121)
- integer,pointer :: Ixxchn => lf(124)
- integer,pointer :: Ktheta => lf(125)
- integer,pointer :: Kvprrt => lf(126)
- integer,pointer :: Kvprrf => lf(127)
- integer,pointer :: Kshift => lf(128)
- integer,pointer :: Klabcm => lf(129)
- integer,pointer :: Ifdif => lf(130)
+ integer,pointer :: Ndatr => lfdim(116)
+ integer,pointer :: Ndatx => lfdim(117)
+ integer,pointer :: Ndatxx => lfdim(118)
+ integer,pointer :: Ndatrx => lfdim(119)
+ integer,pointer :: Ndatsx => lfdim(120)
+ integer,pointer :: Ndatdx => lfdim(121)
+ integer,pointer :: Ixxchn => lfdim(124)
+ integer,pointer :: Ktheta => lfdim(125)
+ integer,pointer :: Kvprrt => lfdim(126)
+ integer,pointer :: Kvprrf => lfdim(127)
+ integer,pointer :: Kshift => lfdim(128)
+ integer,pointer :: Klabcm => lfdim(129)
+ integer,pointer :: Ifdif => lfdim(130)
- ! indexer on LF covers up to 130 (next should be 131
+ ! indexer on lfdim covers up to 130 (next should be 131
! old group 5
- integer,pointer :: Ncrssx => lf(131)
- integer,pointer :: Kcarea => lf(132)
- integer,pointer :: Kreads => lf(133)
- integer,pointer :: Lithne => lf(134)
- integer,pointer :: Kwatta => lf(135)
- integer,pointer :: Nogeom => lf(136)
- integer,pointer :: Kenbbb => lf(137)
- integer,pointer :: Mres => lf(138)
- integer,pointer :: Mxwrec => lf(139)
- integer,pointer :: Jtheta => lf(140)
- integer,pointer :: Kaddcr => lf(141)
- integer,pointer :: Nrfil3 => lf(142)
- integer,pointer :: Npfil3 => lf(143)
- integer,pointer :: Nnnrpi => lf(144)
- integer,pointer :: Krefit => lf(145)
+ integer,pointer :: Ncrssx => lfdim(131)
+ integer,pointer :: Kcarea => lfdim(132)
+ integer,pointer :: Kreads => lfdim(133)
+ integer,pointer :: Lithne => lfdim(134)
+ integer,pointer :: Kwatta => lfdim(135)
+ integer,pointer :: Nogeom => lfdim(136)
+ integer,pointer :: Kenbbb => lfdim(137)
+ integer,pointer :: Mres => lfdim(138)
+ integer,pointer :: Mxwrec => lfdim(139)
+ integer,pointer :: Jtheta => lfdim(140)
+ integer,pointer :: Kaddcr => lfdim(141)
+ integer,pointer :: Nrfil3 => lfdim(142)
+ integer,pointer :: Npfil3 => lfdim(143)
+ integer,pointer :: Nnnrpi => lfdim(144)
+ integer,pointer :: Krefit => lfdim(145)
- ! indexer on LF covers up to 145 (next should be 146
+ ! indexer on lfdim covers up to 145 (next should be 146
! old group 6
- integer,pointer :: Numexc => lf(146)
- integer,pointer :: Numelv => lf(147)
- integer,pointer :: Numjjv => lf(148)
- integer,pointer :: Kkkiso => lf(149)
- integer,pointer :: Kiniso => lf(150)
- integer,pointer :: Kaaaac => lf(151)
- integer,pointer :: Kaaaad => lf(152)
- integer,pointer :: Iterp1 => lf(153)
- integer,pointer :: J2mn => lf(154)
- integer,pointer :: J2mx => lf(155)
- integer,pointer :: Kompar => lf(156)
- integer,pointer :: Kkkmax => lf(157)
- integer,pointer :: Kascii => lf(158)
- integer,pointer :: Ktruet => lf(159)
- integer,pointer :: Kywywy => lf(160)
+ integer,pointer :: Numexc => lfdim(146)
+ integer,pointer :: Numelv => lfdim(147)
+ integer,pointer :: Numjjv => lfdim(148)
+ integer,pointer :: Kkkiso => lfdim(149)
+ integer,pointer :: Kiniso => lfdim(150)
+ integer,pointer :: Kaaaac => lfdim(151)
+ integer,pointer :: Kaaaad => lfdim(152)
+ integer,pointer :: Iterp1 => lfdim(153)
+ integer,pointer :: J2mn => lfdim(154)
+ integer,pointer :: J2mx => lfdim(155)
+ integer,pointer :: Kompar => lfdim(156)
+ integer,pointer :: Kkkmax => lfdim(157)
+ integer,pointer :: Kascii => lfdim(158)
+ integer,pointer :: Ktruet => lfdim(159)
+ integer,pointer :: Kywywy => lfdim(160)
- ! indexer on LF covers up to 160 (next should be 161
+ ! indexer on lfdim covers up to 160 (next should be 161
! old group 7
- integer,pointer :: Kwywyw => lf(161)
- integer,pointer :: Kdropp => lf(162)
- integer,pointer :: Kdtset => lf(163)
- integer,pointer :: Kntmax => lf(164)
- integer,pointer :: K33fil => lf(165)
- integer,pointer :: Matnum => lf(166)
- integer,pointer :: Kkkkza => lf(167)
- integer,pointer :: Knclab => lf(168)
- integer,pointer :: Kcolab => lf(169)
- integer,pointer :: Ndasig => lf(170)
- integer,pointer :: Ndbsig => lf(171)
- integer,pointer :: Ndaxxx => lf(172)
- integer,pointer :: Ndbxxx => lf(173)
- integer,pointer :: K2reso => lf(174)
- integer,pointer :: Mmmrpi => lf(175)
+ integer,pointer :: Kwywyw => lfdim(161)
+ integer,pointer :: Kdropp => lfdim(162)
+ integer,pointer :: Kdtset => lfdim(163)
+ integer,pointer :: Kntmax => lfdim(164)
+ integer,pointer :: K33fil => lfdim(165)
+ integer,pointer :: Matnum => lfdim(166)
+ integer,pointer :: Kkkkza => lfdim(167)
+ integer,pointer :: Knclab => lfdim(168)
+ integer,pointer :: Kcolab => lfdim(169)
+ integer,pointer :: Ndasig => lfdim(170)
+ integer,pointer :: Ndbsig => lfdim(171)
+ integer,pointer :: Ndaxxx => lfdim(172)
+ integer,pointer :: Ndbxxx => lfdim(173)
+ integer,pointer :: K2reso => lfdim(174)
+ integer,pointer :: Mmmrpi => lfdim(175)
- ! indexer on LF covers up to 175 (next should be 176
+ ! indexer on lfdim covers up to 175 (next should be 176
! old group 8
- integer,pointer :: Kntchn => lf(176)
- integer,pointer :: Kkkrsl => lf(177)
- integer,pointer :: Kkkdex => lf(178)
- integer,pointer :: K00001 => lf(179)
- integer,pointer :: Kssmpr => lf(180)
- integer,pointer :: Nxtptv => lf(181)
- integer,pointer :: Legndr => lf(182)
- integer,pointer :: Ndexxx => lf(183)
- integer,pointer :: Nnnudr => lf(184)
- integer,pointer :: Mmmudr => lf(185)
- integer,pointer :: Nudwhi => lf(186)
- integer,pointer :: Nudeng => lf(187)
- integer,pointer :: Nudtim => lf(188)
- integer,pointer :: Nudmax => lf(189)
- integer,pointer :: Kkxlmn => lf(190)
+ integer,pointer :: Kntchn => lfdim(176)
+ integer,pointer :: Kkkrsl => lfdim(177)
+ integer,pointer :: Kkkdex => lfdim(178)
+ integer,pointer :: K00001 => lfdim(179)
+ integer,pointer :: Kssmpr => lfdim(180)
+ integer,pointer :: Nxtptv => lfdim(181)
+ integer,pointer :: Legndr => lfdim(182)
+ integer,pointer :: Ndexxx => lfdim(183)
+ integer,pointer :: Nnnudr => lfdim(184)
+ integer,pointer :: Mmmudr => lfdim(185)
+ integer,pointer :: Nudwhi => lfdim(186)
+ integer,pointer :: Nudeng => lfdim(187)
+ integer,pointer :: Nudtim => lfdim(188)
+ integer,pointer :: Nudmax => lfdim(189)
+ integer,pointer :: Kkxlmn => lfdim(190)
- ! indexer on LF covers up to 190 (next should be 191
+ ! indexer on lfdim covers up to 190 (next should be 191
! old group 9
- integer,pointer :: Numurr => lf(191)
- integer,pointer :: Kdtold => lf(192)
- integer,pointer :: Ndfdat => lf(193)
- integer,pointer :: Matdat => lf(194)
- integer,pointer :: Nucdrc => lf(195)
- integer,pointer :: Numdrc => lf(196)
- integer,pointer :: Montec => lf(197)
- integer,pointer :: Medrpi => lf(198)
- integer,pointer :: Lother => lf(199)
- integer,pointer :: Iq_Val => lf(200)
- integer,pointer :: Iq_Iso => lf(201)
- integer,pointer :: Kipiso => lf(202)
- integer,pointer :: Kipbrd => lf(203)
- integer,pointer :: Iwhrpi => lf(204)
- integer,pointer :: Nbinpd => lf(205)
+ integer,pointer :: Numurr => lfdim(191)
+ integer,pointer :: Kdtold => lfdim(192)
+ integer,pointer :: Ndfdat => lfdim(193)
+ integer,pointer :: Matdat => lfdim(194)
+ integer,pointer :: Nucdrc => lfdim(195)
+ integer,pointer :: Numdrc => lfdim(196)
+ integer,pointer :: Montec => lfdim(197)
+ integer,pointer :: Medrpi => lfdim(198)
+ integer,pointer :: Lother => lfdim(199)
+ integer,pointer :: Iq_Val => lfdim(200)
+ integer,pointer :: Iq_Iso => lfdim(201)
+ integer,pointer :: Kipiso => lfdim(202)
+ integer,pointer :: Kipbrd => lfdim(203)
+ integer,pointer :: Iwhrpi => lfdim(204)
+ integer,pointer :: Nbinpd => lfdim(205)
- ! indexer on LF covers up to 205 (next should be 206)
+ ! indexer on lfdim covers up to 205 (next should be 206)
! old group a
- integer,pointer :: Kuncer => lf(206)
- integer,pointer :: Ifrel => lf(207)
- integer,pointer :: Ntepnt => lf(208)
- integer,pointer :: Ntefil => lf(209)
- integer,pointer :: Kaptur => lf(210)
- integer,pointer :: Nsqfb => lf(211)
- integer,pointer :: Nzzzz => lf(212)
+ integer,pointer :: Kuncer => lfdim(206)
+ integer,pointer :: Ifrel => lfdim(207)
+ integer,pointer :: Ntepnt => lfdim(208)
+ integer,pointer :: Ntefil => lfdim(209)
+ integer,pointer :: Kaptur => lfdim(210)
+ integer,pointer :: Nsqfb => lfdim(211)
+ integer,pointer :: Nzzzz => lfdim(212)
!
! *** THESE TWO SHOULD BE MOVED UP WITH OTHER KIPs EVENTUALLY
! * Kipiso integer :: Kipbrd
diff --git a/sammy/src/blk/Fixedr_common.f90 b/sammy/src/blk/Fixedr_common.f90
index afcc39efb54614eb9524b6a45fc29f32028e9938..f0cbcf6dbbe5b3e1bccdb2ccd8689c74cd49038d 100644
--- a/sammy/src/blk/Fixedr_common.f90
+++ b/sammy/src/blk/Fixedr_common.f90
@@ -74,8 +74,6 @@ module fixedr_m
double precision, pointer :: Dosind => Ff(57)
double precision, pointer :: Sitemp => Ff(58)
double precision, pointer :: Sithck => Ff(59)
- double precision, pointer :: Concro => Ff(60)
- double precision, pointer :: Contot => Ff(61)
double precision, pointer :: Effcap => Ff(62)
! old group 9
diff --git a/sammy/src/blk/Ifwrit_common.f90 b/sammy/src/blk/Ifwrit_common.f90
index b1ad3205631cdff1dd807a5481749d1e592baa2f..73522e0ec49bcd26e7ceecac044a47dbc24e2840 100644
--- a/sammy/src/blk/Ifwrit_common.f90
+++ b/sammy/src/blk/Ifwrit_common.f90
@@ -137,8 +137,6 @@ module ifwrit_m
integer,pointer :: Kresol => Lwrit(103)
integer,pointer :: Nresol => Lwrit(104)
integer,pointer :: Krpitc => Lwrit(105)
- integer,pointer :: Kconcr => Lwrit(106)
- integer,pointer :: Kcontr => Lwrit(107)
integer,pointer :: Kssdbl => Lwrit(108)
integer,pointer :: Knocor => Lwrit(109)
integer,pointer :: Kefcap => Lwrit(110)
diff --git a/sammy/src/blk/Templc_common.f90 b/sammy/src/blk/Templc_common.f90
index 6fa20557b1b88e95132d9b4d0e7a1c976cf211dd..915f01db19993af1c118cee9083c5215e817ca9d 100644
--- a/sammy/src/blk/Templc_common.f90
+++ b/sammy/src/blk/Templc_common.f90
@@ -7,12 +7,11 @@ module templc_common_m
!
IMPLICIT NONE
- integer,allocatable,dimension(:)::I_Inprdr
integer,allocatable,dimension(:)::I_Inpxdr
- real(kind=8),allocatable,dimension(:)::A_Ibr
- real(kind=8),allocatable,dimension(:)::A_Ibi
- real(kind=8),allocatable,dimension(:)::A_Ipr
- real(kind=8),allocatable,dimension(:)::A_Ipi
+ real(kind=8),allocatable,dimension(:,:)::A_Ibr
+ real(kind=8),allocatable,dimension(:,:)::A_Ibi
+ real(kind=8),allocatable,dimension(:,:)::A_Ipr
+ real(kind=8),allocatable,dimension(:,:)::A_Ipi
real(kind=8),allocatable,dimension(:)::A_Ibga
real(kind=8),allocatable,dimension(:)::A_Ipgar
real(kind=8),allocatable,dimension(:)::A_Ipgai
@@ -80,9 +79,6 @@ module templc_common_m
real(kind=8),allocatable,dimension(:)::A_Iddtlz
! cro and mlb
- real(kind=8),allocatable,dimension(:)::A_Ipaone
- real(kind=8),allocatable,dimension(:)::A_Ipatwo
- real(kind=8),allocatable,dimension(:)::A_Ipathr
real(kind=8),allocatable,dimension(:)::A_Ics
real(kind=8),allocatable,dimension(:)::A_Isi
real(kind=8),allocatable,dimension(:)::A_Iaaone, A_Iaatwo
diff --git a/sammy/src/blk/Varyr_common.f90 b/sammy/src/blk/Varyr_common.f90
index e5ac6dce20306fe2806781e688eb72348eca9cac..0f2f3b058affe8ec50347ba5dcaec1765e8744f8 100644
--- a/sammy/src/blk/Varyr_common.f90
+++ b/sammy/src/blk/Varyr_common.f90
@@ -14,6 +14,7 @@ module varyr_common_m
integer, save :: Kstart
integer, save :: Jstart
integer, save :: Npr
+ logical::resDeriv
integer, save :: Npx
integer, save :: Nnnn
integer, save :: Nn
diff --git a/sammy/src/blk/ifsubs_common.f90 b/sammy/src/blk/ifsubs_common.f90
index 5c7fd3124237b01767c732dfe5a155e43d1326bd..8554cff7c3af1d805423480c9068613e45d94570 100644
--- a/sammy/src/blk/ifsubs_common.f90
+++ b/sammy/src/blk/ifsubs_common.f90
@@ -5,12 +5,10 @@ module ifsubs_common
implicit none
- integer(4):: Ifres
- integer(4):: Ifcap
integer(4):: Ifzzz
integer(4):: Ifext
integer(4):: Ifrad
integer(4):: Ifiso
integer(4):: Ifradt
-end module ifsubs_common
\ No newline at end of file
+end module ifsubs_common
diff --git a/sammy/src/cro/mcro0.f b/sammy/src/cro/mcro0.f
index 98afad506216f0e71c9324752e02a739787c6a0a..e2d9beb63583fd918432cba354a994c589c6662c 100644
--- a/sammy/src/cro/mcro0.f
+++ b/sammy/src/cro/mcro0.f
@@ -32,7 +32,7 @@ C
Segmen(3) = 'O'
Nowwww = 0
C
- IF (Numpup.GT.0) THEN
+ IF (covData%getPupedParam().GT.0) THEN
WRITE (6,10100)
10100 FORMAT ('SAMCRO coding does not include options for', /,
* 'PUPs (Propagated-Uncertainty Parameters, Flag=3).', /,
@@ -76,20 +76,15 @@ C
C *** one ***
CALL Set_Kws_Xct
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- call allocate_integer_data(I_Inprdr, Ngroup)
+
call allocate_integer_data(I_Inpxdr, Ngroup)
Krext = Nrext
IF (Nrext.EQ.0) Krext = 1
- IF (Ksolve.NE.2) CALL Ppar(I_Iflext ,
- * I_Iiuif , I_Inprdr, I_Inpxdr, Krext)
-C *** Sbroutine Ppar_Cro Sets Nprdr and Npxdr
+ IF (Ksolve.NE.2) CALL Ppar(I_Iflext, I_Inpxdr, Krext)
+C *** Sbroutine Ppar Sets Npxdr
C
C *** two ***
N = N2
- call allocate_real_data(A_Ibr, N)
- call allocate_real_data(A_Ibi, N)
- call allocate_real_data(A_Ipr, N)
- call allocate_real_data(A_Ipi, N)
C
call allocate_real_data(A_Ixx, Nres)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - <
@@ -108,9 +103,9 @@ C *** Sbroutine Fixx sets Xx = energy shift
C - - - - - - - - - - - - - - - - - - - - - - - - - - - >
C
C
-c Fals is passed to babb since it is used to set parameters NOT for numerical differentiation
- IF (Ksolve.NE.2 .AND. Napres.NE.0) CALL Babb(
- * A_Ipolar , I_Iflpol , I_Iiuif , A_Ibr , A_Ibi , A_Ixx ,.false.)
+c Fals is passed to babb since it is used to set parameters NOT for numerical differentiation
+ IF (Ksolve.NE.2 .AND. needResDerivs) CALL Babb(
+ * A_Ipolar , I_Iflpol , A_Ibr , A_Ibi , A_Ixx ,.false.)
C *** Sbroutine Babb_cro generates energy-independent portion of
C *** partial derivatives
C
@@ -132,7 +127,6 @@ C *** five ***
call allocate_real_data(A_Ialphr, Nres)
call allocate_real_data(A_Ialphi, Nres)
call allocate_integer_data(I_Inot, Nres)
- call allocate_integer_data(I_Inotu, N4)
C
C - - - - - - - - - - - - - - - - <
C *** six ***
@@ -186,7 +180,6 @@ C *** eight ***
* I_Inbt , I_Iint)
C *** Sbroutine Work_Cro generates theory and derivatives
deallocate(A_Idum)
- deallocate(I_Inprdr)
deallocate(A_Ics)
deallocate(A_Isi)
deallocate(A_Idphi)
@@ -241,12 +234,10 @@ C
IF (Kshift.NE.0) Na = Nres
IF (Kshift.NE.0) Nb = Mxany*Mxany*Ngroup
NN = (Ntotc*(Ntotc+1))/2
- Nyyres = Napres
- IF (Krdmsc.NE.0) Nyyres = Napres + Nres
IF (Ksolve.NE.2) THEN
- N2 = NN*Nyyres
+ N2 = NN*Nfpres
N3 = Ngbout
- N4 = Nyyres
+ N4 = Nfpres
ELSE
N2 = 1
N3 = 1
diff --git a/sammy/src/cro/mcro1.f b/sammy/src/cro/mcro1.f
index c1648658fdd822bd563eb5ab7673a8897cde791b..611a6fcaa7f6e8262fe2cd9f386ccd6d7f32afe2 100644
--- a/sammy/src/cro/mcro1.f
+++ b/sammy/src/cro/mcro1.f
@@ -139,10 +139,6 @@ C ********* if there is normalization or background, include it
* Nnnsig)
END IF
C
-C ********* if adding a constant cross section, do so now
-C IF (Concro.NE.Zero) call Addcon (Sigxxx, Dbsigx, Iflmsc,
-C * Nnnsig)
-C
C ********* Write results onto theory if there is no broadening etc
IF (Jjjdop.NE.1) THEN
Kkkkkk = Kkkkkk + 1
diff --git a/sammy/src/cro/mcro2.f b/sammy/src/cro/mcro2.f
index 40550312a5456bc47848147ad0aa953a857f1793..af39ce09131824517fda13bde98b952b3d52691e 100644
--- a/sammy/src/cro/mcro2.f
+++ b/sammy/src/cro/mcro2.f
@@ -20,12 +20,12 @@ C
DIMENSION Pieces(*)
C
CALL Abpart_Cro (
- * A_Ialphr , A_Ialphi , A_Ibr , A_Ibi , A_Ipr ,
- * A_Ipi , A_Idifen , A_Ixden ,
- * I_Iiuif , A_Idifma , I_Inot , I_Inotu , A_Ixx )
+ * A_Ialphr , A_Ialphi ,
+ * A_Idifen , A_Ixden ,
+ * A_Idifma , I_Inot , I_Inotu , A_Ixx )
C
CALL Parsh (
- * I_Inprdr , I_Inpxdr , A_Izke , A_Izkte ,
+ * I_Inpxdr , A_Izke , A_Izkte ,
* A_Izkfe , I_Ifzke , I_Ifzkte , I_Ifzkfe , Ipoten, Pieces,
* A_Isigxx , A_Idasig , A_Idbsig , I_Iisopa )
C
diff --git a/sammy/src/cro/mcro2a.f b/sammy/src/cro/mcro2a.f
index 080f33335e90810afb916387962854a1b899c9a0..8738969890532b614ad0c354aa2a0cf3fb6172e3 100644
--- a/sammy/src/cro/mcro2a.f
+++ b/sammy/src/cro/mcro2a.f
@@ -3,7 +3,7 @@ C
C --------------------------------------------------------------
C
SUBROUTINE Abpart_Cro (Alphar,
- * Alphai, Br, Bi, Pr, Pi, Difen, Xden, Iuif, Difmax,
+ * Alphai, Difen, Xden, Difmax,
* Not, Notu, Xx)
C
C *** PURPOSE -- GENERATE Upr AND Upi = ENERGY-DEPENDENT Pieces OF
@@ -18,22 +18,25 @@ C
use EndfData_common_m
use RMatResonanceParam_M
use templc_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ IMPLICIT None
C
type(SammyResonanceInfo)::resInfo
type(SammySpinGroupInfo)::spinInfo
type(RMatResonance)::resonance
- DIMENSION
- * Alphar(*),Alphai(*), Br(Ntriag,*), Bi(Ntriag,*),
- * Pr(Ntriag,*), Pi(Ntriag,*), Difen(*), Xden(*),
- * Iuif(*), Difmax(*), Not(*), Notu(*), Xx(*)
+ real(kind=8)::
+ * Alphar(*),Alphai(*),
+ * Difen(*), Xden(*),
+ * Difmax(*), Xx(*)
+ integer:: Not(*), Notu(*)
+ real(kind=8)::Zero, Two
+ real(kind=8)::Aa, G2, G3
+ integer::I, Igam, igr, Ij, Ipar, J, K, M, N2, N, Iflr
C
C DIMENSION
C * Alphar(Nres), Alphai(Nres),
-C * BR(Ntriag,nyyres), BI(Ntriag,nyyres), Pr(Ntriag,nyyres),
-C * PI(Ntriag,nyyres), Difen(Nres), Xden(Nres),
-C * Iuif(nxxres), Difmax(Nres), Not(Nres),
-C * Notu(napres), Xx(Nres)
+C * Difen(Nres), Xden(Nres),
+C * Difmax(Nres), Not(Nres),
+C * Xx(Nres)
C
DATA Zero /0.0d0/, Two /2.0d0/
C
@@ -68,63 +71,51 @@ C
C *** GENERATE Upr AND Upi = ENERGY-DEPENDENT PART OF
C *** PARTIAL DERIVATIVES
C
- Iiparx = 0
- Iipar = 0
- Ipar = 0
C
- IF (Ksolve.NE.2 .AND. Napres.NE.0) THEN
+ IF (Ksolve.NE.2 .AND. needResDerivs) THEN
C
C
-C Napres is the number of resonance paramaeters that are varied.
-C If the gamma width data for one or more spingroup are fitted together
-C the value for UPI and UPR is stored at index Napres + N, where
-C N is the index of the resonance. This ensures that all values are calculated for
-C all resonance in the group while using the correct parameter value.
-C Later in the routine the varied parameters are tallied, relaying on
-C Upr and/or UpI to be zero. This should happen with the lines
-C Upr(Iiparx) = Zero and Upi(Iiparx) = Zero. The count does not measure up,
-C as the gamma width is counted in Napres.
+C If gamma width for a spin group are fitted together,
+C this number includes all gamma widths for that spin group,
+C even so the derivative will be stored in the appropriate
+C place in the array of derivatives
C
- call allocate_real_data(Upr, Nyyres)
- call allocate_real_data(Upi, Nyyres)
+ Upr = 0.0d0
+ Upi = 0.0d0
+ Ipar = 0
DO N=1,resParData%getNumResonances()
call resParData%getResonanceInfo(resInfo, N)
igr = resInfo%getSpinGroupIndex()
if (.not.resInfo%getIncludeInCalc()) then
igr = -1 * igr
end if
- IF (resInfo%getEnergyFitOption().GE.0) THEN
-C "if (Igr.GE.0)" but "resInfo%getEnergyFitOption().LT.0" means
-C "Igr.LT.0" so it's OK
+ IF (resInfo%getIncludeInCalc()) THEN
call resparData%getSpinGroupInfo(spinInfo, Igr)
+ IF (.not.spinInfo%getIncludeInCalc()) cycle
N2 = spinInfo%getNumResPar()
DO M=1,N2
if (m.eq.1) then
- Ipar = resInfo%getEnergyFitOption()
+ Iflr = resInfo%getEnergyFitOption()
else
- Ipar = resInfo%getChannelFitOption(M-1)
- end if
- IF (Ipar.GT.0) THEN
- IF (M.EQ.2 .AND. Krdmsc.NE.0) Ipar = Nvpres + N
- IF (Iuif(Ipar).NE.1) THEN
- IF (M.NE.2 .OR. Krdmsc.EQ.0) Iipar = Iipar + 1
- Iiparx = Iipar
- IF (M.EQ.2 .AND. Krdmsc.NE.0) Iiparx = Napres +N
- Notu(Iiparx) = 1
- Upr(Iiparx) = Zero
- Upi(Iiparx) = Zero
- IF (dABS(Difen(N)).LE.Difmax(N)) THEN
- Notu(Iiparx) = 0
- Upr(Iiparx) = Alphar(N)
- Upi(Iiparx) = Alphai(N)
+ Iflr = resInfo%getChannelFitOption(M-1)
+ end if
+ IF (Iflr.GT.0) THEN
+ Ipar = Ipar + 1
+ IF (covData%contributes(Iflr)) THEN
+ if (Iflr.ne.abs(Notu(Ipar))) then
+ STOP 'Count of varied resonance mcro2a'
+ end if
+ IF (dABS(Difen(N)).LE.Difmax(N)) THEN
+ Upr(Ipar) = Alphar(N)
+ Upi(Ipar) = Alphai(N)
IF (M.LT.2) THEN
- Upi(Iiparx) = Upr(Iiparx)*Upi(Iiparx)
- Upr(Iiparx) = -Two*Upr(Iiparx)*Upr(Iiparx)
+ Upi(Ipar) = Upr(Ipar)*Upi(Ipar)
+ Upr(Ipar) = -Two*Upr(Ipar)*Upr(Ipar)
* + Xden(N)
ELSE IF (M.EQ.2) THEN
- Upr(Iiparx) = Upr(Iiparx)*Upi(Iiparx)
- Upi(Iiparx) = -Two*Upi(Iiparx)*Upi(Iiparx)
+ Upr(Ipar) = Upr(Ipar)*Upi(Ipar)
+ Upi(Ipar) = -Two*Upi(Ipar)*Upi(Ipar)
* + Xden(N)
ELSE
END IF
@@ -138,16 +129,20 @@ C
C
C *** MULTIPLY BY BR AND BI TO GIVE PARTIAL OF R WRT PARAMTERS
C
- CALL Zero_Array (Pr, Nyyres*Ntriag)
- CALL Zero_Array (Pi, Nyyres*Ntriag)
- DO K=1,Nyyres
+ A_Ipr = 0.0d0
+ A_Ipi = 0.0d0
+ DO K=1,Ipar
IF (Upr(K).NE.Zero .OR. Upi(K).NE.Zero) THEN
Ij = 0
DO I=1,Ntotc
DO J=1,I
Ij = Ij + 1
- IF (Br(Ij,K).NE.Zero) Pr(Ij,K) = Br(Ij,K)*Upr(K)
- IF (Bi(Ij,K).NE.Zero) PI(Ij,K) = Bi(Ij,K)*Upi(K)
+ IF (A_Ibr(Ij,K).NE.Zero) then
+ A_Ipr(Ij,K) = A_Ibr(Ij,K)*Upr(K)
+ END IF
+ IF (A_Ibi(Ij,K).NE.Zero) then
+ A_Ipi(Ij,K) = A_Ibi(Ij,K)*Upi(K)
+ END IF
END DO
END DO
END IF
@@ -161,7 +156,7 @@ C
C --------------------------------------------------------------
C
SUBROUTINE Parsh (
- * Nprdr, Npxdr, Zke, Zkte, Zkfe, If_Zke,
+ * Npxdr, Zke, Zkte, Zkfe, If_Zke,
* If_Zkte, If_Zkfe, Ipoten, Pieces, Sigxxx, Dasigx, Dbsigx,
* Isopar)
C
@@ -189,7 +184,7 @@ C
C
C
DIMENSION
- * Nprdr(*), Npxdr(*),
+ * Npxdr(*),
* Zke(Ntotc,*), Zkte(Ntotc,*), Zkfe(Ntotc,*), If_Zke(*),
* If_Zkte(Ntotc,*), If_Zkfe(Ntotc,*), Pieces(Ngroup),
* Sigxxx(*), Dasigx(*), Dbsigx(*), Isopar(*)
@@ -197,9 +192,10 @@ C
type(SammyResonanceInfo)::resInfo
type(SammySpinGroupInfo)::spinInfo
type(RMatResonance)::resonance
+ logical::ifcap
C
C DIMENSION
-C * Nprdr(Ngroup), npxdr(Ngroup),
+C * npxdr(Ngroup),
C * Zke(Ntotc,Ngroup), Zkte(Ntotc,Ngroup), zkfe(Ntotc,Ngroup),
C * If_Zke(Ngroup), If_Zkte(Ntotc,Ngroup), If_zkfe(Ntotc,Ngroup),
C * Pieces(Ngroup)
@@ -212,25 +208,19 @@ C
Nnf1 = 0
Nn2 = 0
Kstart = 0
- Jstart = Napres
+ Jstart = Nfpres
C *** DO LOOP OVER GROUPS (IE SPIN-PARITY GROUPS) -
C *** GOES TO END OF SUBROUTINE
C
C
- istart = 1
+ istart = 0
DO N=1,resParData%getNumSpinGroups()
- min = istart
- DO Ires = Min, resParData%getNumResonances()
- call resParData%getResonanceInfo(resInfo, ires)
- istart = ires
- igr = resInfo%getSpinGroupIndex()
- if( igr.ne.N) exit
- end do
-
call resParData%getSpinGroupInfo(spinInfo, N)
- IF (.not.spinInfo%getIncludeInCalc()) THEN
- IF (Ksolve.NE.2) Kstart = Kstart + Nprdr(N)
- ELSE
+ min = istart + 1
+ call getParamPerSpinGroup(istart, N, Npr, resDeriv,
+ * Kstart, ifcap)
+
+ IF (spinInfo%getIncludeInCalc()) THEN
IF (Numiso.GT.0) THEN
Iso = spinInfo%getIsotopeIndex()
VarAbn = resParData%getAbundanceByIsotope(Iso)
@@ -240,7 +230,6 @@ C
END IF
C
Nnnn = N
- IF (Ksolve.NE.2) Npr = Nprdr(N)
IF (Ksolve.NE.2) Npx = Npxdr(N)
Nnf1 = Nnf1 + Nn2
ntot = spinInfo%getNumChannels()
@@ -290,7 +279,7 @@ C *** TOTAL CROSS SECTIONS
nent = spinInfo%getNumEntryChannels()
next = spinInfo%getNumExitChannels()
IF (Kcros.EQ.1) CALL Total (Agoj, nent, Ntotnn,
- * A_Iprext , I_Iflext , A_Ipr , A_Ipi , A_Ics, A_Isi,
+ * A_Iprext , I_Iflext , A_Ics, A_Isi,
* A_Idphi , A_Iwr , A_Iwi , A_Ipwrr , A_Ipwri , A_Itr ,
* A_Iti , A_Iqr , A_Iqi , I_Inotu , Krext, Lrmat,
* min , N, Zke(1,N),
@@ -299,7 +288,7 @@ C *** TOTAL CROSS SECTIONS
C
C *** SCATTERING (ELASTIC) CROSS SECTION
IF (Kcros.EQ.2) CALL Elastc (Agoj, Nent, Ntotnn,
- * A_Iprext , I_Iflext , A_Ipr , A_Ipi , A_Ics,
+ * A_Iprext , I_Iflext , A_Ics,
* A_Isi, A_Idphi , A_Iwr , A_Iwi, A_Ipwrr , A_Ipwri ,
* A_Itr , A_Iti , A_Iqr , A_Iqi , I_Inotu, Krext, Lrmat,
* Min , N, Zke(1,N),
@@ -309,7 +298,7 @@ C
C *** REACTION (FISSION, INELASTIC SCATTERING, ETC.) CROSS SECTIONS
IF (Kcros.EQ.3 .OR. Kcros.EQ.5 .OR. Kcros.EQ.6) CALL Reactn
* ( Agoj, Nent, Next, Ntotnn, A_Iprext ,
- * I_Iflext , A_Ipr , A_Ipi , A_Iwr, A_Iwi, A_Ipwrr ,
+ * I_Iflext , A_Iwr, A_Iwi, A_Ipwrr ,
* A_Ipwri , A_Itr , A_Iti , A_Iqr , A_Iqi , I_Inotu,
* Krext, Lrmat, Min , N,
* Zke(1,N), If_Zke(N), If_Zkte(1,N), Sigxxx, Dasigx,
@@ -318,15 +307,15 @@ C
C *** CAPTURE CROSS SECTION
IF (Kcros.EQ.4 .OR. Kcros.EQ.5 .OR. Kcros.EQ.6) CALL Captur
* ( Agoj, Nent, Next, Ntotnn, A_Iprext ,
- * I_Iflext , A_Ipr , A_Ipi , A_Iwr, A_Iwi, A_Ipwrr ,
+ * I_Iflext , A_Iwr, A_Iwi, A_Ipwrr ,
* A_Ipwri , A_Itr , A_Iti , A_Iqr , A_Iqi, I_Inotu,
* Krext, Lrmat,Min, N,
* Zke(1,N), If_Zke(N), If_Zkte(1,N), Sigxxx, Dasigx,
* Dbsigx, Isopar, Iso)
C
- IF (Ksolve.NE.2) Kstart = Kstart + Npr
IF (Kpiece.EQ.1) Pieces(N) = Sigma
END IF
+ Kstart = Kstart + Npr
END DO
C
RETURN
diff --git a/sammy/src/cro/mcro4.f b/sammy/src/cro/mcro4.f
index dda61213c65092f5f9ee78469195a3a850eb0e97..0644a71b4670b9b500cd94e75e2babc32ca714d7 100644
--- a/sammy/src/cro/mcro4.f
+++ b/sammy/src/cro/mcro4.f
@@ -81,7 +81,7 @@ C
real(kind=8) :: AI, AR
integer :: I, Ii, Ij, IM, J, K, Kl, L, M, JM
C
- IF (Npr.NE.0 .OR. Npx.NE.0) THEN
+ IF (resDeriv .OR. Npx.NE.0) THEN
Kl = 0
DO K=1,Ntot
DO L=1,K
@@ -172,7 +172,7 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Total (Agoj, Nent, Ntot, Parext, Iflext, Pr, Ppi,
+ SUBROUTINE Total (Agoj, Nent, Ntot, Parext, Iflext,
* Cs, Si, Dphi, Wr, Wi, Pwrhor, Pwrhoi, TR, TI, Qr, Qi,
* Notu, Krext, Lrmat, Minres, igr, Zke, If_Zke,
* If_Zkte, If_Zkfe, Sigxxx, Dasigx, Dbsigx, Isopar, iso)
@@ -192,7 +192,7 @@ C
C
C
real(kind=8) :: Parext(Krext,Ntotc,*),
- * Pr(Ntriag,*), Ppi(Ntriag,*), Cs(*), Si(*), Dphi(*),
+ * Cs(*), Si(*), Dphi(*),
* Wr(*), Wi(*), Pwrhor(*), Pwrhoi(*), Tr(*), Ti(*), Qr(NN,*),
* Qi(NN,*), Zke(*)
integer :: Iflext(Krext,Ntotc,*),Notu(*),
@@ -204,8 +204,7 @@ C
integer :: Isopar(*)
C
C DIMENSION Parext(Nrext,Ntotc,Ngroup),
-C * Iflext(Nrext,Ntotc,Ngroup), Pr(Ntriag,Napres),
-C * Ppi(Ntriag,Napres), Notu(Napres),
+C * Iflext(Nrext,Ntotc,Ngroup),
C * Cs(Ntotc), Si(Ntotc), Dphi(Ntotc), Wr(NN), Wi(NN),
C * Pwrhor(NN), Pwrhoi(NN), Tr(NN), Ti(NN), Qr(NN,NN),
C * Qi(NN,NN), Zke(Ntotc), if_Zkte(Ntotc), if_zkfe(Ntotc)
@@ -219,7 +218,7 @@ C
C
Sum = Zero
Sumc = Zero
- Kiso = If_Zke - Nvadif
+ Kiso = If_Zke
Ij = 0
B = Two*Agoj*Pi100/Squ
DO I=1,Nent
@@ -227,7 +226,7 @@ C
A = 1.0D0/Zke(I)**2
Sumc = Sumc + A
Sum = Sum + ( Cs(I)*Wr(Ij) + Si(I)*Wi(Ij) )*A
- Ktru = If_Zkte(I) - Nvadif
+ Ktru = If_Zkte(I)
IF (Ktru.GT.0) THEN
if(ktru.le.ndasig) then
Dasigx(1,Ktru) = Dasigx(1,Ktru) - B*
@@ -237,7 +236,7 @@ C
stop 'Out of range in total in mcro4 for ktru'
end if
END IF
- Keff = If_Zkfe(I) - Nvadif
+ Keff = If_Zkfe(I)
IF (Keff.GT.0) THEN
if (keff.le.ndasig) then
Dasigx(1,Keff) = Dasigx(1,Keff) - Two*B*
@@ -273,7 +272,7 @@ C
Sigxxx(1) = Sigxxx(1) + A
C
IF (Ksolve.NE.2) THEN
- Kiso = If_Zke - Nvadif
+ Kiso = If_Zke
IF (Kiso.GT.0) THEN
if (kiso.le.ndasig) then
Dasigx(1,Kiso) = Dasigx(1,Kiso) + A/VarAbn
@@ -291,7 +290,7 @@ C
C
IF (Lrmat.EQ.1) RETURN
IF (Ksolve.EQ.2) RETURN
- IF (Npr.EQ.0 .AND. Npx.EQ.0) RETURN
+ IF (.not.resDeriv .AND. Npx.EQ.0) RETURN
C
CALL Zero_Array (Tr, Ntriag)
CALL Zero_Array (Ti, Ntriag)
@@ -315,8 +314,8 @@ C
END DO
END DO
C
- IF (Npr.NE.0 .OR. Krdmsc.NE.0) CALL Derres_Cro (Agoj, Ntot, Pr,
- * Ppi, Tr, Ti, Notu, Minres, igr, Zke, Dasigx, Dbsigx,
+ IF (resDeriv) CALL Derres_Cro (Agoj, Ntot,
+ * Tr, Ti, Notu, Minres, igr, Zke, Dasigx, Dbsigx,
* Isopar, Iso)
C
IF (Npx.NE.0) CALL Derext_Cro (Agoj, Ntot, Parext, Iflext, TR,
@@ -328,7 +327,7 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Elastc (Agoj, Nent, Ntot, Parext, Iflext, Pr, Ppi,
+ SUBROUTINE Elastc (Agoj, Nent, Ntot, Parext, Iflext,
* Cs, Si, Dphi, Wr, Wi, Pwrhor, Pwrhoi, Tr, Ti, Qr, Qi, Notu,
* Krext, Lrmat, Minres, igr, Zke, If_Zke, If_Zkte,
* If_Zkfe, Sigxxx, Dasigx, Dbsigx, Isopar, Iso)
@@ -347,7 +346,7 @@ C
integer :: Nent, Ntot, Krext, Lrmat, Minres, igr, If_Zke,Iso
real(kind=8) :: Parext(Krext,Ntotc,*),
- * Pr(Ntriag,*), Ppi(Ntriag,*), Cs(*), Si(*), Dphi(*),
+ * Cs(*), Si(*), Dphi(*),
* Wr(*), Wi(*), Pwrhor(*), Pwrhoi(*), Tr(*), Ti(*), Qr(NN,*),
* Qi(NN,*), Zke(*)
integer :: Iflext(Krext,Ntotc,*), Notu(*),
@@ -357,8 +356,7 @@ C
integer :: Isopar(*)
C
C DIMENSION Parext(Nrext,Ntotc,Ngroup),
-C * Iflext(Nrext,Ntotc,Ngroup), Pr(Ntriag,Napres),
-C * Ppi(Ntriag,Napres), Notu(Napres),
+C * Iflext(Nrext,Ntotc,Ngroup),
C * Cs(Ntotc), Si(Ntotc), Dphi(Ntotc), Wr(NN), Wi(NN),
C * Pwrhor(NN), Pwrhoi(NN), Tr(NN), Ti(NN), Qr(NN,NN),
C * Qi(NN,NN), Zke(Ntotc), If_Zkte(Ntotc), If_zkfe(Ntotc)
@@ -382,7 +380,7 @@ C
Sumc = Sumc + B
Sum = Sum + ( Cs(I)*Wr(Ii)+Si(I)*Wi(Ii) )*B
B = C/Zke(I)
- Ktru = If_Zkte(I) - Nvadif
+ Ktru = If_Zkte(I)
IF (Ktru.GT.0) THEN
if (ktru.le.ndasig) then
Dasigx(1,Ktru) = Dasigx(1,Ktru) -
@@ -392,7 +390,7 @@ C
stop 'Out of range in Elastc in mcro4 for ktru'
end if
END IF
- Keff = If_Zkfe(I) - Nvadif
+ Keff = If_Zkfe(I)
IF (Keff.GT.0) THEN
if( keff.le.ndasig) then
Dasigx(1,Keff) = Dasigx(1,Keff) +
@@ -420,7 +418,7 @@ C
END DO
A = Two*Agoj*Pi100*(Sumc-Two*Sum+Sum1)/Su
Sigxxx(1) = Sigxxx(1) + A
- Kiso = If_Zke - Nvadif
+ Kiso = If_Zke
IF (Kiso.GT.0) THEN
if( kiso.le.ndasig) then
Dasigx(1,Kiso) = Dasigx(1,Kiso)/VarAbn
@@ -450,7 +448,7 @@ C
Sigxxx(1) = Sigxxx(1) + B
C
IF (Ksolve.NE.2) THEN
- Kiso = If_Zke - Nvadif
+ Kiso = If_Zke
IF (Kiso.GT.0) THEN
if (kiso.le.ndasig) then
Dasigx(1,Kiso) = Dasigx(1,Kiso) + B/VarAbn
@@ -466,7 +464,7 @@ C
C
IF (Lrmat.EQ.1) RETURN
IF (Ksolve.EQ.2) RETURN
- IF (Npr.EQ.0 .AND. Npx.EQ.0) RETURN
+ IF (.not.resDeriv .AND. Npx.EQ.0) RETURN
C
CALL Zero_Array (TR, Ntriag)
CALL Zero_Array (TI, Ntriag)
@@ -495,8 +493,8 @@ C
END DO
END DO
C
- IF (Npr.NE.0 .OR. Krdmsc.NE.0) CALL Derres_Cro (Agoj, Ntot, Pr,
- * Ppi, TR, TI, Notu, Minres, igr, Zke, Dasigx, Dbsigx,
+ IF (resDeriv) CALL Derres_Cro (Agoj, Ntot,
+ * TR, TI, Notu, Minres, igr, Zke, Dasigx, Dbsigx,
* Isopar, Iso)
C
IF (Npx.NE.0) CALL Derext_Cro (Agoj, Ntot, Parext, Iflext, TR,
@@ -508,7 +506,7 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Reactn (Agoj, Nent, Next, Ntot, Parext, Iflext, Pr,Ppi,
+ SUBROUTINE Reactn (Agoj, Nent, Next, Ntot, Parext, Iflext,
* Wr, Wi, Pwrhor, Pwrhoi, Tr, Ti, Qr, Qi, Notu, Krext, Lrmat,
* Minres, igr, Zke, If_Zke, If_Zkte, Sigxxx,
* Dasigx, Dbsigx, Isopar, Iso)
@@ -528,7 +526,7 @@ C
integer :: If_Zke, Iso
real(kind=8) :: Parext(Krext,Ntotc,*),
- * Pr(Ntriag,*), Ppi(Ntriag,*), Wr(*), Wi(*), Pwrhor(*),
+ * Wr(*), Wi(*), Pwrhor(*),
* Pwrhoi(*), Tr(*), Ti(*), Qr(NN,*), Qi(NN,*), Zke(*)
integer :: Iflext(Krext,Ntotc,*), Notu(*), If_Zkte(*)
real(kind=8) :: Sigxxx(*), Dasigx(Nnnsig,*),
@@ -536,8 +534,8 @@ C
integer:: Isopar(*)
C
C DIMENSION Parext(Nrext,Ntotc,Ngroup),
-C * Iflext(Nrext,Ntotc,Ngroup), Pr(Ntriag,Napres),
-C * Ppi(Ntriag,Napres), Notu(Napres), Wr(NN), Wi(NN),
+C * Iflext(Nrext,Ntotc,Ngroup),
+C * Wr(NN), Wi(NN),
C * Pwrhor(NN), Pwrhoi(NN), Tr(NN), Ti(NN), Qr(NN,NN), Qi(NN,NN)
C
real(kind=8) :: Zero = 0.0d0, One = 1.0d0, Two = 2.0d00
@@ -565,7 +563,7 @@ C
* (Wr(Ij)**2+Wi(Ij)**2)*B
IF (Jj.EQ.2) F2sum = F2sum +
* (Wr(Ij)**2+Wi(Ij)**2)*B
- Ktru = If_Zkte(I) - Nvadif
+ Ktru = If_Zkte(I)
IF (Ktru.GT.0) THEN
if(ktru.le.ndasig) then
Isopar(Ktru) = Iso
@@ -585,7 +583,7 @@ C
Sigxxx(1) = Sigxxx(1) + A*Sum
Sig1 = Sig1 + A*F1sum
Sig2 = Sig2 + A*F2sum
- Kiso = If_Zke - Nvadif
+ Kiso = If_Zke
IF (Kiso.GT.0) THEN
if( kiso.le.ndasig) then
Dasigx(1,Kiso) = Dasigx(1,Kiso) + A*Sum/VarAbn
@@ -624,7 +622,7 @@ C
Sig1 = Sig1 + F1Sum*B
Sig2 = Sig2 + F2Sum*B
IF (Ksolve.NE.2) THEN
- Kiso = If_Zke - Nvadif
+ Kiso = If_Zke
IF (Kiso.GT.0) THEN
if( kiso.le.ndasig) then
Dasigx(1,Kiso) = Dasigx(1,Kiso) + B*Sum/VarAbn
@@ -639,7 +637,7 @@ C
C
IF (Lrmat.EQ.1) RETURN
IF (Ksolve.EQ.2) RETURN
- IF (Npr.EQ.0 .AND. Npx.EQ.0) RETURN
+ IF (.not.resDeriv .AND. Npx.EQ.0) RETURN
C
CALL Zero_Array (Tr, Ntriag)
CALL Zero_Array (Ti, Ntriag)
@@ -667,8 +665,8 @@ C
END DO
END IF
C
- IF (Npr.NE.0 .OR. Krdmsc.NE.0) CALL Derres_Cro (Agoj, Ntot, PR,
- * Ppi, Tr, Ti, Notu, Minres, igr, Zke, Dasigx, Dbsigx,
+ IF (resDeriv) CALL Derres_Cro (Agoj, Ntot,
+ * Tr, Ti, Notu, Minres, igr, Zke, Dasigx, Dbsigx,
* Isopar, Iso)
C
IF (Npx.NE.0) CALL Derext_Cro (Agoj, Ntot, Parext, Iflext, Tr,
@@ -680,8 +678,8 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Captur (Agoj, Nent, Next, Ntot, Parext, Iflext, Pr,
- * Ppi, Wr, Wi, Pwrhor, Pwrhoi, Tr, Ti, Qr, Qi, Notu, Krext,
+ SUBROUTINE Captur (Agoj, Nent, Next, Ntot, Parext, Iflext,
+ * Wr, Wi, Pwrhor, Pwrhoi, Tr, Ti, Qr, Qi, Notu, Krext,
* Lrmat, Minres, igr, Zke, If_Zke, If_Zkte, Sigxxx,
* Dasigx, Dbsigx, Isopar, Iso)
C
@@ -701,7 +699,7 @@ C
* igr, If_zke, iso, minres
real(kind=8):: Parext(Krext,Ntotc,*),
- * Pr(Ntriag,*), Ppi(Ntriag,*), Wr(*), Wi(*),
+ * Wr(*), Wi(*),
* Pwrhor(*), Pwrhoi(*), Tr(*), Ti(*), Qr(NN,*),
* Qi(NN,*), Zke(*)
integer:: Iflext(Krext,Ntotc,*), Notu(*), If_Zkte(*)
@@ -710,8 +708,7 @@ C
integer :: Isopar(*)
C
C DIMENSION Parext(Nrext,Ntotc,Ngroup),
-C * Iflext(Nrext,Ntotc,Ngroup), Pr(Ntriag,Napres),
-C * Ppi(Ntriag,Napres), Notu(Napres),
+C * Iflext(Nrext,Ntotc,Ngroup),
C * Cs(Ntotc), Si(Ntotc), Dphi(Ntotc), Wr(NN), Wi(NN),
C * Pwrhor(NN), Pwrhoi(NN), Tr(NN), Ti(NN), Qr(NN,NN), Qi(NN,NN)
C
@@ -728,7 +725,7 @@ C
DO J=1,Nent
Jj = (J*(J-1))/2
B = One/Zke(J)**2
- Ktru = If_Zkte(J) - Nvadif
+ Ktru = If_Zkte(J)
A = C/Zke(J)
DO I=1,Ntot
IF (I.LE.J) THEN
@@ -751,7 +748,7 @@ C ??????????? is this right ???????????? methinks not
END DO
B = Pi100*Agoj*(Sumc-Sum)/Su
Sigxxx(1) = Sigxxx(1) + B
- Kiso = If_Zke - Nvadif
+ Kiso = If_Zke
IF (Kiso.GT.0) THEN
if( kiso.le.ndasig) then
Dasigx(1,Kiso) = Dasigx(1,Kiso) + B/VarAbn
@@ -780,7 +777,7 @@ C
B = Pi100*Agoj*(Sumc-Sum)/Su
Sigxxx(1) = Sigxxx(1) + B
IF (Ksolve.NE.2) THEN
- Kiso = If_Zke - Nvadif
+ Kiso = If_Zke
IF (Kiso.GT.0) THEN
if( kiso.le.ndasig) then
Dasigx(1,Kiso) = Dasigx(1,Kiso) + B/VarAbn
@@ -795,7 +792,7 @@ C
C
IF (Lrmat.EQ.1) RETURN
IF (Ksolve.EQ.2) RETURN
- IF (Npr.EQ.0 .AND. Npx.EQ.0) RETURN
+ IF (.not.resDeriv .AND. Npx.EQ.0) RETURN
C
CALL Zero_Array (Tr, Ntriag)
CALL Zero_Array (Ti, Ntriag)
@@ -842,8 +839,8 @@ C ?? B=2.*Wi(Kl)
END DO
END IF
C
- IF (Npr.NE.0 .OR. Krdmsc.NE.0) CALL Derres_Cro (Agoj, Ntot, PR,
- * Ppi, Tr, Ti, Notu, Minres, igr, Zke, Dasigx, Dbsigx,
+ IF (resDeriv) CALL Derres_Cro (Agoj, Ntot,
+ * Tr, Ti, Notu, Minres, igr, Zke, Dasigx, Dbsigx,
* Isopar, Iso)
C
IF (Npx.NE.0) CALL Derext_Cro (Agoj, Ntot, Parext, Iflext, Tr,
@@ -854,7 +851,7 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Derres_Cro (Agoj, Ntot, PR, Ppi, Tr, Ti, Notu,
+ SUBROUTINE Derres_Cro (Agoj, Ntot, Tr, Ti, Notu,
* Minres, igr, Zke, Dasigx, Dbsigx, Isopar, Iso)
C
use fixedi_m
@@ -863,81 +860,57 @@ C
use constn_common_m
use EndfData_common_m
use SammyResonanceInfo_M
+ use templc_common_m, only : A_Ipr, A_Ipi
IMPLICIT NONE
C
real(kind=8) :: agoj
integer :: Ntot, Minres, igr, Iso
- real(kind=8) :: Pr(Ntriag,*), Ppi(Ntriag,*),
- * Tr(*), Ti(*), Zke(*)
+ real(kind=8) :: Tr(*), Ti(*), Zke(*)
integer :: Notu(*)
real(kind=8) :: Dasigx(Nnnsig,*), Dbsigx(Nnnsig,Ndbxxx,*)
integer :: Isopar(*)
type(SammyResonanceInfo)::resInfo
C
-C DIMENSION Pr(Ntriag,Nyyres), Ppi(Ntriag,Nyyres),
-C * Tr(NN), Ti(NN), Notu(Nyyres)
+C DIMENSION
+C * Tr(NN), Ti(NN)
C
real(kind=8) :: Zero = 0.0d0, One = 1.0d0
C,
real(kind=8) :: A, S
integer :: I, Ifl, Ij, J, M, Mm
- IF (Npr.GT.0) THEN
+ IF (resDeriv) THEN
DO Mm=1,Npr
M = Kstart + Mm
- IF (Notu(M).NE.1) THEN
+ IF (Notu(M).NE.0) THEN
S = Zero
Ij = 0
DO I=1,Ntot
A = 1.0D0/Zke(I)**2
DO J=1,I
Ij = Ij + 1
- IF (Ppi(Ij,M).NE.Zero) THEN
- S = S + Ppi(Ij,M)*Ti(Ij)*A
+ IF (A_Ipi(Ij,M).NE.Zero) THEN
+ S = S + A_Ipi(Ij,M)*Ti(Ij)*A
END IF
- IF (Pr(Ij,M).NE.Zero) THEN
- S = S + Pr(Ij,M)*Tr(Ij)*A
+ IF (A_Ipr(Ij,M).NE.Zero) THEN
+ S = S + A_Ipr(Ij,M)*Tr(Ij)*A
END IF
END DO
END DO
- Dasigx(1,M) = Dasigx(1,M) + Fourpi*Agoj*S/Su
- Isopar(M) = iso
+ if (Notu(M).gt.0) then
+ Dasigx(1,Notu(M)) = Dasigx(1,Notu(M)) +
+ * Fourpi*Agoj*S/Su
+ Isopar(Notu(M)) = iso
+ else
+ Ifl = -1 * Notu(M) - Ndasig
+ Dbsigx(1,Ifl,iso) = Dbsigx(1,Ifl,Iso) +
+ * Fourpi*Agoj*S/Su
+ end if
END IF
END DO
END IF
-C
-C
- IF (Krdmsc.EQ.0) RETURN
- call resParData%getResonanceInfo(resInfo, minres)
- Ifl = resInfo%getChannelFitOption(1)
- IF (Ifl.LT.Ndasig) THEN
- STOP '[STOP in Derres_Cro in cro/mcro4.f]'
- END IF
- Ifl = Ifl - Ndasig
- DO Mm=Minres,resParData%getNumResonances()
- call resParData%getResonanceInfo(resInfo, Mm)
- if (resInfo%getSpinGroupIndex().ne.igr) exit
-
- M = Napres + Mm
- IF (Notu(M).NE.1) THEN
- S = Zero
- Ij = 0
- DO I=1,Ntot
- A = One/Zke(I)**2
- DO J=1,I
- Ij = Ij + 1
- IF (Ppi(Ij,M).NE.Zero) THEN
- S = S + Ppi(Ij,M)*Ti(Ij)*A
- END IF
- IF (Pr(Ij,M).NE.Zero) THEN
- S = S + Pr(Ij,M)*Tr(Ij)*A
- END IF
- END DO
- END DO
- Dbsigx(1,Ifl,iso) = Dbsigx(1,Ifl,Iso) + Fourpi*Agoj*S/Su
- END IF
- END DO
+
RETURN
END
C
@@ -975,7 +948,7 @@ C
Ij = Ij + I
Ifl = Iflext(1,I,Nnnn)
IF (Ifl.NE.-1) THEN
- Ifl = Ifl - Nvadif
+ Ifl = Ifl
if( ifl.gt.ndasig) then
stop 'Out of range in Derext_Cro in mcro4 #1'
end if
@@ -989,7 +962,7 @@ C
* Parext(6,I,Nnnn)*Parext(1,I,Nnnn))/
* (Su-Parext(1,I,Nnnn))
END IF
- Ifl = Iflext(2,I,Nnnn) - Nvadif
+ Ifl = Iflext(2,I,Nnnn)
if( ifl.gt.ndasig) then
stop 'Out of range in Derext_Cro in mcro4 #2'
end if
@@ -1001,7 +974,7 @@ C
* (Parext(5,I,Nnnn)+Parext(6,I,Nnnn)*Parext(2,I,Nnnn))/
* (Parext(2,I,Nnnn)-Su) + Dasigx(1,Ifl)
END IF
- Ifl = Iflext(3,I,Nnnn) - Nvadif
+ Ifl = Iflext(3,I,Nnnn)
if( ifl.gt.ndasig) then
stop 'Out of range in Derext_Cro in mcro4 #3'
end if
@@ -1009,7 +982,7 @@ C
Isopar(Ifl) = Iso
Dasigx(1,Ifl) = Tr(Ij)*B + Dasigx(1,Ifl)
END IF
- Ifl = Iflext(4,I,Nnnn) - Nvadif
+ Ifl = Iflext(4,I,Nnnn)
if( ifl.gt.ndasig) then
stop 'Out of range in Derext_Cro in mcro4 #4'
end if
@@ -1017,7 +990,7 @@ C
Isopar(Ifl) = Iso
Dasigx(1,Ifl) = Tr(Ij)*B*Su + Dasigx(1,Ifl)
END IF
- Ifl = Iflext(5,I,Nnnn) - Nvadif
+ Ifl = Iflext(5,I,Nnnn)
IF (Ifl.GT.0) THEN
Isopar(Ifl) = Iso
Dasigx(1,Ifl) = -Two*Tr(Ij)*B * dSQRT(Parext(5,I,Nnnn))*
@@ -1025,7 +998,7 @@ C
* Dasigx(1,Ifl)
END IF
IF (Nrext.GT.5) THEN
- Ifl = Iflext(6,I,Nnnn) - Nvadif
+ Ifl = Iflext(6,I,Nnnn)
IF (Ifl.GT.0) THEN
Isopar(Ifl) = Iso
Dasigx(1,Ifl) = Dasigx(1,Ifl) - Tr(Ij)*B*
@@ -1033,7 +1006,7 @@ C
* Su*dLOG((Parext(2,I,Nnnn)-Su)/
* (Su-Parext(1,I,Nnnn))) )
END IF
- Ifl = Iflext(7,I,Nnnn) - Nvadif
+ Ifl = Iflext(7,I,Nnnn)
IF (Ifl.GT.0) THEN
Isopar(Ifl) = Iso
Dasigx(1,Ifl) = Tr(Ij)*B*Su**2 + Dasigx(1,Ifl)
diff --git a/sammy/src/cro/mcro5.f b/sammy/src/cro/mcro5.f
index 2ccde852d67e37163c4f52026baa013c1c3dffae..b39c474059f2f880637ece2a97e14843a933f51d 100644
--- a/sammy/src/cro/mcro5.f
+++ b/sammy/src/cro/mcro5.f
@@ -11,6 +11,7 @@ C
use abro_common_m
use cbro_common_m
use lbro_common_m
+ use EndfData_common_m, only : covData
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
C deltdp => delttt from fixedr_m (Ff(23) assigned to delt (from common block b39
@@ -32,14 +33,16 @@ C
Odffff = Odfmul
C
Nntype = 1
- Ndasig = Napres + Nfpext + Nfprad + Nfpiso
+ Ndasig = Nfpres + Nfpext + Nfprad + Nfpiso
if(Kvcrfn.gt.0) Ndasig = Ndasig + 1 ! account for fit of matching radius
- Ndbsig = Napthe - Ndasig
+ Ntotal = covData%getNumTotalParam() -
+ * Numusd -
+ * Numdtp
+ Ndbsig = Ntotal - Ndasig
IF (Ksolve.EQ.2) THEN
- IF (Numpup.EQ.0) THEN
+ IF (covData%getPupedParam().EQ.0) THEN
Ndasig = 0
Ndbsig = 0
- Napthe = 0
END IF
END IF
Ndaxxx = Ndasig
@@ -51,13 +54,13 @@ C *** here there is no broadening and no angular distributions and
C *** no multiple-scattering, so all affected theory parameters
C *** occur in output files
IF (.Not.Ydoppr .AND. .Not.Yresol .AND. .Not.Yangle. AND.
- * .Not.Yssmsc) Ngbout = Napthe
+ * .Not.Yssmsc) Ngbout = Ntotal
C
C *** if there is broadening (or ang dis or mul sct), figure ngbout =
C *** # of par in output GB file. Note that this number may be
C *** smaller than in the above case (where all are needed).
IF (Ydoppr .OR. Yresol .OR. Yangle .OR. Yssmsc .OR. Ntgrlq.EQ.1)
- * Ngbout = Napres + Nvpext + Nvprad + Nvpiso + Nvpdet +
+ * Ngbout = Nfpres + Nvpext + Nvprad + Nvpiso + Nvpdet +
* Nvpbrd + Nvpmsc + Nvppmc
C
C
diff --git a/sammy/src/cro/mnrm1.f b/sammy/src/cro/mnrm1.f
index 331469933396a66ebb2d846c9163847c75ab744c..d813517f7c484789cfa82731347203a46c5c5455 100644
--- a/sammy/src/cro/mnrm1.f
+++ b/sammy/src/cro/mnrm1.f
@@ -1,25 +1,6 @@
C
C
C --------------------------------------------------------------
-C
- SUBROUTINE Addcon (Sigxxx, Dbsigx, Iflmsc, Nummmm)
-C
-C *** Purpose -- Add constant cross section
-C
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Sigxxx(*), Dbsigx(Nummmm,*), Iflmsc(*)
- IF (Nummmm.NE.1) STOP '[STOP in Addcon in cro/mnrm1.f]'
- Sigxxx(1) = Sigxxx(1) + Concro
- N = Nvadif - Ndasig
- IF (Iflmsc(Kconcr).GT.N) Dbsigx(1,Iflmsc(Kconcr)-N) = 1.0d0
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
C
SUBROUTINE Norm (Parnbk, Iflnbk, Sig, dA, dB, Em, Nummmm)
C
@@ -66,7 +47,7 @@ C *** that work for all cross sections
C
Se = dSQRT(Em)
IF (Ksolve.NE.2 .OR. Nfpnbk.GT.Nvpnbk) THEN
- N = Nvadif + Ndasig
+ 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
@@ -113,7 +94,7 @@ C *** here is for different normalizations for different cross sections
C
Se = dSQRT(Em)
IF (Ksolve.NE.2 .OR. Nfpnbk.GT.Nvpnbk) THEN
- N = Nvadif + Ndasig
+ N = Ndasig
DO Iangle=1,Nummmm
IF (Iflnbk(1,Iangle).GT.N) dB(Iangle,Iflnbk(1,Iangle)-N) =
* Sig(Iangle)/Parnbk(1,Iangle)
@@ -169,7 +150,7 @@ 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 = Nvadif + Ndasig
+ N = Ndasig
IF (Nnniso.NE.1) STOP '[STOP in Bgfrpi in cro/mnrm1.f]'
C
DO I=1,Numbgf
@@ -349,7 +330,6 @@ C
IF (N.LE.Ndasig) THEN
STOP '[STOP in Nnneta in cro/mnrm1.f]'
ELSE
- N = N - Nvadif
DO Iso=1,Niso
Dbsig(1,N,Iso) = Sig(1,Iso)/Etanuu
END DO
diff --git a/sammy/src/cro/mnrm2.f b/sammy/src/cro/mnrm2.f
index 7a8c1ac6b41208ce39ba653ab5304ff67aaa1347..89069e0959098b524e1eedb541fd80a6d0c54475 100755
--- a/sammy/src/cro/mnrm2.f
+++ b/sammy/src/cro/mnrm2.f
@@ -35,9 +35,9 @@ C *** modify the derivatives to be in terms of transmission
C
IF (Kkkthc.GT.0) THEN
C *** generate derivative wrt thickness
- Ipar = Kkkthc - Nvadif
+ Ipar = Kkkthc
IF (Ipar.LE.Ndasig) THEN
- WRITE (6,10000) Ipar, Ndasig, Kkkthc, Nvadif
+ WRITE (6,10000) Ipar, Ndasig, Kkkthc, 0
10000 FORMAT ('In Transm, Ipar,Ndasig=', 10I5)
STOP '[STOP in Transm in cro/mnrm2.f]'
ELSE
@@ -137,9 +137,9 @@ C *** Modify the derivatives to be in terms of transmission
C
IF (Kkkthc.GT.0) THEN
C *** Generate derivative wrt thickness
- Ipar = Kkkthc - Nvadif
+ Ipar = Kkkthc
IF (Ipar.LE.Ndasig) THEN
- WRITE (6,10000) Ipar, Ndasig, Kkkthc, Nvadif
+ WRITE (6,10000) Ipar, Ndasig, Kkkthc, 0
10000 FORMAT ('In Transm, Ipar,Ndasig=', 10I5)
STOP '[STOP in Transm in cro/mnrm2.f]'
ELSE
diff --git a/sammy/src/dbd/mdbd1.f b/sammy/src/dbd/mdbd1.f
index 85692d9feddd9230a4c20891d540f0c3c30e9293..1e247e3faeb226c9a5614aa884e80eabcc00a871 100644
--- a/sammy/src/dbd/mdbd1.f
+++ b/sammy/src/dbd/mdbd1.f
@@ -257,7 +257,7 @@ C *** Perform integration for Doppler-Broadening from point number
C *** Kc to point number Iup
C
use fixedi_m, only : Nnnsig, Ndaxxx, Ndbxxx, Niniso,
- * Ndasig, Ndbsig, Nvadif
+ * Ndasig, Ndbsig
use ifwrit_m, only : Kdebug, Ksolve, Kvtemp
use fixedr_m, only : Temp
use brdd_common_m, only : Ipnts, Iup, Kc
@@ -334,7 +334,7 @@ C
END DO
C
IF (Kvtemp.GT.0.and.Ndbsig.GT.0) THEN
- K = Kvtemp - Nvadif - Ndasig
+ K = Kvtemp - Ndasig
DO N=1,Nnnsig
Dbsigx(N,K) = Derdop(N)*Wdop*0.5d0/Temp
END DO
diff --git a/sammy/src/dbd/mdbd3.f b/sammy/src/dbd/mdbd3.f
index 405af5a992f496a7d399b03cc9c056acc299c604..49e761c8a222d1dfcefd109296027164af6a5b55 100644
--- a/sammy/src/dbd/mdbd3.f
+++ b/sammy/src/dbd/mdbd3.f
@@ -82,7 +82,7 @@ C *** purpose -- COPY DATA AND DERIVATIVES, CUZ THERE ARE TOO FEW
C *** POINTS TO BROADEN
C
use fixedi_m, only : Nnnsig, Ndaxxx, Ndbsig, Niniso,
- * Ndbxxx, Nvadif, Ndasig
+ * Ndbxxx, Ndasig
use ifwrit_m, only : Kvtemp
IMPLICIT None
C
@@ -115,7 +115,7 @@ C
END DO
END IF
IF (Kvtemp.GT.0) THEN
- K = Kvtemp - Nvadif - Ndasig
+ K = Kvtemp - Ndasig
DO N=1,Nnnsig
Dbsigx(N,K) = Zero
END DO
diff --git a/sammy/src/dop/mdop1.f90 b/sammy/src/dop/mdop1.f90
index 2834961f1812018b555b8f9ec23dc4da26f9860c..a51b003fd089a3857fa903da074f192cb7ba0096 100644
--- a/sammy/src/dop/mdop1.f90
+++ b/sammy/src/dop/mdop1.f90
@@ -364,7 +364,7 @@ module dop1_m
Wsigsi(Kiniso,*), Wdbsis(Ndbxxx,Kiniso,*)
Sig0 = 0.0d0
- Kvt = Kvtemp - Nvadif - Ndasig
+ Kvt = Kvtemp - Ndasig
delt6 = delt * 6.0d0
DO Iso=1,Niniso
DO N=1,Nnnsig
diff --git a/sammy/src/end/mout.f b/sammy/src/end/mout.f
index f7517498dacac2d2cb1858dc4b1629f6aa673d0d..b474a0098b0b082b4903f37e9de8b6bc8228c432 100644
--- a/sammy/src/end/mout.f
+++ b/sammy/src/end/mout.f
@@ -150,26 +150,20 @@ C
if (.not.haveRes) goto 130
IF (Iff.NE.0) THEN
DO N=Minr,Maxr
- call resParData%getResonanceInfo(resInfo, N)
- IF (resInfo%getEnergyFitOption().EQ.0) THEN
- GO TO 20
- ELSE IF (resInfo%getEnergyFitOption().GT.0) THEN
- DO M=1,Mmax2
- if( m.eq.1) then
- ifl = resInfo%getEnergyFitOption()
- else
- ifl = resInfo%getChannelFitOption(m-1)
- end if
- IF (.not.covData%isPupedParameter(Ifl)) THEN
- GO TO 20
- ELSE
- END IF
- END DO
- END IF
+ call resParData%getResonanceInfo(resInfo, N)
+ IF (.not.resInfo%hasAnyVariedParams()) cycle
+ DO M=1,Mmax2
+ if( m.eq.1) then
+ ifl = resInfo%getEnergyFitOption()
+ else
+ ifl = resInfo%getChannelFitOption(m-1)
+ end if
+ if (Ifl.gt.0) goto 20 ! found a varied parameter
+ end do
END DO
- GO TO 130
+ GO TO 130 ! no varied parameters in this spin group
END IF
- 20 CONTINUE
+ 20 CONTINUE ! at least one varied parameter in this spin group
C
IF (Kpolar.NE.1) THEN
C
@@ -202,11 +196,11 @@ C
call resParData%getResonance(resonance, resInfo)
end if
pkenPr = getPkenPr(resonance%getEres(), reduced)
- IF (resInfo%getEnergyFitOption().LT.-1) THEN
+ IF (.not.resInfo%getIncludeInCalc()) THEN
Ixx = 1
ELSE
IF (Iff.EQ.0 .OR.
- * resInfo%getEnergyFitOption().GE.0) THEN
+ * resInfo%hasAnyVariedParams()) THEN
if( allocated(fitFlags).and.
* size(fitFlags).lt.(Mmax2)) then
deallocate(fitFlags)
@@ -263,7 +257,7 @@ C
99985 FORMAT (/' EXCLUDED RESONANCES .....')
DO N=Minr,Maxr
call resParData%getResonanceInfo(resInfo, N)
- IF (resInfo%getEnergyFitOption().LT.-1) THEN
+ IF (.not.resInfo%getIncludeInCalc()) THEN
if( reduced) then
call resParData%getRedResonance(resonance,
* resInfo)
@@ -278,7 +272,7 @@ C
if( .not.allocated(fitFlags)) then
allocate(fitFlags(Mmax+2))
end if
- fitFlags(1) = resInfo%getEnergyFitOption()
+ fitFlags(1) = 0 ! excluded from fit
do nc = 2, Mmax+2
fitFlags(nc) = resInfo%getChannelFitOption(nc-1)
end do
@@ -336,11 +330,11 @@ C *** Here if want fission gamma widths in polar coordinates
call resParData%getResonance(resonance, resInfo)
end if
pkenPr = getPkenPr(resonance%getEres(), reduced)
- IF (resInfo%getEnergyFitOption().LT.-1) THEN
+ IF (.not.resInfo%getIncludeInCalc()) THEN
Ixx = 1
ELSE
IF (Iff.EQ.0 .OR.
- * resInfo%getEnergyFitOption().GE.0) THEN
+ * resInfo%hasAnyVariedParams()) THEN
DO J=1,5
if(j.eq.1) then
Iif(J) = resInfo%getEnergyFitOption()
@@ -385,7 +379,7 @@ C *** Here if want fission gamma widths in polar coordinates
Ccccc FORMAT (/' EXCLUDED RESONANCES .....')
DO N=Minr,Maxr
call resParData%getResonanceInfo(resInfo, N)
- IF (resInfo%getEnergyFitOption().LT.-1) THEN
+ IF (.not.resInfo%getIncludeInCalc()) THEN
if( reduced) then
call resParData%getRedResonance(resonance,
* resInfo)
@@ -876,7 +870,8 @@ C
IF (Iff.EQ.0) GO TO 20
DO N=Minr,Maxr
call resParData%getResonanceInfo(resInfo, N)
- IF (resInfo%getEnergyFitOption().GE.0) GO TO 20
+ IF (resInfo%getIncludeInCalc().and.
+ * resInfo%hasAnyVariedParams()) GO TO 20
END DO
GO TO 150
20 CONTINUE
@@ -925,10 +920,10 @@ C
Ixx = 0
DO 90 N=Minr,Maxr
call resParData%getResonanceInfo(resInfo, N)
- IF (resInfo%getEnergyFitOption().LT.-1) Ixx = 1
- IF (resInfo%getEnergyFitOption().LT.-1) GO TO 90
+ IF (.not.resInfo%getIncludeInCalc()) Ixx = 1
+ IF (.not.resInfo%getIncludeInCalc()) GO TO 90
IF (Iff.NE.0 .AND.
- * resInfo%getEnergyFitOption().LT.0) GO TO 90
+ * .not.resInfo%hasAnyVariedParams()) GO TO 90
if( allocated(fitFlags).and.
* size(fitFlags).lt.(Mmax+2)) then
deallocate(fitFlags)
@@ -1060,7 +1055,7 @@ C
99988 FORMAT (/' EXCLUDED RESONANCES .....')
DO 140 N=Minr,Maxr
call resParData%getResonanceInfo(resInfo, N)
- IF (resInfo%getEnergyFitOption().GE.-1) GO TO 140
+ IF (resInfo%getIncludeInCalc()) GO TO 140
if( allocated(fitFlags).and.
* size(fitFlags).lt.(Mmax+2)) then
deallocate(fitFlags)
diff --git a/sammy/src/end/mout1.f b/sammy/src/end/mout1.f
index 30a36f582b8c65c12d9989d0fbb9afc10dca29c5..b08163b728b0ea4f165661a26b78dade94264a29 100644
--- a/sammy/src/end/mout1.f
+++ b/sammy/src/end/mout1.f
@@ -27,13 +27,13 @@ C
tmp = ""
IF (Iflag(M).GT.0) THEN
Keep = covData%getCovIndex(Iflag(M))
- IF (Keep.LE.Nvpall) THEN
+ IF(.not.covData%isPupedParameter(Iflag(M))) THEN
if (keep.ge.1000) then
write(tmp,'(1a1,I4)') "(",keep
else
write(tmp,'(1a1,I3,1a1)') "(",keep,")"
end if
- ELSE IF (Keep.GT.Nvpall) THEN
+ ELSE
if (keep.ge.1000) then
write(tmp,'(1a1,I4)') "<",keep
else
@@ -105,7 +105,7 @@ C
IF (Iff.NE.0) THEN
DO N=Minr,Maxr
call resParData%getResonanceInfo(resInfo, N)
- IF (resInfo%getEnergyFitOption().GE.0) GO TO 20
+ IF (resInfo%hasAnyVariedParams()) GO TO 20
END DO
GO TO 40
END IF
@@ -133,7 +133,7 @@ C
C
DO N=Minr,Maxr
call resParData%getResonanceInfo(resInfo, N)
- IF (Iff.EQ.0 .OR. resInfo%getEnergyFitOption().GE.0) THEN
+ IF (Iff.EQ.0 .OR. resInfo%hasAnyVariedParams()) THEN
call resParData%getRedResonance(resonanceRed,resInfo)
eres = resonanceRed%getEres()
P = dSQRT(dABS(eres))
@@ -242,8 +242,7 @@ C
else IF (Nfile.EQ.37) THEN
call covData%getUCovariance(uCov)
N = covData%getPupedParam()
- Nn = (N*(N+1))/2
- Kountr = Nvpall
+ Kountr = covData%getNumParam()
call covMat%initialize()
do i = 1, N
@@ -702,7 +701,7 @@ C
IF (Iff.EQ.0) GO TO 20
DO Ires=Minr,Maxr
call resParData%getResonanceInfo(resInfo, Ires)
- IF (resInfo%getEnergyFitOption().GE.0) GO TO 20
+ IF (resInfo%hasAnyVariedParams()) GO TO 20
END DO
GO TO 50
20 CONTINUE
@@ -722,7 +721,7 @@ C
DO Ires=Minr,Maxr
call resParData%getResonanceInfo(resInfo, Ires)
IF (Iff.EQ.0 .OR.
- * resInfo%getEnergyFitOption().GE.0) THEN
+ * resInfo%hasAnyVariedParams()) THEN
call resParData%getResonance(resonance, resInfo)
call resParData%getResonance(resonanceRed, resInfo)
eres = resonance%getEres()
diff --git a/sammy/src/end/mout2.f b/sammy/src/end/mout2.f
index 4fb030329ba0e6611a2e631564a4483281541e5d..dac3fdbba8d671f680f2ccb9113648ef04c318b1 100644
--- a/sammy/src/end/mout2.f
+++ b/sammy/src/end/mout2.f
@@ -487,9 +487,6 @@ C
* Parmsc(N+1), (Draw(J,2),J=1,5)
10800 FORMAT (' self-indication temperature =', 1PE12.4, 5A1,
* /, ' and thickness =', 1PE12.4, 5A1)
-C
- ELSE IF (Kconcr.EQ.N) THEN
-C *** constant cross section, if I ever get around to finishing
C
ELSE IF (Kefcap.EQ.N) THEN
CALL Setflg (Iflmsc(N), 2)
diff --git a/sammy/src/end/mout4.f b/sammy/src/end/mout4.f
index 057266e93c826ae13b8fd43a00c46a5b0c68b800..b23b70582bbea06bbfda5ad7fb06156ac94c897a 100755
--- a/sammy/src/end/mout4.f
+++ b/sammy/src/end/mout4.f
@@ -36,7 +36,7 @@ C
call covData%getCovariance(physCov)
DO N=Minr,Maxr
call resParData%getResonanceInfo(res1, N)
- IF (res1%getEnergyFitOption().GE.0) THEN
+ IF (res1%getIncludeInCalc()) THEN
DO K=1,Mmax2
if( k.eq.1) then
Ipar1 = res1%getEnergyFitOption()
@@ -54,7 +54,7 @@ C
K1(K) = K1(K) + 1
DO Np=Minr,Maxr
call resParData%getResonanceInfo(res2, Np)
- IF (res2%getEnergyFitOption().GE.0) THEN
+ IF (res2%getIncludeInCalc()) THEN
DO Kp=1,Mmax2
if( kp.eq.1) then
Ipar2 = res2%getEnergyFitOption()
@@ -110,7 +110,7 @@ C *** Add over the resonances for each channel K
C
DO N=Minr,Maxr
call resParData%getResonanceInfo(res1, N)
- IF (res1%getEnergyFitOption().GE.0) THEN
+ IF (res1%getIncludeInCalc()) THEN
DO K=1,Mmax2
if( k.eq.1) then
Ipar1 = res1%getEnergyFitOption()
@@ -129,7 +129,7 @@ C
Xa(Keep1) = Zero
DO Np=Minr,Maxr
call resParData%getResonanceInfo(res2, Np)
- IF (res2%getEnergyFitOption().GE.0) THEN
+ IF (res2%getIncludeInCalc()) THEN
DO Kp=1,Mmax2
if( kp.eq.1) then
Ipar2 = res2%getEnergyFitOption()
@@ -185,7 +185,7 @@ C
else
call resParData%getResonance(resonance1, res1)
end if
- IF (res1%getEnergyFitOption().GE.0) THEN
+ IF (res1%getIncludeInCalc()) THEN
DO K=1,Mmax2
if( k.eq.1) then
Ipar1 = res1%getEnergyFitOption()
@@ -220,7 +220,7 @@ C
call resParData%getResonance(resonance2,
* res2)
end if
- IF (res2%getEnergyFitOption().GE.0) THEN
+ IF (res2%getIncludeInCalc()) THEN
DO Kp=1,Mmax2
if( kp.eq.1) then
Ipar2 = res2%getEnergyFitOption()
@@ -291,7 +291,7 @@ C
else
call resParData%getResonance(resonance1, res1)
end if
- IF (res1%getEnergyFitOption().GE.0) THEN
+ IF (res1%getIncludeInCalc()) THEN
DO K=1,Mmax2
if( k.eq.1) then
Ipar1 = res1%getEnergyFitOption()
@@ -324,7 +324,7 @@ C
call resParData%getResonance(resonance2,
* res2)
end if
- IF (res2%getEnergyFitOption().GE.0) THEN
+ IF (res2%getIncludeInCalc()) THEN
DO Kp=1,Mmax2
if( kp.eq.1) then
Ipar2 = res2%getEnergyFitOption()
diff --git a/sammy/src/endf/CovarianceData.cpp b/sammy/src/endf/CovarianceData.cpp
index 9c9df57dcddfdc20e8d54a18bf5fb8d65e67fed9..7073aece1173e9229949c08a26e9c43494fd5769 100644
--- a/sammy/src/endf/CovarianceData.cpp
+++ b/sammy/src/endf/CovarianceData.cpp
@@ -1,6 +1,7 @@
// stdlib includes
#include <cmath>
#include <fstream>
+#include <algorithm>
// SAMMY includes
#include "CovarianceData.h"
@@ -201,4 +202,23 @@ namespace sammy{
if ( covOld != 0.0) cov->setCovariance(ipar, jpar, 0.0);
}
}
+
+
+ void CovarianceData::clearIrrelevant(){
+ irrelevant.clear();
+ }
+
+
+ void CovarianceData::addToIrrelevant(int index){
+ irrelevant.push_back(index);
+ }
+
+
+ bool CovarianceData::contributes(int index) const{
+ return (std::find( irrelevant.begin(), irrelevant.end(), index) == irrelevant.end());
+ }
+
+ int CovarianceData::getNumIrrelevant() const{
+ return (int)irrelevant.size();
+ }
}
diff --git a/sammy/src/endf/CovarianceData.h b/sammy/src/endf/CovarianceData.h
index 83534929bbb2c64de4a41cbf5850d0aed1737f3d..dd88b1e742d24311730ae4ac28a27af56844d3be 100644
--- a/sammy/src/endf/CovarianceData.h
+++ b/sammy/src/endf/CovarianceData.h
@@ -295,6 +295,37 @@ namespace sammy{
* @param val the new value
*/
static void setCovarianceData(endf::ResonanceCovariance * cov, int ipar, int jpar, double val);
+
+ /**
+ * Clear the list of parameters that are varied but don't contribute
+ */
+ void clearIrrelevant();
+
+ /**
+ * Mark a varied parameters as irrelevant to the result
+ */
+ void addToIrrelevant(int index);
+
+ /**
+ * Does the indicated parameter contribute to the result.
+ *
+ * Usually that is set before calculating the derivatives
+ * to avoid fitting and calculating derivatives that don't
+ * contribute to the cross section.
+ *
+ * Usually it is assumed that resonances do not affect cross
+ * section more than 3 times the (doppler+resolution) broadened width
+ * of the resonance away
+ *
+ * @return true if it contributes, false otherwise
+ */
+ bool contributes(int index) const;
+
+ /**
+ * Get the number of parameters marked as irrelevant
+ * @return the number of parameters marked as irrelevant
+ */
+ int getNumIrrelevant() const;
protected:
/** The covariance data - can be NULL */
std::shared_ptr<endf::ResonanceCovariance> covariance;
@@ -319,6 +350,9 @@ namespace sammy{
/** The index of varied/pup'd parameters to resonance objects */
std::vector<int> paramIndex;
+
+ /** Indices of parameters that are varied but don't matter, so they can be ignored */
+ std::vector<int> irrelevant;
};
}
diff --git a/sammy/src/endf/SammyResonanceInfo.h b/sammy/src/endf/SammyResonanceInfo.h
index ea7c6349678eaa84a96d294944e50c3e75a79cc7..9e72b823d300378ce49ca71258a43569aed698a3 100644
--- a/sammy/src/endf/SammyResonanceInfo.h
+++ b/sammy/src/endf/SammyResonanceInfo.h
@@ -241,6 +241,14 @@ namespace sammy{
void setXVal(double val){
xVal = val;
}
+
+ bool hasAnyVariedParams(){
+ if (!includeInCalc) return false;
+ for ( auto v : fitOption){
+ if( v > 0) return true;
+ }
+ return false;
+ }
private:
/** The index of the resonance in the input file */
int inputIndex;
diff --git a/sammy/src/endf/interface/cix/CovarianceData.cpp2f.xml b/sammy/src/endf/interface/cix/CovarianceData.cpp2f.xml
index c93db13a82794dee85a4ad9264b0dafc194b4efc..0feb3d3fde337be49e227154142f9369e4a83e0e 100644
--- a/sammy/src/endf/interface/cix/CovarianceData.cpp2f.xml
+++ b/sammy/src/endf/interface/cix/CovarianceData.cpp2f.xml
@@ -100,5 +100,14 @@
<param name="jpar" type="int" offset="-1"/>
<param name="val" type="double"/>
</static_method>
+
+ <method name="clearIrrelevant"/>
+ <method name="addToIrrelevant">
+ <param name="index" type="int" offset="-1"/>
+ </method>
+ <method name="contributes" return_type="bool">
+ <param name="index" type="int" offset="-1"/>
+ </method>
+ <method name="getNumIrrelevant" return_type="int"/>
</class>
</generate>
diff --git a/sammy/src/endf/interface/cix/SammyResonanceInfo.cpp2f.xml b/sammy/src/endf/interface/cix/SammyResonanceInfo.cpp2f.xml
index 870d7fd4714e2e888969211fee839b7fe3553e32..8628de98370f905d17e08088d7ab1e9be14cf6e1 100644
--- a/sammy/src/endf/interface/cix/SammyResonanceInfo.cpp2f.xml
+++ b/sammy/src/endf/interface/cix/SammyResonanceInfo.cpp2f.xml
@@ -61,6 +61,8 @@
<method name="getResonance" return_type="RMatResonance*">
<param name="spinGroup" type="RMatSpinGroup *"/>
</method>
+
+ <method name="hasAnyVariedParams" return_type="bool"/>
</class>
</generate>
diff --git a/sammy/src/endf/interface/cpp/CovarianceDataInterface.cpp b/sammy/src/endf/interface/cpp/CovarianceDataInterface.cpp
index 6ca1128fcf9ab747f1b426f9e67b574f986bbf2c..4dab8c5f9b0e88ddfcee4619d813765a4637cfdf 100644
--- a/sammy/src/endf/interface/cpp/CovarianceDataInterface.cpp
+++ b/sammy/src/endf/interface/cpp/CovarianceDataInterface.cpp
@@ -2,7 +2,7 @@
* This file has been dynamically generated by Class Interface Xml (CIX)
* DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
* If changes need to occur, modify the appropriate CIX xml file
-* Date Generated: Tue Oct 20 10:09:41 EDT 2020
+* Date Generated: Thu Feb 18 16:56:27 EST 2021
* If any issues are experiences with this generated file that cannot be fixed
* with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
*/
@@ -159,6 +159,26 @@ void CovarianceData_setCovarianceData( endf::ResonanceCovariance * cov,int * ipa
CovarianceData::setCovarianceData(cov,*ipar,*jpar,*val);
}
+void CovarianceData_clearIrrelevant(void * CovarianceData_ptr)
+{
+ ((CovarianceData*)CovarianceData_ptr)->clearIrrelevant();
+}
+
+void CovarianceData_addToIrrelevant(void * CovarianceData_ptr,int * index)
+{
+ ((CovarianceData*)CovarianceData_ptr)->addToIrrelevant(*index);
+}
+
+bool CovarianceData_contributes(void * CovarianceData_ptr,int * index)
+{
+ return ((CovarianceData*)CovarianceData_ptr)->contributes(*index);
+}
+
+int CovarianceData_getNumIrrelevant(void * CovarianceData_ptr)
+{
+ return ((CovarianceData*)CovarianceData_ptr)->getNumIrrelevant();
+}
+
void* CovarianceData_initialize()
{
return new CovarianceData();
diff --git a/sammy/src/endf/interface/cpp/CovarianceDataInterface.h b/sammy/src/endf/interface/cpp/CovarianceDataInterface.h
index 4cf717dc78dcbc3953085b098925990cddefeebd..53fdfd866eab278a257f58129e345dc3e8c05e03 100644
--- a/sammy/src/endf/interface/cpp/CovarianceDataInterface.h
+++ b/sammy/src/endf/interface/cpp/CovarianceDataInterface.h
@@ -2,7 +2,7 @@
* This file has been dynamically generated by Class Interface Xml (CIX)
* DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
* If changes need to occur, modify the appropriate CIX xml file
-* Date Generated: Tue Oct 20 10:09:41 EDT 2020
+* Date Generated: Thu Feb 18 16:56:27 EST 2021
* If any issues are experiences with this generated file that cannot be fixed
* with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
*/
@@ -44,6 +44,10 @@ void CovarianceData_saveOrigUParam(void * CovarianceData_ptr);
void CovarianceData_dropCorrelation( endf::ResonanceCovariance * cov,double * cut,int * numRow);
void CovarianceData_scaleCovariance( endf::ResonanceCovariance * cov,double * factor,int * numRow);
void CovarianceData_setCovarianceData( endf::ResonanceCovariance * cov,int * ipar,int * jpar,double * val);
+void CovarianceData_clearIrrelevant(void * CovarianceData_ptr);
+void CovarianceData_addToIrrelevant(void * CovarianceData_ptr,int * index);
+bool CovarianceData_contributes(void * CovarianceData_ptr,int * index);
+int CovarianceData_getNumIrrelevant(void * CovarianceData_ptr);
void* CovarianceData_initialize();
void CovarianceData_destroy(void * CovarianceData_ptr);
#ifdef __cplusplus
diff --git a/sammy/src/endf/interface/cpp/SammyResonanceInfoInterface.cpp b/sammy/src/endf/interface/cpp/SammyResonanceInfoInterface.cpp
index 608d726ce64f3a596d6335ea07b0ce01d4fb40b7..f5fd7b876924e6a343f63ced781261749d6b4483 100644
--- a/sammy/src/endf/interface/cpp/SammyResonanceInfoInterface.cpp
+++ b/sammy/src/endf/interface/cpp/SammyResonanceInfoInterface.cpp
@@ -2,7 +2,7 @@
* This file has been dynamically generated by Class Interface Xml (CIX)
* DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
* If changes need to occur, modify the appropriate CIX xml file
-* Date Generated: Tue Jul 16 10:23:58 EDT 2019
+* Date Generated: Fri Feb 19 11:38:39 EST 2021
* If any issues are experiences with this generated file that cannot be fixed
* with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
*/
@@ -109,6 +109,11 @@ void* SammyResonanceInfo_getResonance(void * SammyResonanceInfo_ptr,endf::RMatSp
return (void*)((SammyResonanceInfo*)SammyResonanceInfo_ptr)->getResonance(spinGroup);
}
+bool SammyResonanceInfo_hasAnyVariedParams(void * SammyResonanceInfo_ptr)
+{
+ return ((SammyResonanceInfo*)SammyResonanceInfo_ptr)->hasAnyVariedParams();
+}
+
void* SammyResonanceInfo_initialize()
{
return new SammyResonanceInfo();
diff --git a/sammy/src/endf/interface/cpp/SammyResonanceInfoInterface.h b/sammy/src/endf/interface/cpp/SammyResonanceInfoInterface.h
index 26e0279f057143d347ecd98eda3eb70ef5bf0ab2..5d89f5524ccc339119f9c48d3fbd0b5ad7145fc8 100644
--- a/sammy/src/endf/interface/cpp/SammyResonanceInfoInterface.h
+++ b/sammy/src/endf/interface/cpp/SammyResonanceInfoInterface.h
@@ -2,7 +2,7 @@
* This file has been dynamically generated by Class Interface Xml (CIX)
* DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
* If changes need to occur, modify the appropriate CIX xml file
-* Date Generated: Tue Jul 16 10:23:58 EDT 2019
+* Date Generated: Fri Feb 19 11:38:39 EST 2021
* If any issues are experiences with this generated file that cannot be fixed
* with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
*/
@@ -33,6 +33,7 @@ int SammyResonanceInfo_getChannelFitOption(void * SammyResonanceInfo_ptr,int * n
void SammyResonanceInfo_setXVal(void * SammyResonanceInfo_ptr,double * val);
double SammyResonanceInfo_getXVal(void * SammyResonanceInfo_ptr);
void* SammyResonanceInfo_getResonance(void * SammyResonanceInfo_ptr,endf::RMatSpinGroup * spinGroup);
+bool SammyResonanceInfo_hasAnyVariedParams(void * SammyResonanceInfo_ptr);
void* SammyResonanceInfo_initialize();
void SammyResonanceInfo_destroy(void * SammyResonanceInfo_ptr);
#ifdef __cplusplus
diff --git a/sammy/src/endf/interface/fortran/CovarianceData_I.f90 b/sammy/src/endf/interface/fortran/CovarianceData_I.f90
index 2c7a9f94ea441d48ba8fdae46742805daaab2941..a0db95191e90d0dab6e1a4bc94118d3d144e8001 100644
--- a/sammy/src/endf/interface/fortran/CovarianceData_I.f90
+++ b/sammy/src/endf/interface/fortran/CovarianceData_I.f90
@@ -2,7 +2,7 @@
!! This file has been dynamically generated by Class Interface Xml (CIX)
!! DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
!! If changes need to occur, modify the appropriate CIX xml file
-!! Date Generated: Tue Oct 20 10:09:41 EDT 2020
+!! Date Generated: Thu Feb 18 16:56:27 EST 2021
!! If any issues are experiences with this generated file that cannot be fixed
!! with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
!!/
@@ -183,6 +183,28 @@ subroutine f_CovarianceData_setCovarianceData( cov,ipar,jpar,val ) BIND(C,name=
integer(C_INT) :: jpar;
real(C_DOUBLE) :: val;
end subroutine
+subroutine f_CovarianceData_clearIrrelevant(CovarianceData_ptr ) BIND(C,name="CovarianceData_clearIrrelevant")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: CovarianceData_ptr;
+end subroutine
+subroutine f_CovarianceData_addToIrrelevant(CovarianceData_ptr, index ) BIND(C,name="CovarianceData_addToIrrelevant")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: CovarianceData_ptr;
+ integer(C_INT) :: index;
+end subroutine
+logical(C_BOOL) function f_CovarianceData_contributes(CovarianceData_ptr, index ) BIND(C,name="CovarianceData_contributes")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: CovarianceData_ptr;
+ integer(C_INT) :: index;
+end function
+integer(C_INT) function f_CovarianceData_getNumIrrelevant(CovarianceData_ptr ) BIND(C,name="CovarianceData_getNumIrrelevant")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: CovarianceData_ptr;
+end function
type(C_PTR) function f_CovarianceData_initialize( )BIND(C,name="CovarianceData_initialize")
use,intrinsic :: ISO_C_BINDING
implicit none
diff --git a/sammy/src/endf/interface/fortran/CovarianceData_M.f90 b/sammy/src/endf/interface/fortran/CovarianceData_M.f90
index e110aa8307e46a7380af3126a7021ec71be8759b..30fee024e39399c444b3e1681b17cf38ab9dba0d 100644
--- a/sammy/src/endf/interface/fortran/CovarianceData_M.f90
+++ b/sammy/src/endf/interface/fortran/CovarianceData_M.f90
@@ -2,7 +2,7 @@
!! This file has been dynamically generated by Class Interface Xml (CIX)
!! DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
!! If changes need to occur, modify the appropriate CIX xml file
-!! Date Generated: Tue Oct 20 10:09:41 EDT 2020
+!! Date Generated: Thu Feb 18 16:56:27 EST 2021
!! If any issues are experiences with this generated file that cannot be fixed
!! with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
!!/
@@ -43,6 +43,10 @@ type CovarianceData
procedure, pass(this) :: dropCorrelation => CovarianceData_dropCorrelation
procedure, pass(this) :: scaleCovariance => CovarianceData_scaleCovariance
procedure, pass(this) :: setCovarianceData => CovarianceData_setCovarianceData
+ procedure, pass(this) :: clearIrrelevant => CovarianceData_clearIrrelevant
+ procedure, pass(this) :: addToIrrelevant => CovarianceData_addToIrrelevant
+ procedure, pass(this) :: contributes => CovarianceData_contributes
+ procedure, pass(this) :: getNumIrrelevant => CovarianceData_getNumIrrelevant
procedure, pass(this) :: initialize => CovarianceData_initialize
procedure, pass(this) :: destroy => CovarianceData_destroy
end type CovarianceData
@@ -236,6 +240,30 @@ subroutine CovarianceData_setCovarianceData(this, cov, ipar, jpar, val)
real(C_DOUBLE)::val
call f_CovarianceData_setCovarianceData( cov%instance_ptr,ipar-1,jpar-1,val)
end subroutine
+subroutine CovarianceData_clearIrrelevant(this)
+ implicit none
+ class(CovarianceData)::this
+ call f_CovarianceData_clearIrrelevant(this%instance_ptr)
+end subroutine
+subroutine CovarianceData_addToIrrelevant(this, index)
+ implicit none
+ class(CovarianceData)::this
+ integer(C_INT)::index
+ call f_CovarianceData_addToIrrelevant(this%instance_ptr, index-1)
+end subroutine
+function CovarianceData_contributes(this, index) result(result2Return)
+ implicit none
+ class(CovarianceData)::this
+ integer(C_INT)::index
+ logical(C_BOOL):: result2Return
+ result2Return=f_CovarianceData_contributes(this%instance_ptr, index-1)
+end function
+function CovarianceData_getNumIrrelevant(this) result(result2Return)
+ implicit none
+ class(CovarianceData)::this
+ integer(C_INT):: result2Return
+ result2Return=f_CovarianceData_getNumIrrelevant(this%instance_ptr)
+end function
subroutine CovarianceData_initialize(this)
implicit none
class(CovarianceData) :: this
diff --git a/sammy/src/endf/interface/fortran/SammyResonanceInfo_I.f90 b/sammy/src/endf/interface/fortran/SammyResonanceInfo_I.f90
index 01ee986d6389f2ca8bdda0f75d1e9a431751ad29..0eff114efcce063162dfb48385cc2767bfb7b29d 100644
--- a/sammy/src/endf/interface/fortran/SammyResonanceInfo_I.f90
+++ b/sammy/src/endf/interface/fortran/SammyResonanceInfo_I.f90
@@ -2,7 +2,7 @@
!! This file has been dynamically generated by Class Interface Xml (CIX)
!! DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
!! If changes need to occur, modify the appropriate CIX xml file
-!! Date Generated: Tue Jul 16 10:23:58 EDT 2019
+!! Date Generated: Fri Feb 19 11:38:39 EST 2021
!! If any issues are experiences with this generated file that cannot be fixed
!! with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
!!/
@@ -124,6 +124,11 @@ type(C_PTR) function f_SammyResonanceInfo_getResonance(SammyResonanceInfo_ptr, s
type(C_PTR), value :: SammyResonanceInfo_ptr;
type(C_PTR), value :: spinGroup;
end function
+logical(C_BOOL) function f_SammyResonanceInfo_hasAnyVariedParams(SammyResonanceInfo_ptr ) BIND(C,name="SammyResonanceInfo_hasAnyVariedParams")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: SammyResonanceInfo_ptr;
+end function
type(C_PTR) function f_SammyResonanceInfo_initialize( )BIND(C,name="SammyResonanceInfo_initialize")
use,intrinsic :: ISO_C_BINDING
implicit none
diff --git a/sammy/src/endf/interface/fortran/SammyResonanceInfo_M.f90 b/sammy/src/endf/interface/fortran/SammyResonanceInfo_M.f90
index fc4da162f15caaa2a35645573ea0f807d9cd5f14..d96a3d2661a05028cfa002865a2e06b2e9207aa0 100644
--- a/sammy/src/endf/interface/fortran/SammyResonanceInfo_M.f90
+++ b/sammy/src/endf/interface/fortran/SammyResonanceInfo_M.f90
@@ -2,7 +2,7 @@
!! This file has been dynamically generated by Class Interface Xml (CIX)
!! DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
!! If changes need to occur, modify the appropriate CIX xml file
-!! Date Generated: Tue Jul 16 10:23:58 EDT 2019
+!! Date Generated: Fri Feb 19 11:38:39 EST 2021
!! If any issues are experiences with this generated file that cannot be fixed
!! with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
!!/
@@ -33,6 +33,7 @@ type SammyResonanceInfo
procedure, pass(this) :: setXVal => SammyResonanceInfo_setXVal
procedure, pass(this) :: getXVal => SammyResonanceInfo_getXVal
procedure, pass(this) :: getResonance => SammyResonanceInfo_getResonance
+ procedure, pass(this) :: hasAnyVariedParams => SammyResonanceInfo_hasAnyVariedParams
procedure, pass(this) :: initialize => SammyResonanceInfo_initialize
procedure, pass(this) :: destroy => SammyResonanceInfo_destroy
end type SammyResonanceInfo
@@ -73,7 +74,7 @@ subroutine SammyResonanceInfo_setResonanceIndex(this, index)
integer(C_INT)::index
call f_SammyResonanceInfo_setResonanceIndex(this%instance_ptr, index-1)
end subroutine
-function SammyResonanceInfo_getResonanceIndex(this) result(result2Return)
+function SammyResonanceInfo_getResonanceIndex(this) result(result2Return)
implicit none
class(SammyResonanceInfo)::this
integer(C_INT):: result2Return
@@ -110,8 +111,8 @@ subroutine SammyResonanceInfo_setChannelCovarianceIndex(this, nc, index)
integer(C_INT)::index
call f_SammyResonanceInfo_setChannelCovarianceIndex(this%instance_ptr, nc-1,index-1)
end subroutine
-function SammyResonanceInfo_getChannelCovarianceIndex(this, nc) result(result2Return)
- implicit none
+function SammyResonanceInfo_getChannelCovarianceIndex(this, nc) result(result2Return)
+ implicit none
class(SammyResonanceInfo)::this
integer(C_INT)::nc
integer(C_INT):: result2Return
@@ -162,6 +163,12 @@ subroutine SammyResonanceInfo_getResonance(this, object_ptr, spinGroup)
class(RMatSpinGroup)::spinGroup
object_ptr%instance_ptr = f_SammyResonanceInfo_getResonance(this%instance_ptr, spinGroup%instance_ptr)
end subroutine
+function SammyResonanceInfo_hasAnyVariedParams(this) result(result2Return)
+ implicit none
+ class(SammyResonanceInfo)::this
+ logical(C_BOOL):: result2Return
+ result2Return=f_SammyResonanceInfo_hasAnyVariedParams(this%instance_ptr)
+end function
subroutine SammyResonanceInfo_initialize(this)
implicit none
class(SammyResonanceInfo) :: this
diff --git a/sammy/src/fff/mfff0.f90 b/sammy/src/fff/mfff0.f90
index 26123ad0f30a6cfa54c36867e380a97d0c910c58..670a3eeb9aacc971f1ee84f643a30a55b6d21249 100644
--- a/sammy/src/fff/mfff0.f90
+++ b/sammy/src/fff/mfff0.f90
@@ -257,7 +257,7 @@ module fff_m
use broad_common_m
use exploc_urr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- CALL Zero_Integer (Lf , 200)
+ Lfdim = 0
CALL Zero_Integer (Lwrit, 200)
CALL Zero_Array (Ff , 200)
CALL Zero_Array (Abcd_real , 30 )
diff --git a/sammy/src/fgm/mfgm3.f b/sammy/src/fgm/mfgm3.f
index 969ac7587b0896883c4c2af7d400a9c942a518be..ad940daa1ceaa3f27d2b837f577d26eddb64191c 100644
--- a/sammy/src/fgm/mfgm3.f
+++ b/sammy/src/fgm/mfgm3.f
@@ -66,7 +66,7 @@ C *** purpose -- COPY DATA AND DERIVATIVES, CUZ THERE ARE TOO FEW
C *** POINTS TO BROADEN
C
use fixedi_m, only : Niniso, Ndaxxx, Ndbxxx,
- * Ndbsig, Ndasig, Nvpall, Nvadif
+ * Ndbsig, Ndasig, Nvpall
use ifwrit_m, only : Ksolve
IMPLICIT None
C
@@ -116,7 +116,7 @@ C
END IF
C
IF ((Ksolve.NE.2 .AND. Ktempx.GT.0) .OR. Ktempx.GT.Nvpall) THEN
- Kmin = Ktempx - Nvadif - Ndasig
+ Kmin = Ktempx - Ndasig
IF (Locate.NE.0) THEN
Db(1,Kmin) = Zero
ELSE
diff --git a/sammy/src/fgm/mfgm4.f b/sammy/src/fgm/mfgm4.f
index 404b2234106f658f48885ab0a6c0f56eda44b08f..3b36d6d37edeea5a002764c10da59065b862f7b0 100644
--- a/sammy/src/fgm/mfgm4.f
+++ b/sammy/src/fgm/mfgm4.f
@@ -10,7 +10,7 @@ C *** PERFORM INTEGRATION FOR DOPPLER-BROADENING FROM POINT NUMBER
C *** Kc TO POINT NUMBER Iup
C
use fixedi_m, only : Niniso, Ndaxxx, Ndbxxx,
- * Ndasig, Ndbsig, Nvadif, Nvpall
+ * Ndasig, Ndbsig, Nvpall
use ifwrit_m, only : Kdebug, Ksolve
use brdd_common_m, only : Ipnts, Kc
use fgm2_m
@@ -217,7 +217,7 @@ C
IF (Ktempx.LE.0 .OR. (Ksolve.EQ.2 .AND. Ktempx.LE.Nvpall)) THEN
GO TO 200
ELSE
- K = Ktempx - Nvadif - Ndasig
+ K = Ktempx - Ndasig
DO N=1,Na
Db(N,K) = Derdop(N)*Ddo*0.5d0/Tempx
C Derdop already has 1/Em built in
diff --git a/sammy/src/fin/mfin0.f90 b/sammy/src/fin/mfin0.f90
index 77b7ee578c063699f67251f46d621fcaee2838da..94df9c11d8bc348b7ae7c321a0c4a2cf986b5159 100644
--- a/sammy/src/fin/mfin0.f90
+++ b/sammy/src/fin/mfin0.f90
@@ -234,7 +234,7 @@ module fin
A_Iprbgf , I_Iflbgf , A_Idebgf , I_Indbgf , A_Ibgfmi , &
A_Ibgfma , A_Iprdtp , I_Ifldtp , A_Idedtp , &
A_Iprusd , A_Iprbag , I_Iflbag , &
- A_Iddcov , A_Iux , Ratio, &
+ A_Iux , Ratio, &
0, 1, relevantData, .true.)
! *** Routine Oldord reorders parameters into original order,
! *** and writes the new PARameter file
diff --git a/sammy/src/fin/mfin1.f90 b/sammy/src/fin/mfin1.f90
index b9fc4155f888dc3eaf3859132517ed8d227a1d5c..4bf88e1e4f8110f6a98452941030e34189ce31ee 100644
--- a/sammy/src/fin/mfin1.f90
+++ b/sammy/src/fin/mfin1.f90
@@ -384,7 +384,7 @@ module fin1
DO Ires=1,resParData%getNumResonances()
Jpken = 0
call resParData%getResonanceInfo(resInfo, Ires)
- IF (resInfo%getEnergyFitOption().GE.0) THEN ! why do we check E-fit here? We could only fit Gn,Gg,...
+ IF (resInfo%getIncludeInCalc()) THEN
call resParData%getResonance(resonance, resInfo)
call resParData%getRedResonance(resonanceRed, resInfo)
@@ -652,7 +652,7 @@ module fin1
Iiipar = 0
DO Ires=1,resParData%getNumResonances()
call resParData%getResonanceInfo(resInfo, Ires)
- IF (resInfo%getEnergyFitOption().GE.0) THEN
+ IF (resInfo%getIncludeInCalc()) THEN
call resParData%getResonance(resonance, resInfo)
call resParData%getRedResonance(resonanceRed, resInfo)
Igrp = resInfo%getSpinGroupIndex()
diff --git a/sammy/src/fin/mfin2.f90 b/sammy/src/fin/mfin2.f90
index 47d17b26acd9b5cd030bfd394061f9ef2c84f3c5..29af18d1e56ef157ea7aceb22bb101ed1754c3bd 100644
--- a/sammy/src/fin/mfin2.f90
+++ b/sammy/src/fin/mfin2.f90
@@ -302,7 +302,7 @@ module fin2
END IF
END DO
Ii = Nfpres + 1
- DO Iparq=Ii,Nfpall
+ DO Iparq=Ii,covData%getNumTotalParam()
Ipar = covData%getCovIndex(Iparq)
IF (.not.covData%isPupedParameter(Iparq)) THEN
DO Jparq=1,Iparq
diff --git a/sammy/src/fin/mfin3.f90 b/sammy/src/fin/mfin3.f90
index 68c3e2ef99331fd329c849fcd63dec7115af9f61..8a08a3030c2e3de37b62f380ab95af5935efaae6 100644
--- a/sammy/src/fin/mfin3.f90
+++ b/sammy/src/fin/mfin3.f90
@@ -17,7 +17,7 @@ module fin3
Parnbk, Iflnbk, Delnbk, &
Parbgf, Iflbgf, Delbgf, Kndbgf, Bgfmin, Bgfmax, &
Pardtp, Ifldtp, Deldtp, &
- Parusd, Parbag, Iflbag, Ddcov , &
+ Parusd, Parbag, Iflbag, &
Uncxxx, Ratio, Iuxx , If_Pub, &
relevantData, resetFitFlags)
!
@@ -54,7 +54,7 @@ module fin3
Parnbk(*), Iflnbk(*), Delnbk(*), &
Parbgf(*), Iflbgf(*), Delbgf(*), Kndbgf(*), Bgfmin(*), &
Bgfmax(*), Pardtp(*), Ifldtp(*), Deldtp(*), Parusd(*), &
- Parbag(*), Iflbag(*), Ddcov (*), &
+ Parbag(*), Iflbag(*), &
Uncxxx(Ntotc2,*), Ratio(*)
!
! DIMENSION Parbrd(Numbrd), Iflbrd(Numbrd),
@@ -77,10 +77,10 @@ module fin3
! * Kndbgf(Numbgf), Bgfmin(Numbgf), Bgfmax(Numbgf),
! * Pardtp(Numdtp), Ifldtp(Numdtp), Parusd(Numusd),
! * Parbag(Numusd), Iflbag(Numusd),
-! * Ddcov(Nres),
! * Uncxxx(Ntotc2,Nres)
!
!
+
CALL Newopn (38, Sam38x, 0)
CALL Newopn (36, Sam36x, 0)
IF (Ifrel.EQ.1) CALL Newopn (40, Sam40x, 0)
@@ -91,7 +91,7 @@ module fin3
END IF
!
IF (resParData%getNumResonances().GT.0) THEN
- CALL Ordres (Iflpol, Ddcov, &
+ CALL Ordres (Iflpol, &
Uncxxx, Ratio, If_Pub, &
relevantData, resetFitFlags)
ELSE
@@ -217,7 +217,7 @@ module fin3
!
! ----------------------------------------------------------------
!
- SUBROUTINE Ordres ( Iflpol, Ddcov, &
+ SUBROUTINE Ordres ( Iflpol, &
Uncxxx, Ratio, &
If_Pub, relevantData, resetFitFlags)
!
@@ -240,15 +240,14 @@ module fin3
type(SammyResonanceInfo)::resInfo,resRelInfo
type(RMatResonance)::resonance, resonanceRel, resonanceRed
logical::resetFitFlags
+ real(kind=8)::Ddcov
DATA Ww /'Width_'/, Uu /'Uncer_'/
!
type(SammyRMatrixParameters)::relevantData
type(ResonanceCovariance)::physCov
integer,allocatable::ifits(:)
DIMENSION Iflpol(2,*), &
- Ddcov(*), Uncxxx(Ntotc2,*), Ratio(*)
-!
-!
+ Uncxxx(Ntotc2,*), Ratio(*)
Tab = CHAR(9)
Ifk = If_Pub*Kpblsh
IF (Ifk.GT.0) then
@@ -270,6 +269,7 @@ module fin3
! Get original input order
call resParData%getResonanceInfoByInput(resInfo, Nn, N)
call resParData%getResonance(resonance, resInfo)
+ Ddcov = resInfo%getXVal()
! rewrite fit flag data to parameter flags, i.e. 0, 1, 3
@@ -343,7 +343,7 @@ module fin3
if (ig.lt.0) ig = -1 * ig
CALL Reswrt (resonance%getEres(), resonance, Ifits(1:N2), &
- IgroupW, Ddcov(N), spinInfo%getNumChannels(), &
+ IgroupW, Ddcov, spinInfo%getNumChannels(), &
Kdecpl, Kenunc, Kkkgrp, 38)
! repeat for reduced resonance parameters
call resParData%getRedResonance(resonanceRed, resInfo)
@@ -354,7 +354,7 @@ module fin3
PSQR = -dSQRT(-resonanceRed%getEres())
END IF
CALL Reswrt (PSQR, resonanceRed, Ifits, &
- IgroupW, Ddcov(N), spinInfo%getNumChannels(), Kdecpl, &
+ IgroupW, Ddcov, spinInfo%getNumChannels(), Kdecpl, &
Kenunc, Kkkgrp, 36)
IF (Ifrel.EQ.1) then
@@ -364,7 +364,7 @@ module fin3
call relevantData%getResonanceInfoByInput(resRelInfo, Nn, N)
call relevantData%getResonance(resonanceRel, resRelInfo)
CALL Reswrt (resonanceRel%getEres(),resonanceRel, &
- Ifits(N2+1:2*N2), IgroupW, Ddcov(N), &
+ Ifits(N2+1:2*N2), IgroupW, Ddcov, &
spinInfo%getNumChannels(), Kdecpl, Kenunc, &
Kkkgrp, 40)
end if
diff --git a/sammy/src/fin/mfin4.f90 b/sammy/src/fin/mfin4.f90
index 4d525c630f00d9e4bef7f02ee9b1a1b4653aa7eb..00c55e70a4bb0c43566a30dbb353551bafc08e3a 100644
--- a/sammy/src/fin/mfin4.f90
+++ b/sammy/src/fin/mfin4.f90
@@ -598,9 +598,6 @@ module fin4
WRITE (Iunit,10700) Iflmsc(I), Iflmsc(I+1), Parmsc(I), &
Delmsc(I), Parmsc(I+1), Delmsc(I+1)
10700 FORMAT ('%14SELFI', 2I2, 1X, 4F30.15)
-!
- ELSE IF (Kconcr.EQ.I) THEN
-! *** constant cross section, if I ever get this finished !
!
ELSE IF (Kefcap.EQ.I) THEN
WRITE (Iunit,10900) Iflmsc(I), Iflmsc(I+1), Parmsc(I), &
diff --git a/sammy/src/fin/mfin5.f90 b/sammy/src/fin/mfin5.f90
index 94c872ae23ad80e62ef1c527c5caed39e00cea09..37cbbaa412e9581cb01599a82ac74d5df5062f31 100644
--- a/sammy/src/fin/mfin5.f90
+++ b/sammy/src/fin/mfin5.f90
@@ -533,7 +533,10 @@ module fin5
!
WRITE (Iu64) Versn
!# WRITE (Iu64) 'B01ZYX', 300, 0
- WRITE (Iu64) Lf
+ lfdim(56) = covData%getPupedParam()
+ lfdim(52) = covData%getNumTotalParam() - &
+ Numusd - Numdtp
+ WRITE (Iu64) Lfdim
!
! *** WRITE COVARIANCE FOR PHYSICAL PARAMETERS ONTO OUTPUT FILE
!
diff --git a/sammy/src/grp/mgrp0.f b/sammy/src/grp/mgrp0.f
index 283636bff149f36dc1c72ce549460ae88231ef89..e07ac680b22a9f3d3449877b50088a75991143d4 100644
--- a/sammy/src/grp/mgrp0.f
+++ b/sammy/src/grp/mgrp0.f
@@ -114,7 +114,7 @@ C - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
call allocate_integer_data(I_Ikmn, Ndatq)
call allocate_integer_data(I_Ikmx, Ndatq)
C *** Grpavg calculates group-averaged cross section
- CALL Grpavg (I_Iiuif , A_Iemn , A_Iemx , A_Iebond ,
+ CALL Grpavg (A_Iemn , A_Iemx , A_Iebond ,
* A_Ibonda , A_Iwsigx , A_Iwdasi , A_Iwdbsi , Weights,
* A_Iemmmq , A_Idum, A_Iwts, A_Ivsigx , A_Ivdasi , A_Ivdbsi ,
* A_Ifintg , A_Iaa, A_Ix3, I_Ikmn, I_Ikmx, Sig000,
diff --git a/sammy/src/grp/mgrp3.f b/sammy/src/grp/mgrp3.f
index 786e24da9e955de1d451a29ebc1de95172675dde..479db322435fcab8d047a36f3c3ef786efdcdffc 100644
--- a/sammy/src/grp/mgrp3.f
+++ b/sammy/src/grp/mgrp3.f
@@ -2,7 +2,7 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Grpavg (Iuif, Emn, Emx, Ebonda, Bondar,
+ SUBROUTINE Grpavg (Emn, Emx, Ebonda, Bondar,
* Wsigxx, Wdasig, Wdbsig, Weight, Emmmq, Dum, Wts, Vsigxx, Vdasig,
* Vdbsig, Fintgr, Aa, X, Kmn, Kmx, Sig000, Kdatb, Ndatq,
* Nbonda, Ngbxxx, Jx)
@@ -24,7 +24,7 @@ C
C
C
type(SammyGridAccess)::grid
- DIMENSION Iuif(*), Emn(*), Emx(*),
+ DIMENSION Emn(*), Emx(*),
* Ebonda(*), Bondar(*), Wsigxx(*), Wdasig(Ndaxxx,*),
* Wdbsig(Ndbxxx,*), Weight(*), Emmmq(*), Dum(*), Wts(*),
* Vsigxx(Nnnsig,*), Vdasig(Nnnsig,Ndaxxx,*),
@@ -87,7 +87,7 @@ C *** Multiply Wts by integrands and add; combine results
C
Ndatqq = (Ndatq*(Ndatq+1))/2
C *** figure covariance matrix
- CALL Fixcov_Mxw (Iuif, Emmmq, Wdasig, Wdbsig, X, Ndatq,
+ CALL Fixcov_Mxw (Emmmq, Wdasig, Wdbsig, X, Ndatq,
* Ndatqq)
C
CALL Qprint (Kaverg+1, Emn, Emx, Wsigxx, Emmmq, X, Ndatq)
diff --git a/sammy/src/inp/minp01.f b/sammy/src/inp/minp01.f
index 173648202bc2a674851c45ca9946972ad9500d5e..16330f04fee6cac410c1cdbe53f5e4e99ed585b8 100644
--- a/sammy/src/inp/minp01.f
+++ b/sammy/src/inp/minp01.f
@@ -61,6 +61,7 @@ C
use fixedr_m
use broad_common_m
use MultScatPars_common_m
+ use EndfData_common_m, only : covData
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
IF (Ngroup.GT.Ngr) THEN
@@ -224,8 +225,9 @@ C *** eight PAR
END IF
C
C *** nine PAR
- IF (Numpup.NE.0) THEN
- K = K + (Numpup*(Numpup+1))/2
+ npups = covData%getPupedParam()
+ IF (npups.NE.0) THEN
+ K = K + (npups*(npups+1))/2
END IF
C
C *** ------------------------------- end of set3
@@ -285,9 +287,9 @@ C
C EQUIVALENCE (Nvpres,Nvp(1)), (Nfpres,Nfp(1))
C
-C nvp => Nvpres => (common block start of nvpres section 1) or lf(3)
+C nvp => Nvpres => (common block start of nvpres section 1) or lfdim(3)
C
-C nfp => Nfpres => (common block start of nfpres section 2) or lf(20)
+C nfp => Nfpres => (common block start of nfpres section 2) or lfdim(20)
C
IF (Lllmax.LT.1000) Lllmax = 2*Lllmax + 1
IF (Lllmax.GE.1000) Lllmax = 0
@@ -517,18 +519,16 @@ C
Nvpall = 0
DO I=1,15
!Nvpall = Nvpall + Nvp(I)
- Nvpall = Nvpall + lf(2+i)
+ Nvpall = Nvpall + lfdim(2+i)
END DO
call covData%setNumParameters(Nvpall)
Nfpall = 0
DO I=1,15
!Nfpall = Nfpall + Nfp(I)
- Nfpall = Nfpall + lf(19 + I)
+ Nfpall = Nfpall + lfdim(19 + I)
END DO
call covData%resetTotalParam(Nfpall)
-
- Numpup = Nfpall - Nvpall
C
N = (Nfpall+Numusd+Numbag+1)
C
diff --git a/sammy/src/inp/minp02.f b/sammy/src/inp/minp02.f
index 093f68e7517d7c99725608b1b97240f135c92189..10c7debb975579702c794ce2f0cf9800719d8606 100644
--- a/sammy/src/inp/minp02.f
+++ b/sammy/src/inp/minp02.f
@@ -163,14 +163,14 @@ C
Nvpall = 100
call covData%setNumParameters(Nvpall)
DO I=1,57
- lf(i) = 0
+ lfdim(i) = 0
END DO
Numbrd = Numbrdx
Kvpbrd = 0
DO I=1,9
!Kipall(I) = -1
- lf(57 + I) = -1
+ lfdim(57 + I) = -1
END DO
Kipbrd = -1
diff --git a/sammy/src/inp/minp18.f b/sammy/src/inp/minp18.f
index a451efd4540b0682f325afd48d82e5f4bb80fb71..3eb849972600a368c8d85fa410056f1fcee45469 100644
--- a/sammy/src/inp/minp18.f
+++ b/sammy/src/inp/minp18.f
@@ -803,6 +803,7 @@ C
IF (J.EQ.3) K3 = K3 + 1
C
ELSE IF (Charac.EQ.Concrz) THEN
+ stop 'Adding of a constant cross section is not supported'
Nummsc = Nummsc + 2
N = N + 2
IF (I.EQ.1) K1 = K1 + 1
diff --git a/sammy/src/int/mint0.f b/sammy/src/int/mint0.f
index c5f0b47caf435c20896a28b086589e1d9c0c0228..1e0a02f24d4365ea8ee309c54f7014aca8a6369a 100644
--- a/sammy/src/int/mint0.f
+++ b/sammy/src/int/mint0.f
@@ -38,7 +38,7 @@ C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
IF (Jjjdop.EQ.1) THEN
C (intermediate results, using Leal-Hwang Energy grid)
- CALL Leal_Hwang (Nblmax, I_Iiuif )
+ CALL Leal_Hwang (Nblmax)
C
ELSE IF (Segnam.NE.'sambrd') THEN
C (intermediate results, using regular auxiliary grid)
diff --git a/sammy/src/int/mint0a.f b/sammy/src/int/mint0a.f
index b7cd6dfb8dea81cc9a3162a3e29394a84006e3c2..dac025c11b69cc90e4f2b80e50f39dbe7d3a6a69 100644
--- a/sammy/src/int/mint0a.f
+++ b/sammy/src/int/mint0a.f
@@ -61,7 +61,7 @@ C
Nanb = Nnnsig*Ndasig
call allocate_integer_data(I_Jjjder, Nanb)
call allocate_integer_data(I_Jjjpar, Nanb)
- CALL Out_Deriv (I_Ixciso , A_Iwdasi , gridAccess,I_Iiuif,
+ CALL Out_Deriv (I_Ixciso , A_Iwdasi , gridAccess,
* I_Jjjder , I_Jjjpar, Nnnsig, Ndasig, Nanb, 1, Jgbmax,
* 0)
END IF
@@ -69,7 +69,7 @@ C
Nanb = Nnnsig*Ndbsig
call allocate_integer_data(I_Jjjder, Nanb)
call allocate_integer_data(I_Jjjpar, Nanb)
- CALL Out_Deriv (I_Ixciso , A_Iwdbsi , gridAccess,I_Iiuif,
+ CALL Out_Deriv (I_Ixciso , A_Iwdbsi , gridAccess,
* I_Jjjder, I_Jjjpar, Nnnsig, Ndbsig, Nanb, Niniso,
* Jgbmax, 1)
END IF
@@ -83,7 +83,6 @@ C
call allocate_integer_data(I_Jjjder, Nanb)
call allocate_integer_data(I_Jjjpar, Nanb)
CALL Out_Deriv (I_Ixciso , A_Iwdass , gridAccess,
- * I_Iiuif,
* I_Jjjder, I_Jjjpar, 1, Ndasig, Nanb, 1, Jgbmax,0)
END IF
IF (Ndbsig.GT.0) THEN
@@ -91,7 +90,6 @@ C
call allocate_integer_data(I_Jjjder, Nanb)
call allocate_integer_data(I_Jjjpar, Nanb)
CALL Out_Deriv (I_Ixciso , A_Iwdbss , gridAccess,
- * I_Iiuif,
* I_Jjjder, I_Jjjpar, 1, Ndbsig, Nanb, Kiniso,
* Jgbmax, 1)
END IF
@@ -163,14 +161,14 @@ C
Nanb = Nnnsig*Ndasig
call allocate_integer_data(I_Jjjder, Nanb)
call allocate_integer_data(I_Jjjpar, Nanb)
- CALL Out_Deriv (I_Ixciso , A_Iwdasi , gridAccess, I_Iiuif,
+ CALL Out_Deriv (I_Ixciso , A_Iwdasi , gridAccess,
* I_Jjjder, I_Jjjpar, Nnnsig, Ndasig, Nanb, 1, Ndat, 0)
END IF
IF (Ndbsig.GT.0) THEN
Nanb = Nnnsig*Ndbsig
call allocate_integer_data(I_Jjjder, Nanb)
call allocate_integer_data(I_Jjjpar, Nanb)
- CALL Out_Deriv (I_Ixciso , A_Iwdbsi , gridAccess, I_Iiuif,
+ CALL Out_Deriv (I_Ixciso , A_Iwdbsi , gridAccess,
* I_Jjjder, I_Jjjpar, Nnnsig, Ndbsig, Nanb, 1, Ndat, 1)
END IF
END IF
@@ -187,9 +185,9 @@ C
C *** seven ***
C - - - - - - - - - - - - - <
call allocate_real_data(A_Idd, Ndat)
- call allocate_real_data(A_Ide, Nfpall)
+ call allocate_real_data(A_Ide, covData%getNumTotalParam())
call allocate_real_data(A_Ivarda, Ndat)
- CALL Pdwrit (A_Idd, A_Ivarda, A_Iwdasi , A_Ide, I_Iiuif)
+ CALL Pdwrit (A_Idd, A_Ivarda, A_Iwdasi , A_Ide)
deallocate(A_Idd)
deallocate(A_Ide)
deallocate(A_Ivarda)
diff --git a/sammy/src/int/mint2.f90 b/sammy/src/int/mint2.f90
index ce55d22560bf0edddabacd691396c2c9ff928b3a..5ef582c4f0776fce1becc226a9099599d52d58a6 100644
--- a/sammy/src/int/mint2.f90
+++ b/sammy/src/int/mint2.f90
@@ -191,7 +191,7 @@ module mint2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Out_Deriv (Ixciso, Vd, grid, Iuif, Jjder, Jjpar, &
+ SUBROUTINE Out_Deriv (Ixciso, Vd, grid, Jjder, Jjpar, &
Na, Nb, Nanb, Nc, Nd, Iff)
!
! *** PURPOSE -- OUTPUT E VS derivatives
@@ -205,90 +205,120 @@ module mint2_m
use titles_b30_common_m
use EndfData_common_m
use SammyGridAccess_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ IMPLICIT none
!
type(SammyGridAccess)::grid
- DIMENSION Ixciso(*), Vd(Nanb,Nc,*), Iuif(*), Jjder(*), Jjpar(*)
-! DIMENSION Vd(Nanb,Nc,Nd), Iuif(Nfpres)
+ real(kind=8)::Vd(Nanb,Nc,*)
+ integer::Ixciso(*), Jjder(*), Jjpar(*)
+ integer::Maxcol
+ integer::Nanb, Na, Nb, Nc, Nd, Iff
+ integer::Ifw, I, Ii, Ip, Iso, Isox, Iwrite, J
+ integer::Max, Min, N, Nnn, Iipar, Ipos, nn
+ integer,allocatable,dimension(:)::positioner, params
+ logical::wroteHeader, wroteIso ! ensure header and isotope header are only printed once
+
!
Data Maxcol /4/
!
!
Nnn = Nd
- WRITE (21,99999) Partia
+ wroteHeader = .false.
+ wroteIso = .false.
+ allocate(positioner(Maxcol))
+ allocate(params(Maxcol))
!
DO Iso=1,Nc
Iwrite = 0
Isox = Iso
- IF (Nc.GT.1) WRITE (21,10000) Iso
+ Ipos = 0
+ wroteIso =.false.
10000 FORMAT (/, ' *** Nuclide Number', I3)
IF (Nc.NE.Numiso .OR. Ixciso(Iso).NE.1) THEN
!
- Iipar = 0
Ip = 0
+ Ipos = 0
IF (Iff.EQ.0) THEN
DO Ii=1,Nfpres
- IF (Iuif(Ii).NE.1) THEN
- Iipar = Iipar + 1
- DO J=1,Na
- Ip = Ip + 1
- Jjder(Ip) = J
- Jjpar(Ip) = Ii
+ Iipar = Iipar + 1 ! count the derivatives of all resonance parameters
+ IF (covData%contributes(Ii)) THEN ! count only the ones that contribute
+ DO J=1,Na ! loop over angles, which might be 1 (=numcro in most other places)
+ Ipos = Ipos + 1
+ Jjder(Ipos) = J ! the angle index for this derivative
+ Jjpar(Ipos) = Ii ! the index of the resonance for which this derivative is given
END DO
END IF
END DO
- N = Iipar + 1
- IF (N.GT.Nb) GO TO 50
+ N = Nfpres + 1 ! we count all varied resonance parameters
+ IF (N.GT.Nb) GO TO 50 ! if Nb (other varied parameters) does not exist, we are done
Ii = Nfpres + 1
ELSE
- Ii = Ndasig + Nvadif + 1
+ Ii = 1 ! no resonance parameters are varied, skip right to the other parameters
N = 1
END IF
- DO Iipar=N,Nb
- DO J=1,Na
- Ip = Ip + 1
- Jjder(Ip) = J
- Jjpar(Ip) = Ii
+ DO Iipar=N,Nb ! count the remaining derivatives by index
+ DO J=1,Na ! and angle
+ Ipos = Ipos + 1
+ Jjder(Ipos) = J
+ Jjpar(Ipos) = Ii
END DO
Ii = Ii + 1
END DO
50 CONTINUE
-!
+!
Min = 1
- Max = MIN0 (Maxcol, Nanb)
+ Max = MIN0 (Maxcol, Ipos)
60 CONTINUE
- CALL Chzero (Vd, Nanb, Nc, Nd, Min, Max, Isox, Ifw)
- IF (Ifw.NE.0) THEN
+ do I = Min, Max
+ ip = Jjpar(I)
+ Ii = Jjder(I)
+ positioner(I - Min + 1) = (ip-1)*Na + ii ! position of the desired derivative in array Vd
+ params(I-Min+1) = ip ! index to print
+ if (Iff.Ne.0) params(I-Min+1) = params(I-Min+1) + Ndasig ! which needs to be corrected if all parameters are printed
+ end do
+ CALL Chzero (Vd, Nanb, Nc, Nd, Min, Max, Isox, Ifw, positioner) ! check whether there are any non-zero derivatives in this block
+ IF (Ifw.NE.0) THEN ! if so, print
Iwrite = 1
+ if (.not.wroteHeader) WRITE (21,99999) Partia ! make sure header is only printed once
+ wroteHeader = .true.
+ IF (Nc.GT.1) then ! add isotope header if needed, but only once
+ if(.not.wroteIso) WRITE (21,10000) Iso
+ end if
+ wroteIso = .true.
+
IF (Nnnsig.EQ.1) THEN
WRITE (21,99998) Parame
99999 FORMAT (//, ' ***** ', A50)
- WRITE (21,99997) Chaene, (Jjpar(Ip),Ip=Min,Max)
+ WRITE (21,99997) Chaene, (params(Ip-min+1),Ip=Min,Max)
ELSE IF (Nnnsig.GT.1) THEN
WRITE (21,99988)
99988 FORMAT (20X, 'CROSS SECTION # / PARAMETER #')
- WRITE (21,89997) Chaene, (Jjder(Ip),Jjpar(Ip), &
+ WRITE (21,89997) Chaene, (Jjder(Ip),params(Ip-min+1), &
Ip=Min,Max)
ELSE IF (Nnnsig.LT.1) THEN
STOP '[STOP in Out_Deriv in int/mint2.f]'
END IF
DO J=1,Nnn
- WRITE (21,99996) J, grid%getEnergy(J, expData), (Vd(I,Iso,J),I=Min,Max)
+ WRITE (21,99996) J, grid%getEnergy(J, expData), (Vd( positioner(I-Min+1),Iso,J),I=Min,Max)
END DO
END IF
Min = Max + 1
- IF (Min.LE.Nanb) THEN
+ IF (Min.LE.Ipos) THEN
Max = Max + Maxcol
- IF (Max.GT.Nanb) Max = Nanb
+ IF (Max.GT.Ipos) Max = Ipos
GO TO 60
END IF
END IF
- IF (Iwrite.EQ.0) THEN
+ IF (Iwrite.EQ.0.and.Ipos.ne.0) THEN
+ ! if desired, print that there are no non-zero derivatives
+ if (.not.wroteHeader) WRITE (21,99999) Partia
+ wroteHeader = .true.
WRITE (21,20000)
20000 FORMAT ('There are no non-zero derivatives of this type for' &
, 1x, 'this nuclide.', /)
END IF
END DO
+ deallocate(positioner)
+ deallocate(params)
!
RETURN
!
@@ -301,14 +331,18 @@ module mint2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Chzero (Vd, Nanb, Nc, Nd, Min, Max, Isox, Ifw)
+ SUBROUTINE Chzero (Vd, Nanb, Nc, Nd, Min, Max, Isox, Ifw, ipos)
use fixedi_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Vd(Nanb,Nc,*)
+ IMPLICIT None
+ integer::Nanb, Nc, Nd, Min, Max, Isox, Ifw
+ real(kind=8):: Vd(Nanb,Nc,*)
+ integer::ipos(*)
+ integer::index, I, J
Ifw = 0
DO J=1,Nd
DO I=Min,Max
- IF (Vd(I,Isox,J).NE.0.0d0) THEN
+ index = ipos(I - Min + 1)
+ IF (Vd(index,Isox,J).NE.0.0d0) THEN
Ifw = 1
RETURN
END IF
diff --git a/sammy/src/int/mint4.f b/sammy/src/int/mint4.f
index c1d7c0c1fdda2ee1bc1bf376a1516cfe6b00a13b..ce404a0d5ece97a9e283de7db721eb432ce63ae5 100644
--- a/sammy/src/int/mint4.f
+++ b/sammy/src/int/mint4.f
@@ -2,7 +2,7 @@ C
C
C _________________________________________________________________
C
- SUBROUTINE Pdwrit (Data, Vardat, Wdasig, Deriv, Iuif)
+ SUBROUTINE Pdwrit (Data, Vardat, Wdasig, Deriv)
C
use fixedi_m
use ifwrit_m
@@ -12,12 +12,13 @@ C
use cbro_common_m
use lbro_common_m
use EndfData_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ IMPLICIT none
C
type(GridData)::grid
- DIMENSION Data(*), Vardat(*), Wdasig(Nnpar,*), Deriv(*), Iuif(*)
-C Data(Ndat), Vardat(Ndat), Wdasig(Nnpar,Ndat), Deriv(Nfpall),
-C * Iuif(Nfpall)
+ real(kind=8)::Data(*), Vardat(*), Wdasig(Nnpar,*), Deriv(*)
+ integer::I, idat, Ii, Iipar, Ipar, ipos
+ real(kind=8)::val
+C Data(Ndat), Vardat(Ndat), Wdasig(Nnpar,Ndat), Deriv(Nfpall)
C
C
C For now assume only one grid
@@ -38,7 +39,7 @@ C
STOP '[STOP in Pdwrit in int/mint4.f]'
END IF
C
- IF (Numpup.GT.0) THEN
+ IF (covData%getPupedParam().GT.0) THEN
WRITE (6,10200)
WRITE (21,10200)
10200 FORMAT ('Cannot write out partial derivatives if there are PUPped
@@ -48,18 +49,14 @@ C
C
C
DO Idat=1,Ndat
- Ipar = 0
- Iipar = 0
DO Ii=1,Nfpres
- Ipar = Ipar + 1
- Deriv(Ipar) = 0.0d0
- IF (Iuif(Ii).NE.1) THEN
- Iipar = Iipar + 1
- Deriv(Ipar) = Wdasig(Iipar,Idat)
+ Deriv(Ii) = 0.0d0
+ IF (covData%contributes(Ii)) THEN
+ Deriv(Ii) = Wdasig(Ii,Idat)
END IF
END DO
WRITE (71,10000) Data(Idat), Vardat(Idat),
- * (Deriv(Ipar),Ipar=1,Nfpall)
+ * (Deriv(Ipar),Ipar=1,covData%getNumTotalParam())
END DO
C
CLOSE (UNIT=71)
diff --git a/sammy/src/int/mint6.f b/sammy/src/int/mint6.f
index 9fd2f2a488d2a42e7b782dc2630c827afbfa1d9c..135ad4946223656164c326748701aa06329c4763 100644
--- a/sammy/src/int/mint6.f
+++ b/sammy/src/int/mint6.f
@@ -2,7 +2,7 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Leal_Hwang (Nblmax, I_Iuif)
+ SUBROUTINE Leal_Hwang (Nblmax)
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -26,7 +26,6 @@ C
type(SammyGridAccess)::gridAccess
integer,allocatable,dimension(:)::I_Jjjder, I_Jjjpar
integer::nauxStart
- DIMENSION I_Iuif(*)
real(kind=8),allocatable,dimension(:)::A_Idum, A_Iblock
C
C *** Here when using Leal-Hwang so need to interpolate to present results
@@ -61,7 +60,7 @@ C
Nanb = Nnnsig*Ndasig
call allocate_integer_data(I_Jjjder, Nanb)
call allocate_integer_data(I_Jjjpar, Nanb)
- CALL Out_Deriv (I_Ixciso , A_Ivdasi , gridAccess,I_Iuif,
+ CALL Out_Deriv (I_Ixciso , A_Ivdasi , gridAccess,
* I_Jjjder, I_Jjjpar, Nnnsig, Ndasig, Nanb, 1, Ndat,
* 0)
END IF
@@ -69,7 +68,7 @@ C
Nanb = Nnnsig*Ndbsig
call allocate_integer_data(I_Jjjder, Nanb)
call allocate_integer_data(I_Jjjpar, Nanb)
- CALL Out_Deriv (I_Ixciso , A_Ivdbsi , gridAccess, I_Iuif,
+ CALL Out_Deriv (I_Ixciso , A_Ivdbsi , gridAccess,
* I_Jjjder , I_Jjjpar, Nnnsig, Ndbsig, Nanb, Niniso,
* Ndat, 1)
END IF
@@ -83,7 +82,6 @@ C
call allocate_integer_data(I_Jjjder, Nanb)
call allocate_integer_data(I_Jjjpar, Nanb)
CALL Out_Deriv (I_Ixciso , A_Ivdass , gridAccess,
- * I_Iuif,
* I_Jjjder, I_Jjjpar , 1, Ndasig, Nanb, 1, Ndat, 0)
END IF
IF (Ndbsig.GT.0) THEN
@@ -91,7 +89,6 @@ C
call allocate_integer_data(I_Jjjder, Nanb)
call allocate_integer_data(I_Jjjpar, Nanb)
CALL Out_Deriv (I_Ixciso , A_Ivdbss , gridAccess,
- * I_Iuif,
* I_Jjjder , I_Jjjpar, 1, Ndbsig, Nanb, Niniso,
* Ndat, 1)
END IF
diff --git a/sammy/src/ipq/mipq0.f b/sammy/src/ipq/mipq0.f
index 4dd5d7a99f9fac3d25f1e59868c3e810ef19eb75..445e33026a64269210dea19bb8821cb44693ae2b 100644
--- a/sammy/src/ipq/mipq0.f
+++ b/sammy/src/ipq/mipq0.f
@@ -177,8 +177,9 @@ C
SUBROUTINE Estx (Nnndat, Jidc1, Jidc3, Kkkidc, Numidc,
* N1, N2, K1, Kdat, Izz)
C
- use fixedi_m, only : Numcro, Numpup, Nvpall
+ use fixedi_m, only : Numcro, Nvpall
use ifwrit_m, only : Kidcxx, Ndat, Ntgrlq
+ use EndfData_common_m, only : covData
use samxxx_common_m, only : Sam30x
IMPLICIT None
integer::Nnndat, Jidc1, Jidc3, Kkkidc, Numidc,
@@ -211,10 +212,10 @@ C --- start of Get_Idc
Jidc1 = Kkkidc**2
Jidc3 = Kkkidc*Nvpall
K4 = Jidc1 + Ndat + Ndat
- ELSE IF (Numpup.GT.0) THEN
+ ELSE IF (covData%getPupedParam().GT.0) THEN
C *** Here PUPs are used, but no other kind of IDCM
- Jidc1 = Numpup**2
- Jidc3 = Numpup*Nvpall
+ Jidc1 = covData%getPupedParam()**2
+ Jidc3 = covData%getPupedParam()*Nvpall
K4 = Jidc1
ELSE
K4 = 0
diff --git a/sammy/src/ipq/mipq1.f90 b/sammy/src/ipq/mipq1.f90
index 8fd3977db061ba3b2dbc86dd07a8eda76f712406..5517bbfd533f71b40f04407071b18d3707f54862 100644
--- a/sammy/src/ipq/mipq1.f90
+++ b/sammy/src/ipq/mipq1.f90
@@ -211,7 +211,8 @@ contains
!
use sammy_ipq_common_m, only :resultData,derivStart,npars, implicitInv
real(kind=8):: Dminth(:)
- real(kind=8):: Gvg(:,:), P1(:), Q(:,:), Gvx(:,:), Dvx(:)
+ real(kind=8):: Gvg(:,:), P1(:), Q(:,:)
+ real(kind=8),allocatable::Gvx(:,:), Dvx(:)
integer::Nnndat
integer::i, J, idat, Ipar, jpar, Kpar, Kkkpar, Ldat
diff --git a/sammy/src/mas/mmas0.f90 b/sammy/src/mas/mmas0.f90
index bc4bb01e7b08692e28dff40ec538693deec82be3..77d7368ac6a926cda2477cd250cbf7c0a527102a 100644
--- a/sammy/src/mas/mmas0.f90
+++ b/sammy/src/mas/mmas0.f90
@@ -64,7 +64,7 @@ module Sammas_0_m
!
CALL Timer (1)
! *** Zero all variables in B0?ZYX
- CALL Zero_Integer (Lf, 300)
+ Lfdim = 0
CALL Zero_Integer (Lwrit, 200)
!
Nsize = Msize
diff --git a/sammy/src/mlb/mmlb0.f b/sammy/src/mlb/mmlb0.f
index 7fbd9ed661960b71d31863e9224a8fe860c44f4b..a0e1197be6870fa411d6cab844c3def3d3ad4433 100644
--- a/sammy/src/mlb/mmlb0.f
+++ b/sammy/src/mlb/mmlb0.f
@@ -21,6 +21,7 @@ C
use AllocateFunctions_m
use rsl7_m
use xct_m
+ use EndfData_common_m, only : covData
use AuxGridHelper_M, only : setAuxGridOffset, setAuxGridRowMax
IMPLICIT DOUBLE PRECISION (a-h,o-z)
real(kind=8),allocatable,dimension(:)::A_Idum
@@ -46,7 +47,7 @@ C
Segmen(3) = 'B'
Nowwww = 0
C
- IF (Numpup.GT.0) THEN
+ IF (covData%getPupedParam().GT.0) THEN
WRITE (6,10100)
10100 FORMAT ('Breit-Wigner coding does not include options for', /,
* 'PUPs (Propagated-Uncertainty Parameters, Flag=3).', /,
@@ -76,10 +77,6 @@ C ### one ###
Ks_Res = Ksolve
CALL Set_Kws_Xct
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- call allocate_integer_data(I_Inprdr, Ngroup)
- IF (Ksolve.NE.2) CALL Ppar_Mlb (I_Iiuif , I_Inprdr)
-C *** SUBR Ppar_Mlb sets Nprdr
-C
C
C ### three ###
N = Ndatb
@@ -87,12 +84,7 @@ C ### three ###
call allocate_real_data(A_Iaaone, N)
call allocate_real_data(A_Iaatwo, N)
N = Ntriag*Ngroup
- call allocate_real_data(A_Iaathr, N)
- N = N1
- call allocate_real_data(A_Ipaone, N)
- call allocate_real_data(A_Ipatwo, N)
- N = N2
- call allocate_real_data(A_Ipathr, N)
+ call allocate_real_data(A_Iaathr, N)
N = Ntotc
call allocate_real_data(A_Ics, N) ! this was set equal to Ip
call allocate_real_data(A_Isi, N) ! this was set equal to Igami
@@ -118,10 +110,6 @@ C *** Sub Work generates Theory and derivatives
* A_Iwdbsi , A_Isigxx , A_Idasig , A_Idbsig , I_Iisopa ,
* A_Ipiece , A_Idum , A_Iadder , A_Iaddcr , I_Inbt ,
* I_Iint)
- deallocate(I_Inprdr)
- deallocate(A_Ipaone)
- deallocate(A_Ipatwo)
- deallocate(A_Ipathr)
deallocate(A_Ics)
deallocate(A_Isi)
deallocate(A_Idphi)
@@ -175,7 +163,7 @@ C
use rsl7_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
- N1 = Ntotc*Napres
+ N1 = Ntotc*Nfpres
IF (N1.EQ.0) N1 = 1
C ### one ###
CALL Figure_Kws_Cro (Kone)
@@ -184,7 +172,7 @@ C
C ### three ###
Ntriag = (Ntotc*(Ntotc+1))/2
N2 = 1
- IF (Ksolve.NE.2) N2 = Ntriag*Napres
+ N2 = Ntriag*Nfpres
N3 = 1
IF (Ksolve.NE.2) N3 = Ngbout
N5 = 1
diff --git a/sammy/src/mlb/mmlb1.f b/sammy/src/mlb/mmlb1.f
index 3b3b6e3d446483accf45c71aaac893f28a5a2934..46fb0ae2069fa7238cf2d72e5227998dd1272c7d 100644
--- a/sammy/src/mlb/mmlb1.f
+++ b/sammy/src/mlb/mmlb1.f
@@ -1,69 +1,5 @@
C
C --------------------------------------------------------------
-C
- SUBROUTINE Ppar_Mlb (Iuif, Nprdr)
-C
-C *** Purpose -- Set Nprdr(K) = Number of varied parameters in group K
-C
- use fixedi_m
- use ifwrit_m
- use EndfData_common_m
- use SammyResonanceInfo_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- type(SammyResonanceInfo)::resInfo
- type(SammySpinGroupInfo)::spinInfo
- DIMENSION Iuif(*), Nprdr(*)
-C DIMENSION Ntot(Ngroup),
-C * Iuif(Nvpres), Nprdr(Ngroup)
-C
- DO M=1,resParData%getNumSpinGroups()
- Nprdr(M) = 0
- END DO
- Ipar = 0
- Iipar = 0
- DO I=1,resParData%getNumResonances()
- call resParData%getResonanceInfo(resInfo, I)
- IF (resInfo%getIncludeInCalc()) THEN
- igrp = resInfo%getSpinGroupIndex()
- call resparData%getSpinGroupInfo(spinInfo, igrp)
- Mmax = spinInfo%getNumChannels()
- Mmax2 = spinInfo%getNumResPar()
- DO M=1,Mmax2
- if( m.eq.1) then
- Ifl = resInfo%getEnergyFitOption()
- else
- ifl = resInfo%getChannelFitOption(M-1)
- end if
- IF (Ifl.GT.0) THEN
- Ipar = Ipar + 1
- IF (Iuif(Ipar).NE.1) THEN
- Iipar = Iipar + 1
- Nprdr(Igrp) = Nprdr(Igrp) + 1
- END IF
- END IF
- END DO
- END IF
- END DO
-C
- IF (Ipar.NE.Nvpres) THEN
- WRITE (6,99998) Ipar, Nvpres
- WRITE (21,99998) Ipar, Nvpres
-99998 FORMAT (' PROBLEM IN Ppar_Mlb -- Nvpres NOT CORRECT', 2I5)
- STOP '[STOP in Ppar_Mlb in mlb/mmlb1.f]'
- END IF
-C
- IF (Iipar.NE.Napres) THEN
- WRITE (6,99999) Iipar, Napres
- WRITE (21,99999) Iipar, Napres
-99999 FORMAT (' PROBLEM IN Ppar_Mlb -- Napres NOT CORRECT', 2I5)
- STOP '[STOP in Ppar_Mlb in mlb/mmlb1.f # 2]'
- END IF
-C
- RETURN
- END
-C
-C --------------------------------------------------------------
C
SUBROUTINE Work_Mlb ( Iflmsc, Parnbk, Iflnbk, Parbgf,
* Iflbgf, Kndbgf, Bgfmin, Bgfmax, Texbgf, Teabgf,
@@ -214,10 +150,6 @@ C ********* If there is normalization or background ...
* Dbsigx, Su, Nnnsig)
END IF
C
-C ********* If adding a constant cross section, do so now
-C IF (Concro.NE.Zero) call Addcon (Sigxxx, Dbsigx,
-C * Iflmsc, Nnnsig)
-C
C ********* Write results onto Theory if there is no broadening etc
IF (Jjjdop.NE.1) THEN
Theory(Jdat) = Zero
diff --git a/sammy/src/mlb/mmlb2.f b/sammy/src/mlb/mmlb2.f
index f3dab763b4a2813bfa4813a149412c0080235b99..0cf5d246e78ab071f5f0e881a74946e42a96d7aa 100755
--- a/sammy/src/mlb/mmlb2.f
+++ b/sammy/src/mlb/mmlb2.f
@@ -19,11 +19,11 @@ C
C
C
CALL Abpart_Mlb (A_Iechan ,
- * I_Iiuif , A_Izkte , A_Iaaone , A_Iaatwo, A_Iaathr ,
- * A_Ipaone , A_Ipatwo , A_Ipathr,
+ * A_Izkte , A_Iaaone , A_Iaatwo, A_Iaathr ,
+ * A_Ipathr,
* A_Ics , A_Isi , A_Idphi )
C
- CALL Parsh_Mlb (I_Inprdr,
+ CALL Parsh_Mlb (
* A_Izke , A_Izkfe , I_Ifzke , I_Ifzkte , I_Ifzkfe ,
* A_Iaaone , A_Iaatwo , A_Iaathr , A_Ipiece , Ipoten,
* A_Isigxx , A_Idasig , A_Idbsig , I_Iisopa )
diff --git a/sammy/src/mlb/mmlb3.f b/sammy/src/mlb/mmlb3.f
index 2d6f241dbc80af95b5f24994365acb6281f57d9a..3e16f0978870b4df1bef0d2ffb8207bea5b83816 100644
--- a/sammy/src/mlb/mmlb3.f
+++ b/sammy/src/mlb/mmlb3.f
@@ -3,7 +3,7 @@ C
C --------------------------------------------------------------
C
SUBROUTINE Elastc_Mlb (Goj, Nent, Next, Zke, If_Zke, If_Zkte,
- * If_Zkfe, Aaaone, Aaatwo, Aaathr, Paaone, Paatwo, Paathr,
+ * If_Zkfe, Aaaone, Aaatwo, Aaathr,
* Cs, Si, Dphi, Sigxxx, Dasigx, Isopar, Iso)
C
C *** Purpose -- Generate Sigxxx = elastic cross section
@@ -14,10 +14,11 @@ C
use ifwrit_m
use varyr_common_m
use constn_common_m
+ use templc_common_m, only : A_Ibr, A_Ibi, A_Ipr
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
DIMENSION Zke(*), If_Zkfe(*), If_Zkte(*), Aaaone(*), Aaatwo(*),
- * Aaathr(*), Paaone(Ntotc,*), Paatwo(Ntotc,*), Paathr(Ntriag,*),
+ * Aaathr(*),
* Cs(*), Si(*), Dphi(*), Sigxxx(*), Dasigx(Nnnsig,*), Isopar(*)
DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/
C
@@ -47,14 +48,14 @@ C
IF (Krmatx.EQ.1) Sum = Sum + ( (One-Cs(J))*A + Si(J)*B + E ) *D
IF (Krmatx.EQ.-1) Sum = Sum + ( (One-Cs(J))*A + Si(J)*B +
* Aaathr(JJ) ) * D
- Ktru = If_Zkte(J) - Nvadif
- IF (Ktru.GT.0) THEN
+ Ktru = If_Zkte(J)
+ IF (Ktrue.gt.0.and.Ktru.LE.Ndasig) THEN
cq Dasigx(1,Ktru) = Dasigx(1,Ktru) + X
Cq *** note this is not right! don't have x defined yet! someday do it right!
Isopar(Ktru) = Iso
END IF
- Keff = IF_Zkfe(J) - Nvadif
- IF (Keff.GT.0) THEN
+ Keff = IF_Zkfe(J)
+ IF (Keff.Gt.0.and.Keff.LE.Ndasig) THEN
Dasigx(1,Keff) = Dasigx(1,Keff) +
* ( (Si(J)*A+Cs(J)*B)*Dphi(J) ) * C / Zke(J)
Isopar(Keff) = Iso
@@ -63,8 +64,8 @@ Cq *** note this is not right! don't have x defined yet! someday do it right!
C = Goj*Pi100/Su
Sigxxx(1) = C*Sum + Sigxxx(1)
IF (Ksolve.EQ.2) RETURN
- Kiso = If_Zke - Nvadif
- IF (Kiso.GT.0) THEN
+ Kiso = If_Zke
+ IF (Kiso.gt.0.and.Kiso.le.Ndasig) THEN
Dasigx(1,Kiso) = Dasigx(1,Kiso) + A/VarAbn
Isopar(Kiso) = Iso
END IF
@@ -77,23 +78,23 @@ C
Jj = 0
DO J=1,Nent
Jj = Jj + J
- Paatot = Paatwo(J,M)
+ Paatot = A_Ibi(J,M)
DO I=1,Ntot
IF (I.LE.J) THEN
Ij = (J*(J-1))/2 + I
ELSE
Ij = (I*(I-1))/2 + J
END IF
- Paatot = Paatot + Paathr(Ij,M)
+ Paatot = Paatot + A_Ipr(Ij,M)
END DO
IF (Krmatx.EQ.1) THEN
A = -One + Cs(J) + 0.5*Aaatot
B = Two*(SI(J)+Aaaone(J))
- Sum = Sum + (A*Paatot+B*Paaone(J,M))/Zke(J)**2
+ Sum = Sum + (A*Paatot+B*A_Ibr(J,M))/Zke(J)**2
ELSE IF (Krmatx.EQ.-1) THEN
A = -One + Cs(J)
B = Two*Si(J)
- Sum = Sum + (A*Paatot+B*Paaone(J,M)+Paathr(Jj,M)) /
+ Sum = Sum + (A*Paatot+B*A_Ibr(J,M)+A_Ipr(Jj,M)) /
* Zke(J)**2
ELSE
STOP '[STOP in Elastc_Mlb in mlb/mmlb3.f]'
@@ -110,7 +111,7 @@ C
C --------------------------------------------------------------
C
SUBROUTINE Reactn_Mlb (Goj, Nent, Next, Zke, If_Zke, If_Zkte,
- * Aaathr, Paathr, Sigxxx, Dasigx, Isopar, Iso)
+ * Aaathr, Sigxxx, Dasigx, Isopar, Iso)
C
C *** Purpose -- Generate Sigxxx = reaction cross section
C *** and Dasigx = partial derivative of reaction cross
@@ -120,11 +121,12 @@ C
use ifwrit_m
use varyr_common_m
use constn_common_m
+ use templc_common_m, only : A_Ipr
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
- DIMENSION Zke(*), If_Zkte(*), Aaathr(*), Paathr(Ntriag,*),
+ DIMENSION Zke(*), If_Zkte(*), Aaathr(*),
* Sigxxx(*), Dasigx(Nnnsig,*), Isopar(*)
-C DIMENSION Aaathr(ntriag), Paathr(Ntriag,Napres)
+C DIMENSION Aaathr(ntriag)
DATA Zero /0.0d0/
C
IF (Next.EQ.0) RETURN
@@ -137,7 +139,7 @@ C
C = Zero
DO J=1,Nent
B = A/Zke(J)**2
- Ktru = If_Zkte(J) - Nvadif
+ Ktru = If_Zkte(J)
IF (Ktru.GT.0) Dasigx(1,Ktru) = Dasigx(1,Ktru) + C
DO I=Nent1,NextN
IJ = (I*(I-1))/2 + J
@@ -152,7 +154,7 @@ C
Sig2 = Sum2 + Sig2
C
IF (Ksolve.EQ.2) RETURN
- Kiso = IF_Zke - Nvadif
+ Kiso = IF_Zke
IF (Kiso.GT.0) THEN
Dasigx(1,Kiso) = Dasigx(1,Kiso) + Sum/VarAbn
Isopar(Kiso) = Iso
@@ -165,7 +167,7 @@ C
B = A/Zke(J)**2
DO I=Nent1,Nextn
Ij = (I*(I-1))/2 + J
- Sum = Sum + Paathr(Ij,M)*B
+ Sum = Sum + A_Ipr(Ij,M)*B
END DO
END DO
Dasigx(1,M) = Sum + Dasigx(1,M)
@@ -179,7 +181,7 @@ C
C --------------------------------------------------------------
C
SUBROUTINE Captur_Mlb (Goj, Nent, Zke, If_Zke, If_Zkte, Aaatwo,
- * Paatwo, Sigxxx, Dasigx, Isopar, Iso)
+ * Sigxxx, Dasigx, Isopar, Iso)
C
C *** Purpose -- Generate Sigxxx = capture cross section
C *** and Dasigx = partial derivative of capture cross
@@ -189,9 +191,10 @@ C
use ifwrit_m
use varyr_common_m
use constn_common_m
+ use templc_common_m, only : A_Ibi
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
- DIMENSION Zke(*), If_Zkte(*), Aaatwo(*), Paatwo(Ntotc,*),
+ DIMENSION Zke(*), If_Zkte(*), Aaatwo(*),
* Sigxxx(*), Dasigx(Nnnsig,*), Isopar(*)
Data Zero /0.0d0/
C
@@ -199,7 +202,7 @@ C
B = Zero
DO I=1,Nent
Sum = Sum + Aaatwo(I)/Zke(I)**2
- Ktru = If_Zkte(I) - Nvadif
+ Ktru = If_Zkte(I)
IF (Ktru.GT.0) THEN
Dasigx(1,Ktru) = Dasigx(1,Ktru) + B
Isopar(Ktru) = Iso
@@ -208,7 +211,7 @@ C
A = Goj*Pi100/Su
Sigxxx(1) = A*Sum + Sigxxx(1)
IF (Ksolve.EQ.2) RETURN
- Kiso = If_Zke - Nvadif
+ Kiso = If_Zke
IF (Kiso.GT.0) THEN
Dasigx(1,Kiso) = Dasigx(1,Kiso) + A*Sum/VarAbn
Isopar(Kiso) = Iso
@@ -218,7 +221,7 @@ C
M = Kstart + Mm
Sum = Zero
DO I=1,Nent
- Sum = Sum + Paatwo(I,M)/Zke(I)**2
+ Sum = Sum + A_Ibi(I,M)/Zke(I)**2
END DO
Dasigx(1,M) = A*Sum + Dasigx(1,M)
Isopar(M) = Iso
diff --git a/sammy/src/mlb/mmlb4.f b/sammy/src/mlb/mmlb4.f
index 4e73b838ba481dfa861775657a5e488dd5c8fc9d..754f3782a0f86d9033f9616b88529a2e48fd1b00 100644
--- a/sammy/src/mlb/mmlb4.f
+++ b/sammy/src/mlb/mmlb4.f
@@ -2,8 +2,8 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Abpart_Mlb (Echan, Iuif, Zkte, Aaaone,
- * Aaatwo, Aaathr, Paaone, Paatwo, Paathr, P, Gami , Dphi)
+ SUBROUTINE Abpart_Mlb (Echan, Zkte, Aaaone,
+ * Aaatwo, Aaathr, P, Gami , Dphi)
C
C *** Purpose -- Generate Aaaone(I ,ig) = Gamma(I)*(E-Pken)/Den
C *** Aaatwo(I ,ig) = Gamma(I)*Gamgam /Den
@@ -21,7 +21,8 @@ C
use SammySpinGroupInfo_M
use EndfData_common_m
use RMatResonanceParam_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ use templc_common_m, only : I_Inotu, A_Ibr, A_Ibi, A_Ipr
+ IMPLICIT none
C
type(SammyResonanceInfo)::resInfo
type(SammySpinGroupInfo)::spinInfo
@@ -30,29 +31,32 @@ C
type(RMatParticlePair)::pair
type(RMatChannelParams)::channel
type(SammyChannelInfo)::channelInfo
- DIMENSION Echan(Ntotc,*), Iuif(*), Zkte(Ntotc,*),
+ real(kind=8):: Echan(Ntotc,*), Zkte(Ntotc,*),
* Aaaone(Ntotc,*), Aaatwo(Ntotc,*), Aaathr(Ntriag,*),
- * Paaone(Ntotc,*), Paatwo(Ntotc,*), Paathr(Ntriag,*),
* P(*), Gami(*), Dphi(*)
+ real(kind=8)::Zero, One
+ real(kind=8)::D, De, Den, E, eres, G, Gamgam, Gamj
+ real(kind=8)::gammaRed, Gamtot, Pfd
+ integer::I, ichan, Igr, Ij, Ipar, Ires, istart, Iflr
+ integer::J, K, L, Min, Ntott, Ig
+ real(kind=8)::W, Rho, width, X, Y, Z
C
C DIMENSION Ntot(Ngroup), Echan(Ntotc,Ngroup),
-C * Iuif(Nvpres), Zkte(ntotc,Ngroup),
+C * Zkte(ntotc,Ngroup),
C * Aaaone(Ntotc,Ngroup),
C * Aaatwo(Ntotc,Ngroup), Aaathr(Ntriag,Ngroup),
-C * Paaone(Ntotc,Napres), Paatwo(Ntotc,Napres),
-C * Paathr(Ntriag,Napres), P(Ntotc), Gami(Ntotc), Dphi(ntotc)
+C * P(Ntotc), Gami(Ntotc), Dphi(ntotc)
C
EXTERNAL Pfd
Data Zero /0.0d0/, One /1.0d0/
C
- CALL Zero_Array (Paaone, Ntotc*Napres)
- CALL Zero_Array (Paatwo, Ntotc*Napres)
- CALL Zero_Array (Paathr, Ntriag*Napres)
+ A_Ibr = 0.0d0
+ A_Ibi = 0.0d0
+ A_Ipr = 0.0d0
CALL Zero_Array (Aaaone, Ntotc*Ngroup)
CALL Zero_Array (Aaatwo, Ntotc*Ngroup)
CALL Zero_Array (Aaathr, Ntriag*Ngroup)
C
- Iipar = 0
Ipar = 0
istart = 1
@@ -119,13 +123,17 @@ C *** Note that, in what follows, X is prtl( (E-Pken)/Den ) wrt U-variable,
C *** Y Gamgam /Den
C *** and Z Gamma(J)/Den
C
- IF (resInfo%getEnergyFitOption().GE.0) THEN
+ IF (resInfo%getIncludeInCalc().and.
+ * spinInfo%getIncludeInCalc()) THEN
C
- IF (resInfo%getEnergyFitOption().NE.0) THEN
-C *** HERE RESONANCE ENERGY IS A VARIABLE
+ IF (resInfo%getEnergyFitOption().gt.0) THEN
+ Iflr = resInfo%getEnergyFitOption()
Ipar = Ipar + 1
- IF (Iuif(Ipar).NE.1) THEN
- Iipar = Iipar + 1
+C *** HERE RESONANCE ENERGY IS A VARIABLE
+ IF (covData%contributes(Iflr)) THEN
+ if (Iflr.ne.abs(I_Inotu(Ipar)))then
+ STOP 'Count of varied resonance mmlb4'
+ end if
eres = resonance%getEres()
X = 2.0D0*dSQRT(dABS(eres))*
* (-One+2.0D0*De**2/Den)/Den
@@ -133,11 +141,11 @@ C *** HERE RESONANCE ENERGY IS A VARIABLE
Y = Z*Gamgam
Ij = 0
DO I=1,Ntott
- Paaone(I,Iipar) = Gami(I)*X
- Paatwo(I,Iipar) = Gami(I)*Y
+ A_Ibr(I,Ipar) = Gami(I)*X
+ A_Ibi(I,Ipar) = Gami(I)*Y
DO J=1,I
Ij = Ij + 1
- Paathr(IJ,Iipar) = Gami(I)*Gami(J)*Z
+ A_Ipr(IJ,Ipar) = Gami(I)*Gami(J)*Z
END DO
END DO
END IF
@@ -145,9 +153,12 @@ C *** HERE RESONANCE ENERGY IS A VARIABLE
C
IF (resInfo%getChannelFitOption(1).NE.0) THEN
C *** HERE Gamma-SUB-Gamma IS A VARIABLE
+ Iflr = resInfo%getChannelFitOption(1)
Ipar = Ipar + 1
- IF (Iuif(Ipar).NE.1) THEN
- Iipar = Iipar + 1
+ IF (covData%contributes(Iflr)) THEN
+ if (Iflr.ne.abs(I_Inotu(Ipar)))then
+ STOP 'Count of varied resonance mmlb4'
+ end if
X = -2.0D0*gammaRed*(De/Den)*
* (Gamtot/Den)
Y = 2.0D0*gammaRed*
@@ -155,11 +166,11 @@ C *** HERE Gamma-SUB-Gamma IS A VARIABLE
Z = -2.0D0*gammaRed*Gamtot/Den**2
Ij = 0
DO I=1,Ntott
- Paaone(I,Iipar) = X*Gami(I)
- Paatwo(I,Iipar) = Y*Gami(I)
+ A_Ibr(I,Ipar) = X*Gami(I)
+ A_Ibi(I,Ipar) = Y*Gami(I)
DO J=1,I
Ij = Ij + 1
- Paathr(Ij,Iipar) =Z*Gami(I)*Gami(J)
+ A_Ipr(Ij,Ipar) =Z*Gami(I)*Gami(J)
END DO
END DO
END IF
@@ -169,9 +180,12 @@ C
IF (resInfo%getChannelFitOption(K+1).NE.0) THEN
C
C *** HERE Gamma-CHANNEL-K IS A VARIABLE
+ Iflr = resInfo%getChannelFitOption(K+1)
Ipar = Ipar + 1
- IF (Iuif(Ipar).NE.1) THEN
- Iipar = Iipar + 1
+ IF (covData%contributes(Iflr)) THEN
+ if (Iflr.ne.abs(I_Inotu(Ipar)))then
+ STOP 'Count of varied resonance mmlb4'
+ end if
ichan = spinInfo%getWidthForChannel(K)
width = resonance%getWidth(ichan)
W = 0.5D0*Gamtot*Gami(K)/Den
@@ -182,13 +196,13 @@ C *** HERE Gamma-CHANNEL-K IS A VARIABLE
DO I=1,Ntott
D = Zero
IF (I.EQ.K) D = One
- Paaone(I,Iipar) = X*Gami(I)*(D-W)
- Paatwo(I,Iipar) = Y*Gami(I)*(D-W)
+ A_Ibr(I,Ipar) = X*Gami(I)*(D-W)
+ A_Ibi(I,Ipar) = Y*Gami(I)*(D-W)
DO J=1,I
Ij = Ij + 1
E = Zero
IF (J.EQ.K) E = One
- Paathr(Ij,Iipar) =
+ A_Ipr(Ij,Ipar) =
* Z*Gami(I)*Gami(J)*(D+E-W)
END DO
END DO
@@ -208,7 +222,7 @@ C
C --------------------------------------------------------------
C
SUBROUTINE Parsh_Mlb (
- * Nprdr, Zke, Zkfe, Jfzke, Jfzkte, Jfzkfe,
+ * Zke, Zkfe, Jfzke, Jfzkte, Jfzkfe,
* Aaaone, Aaatwo, Aaathr, Pieces, Ipoten, Sigxxx, Dasigx,
* Dbsigx, Isopar)
C
@@ -231,15 +245,16 @@ C
C
C
DIMENSION
- * Nprdr(*), Zke(Ntotc,*), Zkfe(Ntotc,*),
+ * Zke(Ntotc,*), Zkfe(Ntotc,*),
* Jfzke(*), Jfzkte(Ntotc,*), Jfzkfe(Ntotc,*), Aaaone(Ntotc,*),
* Aaatwo(Ntotc,*), Aaathr(Ntriag,*), Pieces(*), Sigxxx(*),
* Dasigx(*), Dbsigx(*), Isopar(*)
type(SammySpinGroupInfo)::spinInfo
+ type(SammyResonanceInfo)::resInfo
C
C DIMENSION
-C * Nprdr(Ngroup), Aaaone(Ntotc,Ngroup), Aaatwo(Ntotc,Ngroup),
+C * Aaaone(Ntotc,Ngroup), Aaatwo(Ntotc,Ngroup),
C * Aaathr(ntriag,Ngroup), Cayiso(Numiso), Pilmis(Numiso),
C * Pilsis(Numiso), Pieces(Ngroup)
C
@@ -248,7 +263,8 @@ C
NNF1 = 0
NN2 = 0
Kstart = 0
- Jstart = Napres
+ Jstart = Nfpres
+ imax = 0
C
C *** Do loop over groups (i.e., spin-parity groups) --
C *** Goes to end of sub_routine
@@ -256,7 +272,30 @@ C
DO N=1,resParData%getNumSpinGroups()
Kiso = 0
call resParData%getSpinGroupInfo(spinInfo, N)
- IF (spinInfo%getIncludeInCalc()) THEN
+
+ imin = imax + 1
+ Npr = 0
+ DO I=imin,resParData%getNumResonances()
+ call resParData%getResonanceInfo(resInfo, I)
+ if( resInfo%getSpinGroupIndex().ne.n) exit
+ imax = i
+ IF (.not.resInfo%getIncludeInCalc()) cycle
+
+
+ Mmax2 = spinInfo%getNumResPar()
+ DO M=1,Mmax2
+ if( m.eq.1) then
+ Ifl = resInfo%getEnergyFitOption()
+ else
+ ifl = resInfo%getChannelFitOption(M-1)
+ end if
+ IF (Ifl.GT.0) THEN
+ Npr = Npr + 1
+ END IF
+ end do
+ END DO
+
+ IF (spinInfo%getIncludeInCalc()) THEN
C
IF (Numiso.GT.0) THEN
isoN = spinInfo%getIsotopeIndex()
@@ -268,7 +307,6 @@ C
END IF
C
Nnnn = N
- IF (Ksolve.NE.2) Npr = Nprdr(N)
Nnf1 = Nnf1 + Nn2
Ntot = spinInfo%getNumChannels()
Nn2 = Ntot*(Ntot+1)
@@ -288,19 +326,19 @@ C *** SCATTERING CROSS SECTION (IE ELASTIC CROSS SECTION)
IF (Kcros.EQ.1 .OR. Kcros.EQ.2) CALL Elastc_Mlb (Agoj,
* Nent, Next, Zke(1,N), Jfzke(N), Jfzkfe(1,N),
* Jfzkfe(1,N), Aaaone(1,N), Aaatwo(1,N), Aaathr(1,N),
- * A_Ipaone, A_Ipatwo , A_Ipathr, A_Ics, A_Isi,
+ * A_Ics, A_Isi,
* A_Idphi , Sigxxx, Dasigx, Isopar, Iso)
C
C *** REACTION CROSS SECTIONS
IF (Kcros.EQ.1 .OR. Kcros.EQ.3 .OR. Kcros.EQ.5) CALL
* Reactn_Mlb (Agoj, Nent, Next, Zke(1,N), Jfzke(N),
- * Jfzkte(1,N), Aaathr(1,N), A_Ipathr,
+ * Jfzkte(1,N), Aaathr(1,N),
* Sigxxx, Dasigx, Isopar, Iso)
C
C *** CAPTURE CROSS SECTION
IF (Kcros.EQ.1 .OR. Kcros.EQ.4 .OR. Kcros.EQ.5) CALL
* Captur_Mlb (Agoj, Nent, Zke(1,N), Jfzke(N),
- * Jfzkte(1,N), Aaatwo(1,N), A_Ipatwo,
+ * Jfzkte(1,N), Aaatwo(1,N),
* Sigxxx, Dasigx, Isopar, Iso)
C
IF (Ksolve.NE.2) Kstart = Kstart + Npr
diff --git a/sammy/src/mpw/mmpw0.f b/sammy/src/mpw/mmpw0.f
index fac8a985a942bbf2ef0ff3a18acf629d28a0068e..98a5f4dc25acf6b029e2559587eb79cf8acd9914 100644
--- a/sammy/src/mpw/mmpw0.f
+++ b/sammy/src/mpw/mmpw0.f
@@ -28,6 +28,7 @@ C
real(kind=8),allocatable,dimension(:)::A_Istd
integer,allocatable,dimension(:)::I_Ikpvt
real(kind=8),allocatable,dimension(:)::A_Idelpa
+ integer::npars
C
C
@@ -47,8 +48,9 @@ C
IF (Ksolve.NE.2) WRITE (21,99996)
99996 FORMAT (/, ' Use (M+W) inversion scheme ')
C
- Kkkkkk = Nvpall
- IF (Nvpall.EQ.0) Kkkkkk = 1
+ npars = covData%getNumParam()
+ Kkkkkk = npars
+ IF (Kkkkkk.EQ.0) Kkkkkk = 1
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
C
@@ -60,18 +62,18 @@ C *** GUESSTIMATE ARRAY SIZE REQUIRED --
C
C
call allocate_real_data(A_Iwww, Ntri)
- call allocate_real_data(A_Iyyy, Nvpall)
- CALL Readwy (A_Iwww , A_Iyyy , Nvpall, Ntri)
+ call allocate_real_data(A_Iyyy, npars)
+ CALL Readwy (A_Iwww , A_Iyyy , npars, Ntri)
C *** Www = sum (all data sets) g v^-1 g
C *** Yyy = sum (all data sets) g v^-1 (d-t)
C
call allocate_real_data(A_Ivrpr, Ntri)
call allocate_real_data(A_Ivrprx, Ntri)
call allocate_real_data(A_Ivrprn, Ntri)
- call allocate_real_data(A_Idum, Nvpall)
- call allocate_real_data(A_Istd, Nvpall)
- call allocate_integer_data(I_Ikpvt, Nvpall)
- call allocate_real_data(A_Idelpa, Nvpall)
+ call allocate_real_data(A_Idum, npars)
+ call allocate_real_data(A_Istd, npars)
+ call allocate_integer_data(I_Ikpvt, npars)
+ call allocate_real_data(A_Idelpa, npars)
C
CALL Newpar_Mpw (A_Iwww , A_Iyyy , A_Ivrpr ,
* A_Ivrprx , A_Ivrprn , A_Idum , A_Istd , I_Ikpvt, A_Idelpa,
@@ -109,11 +111,16 @@ C
C *** purpose -- estimate array size needed for segment MPW
C
use fixedi_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- Ntri = (Nvpall*(Nvpall+1))/2
- K1 = 4*Ntri + 5*Nvpall
- K2 = Nvpall**2 + Ntri + Nvpall
+ use EndfData_common_m, only : covData
+ IMPLICIT none
+ integer::Ntri, npars, I, K, K1, K2
+ integer::Idimen
+ external Idimen
+C
+ npars = covData%getNumParam()
+ Ntri = (npars*(npars+1))/2
+ K1 = 4*Ntri + 5*npars
+ K2 = npars**2 + Ntri + npars
K = MAX0 (K1, K2)
K = Idimen (K, 1, 'K, 1')
I = Idimen (K, -1, 'K, -1')
diff --git a/sammy/src/mpw/mmpw1.f b/sammy/src/mpw/mmpw1.f
index 161631e5cf6fdab7db34703c37fd5894972ccd33..4bf3c43260aa9a9c9a47ab7c71fbf0c2ab416821 100644
--- a/sammy/src/mpw/mmpw1.f
+++ b/sammy/src/mpw/mmpw1.f
@@ -24,9 +24,11 @@ C
DIMENSION Www(*), Yyy(*), Vrpr(*), Vrprx(*),
* Vrprnv(*), Dum(*), Std(*), Kpvt(*), Delpar(*)
type(ResonanceCovariance)::uCov, invCov
+ integer::npars
DATA Zero /0.0d0/, One /1.0d0/
C
C
+ npars = covData%getNumParam()
IF (KLeast.EQ.1 .OR. Kleast.EQ.2) THEN
C *** set Vrpr = Www; this is inverse of new par cov matrix
DO I=1,Ntri
@@ -35,7 +37,7 @@ C *** set Vrpr = Www; this is inverse of new par cov matrix
ELSE
call covData%getInverseUCovariance(invCov)
Ii = 0
- DO Ipar=1, Nvpall
+ DO Ipar=1, npars
do i = 1, Ipar
Vrpr(Ii+i) = invCov%getCovariance(ipar,i) + WWw(Ii+i)
end do
@@ -50,22 +52,22 @@ C
END DO
C
C *** Scale Vrpr
- CALL Qscale (Vrpr, Std, Nvpall, Ntri)
+ CALL Qscale (Vrpr, Std, npars, Ntri)
C
C *** FACTORIZE Vrpr
- CALL Sspcod (Vrpr, Nvpall, Kpvt, Rcond, Dum)
+ CALL Sspcod (Vrpr, npars, Kpvt, Rcond, Dum)
IF (One+Rcond.EQ.One) RETURN
C
C *** SCALE Yyy
- DO I=1,Nvpall
+ DO I=1,npars
Dum(I) = Yyy(I)*Std(I)
END DO
C
C *** CALCULATE Vrpr**-1 * Dum
- CALL Sspsld (Vrpr, Nvpall, Kpvt, Dum)
+ CALL Sspsld (Vrpr, npars, Kpvt, Dum)
C
C *** CALCULATE UPDATED PARAMETER VALUES, STORE IN "Parm"
- DO I=1,Nvpall
+ DO I=1,npars
Delpar(I) = Dum(I)*Std(I)
call covData%setFitStep(I, Delpar(I))
val = covData%getOrigUParam(I) + Delpar(I)
@@ -78,7 +80,7 @@ C
C *** CALCULATE UPDATED COVARIANCE MATRIX
C After this we have u parameter covariance in Vrpr and inverse in Vrprx
C
- CALL Fixvrp (Vrpr, Vrprx, Dum, Std, Kpvt, Nvpall)
+ CALL Fixvrp (Vrpr, Vrprx, Dum, Std, Kpvt, npars)
C
C *** Multiply by fudge factor if needed
IF (Fcvout.NE.Zero) THEN
@@ -95,7 +97,7 @@ C
Kxxx = 1
C
call covData%getUCovariance(uCov)
- call setCovMatrix(nvpall, uCov, Vrprx)
+ call setCovMatrix(npars, uCov, Vrprx)
IF (Iterat.EQ.Itmax) THEN
@@ -108,7 +110,7 @@ C Inverse U covariance (and U covariance and parameters) were previously save
C
call covData%makeNewInverseUCovariance()
call covData%getInverseUCovariance(invCov)
- call setCovMatrix(nvpall, invCov, Vrprnv)
+ call setCovMatrix(npars, invCov, Vrprnv)
END IF
C
C
diff --git a/sammy/src/mso/mmso0.f b/sammy/src/mso/mmso0.f
index 5a2c56fcf5eb84ba659ab49e7f4d15a9816a0f78..e8ac5f7e787a2b7b5d987f86a4fa9df728a56ee7 100644
--- a/sammy/src/mso/mmso0.f
+++ b/sammy/src/mso/mmso0.f
@@ -341,9 +341,9 @@ C
IF (Nx.EQ.0) THEN
Nx = 1
ELSE
- IF (Kvthck-Nvadif.GT.Nx) Nx = Kvthck - Nvadif
+ IF (Kvthck.GT.Nx) Nx = Kvthck
END IF
- IF (Debug) WRITE (6,12345) Kvthck, Nvadif, Nx
+ IF (Debug) WRITE (6,12345) Kvthck, 0, Nx
12345 FORMAT (' Kvthck, Nvadif, Nx=', 3I5)
Nnx = Nx
IF (Kssdbl.NE.1) Nnx = 1
diff --git a/sammy/src/mso/mmso5.f b/sammy/src/mso/mmso5.f
index 21a8d54527c8b820bfcf8c9cd7a0ac25a525557b..c925e96838b5840e0a3340a4b844b1f2a26b0589 100644
--- a/sammy/src/mso/mmso5.f
+++ b/sammy/src/mso/mmso5.f
@@ -160,7 +160,6 @@ C
* Y2aaaq, Total, Exp1, Costhe, Ep, Ggg, Iiso, Nx, Jj, Ientrp,
* Itntrp, Jfb, Jth, Knthet, Nn, Kdatb, Izero, Idone, Nxtptn)
C
- use fixedi_m, only : Nvadif
use ifwrit_m, only : Ksolve, Kssdbl, Kssmsc, Kvthck, Nnpar
use ssm_18_m, only : Hmez3x
use ssssss_common_m, only : Costh1, Dthick, Fffdbl
@@ -186,7 +185,7 @@ C
DATA Zero /0.0d0/, Half /0.5d0/, One /1.0d0/
C
Izero = 1
- Kv = Kvthck - Nvadif
+ Kv = Kvthck
C
C *** find differential elastic scattering cross section Elas and
C *** derivatives Delas at Energy Em and angle Theta
@@ -531,7 +530,7 @@ C
IF (Kvthck.GT.0) THEN
C *** Add deriv of Y0 wrt Thickness; modify deriv of Y1 & Y2 wrt Thick
- Kv = Kvthck - Nvadif - Ndasig
+ Kv = Kvthck - Ndasig
IF (yld%normTypeIsSelfShielded()) THEN
Dbsigx(Kv) = Exp1*Cap + Dbsigx(Kv)
ELSE IF (yld%normTypeIsDivideByN()) THEN
@@ -554,7 +553,7 @@ C
IF (yld%normTypeIsSelfShielded()) Asensn = Asensn * Dthick
IF (yld%normTypeIsTimesSigTot()) Asensn = Asensn *Dthick *Total
C *** Add deriv of Y0 wrt neutron sensitivity multiplier
- Kv = Ksensc - Nvadif - Ndasig
+ Kv = Ksensc - Ndasig
Dbsigx(Kv) = Asensn
END IF
RETURN
@@ -683,7 +682,7 @@ C *** capture sample
C
IF (Kv.GT.0) THEN
C *** Add deriv of Y0 wrt Thickness of transmission sample
- Kv = Kv - Nvadif - Ndasig
+ Kv = Kv - Ndasig
Dbsigx(Kv) = Dbsigx(Kv) - Sigxxx(1)*Total2
END IF
RETURN
diff --git a/sammy/src/mxw/mmxw0.f b/sammy/src/mxw/mmxw0.f
index 71cc98926aaa0982e0d2486530aea2c366de2292..c83d117281956080ab9dc5e6709688baae815547 100644
--- a/sammy/src/mxw/mmxw0.f
+++ b/sammy/src/mxw/mmxw0.f
@@ -81,7 +81,7 @@ C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
C *** four ***
call allocate_real_data(A_Ix, Ndatq*Nvpall)
- CALL Fixcov_Mxw (I_Iiuif , A_Iemmmq, A_Iwdasi , A_Iwdbsi ,
+ CALL Fixcov_Mxw (A_Iemmmq, A_Iwdasi , A_Iwdbsi ,
* A_Ix , Ndatq, Ndatqq)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
C
diff --git a/sammy/src/mxw/mmxw2.f b/sammy/src/mxw/mmxw2.f
index 6f28f250f693a8ba78246b845fa882e475a06359..e21cea94e990b332f64ed6c3885d710851f516b0 100755
--- a/sammy/src/mxw/mmxw2.f
+++ b/sammy/src/mxw/mmxw2.f
@@ -2,7 +2,7 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Fixcov_Mxw (Iuif, Emmmq, Wdasig, Wdbsig, X,
+ SUBROUTINE Fixcov_Mxw (Emmmq, Wdasig, Wdbsig, X,
* Ndatq, Ndatqq)
C
C *** PURPOSE -- multiply Emmmq = gq * (u parameter covariance) * gq
@@ -14,10 +14,10 @@ C
use ResonanceCovariance_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
- DIMENSION Iuif(*), Emmmq(*), Wdasig(Ndaxxx,*), Wdbsig(Ndbxxx,*),
+ DIMENSION Emmmq(*), Wdasig(Ndaxxx,*), Wdbsig(Ndbxxx,*),
* X(Ndatq,*)
type(ResonanceCovariance)::uCov
-C DIMENSION Iuif(Nvpres), Emmmq(Ndatqq), Wdasig(Ndasig,Ndatq),
+C DIMENSION Emmmq(Ndatqq), Wdasig(Ndasig,Ndatq),
C * Wdbsig(Ndbsig,Ndatq), X(Ndatq,Nvpall)
C
DATA Zero /0.0d0/
@@ -25,19 +25,17 @@ C
Call Zero_Array (Emmmq, Ndatqq)
CALL Zero_Array (X, Nvpall*Ndatq)
C
- Jjpar = 0
call covData%getUCovariance(uCov)
DO Jpar=1,Nvpthe
- IF (Jpar.GT.Nvpres .OR. Iuif(Jpar).NE.1) THEN
- Jjpar = Jjpar + 1
+ IF (covData%contributes(Jpar)) THEN
DO Kpar=1,Nvpall
cov = uCov%getCovariance(Kpar, Jpar)
IF (cov.NE.Zero) THEN
DO Idatq=1,Ndatq
- IF (Jjpar.LE.Ndasig) THEN
- Wd = Wdasig(Jjpar,Idatq)
+ IF (Jpar.LE.Ndasig) THEN
+ Wd = Wdasig(Jpar,Idatq)
ELSE
- Wd = Wdbsig(Jjpar-Ndasig,Idatq)
+ Wd = Wdbsig(Jpar-Ndasig,Idatq)
END IF
IF (Wd.NE.Zero) X(Idatq,Kpar) = X(Idatq,Kpar) +
* Wd*cov
@@ -47,16 +45,14 @@ C
END IF
END DO
C
- Kkpar = 0
DO Kpar=1,Nvpthe
- IF (Kpar.GT.Nvpres .OR. Iuif(Kpar).NE.1) THEN
- Kkpar = Kkpar + 1
+ IF (covData%contributes(Kpar)) THEN
Kk = 0
DO Kdatq=1,Ndatq
- IF (Kkpar.LE.Ndasig) THEN
- Wd = Wdasig(Kkpar,Kdatq)
+ IF (Kpar.LE.Ndasig) THEN
+ Wd = Wdasig(Kpar,Kdatq)
ELSE
- Wd = Wdbsig(Kkpar-Ndasig,Kdatq)
+ Wd = Wdbsig(Kpar-Ndasig,Kdatq)
END IF
DO Idatq=1,Kdatq
IK = Kk + Idatq
diff --git a/sammy/src/ndf/mndf0.f b/sammy/src/ndf/mndf0.f
index 96b25678258e8a92439be0d96f99964f57b1b1a0..a63f626269558c4083a920ca394bde304843ecf2 100644
--- a/sammy/src/ndf/mndf0.f
+++ b/sammy/src/ndf/mndf0.f
@@ -17,6 +17,7 @@ C
use hhhhhh_common_m
use format_common_m
use AllocateFunctions_m
+ use EndfData_common_m, only : covData
IMPLICIT DOUBLE PRECISION (A-h,o-z)
integer,allocatable,dimension(:)::I_Ilocat, I_Icov, I_Ix
real(kind=8),allocatable,dimension(:)::A_Ksj, A_Ispi, A_Izai
@@ -41,8 +42,9 @@ C
cx WRITE (6,10200)
cx10200 FORMAT (' Initialized')
If (Ndfcov.NE.0) THEN
- N = (Nvpall*(Nvpall+1))/2
- allocate(I_Ix(Nvpall))
+ N = covData%getNumParam()
+ N = (N*(N+1))/2
+ allocate(I_Ix(N))
CALL Get_Allvr (I_Ix )
deallocate(I_Ix)
allocate(I_Ilocat(nres))
@@ -71,12 +73,12 @@ cx WRITE (6,10600)
cx10600 FORMAT (' After Pre_Endfb6')
call allocate_integer_data(I_Kresis, Nres)
call allocate_real_data(A_Iunc, Nres*Ntotc2)
- N = Nres*Ntotc2 - Nvpall
+ N = Nres*Ntotc2 - covData%getNumParam()
call allocate_real_data(A_Iunkun, N)
IF (Lcomp.EQ.1 .AND. Lrf.EQ.3 .AND. Nsrs.GT.0) THEN
call allocate_integer_data(I_Iisrs, Nsrs*Ngroup)
call allocate_real_data(A_Iesrs, 2*Nsrs)
- N = Nvpall
+ N = covData%getNumParam()
N = (N*(N+1))/2
call allocate_real_data(A_Ivsrs, N)
END IF
@@ -91,9 +93,10 @@ C
IF (Ndfcov.NE.0) THEN
IF (Lcomp.EQ.2) THEN
- call allocate_real_data(A_Idiag, Nvpall)
+ call allocate_real_data(A_Idiag, covData%getNumParam())
CALL Write_Compact_Cov (I_Icov, A_Idiag,
- * Nvpall, Num_Res_Parx, Ndigit, Mat, Mfx, Mt, Ns)
+ * covData%getNumParam(),
+ * Num_Res_Parx, Ndigit, Mat, Mfx, Mt, Ns)
deallocate(A_Idiag)
ELSE IF (Lcomp.EQ.1 .AND. If_Diag.EQ.0 .AND. Nsrs.LE.0) THEN
CALL Fix_Allvr (I_ILocat)
diff --git a/sammy/src/ndf/mndf1.f b/sammy/src/ndf/mndf1.f
index edf28a2e0e077c772496bf10a432863da1b27f22..481e01a407759dab65fec16b907069598a6c298f 100644
--- a/sammy/src/ndf/mndf1.f
+++ b/sammy/src/ndf/mndf1.f
@@ -32,7 +32,8 @@ C *** Set Is(Ipar) = 0 if width is positive, 1 if negative
else
ifl = resInfo%getChannelFitOption(M-1)
end if
- IF (Ifl.GT.0 .AND. Ifl.LE.Nvpall) THEN
+ IF (Ifl.GT.0 .AND.
+ * .not.covData%isPupedParameter(ifl)) THEN
Ipar = Ipar + 1
Ix(Ipar) = 0
IF (M.EQ.1) THEN
@@ -44,12 +45,14 @@ C *** Set Is(Ipar) = 0 if width is positive, 1 if negative
END IF
END DO
END DO
- IF (Ipar.NE.Nvpall) STOP '[STOP in Get_Allvr in mndf1.f]'
+ IF (Ipar.NE.covData%getNumParam()) then
+ STOP '[STOP in Get_Allvr in mndf1.f]'
+ end if
C
C *** Adjust the covariance matrix to be in terms of G not Gamma
call covData%getCovariance(physCov)
Ij = 0
- DO I=1,Nvpall
+ DO I=1,covData%getNumParam()
DO J=1,I
Ij = Ij + 1
cov = physCov%getCovariance(I,J)
@@ -215,7 +218,9 @@ C
ELSE
Iux = 58
CALL Newopn (58, Sam58x, 0)
- IF (Lrf.NE.7) CALL Two_Flip (Ntotc2, Nvpall)
+ IF (Lrf.NE.7) then
+ CALL Two_Flip (Ntotc2, covData%getNumParam())
+ end if
C *** Test whether fission widths are flagged
Knofis = Ntotc2
IF (Lcomp.EQ.1 .AND. Lrf.EQ.3 .AND. Ntotc2.GT.3) THEN
diff --git a/sammy/src/ndf/mndf3.f b/sammy/src/ndf/mndf3.f
index 48ec1c133a5a7fc0d3c40f696b335366700df406..68426bbe8f1303f3604b449e0ceac656396838ca 100644
--- a/sammy/src/ndf/mndf3.f
+++ b/sammy/src/ndf/mndf3.f
@@ -79,19 +79,11 @@ C *** Here only resonances with flags are to be included in File 32,
C *** ergo must count how many resonances have flags
Nres_Included = 0
DO I=1,resParData%getNumResonances()
- call resParData%getResonanceInfo(resInfo, I)
- call resParData%getSpinGroupInfo(spinInfo,
- * resInfo%getSpinGroupIndex())
- Ntot2 = spinInfo%getNumResPar()
+ call resParData%getResonanceInfo(resInfo, I)
Iflag = 0
- if (resInfo%getEnergyFitOption().gt.0) then
+ if (resInfo%hasAnyVariedParams()) then
Iflag = 1
end if
- DO J=2,Ntotc2
- IF (resInfo%getChannelFitOption(j-1).GT.0) then
- Iflag = 1
- end if
- END DO
IF (Iflag.EQ.1) Nres_Included = Nres_Included + 1
END DO
END IF
@@ -213,7 +205,7 @@ C ****************** write the resonances into File 32
IF (Nsrs.EQ.0) THEN
CALL Write_Lrf3 (resonance, Sj(Igy),
* Mat, Mfx, Mt, Ns, Iux)
- ELSE IF (resInfo%getEnergyFitOption().GE.0) THEN
+ ELSE IF (resInfo%hasAnyVariedParams()) THEN
C ********************* For Nsrs < 0, add to File 32 only if flags
CALL Write_Lrf3 (resonance, Sj(Igy),
* Mat, Mfx, Mt, Ns, Iux)
@@ -221,7 +213,7 @@ C ********************* For Nsrs < 0, add to File 32 only if flags
C
IF (Lcomp.EQ.2 .AND.
* (Nsrs.EQ.0 .OR.
- * resInfo%getEnergyFitOption().GE.0)) THEN
+ * resInfo%hasAnyVariedParams())) THEN
C ********************* Write uncertainties into File 32 for LCOMP=2
CALL Write_Lrf3_2 (ntotIgy, E, Ax, Ga, Gb, Gc,
* Gd, Mat, Mfx, Mt, Ns, Iux)
@@ -267,6 +259,7 @@ C *** Energy
call covData%getCovariance(physCov)
Nn = resInfo%getEnergyFitOption()
+ if (.not.resInfo%hasAnyVariedParams()) Nn = -1
Nne = Nn
IF (Nn.LE.0) THEN
IF (Defunc.EQ.Zero) THEN
diff --git a/sammy/src/ndf/mndf4.f b/sammy/src/ndf/mndf4.f
index fb093ac8e9e80c9b79f01eeeb6b42abcc756f611..d2badf7c25bdf8ea82a451035b7191392d0781f0 100644
--- a/sammy/src/ndf/mndf4.f
+++ b/sammy/src/ndf/mndf4.f
@@ -83,14 +83,9 @@ C *** ergo must count how many resonances have flags
call resParData%getSpinGroupInfo(spinInfo, igrp)
Ntot2 = spinInfo%getNumResPar()
Iflag = 0
- DO J=1,Ntot2
- if (j.eq.1) then
- ifl = resInfo%getEnergyFitOption()
- else
- ifl = resInfo%getChannelFitOption(j-1)
- end if
- IF (Ifl.GT.0) Iflag = 1
- END DO
+ if (resInfo%hasAnyVariedParams()) then
+ Iflag = 1
+ end if
IF (Iflag.EQ.1) Nres_Included = Nres_Included + 1
END DO
END IF
@@ -131,15 +126,9 @@ C
call resParData%getResonanceInfo(resInfo, N)
IF (Kresis(N).EQ.1) THEN
K = 0
-
- DO I=1,Ntotc2
- if (i.eq.1) then
- ifl = resInfo%getEnergyFitOption()
- else
- ifl = resInfo%getChannelFitOption(i-1)
- end if
- IF (Ifl.GT.0) K = 1
- END DO
+ if( resInfo%hasAnyVariedParams()) then
+ K = 1
+ end if
IF (K.EQ.1) Nsrsx = Nsrsx + 1
END IF
END DO
@@ -232,7 +221,7 @@ C ****************** write the resonances into File 32
IF (Nsrs.EQ.0) THEN
CALL Write_Lrf2 (resonance, Sj(Igy),
* Mat, Mfx, Mt, Ns, No, N1, Iux)
- ELSE IF (resInfo%getEnergyFitOption().GE.0) THEN
+ ELSE IF (resInfo%hasAnyVariedParams()) THEN
C ********************* For Nsrs < 0, add to File 32 only if flags
CALL Write_Lrf2 (resonance, Sj(Igy),
* Mat, Mfx, Mt, Ns, No, N1, Iux)
@@ -240,7 +229,7 @@ C ********************* For Nsrs < 0, add to File 32 only if flags
C
IF (Lcomp.EQ.2 .AND.
* (Nsrs.EQ.0 .OR.
- * resInfo%getEnergyFitOption().GE.0)) THEN
+ * resInfo%hasAnyVariedParams())) THEN
C ********************* Write uncertainties into File 32 for LCOMP=2
CALL Write_Lrf2_2 (ntotIgy, E, Ax, Ga, Gb, Gc,
* Gd, Mat, Mfx, Mt, Ns, Iux)
@@ -251,7 +240,7 @@ C ********************* wrt resonances
IF (Nsrs.EQ.0) THEN
CALL Write_Lrf2_3 (ntotIgy, E, Ax, Ga, Gb,
* Gc, Gd, Mat, Mfx, Mt, Ns, Iux)
- ELSE IF (resInfo%getEnergyFitOption().ge.0) THEN
+ ELSE IF (resInfo%hasAnyVariedParams()) THEN
CALL Write_Lrf2_3 (ntotIgy, E, Ax, Ga, Gb,
* Gc, Gd, Mat, Mfx, Mt, Ns, Iux)
END IF
@@ -261,7 +250,7 @@ C ********************* Write cov mtrx for LCOMP=0
IF (Nsrs.EQ.0) THEN
CALL Write_Lrf2_0 (ntotIgy, E, Ax, Ga, Gb,
* Gc, Gd, Mat, Mfx, Mt, Ns, Iux)
- ELSE IF (resInfo%getEnergyFitOption().GE.0) THEN
+ ELSE IF (resInfo%hasAnyVariedParams()) THEN
CALL Write_Lrf2_0 (ntotIgy, E, Ax, Ga, Gb,
* Gc, Gd, Mat, Mfx, Mt, Ns, Iux)
END IF
diff --git a/sammy/src/ndf/mndf6.f b/sammy/src/ndf/mndf6.f
index 3b1ec379489c3ab4f89c7a4a2e5a85fab48be854..46d45672f5022d0a8fa5280f99d101bfb84d8e06 100644
--- a/sammy/src/ndf/mndf6.f
+++ b/sammy/src/ndf/mndf6.f
@@ -319,14 +319,9 @@ C *** and (if needed) Nrsx = how many have varied parameters
Nrs = Nrs + 1
IF (Iux.NE.0 .AND. Nsrs.LT.0) THEN
Ifl = 0
- if (resInfo%getEnergyFitOption().gt.0) then
+ if ( resInfo%hasAnyVariedParams()) then
Ifl = 1
end if
- DO J=2,Ntotc2x
- IF (resInfo%getChannelFitOption(j-1).GT.0) then
- Ifl = 1
- end if
- END DO
IF (Ifl.NE.0) Nrsx = Nrsx + 1
ELSE
Nrsx = Nrs
@@ -484,15 +479,9 @@ C ****************** If needed, find and write covariance information
Ifl = 0
Locate(N) = Lful
IF (Nsrs.LT.0) THEN
- if (resInfo%getEnergyFitOption().gt.0) then
- Ifl = 1
- end if
- DO J=2,Ntotc2x
- IF (resInfo%getChannelFitOption(j-1)
- * .GT.0) then
+ if (resInfo%hasAnyVariedParams()) then
Ifl = 1
- end if
- END DO
+ end if
ELSE
Ifl = 1
END IF
diff --git a/sammy/src/ndf/mndf7.f b/sammy/src/ndf/mndf7.f
index 9d1f32e5b989e0bfaad063bbbf155f0cf4cb7e33..53c6e06a8475889ceda2c2f2eda5b0d5d507c7ea 100644
--- a/sammy/src/ndf/mndf7.f
+++ b/sammy/src/ndf/mndf7.f
@@ -22,6 +22,7 @@ C *** Energy
call resParData%getResonanceInfo(resInfo, N)
call resParData%getResonance(resonance, resInfo)
Nn = resInfo%getEnergyFitOption()
+ if (.not.resInfo%hasAnyVariedParams()) Nn = -1
Iparf = Iparf + 1
IF (Nn.GT.0) THEN
Icov(Iparf) = Nn
diff --git a/sammy/src/ndf/mndf8.f b/sammy/src/ndf/mndf8.f
index e4369406f1d6e87132fad3038a97d51b1dc41d24..20282cf68a181c297328fa02303d6a7ca579e635 100755
--- a/sammy/src/ndf/mndf8.f
+++ b/sammy/src/ndf/mndf8.f
@@ -295,7 +295,7 @@ C
DO J=2,resParData%getNumResonances()
IF (Locate(J).LT.Locate(J-1)) THEN
Iflip = 1
- CALL Full_Flip (J, Ntotc2, Nvpall)
+ CALL Full_Flip (J, Ntotc2, covData%getNumParam())
Ifl = Locate(J)
Locate(J) = Locate(J-1)
Locate(J-1) = Ifl
@@ -751,14 +751,9 @@ C ######################################################## find Ipar ####
IF (Nn2.GT.Knofis) Nn2 = Knofis
Iflag = 0
IF (Nsrs.LT.0) THEN
- DO M=1,Nn2
- if (m.eq.1) then
- Iparx = resN%getEnergyFitOption()
- else
- Iparx = resN%getChannelFitOption(M-1)
- end if
- IF (Iparx.GT.0) Iflag = 1
- END DO
+ if ( resN%hasAnyVariedParams()) THEN
+ Iflag = 1
+ END IF
END IF
IF (Nsrs.EQ.0 .OR. Iflag.EQ.1) THEN
C *** This resonance is to be included
@@ -786,14 +781,9 @@ C ######################################################## find Jpar ####
IF (Ll2.GT.Knofis) Ll2 = Knofis
Jflag = 0
IF (Nsrs.LT.0) THEN
- DO K=1,Ll2
- if (K.eq.1) then
- Jparx = resL%getEnergyFitOption()
- else
- Jparx = resL%getChannelFitOption(K-1)
- end if
- IF (Jparx.GT.0) Jflag = 1
- END DO
+ IF ( resL%hasAnyVariedParams()) then
+ Jflag = 1
+ end if
END IF
IF (Nsrs.EQ.0 .OR. Jflag.EQ.1) THEN
C *** This resonance is to be included
@@ -840,14 +830,9 @@ C ######################################################## find Jpar ####
IF (Ll2.GT.Knofis) Ll2 = Knofis
Jflag = 0
IF (Nsrs.LT.0) THEN
- DO K=1,Ll2
- if (K.eq.1) then
- Jparx = resL%getEnergyFitOption()
- else
- Jparx = resL%getChannelFitOption(K-1)
- end if
- IF (Jparx.GT.0) Jflag = 1
- END DO
+ if( resL%hasAnyVariedParams()) then
+ Jflag = 1
+ end if
END IF
IF (Nsrs.EQ.0 .OR. Jflag.EQ.1) THEN
C *** This resonance is to be included
diff --git a/sammy/src/ndf/mndf9.f b/sammy/src/ndf/mndf9.f
index 245930a8eacff42cf219fd39e9e6dc0642d08167..01aee9ba825e0c9b415ffbef6269bb5405f10284 100644
--- a/sammy/src/ndf/mndf9.f
+++ b/sammy/src/ndf/mndf9.f
@@ -466,7 +466,8 @@ C
C
C
IF (Lrf.EQ.6) RETURN
- IF (Ireord.EQ.1) CALL Reorder (Ntotc, Ntotc2, Nvpall, Ndfcov)
+ IF (Ireord.EQ.1) CALL Reorder (Ntotc, Ntotc2,
+ * covData%getNumParam(), Ndfcov)
C *** This is to reorder resonances by energy, in the case where more than
C *** one SAMMY spin group contribute to one ENDF/B-VI spin group.
C
diff --git a/sammy/src/new/SetUResonanceCovData.cpp b/sammy/src/new/SetUResonanceCovData.cpp
index 9d762d2a5d78fe9fe6b9ef9b5f400b6a0e85bebd..dce60d5e73e94f66504eea53528825ecfbf78d58 100644
--- a/sammy/src/new/SetUResonanceCovData.cpp
+++ b/sammy/src/new/SetUResonanceCovData.cpp
@@ -10,7 +10,7 @@ namespace sammy{
for( int ires = 0; ires < resData.getNumResonances(); ires++){
SammyResonanceInfo * resInfo = resData.getResonanceInfo(ires);
- if (resInfo->getEnergyFitOption() < 0) continue; // this flags to omit the resonance
+ if (!resInfo->getIncludeInCalc()) continue; // this flags to omit the resonance
updateNumbers(resInfo->getEnergyFitOption(), covData, initial);
@@ -33,7 +33,7 @@ namespace sammy{
for( int ires = 0; ires < resData.getNumResonances(); ires++){
SammyResonanceInfo * resInfo = resData.getResonanceInfo(ires);
- if (resInfo->getEnergyFitOption() < 0) continue; // this flags to omit the resonance
+ if (!resInfo->getIncludeInCalc()) continue; // this flags to omit the resonance
int flag = getUpdatedFitFlag( resInfo->getEnergyFitOption(), covData, index, indexVar, indexPup);
resInfo->setEnergyFitOption( flag);
@@ -62,7 +62,7 @@ namespace sammy{
for( int ires = 0; ires < resData.getNumResonances(); ires++){
SammyResonanceInfo * resInfo = resData.getResonanceInfo(ires);
- if (resInfo->getEnergyFitOption() < 0) continue; // this flags to omit the resonance
+ if (!resInfo->getIncludeInCalc()) continue; // this flags to omit the resonance
endf::RMatResonance * redResonance = resData.getRedResonance(resInfo);
@@ -146,7 +146,7 @@ namespace sammy{
for( int ires = 0; ires < resData.getNumResonances(); ires++){
SammyResonanceInfo * resInfo = resData.getResonanceInfo(ires);
- if (resInfo->getEnergyFitOption() < 0) continue; // this flags to omit the resonance
+ if (!resInfo->getIncludeInCalc()) continue; // this flags to omit the resonance
endf::RMatResonance * resonance = resData.getResonance(resInfo);
diff --git a/sammy/src/new/mnew0.f b/sammy/src/new/mnew0.f
index 76faba21f19a7cabcec4b6107947cd40e34a77c5..dee5d72cbeee90de946598a932731c48df8161b8 100644
--- a/sammy/src/new/mnew0.f
+++ b/sammy/src/new/mnew0.f
@@ -76,8 +76,9 @@ C *** Put quantum numbers into PARameter file
END IF
C
C
- Nn = (Numpup*(Numpup+1))/2
- IF (Numpup.EQ.0) Nn = 1
+ Nn = covData%getPupedParam()
+ Nn = (Nn*(Nn+1))/2
+ IF (covData%getPupedParam().EQ.0) Nn = 1
IF (Ksolve.NE.2 .OR. (Ksolve.EQ.2 .AND. Nfpall.NE.Nvpall)) THEN
Ks_Res = 0
ELSE
@@ -172,7 +173,7 @@ C
* I_Iflorr , A_Ideorr , I_Iflrpi , A_Iderpi ,
* I_Ifludr , A_Ideudr ,
* I_Iflnbk , A_Idenbk , I_Iflbgf , A_Idebgf ,
- * I_Ifldtp , A_Idedtp , A_Iddcov ,
+ * I_Ifldtp , A_Idedtp ,
* I_Inn , I_Imm , I_Ikk , I_Ill , A_Ivv ,
* A_Idiag , A_Iuncs , I_Ijuncs ,
* A_Ipriox , I_Iiprio , I_Ijprio ,
@@ -417,7 +418,7 @@ C write the par file but with the new fit values
* A_Iprbgf , I_Jflbgf , A_Idebgf , I_Indbgf , A_Ibgfmi ,
* A_Ibgfma , A_Iprdtp , I_Jfldtp , A_Idedtp ,
* A_Iprusd , A_Iprbag , I_Jflbag ,
- * A_Iddcov , A_I2 ,
+ * A_I2 ,
* A_I1 ,
* Iu32, 0, relevantData, .false.)
C *** Routine Oldord reorders parameters into original order,
diff --git a/sammy/src/new/mnew2.f b/sammy/src/new/mnew2.f
index 99deb67b8b2779fbb40ff3e01be4c9eea471e65c..4316cf1868ae2efe2c464d6cf4e5c6216d5798a6 100644
--- a/sammy/src/new/mnew2.f
+++ b/sammy/src/new/mnew2.f
@@ -96,7 +96,7 @@ C *** Now convert
call resParData%getResonanceInfo(resInfo, Nnnn)
N = Nnnn
Iparx = 0
- IF (resInfo%getEnergyFitOption().GE.0) THEN
+ IF (resInfo%getIncludeInCalc()) THEN
call resParData%getResonance(resonance, resInfo)
eres = resonance%getEres()
igr = resInfo%getSpinGroupIndex()
@@ -183,7 +183,7 @@ C
igr = resInfo%getSpinGroupIndex()
call resparData%getSpinGroupInfo(spinInfo, Igr)
Mmax2 = spinInfo%getNumResPar()
- IF (resInfo%getEnergyFitOption().GE.0) THEN
+ IF (resInfo%getIncludeInCalc()) THEN
call resParData%getResonance(resonance, resInfo)
eres = resonance%getEres()
DO L=1,Mmax2
diff --git a/sammy/src/new/mnew3.f90 b/sammy/src/new/mnew3.f90
index 3f8a0678532f8d769935540c66c67c29d57e227c..35d6fefdf9888d07de4e36e7d1741c216f9cf7ff 100644
--- a/sammy/src/new/mnew3.f90
+++ b/sammy/src/new/mnew3.f90
@@ -100,7 +100,7 @@
if( .not.resInfo%getIncludeInCalc()) then
igrp = -1 * igrp
end if
- IF (resInfo%getEnergyFitOption().GE.0) THEN
+ IF (resInfo%getIncludeInCalc()) THEN
call resParData%getRedResonance(resonance, resInfo)
igrp = resInfo%getSpinGroupIndex()
call resparData%getSpinGroupInfo(spinInfo, Igrp)
diff --git a/sammy/src/new/mnew4.f b/sammy/src/new/mnew4.f
index 8bc8bfe219d3b64c4530fb056594c4f21ca83ac8..379c5e161334df9f67ce8c7e116c99577bd8c92d 100644
--- a/sammy/src/new/mnew4.f
+++ b/sammy/src/new/mnew4.f
@@ -9,7 +9,7 @@ C
* Iflmsc, Delmsc, Iradms, Iflpmc, Delpmc,
* Iflorr, Delorr, Iflrpi, Delrpi, Ifludr, Deludr,
* Iflnbk, Delnbk, Iflbgf, Delbgf, Ifldtp, Deldtp,
- * Ddcov , Nn, Mm, Kk, Ll, Vv, Diag,
+ * Nn, Mm, Kk, Ll, Vv, Diag,
* Runcs , Juncs , Prior , Iprior, Jprior,
* Noffv , Nuncer, Nprior)
C
@@ -40,7 +40,7 @@ C
* Delbgf(*), Deldtp(*),
* Vv(*), Diag(*),
* Runcs(Ntotc2+1,*),
- * Prior(*), Ddcov(*)
+ * Prior(*)
integer::Iflbrd(*),
* Ifleff(*), Ifltru(*),
* Ifliso(*), Iflpmc(*),
@@ -219,7 +219,7 @@ C are given as correlations
C
C
C *** If necessary, reorganize covariance data
- IF (Numpup.GT.0) THEN
+ IF (covData%getPupedParam().GT.0) THEN
CALL Reorg_Cov
ELSE
Iterat = 0
diff --git a/sammy/src/new/mnew6.f b/sammy/src/new/mnew6.f
index f79c9b1a72973f455ff430a9e383a16b03cd53d7..83a894fca25ac16144cb658af514363a3382086e 100644
--- a/sammy/src/new/mnew6.f
+++ b/sammy/src/new/mnew6.f
@@ -24,7 +24,7 @@ C
call resParData%getResonanceInfo(resInfo, N)
igrp = resInfo%getSpinGroupIndex()
- if (resInfo%getEnergyFitOption().lt.0) cycle
+ if (.not.resInfo%getIncludeInCalc()) cycle
call resParData%getResonance(resonance, resInfo)
call resParData%getSpinGroupInfo(spinInfo, igrp)
Mmax2 = spinInfo%getNumResPar()
diff --git a/sammy/src/new/mnew9.f b/sammy/src/new/mnew9.f
index 1f3b07b90855b7d8600dc6e2f02a6efc999dbbc6..6e4505b5f547d822ad4fd2a06b91855b536eea9f 100644
--- a/sammy/src/new/mnew9.f
+++ b/sammy/src/new/mnew9.f
@@ -895,7 +895,7 @@ C
N = Nnnn
Iparx = 0
- IF (resInfo%getEnergyFitOption().GE.0) THEN
+ IF (resInfo%getIncludeInCalc()) THEN
call resParData%getResonance(resonance, resInfo)
eres = resonance%getEres()
call resparData%getSpinGroupInfo(spinInfo, igr)
@@ -983,7 +983,7 @@ C
Kxx = K
call resparData%getSpinGroupInfo(spinInfo, Igr)
Mmax2 = spinInfo%getNumResPar()
- IF (resInfo%getEnergyFitOption().GE.0) THEN
+ IF (resInfo%getIncludeInCalc()) THEN
call resParData%getResonance(resonance, resInfo)
eres = resonance%getEres()
DO L=1,Mmax2
diff --git a/sammy/src/npv/mnpv7.f b/sammy/src/npv/mnpv7.f
index 4b3c7fb424239e358df1097e74c67078fa842b96..b86b9b7ff752e588d203049f357d7c76997cbdd9 100644
--- a/sammy/src/npv/mnpv7.f
+++ b/sammy/src/npv/mnpv7.f
@@ -45,12 +45,12 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Setg (Iuif, Wgxa, Wgxb)
+ SUBROUTINE Setg (Wgxa, Wgxb)
C
C *** Purpose == Rewrite partial derivatives Gx into resultData
C
use fixedi_m, only : Numcro, Ndaxxx, Ndbxxx, Nfpres,
- * Nfpall, Nvpthe
+ * Nvpthe
use ifwrit_m, only : Ksolve
use EndfData_common_m, only : covData
use sammy_ipq_common_m, only :resultData,derivStart,
@@ -58,10 +58,9 @@ C
IMPLICIT None
C
integer::ipup
- Integer::Iuif(*)
real(kind=8)::Wgxa(Numcro,Ndaxxx,*), Wgxb(Numcro,Ndbxxx,*)
integer:: Kdat
- integer::Ipar, Ii, I, K, Iffy, Iipar, keep
+ integer::Ipar, Ii, I, K, Iffy, keep
integer::ipos
real(kind=8)::gg, getDeriviative
@@ -80,22 +79,14 @@ C
End do
- Iipar = 0
DO Ipar=1,covData%getNumTotalParam()
- Iffy = 0
- IF (Ipar.GT.Nfpres) THEN
- Iffy = 1
- ELSE IF (Iuif(Ipar).NE.1) THEN
- Iffy = 1
- END IF
- IF (Iffy.EQ.1) THEN
- keep = covData%getCovIndex(Ipar)
- Iipar = Iipar + 1
+ IF (covData%contributes(Ipar))THEN
+ keep = covData%getCovIndex(Ipar)
Ii = 0
DO I=1,Kdat
DO K=1,Numcro
Ii = Ii + 1
- gg = getDeriviative(i, k, iipar, Wgxa, Wgxb)
+ gg = getDeriviative(i, k, ipar, Wgxa, Wgxb)
ipos = 0
IF (Keep.LE.Nvpthe) THEN ! derivatives start right after derivStart
@@ -112,19 +103,17 @@ C
END DO
C
ELSE IF (covData%getPupedParam().ne.0) THEN ! just do PUPs
- Iipar = 0
DO Ipar=1,covData%getNumTotalParam()
- IF (Ipar.GT.Nfpres .OR. Iuif(Ipar).NE.1) THEN
+ IF (covData%contributes(Ipar)) THEN
Keep = covData%getCovIndex(Ipar)
- Iipar = Iipar + 1
IF (Keep.LE.Nvpthe) THEN
C These are not part of IDC so not needed at Ksolve=2
- ELSE IF (covData%isPupedParameter(ipar)) THEN
+ ELSE IF (covData%isPupedParameter(Ipar)) THEN
Ii = 0
DO I=1,Kdat
DO K=1,Numcro
Ii = Ii + 1
- gg = getDeriviative(i, k, iipar, Wgxa, Wgxb)
+ gg = getDeriviative(i, k, Ipar, Wgxa, Wgxb)
ipos = keep + derivStart + nimplgiven ! pup'ed derivatives start after implicit derivatives
call resultData%addData(Ii, ipos, gg)
diff --git a/sammy/src/npv/mnpv9.f b/sammy/src/npv/mnpv9.f
index 23fa851881d02cf3af05d9ff8c6c85691ea7826c..637b3301064af53d264686d16aba69d93c42168d 100644
--- a/sammy/src/npv/mnpv9.f
+++ b/sammy/src/npv/mnpv9.f
@@ -8,7 +8,7 @@ C *** Purpose -- Create the arrays Th, G, X, in lowest possible storage
C *** location so that other needed arrays will not wipe out
C *** the storage
C
- use fixedi_m, only : Nfpall, Numcro, Nvpdtp
+ use fixedi_m, only : Numcro, Nvpdtp
use ifwrit_m, only : Ksolve, Ntgrlq
use exploc_common_m
use samxxx_common_m, only : Sam30x
@@ -38,7 +38,7 @@ C *** Open SAM30.DAT for integral quantities, read dimensions
IF (Ksolve.NE.2 .OR. covData%getPupedParam().gt.0) THEN
C *** Put derivatives into resultData
C
- CALL Setg (I_Iiuif , A_Iwdasi , A_Iwdbsi)
+ CALL Setg (A_Iwdasi , A_Iwdbsi)
END IF
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
diff --git a/sammy/src/ntg/mntg0.f b/sammy/src/ntg/mntg0.f
index 04610f3eace7d7fc1ac22e19719025f36574d1e7..be046984306be9076327f0cf9acb53e1796b0dfd 100644
--- a/sammy/src/ntg/mntg0.f
+++ b/sammy/src/ntg/mntg0.f
@@ -134,7 +134,7 @@ C *** Write theoretical values & derivatives onto SAM30
C *** Calculate theoretical covariance matrix for integral quantities
IF (Ksolve.NE.2) THEN
- CALL Fixcov (I_Iiuif , A_Iemmmq, A_Iwdasi , A_Iwdbsi ,
+ CALL Fixcov (A_Iemmmq, A_Iwdasi , A_Iwdbsi ,
* A_Ix1, Numntg, Numxxx)
END IF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
@@ -192,10 +192,15 @@ C *** purpose -- guesstimate size of array needed for sammxw
C
use fixedi_m
use ifwrit_m
+ use EndfData_common_m, only : covData
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
- Ngbout = Napthe
- Nsgbou = Napthe + 1
+ IF (Ksolve.EQ.2 .AND. covData%getPupedParam().eq.0) THEN
+ Ngbout = 0
+ else
+ Ngbout = covData%getNumTotalParam() - Numusd - Numdtp
+ end if
+ Nsgbou = Ngbout + 1
C
C *** one ***
Kddddd = Kdatb
diff --git a/sammy/src/ntg/mntg5.f b/sammy/src/ntg/mntg5.f
index 9b9e4e8294bb81ba136d3e4cb1bf9fe972ec903b..14fc3f57c65ec4526e6734837193649a08955fc1 100644
--- a/sammy/src/ntg/mntg5.f
+++ b/sammy/src/ntg/mntg5.f
@@ -110,7 +110,7 @@ C
END IF
IF (Etanuu.NE.0.0d0 .AND. Kjetan.GT.0) THEN
Dt = Wsigxx(Kountr-12)*Tosp
- Wdbsig(Kjetan-Nvadif-Ndasig,Kountr) = Dt
+ Wdbsig(Kjetan-Ndasig,Kountr) = Dt
END IF
WRITE (21,10000) Wsigxx(Kountr), Xnu
10000 FORMAT (' K1 = [MXFIS*nu-MXABS]*2/Sqrtpi =', 1P4G14.6)
diff --git a/sammy/src/ntg/mntg9.f b/sammy/src/ntg/mntg9.f
index 82e7120e053e4425fec43dde3a4bc16b89738bbe..7686d5f146694b0550e0341211ac3385dcd823d9 100644
--- a/sammy/src/ntg/mntg9.f
+++ b/sammy/src/ntg/mntg9.f
@@ -71,7 +71,7 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Fixcov (Iuif, Emmmq, Wdasig, Wdbsig, X, Numntg,
+ SUBROUTINE Fixcov (Emmmq, Wdasig, Wdbsig, X, Numntg,
* Numxxx)
C
C *** PURPOSE -- multiply Emmmq = Gq * Vrpr * Gq where Gq=wd?sig
@@ -84,10 +84,10 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
cx INCLUDE 'B34ZYX'
C
- DIMENSION Iuif(*), Emmmq(*), Wdasig(Ndaxxx,*), Wdbsig(Ndbxxx,*),
+ DIMENSION Emmmq(*), Wdasig(Ndaxxx,*), Wdbsig(Ndbxxx,*),
* X(Numntg,*)
type(ResonanceCovariance)::uCov
-C DIMENSION Iuif(Nvpres), Emmmq(Numxxx),
+C DIMENSION Emmmq(Numxxx),
C * X(Numntg,Nvpall)
C
DATA Zero /0.0d0/
@@ -99,18 +99,16 @@ C
C
C
call covData%getUCovariance(uCov)
- Jjpar = 0
- DO Jpar=1,Nvpthe
- IF (Jpar.GT.Nvpres .OR. Iuif(Jpar).NE.1) THEN
- Jjpar = Jjpar + 1
+ DO Jpar=1,Nvpthe
+ IF (covData%contributes(Jpar)) THEN
DO Kpar=1,Nvpall
cov = uCov%getCovariance(Kpar, Jpar)
IF (cov.NE.Zero) THEN
DO Idatq=1,Numntg
- IF (Jjpar.LE.Ndasig) THEN
- Gq = Wdasig(Jjpar,Idatq)
+ IF (Jpar.LE.Ndasig) THEN
+ Gq = Wdasig(Jpar,Idatq)
ELSE
- Gq = Wdbsig(Jjpar-Ndasig,Idatq)
+ Gq = Wdbsig(Jpar-Ndasig,Idatq)
END IF
IF (Gq.NE.Zero) THEN
X(Idatq,Kpar) = X(Idatq,Kpar) + Gq*cov
@@ -121,16 +119,14 @@ C
END IF
END DO
C
- Kkpar = 0
DO Kpar=1,Nvpthe
- IF (Kpar.GT.Nvpres .OR. Iuif(Kpar).NE.1) THEN
- Kkpar = Kkpar + 1
+ IF (covData%contributes(Kpar)) THEN
Kk = 0
DO Kdatq=1,Numntg
- IF (Kkpar.LE.Ndasig) THEN
- Gq = Wdasig(Kkpar ,Kdatq)
+ IF (Kpar.LE.Ndasig) THEN
+ Gq = Wdasig(Kpar ,Kdatq)
ELSE
- Gq = Wdbsig(KKpar-Ndasig,Kdatq)
+ Gq = Wdbsig(Kpar-Ndasig,Kdatq)
END IF
IF (Gq.NE.Zero) THEN
DO Idatq=1,Kdatq
diff --git a/sammy/src/old/mold0.f b/sammy/src/old/mold0.f
index f1b72db40314d7f43105d6549f31c31c0b7f88a2..c527ab5287a0dc19466d81d1ef4a85be7f59f799 100644
--- a/sammy/src/old/mold0.f
+++ b/sammy/src/old/mold0.f
@@ -124,7 +124,7 @@ C *** Generate associated flags
* I_Ifliso , I_Ifzke , I_Ifzkte , I_Ifzkfe )
C
C *** Organized PUPs
- IF (Numpup.GT.0) CALL Set_Keep
+ IF (covData%getPupedParam().GT.0) CALL Set_Keep
C
C
IF (Kpara+Kparv.NE.0) THEN
@@ -204,12 +204,14 @@ C
use exploc_common_m
use oopsch_common_m
use AllocateFunctions_m
+ use EndfData_common_m, only : covData
IMPLICIT DOUBLE PRECISION (a-h,o-z)
real(kind=8),allocatable,dimension(:)::A_Idiag
real(kind=8),allocatable,dimension(:):: A_Idummy
call allocate_real_data(A_Idiag, Nfpall)
- Nn = (Numpup*(Numpup+1))/2
+ Nn = covData%getPupedParam()
+ Nn = (Nn*(Nn+1))/2
Kkrext = Nrext
IF (Kkrext.EQ.0) Kkrext = 1
CALL Bet_Pup( A_Iprbrd , I_Iflbrd , A_Iechan ,
@@ -231,7 +233,7 @@ C
* I_Iflorr , A_Ideorr , I_Iflrpi , A_Iderpi ,
* I_Ifludr , A_Ideudr ,
* I_Iflnbk , A_Idenbk , I_Iflbgf , A_Idebgf ,
- * I_Ifldtp , A_Idedtp , A_Iddcov ,
+ * I_Ifldtp , A_Idedtp ,
* I_Inn , I_Imm , I_Ikk , I_Ill , A_Ivv ,
* A_Idiag ,
* A_Iuncs , I_Ijuncs ,
diff --git a/sammy/src/old/mold1.f b/sammy/src/old/mold1.f
index 1d1402ddb564d9f46ee2d87cefdafaf4ef373fbe..12a9fd8e204604b19f81951b2d8d1aff64115ed4 100644
--- a/sammy/src/old/mold1.f
+++ b/sammy/src/old/mold1.f
@@ -340,7 +340,7 @@ C
END IF
Npups = covData%getPupedParam()
IF (Npups.NE.0) THEN
- call allocate_real_data(A_Id2, Numpup)
+ call allocate_real_data(A_Id2, Npups)
DO I=1,Npups
II = I + covData%getNumParam()
A_Id2(I) = covData%getUParamValue(II)
diff --git a/sammy/src/old/mold4.f90 b/sammy/src/old/mold4.f90
index 05a3dfdc7e4fa5ef8f9eef76b47de5453d95948c..f747b9eb5558fa7f1118c30905f4dd4f30220f8b 100644
--- a/sammy/src/old/mold4.f90
+++ b/sammy/src/old/mold4.f90
@@ -170,7 +170,7 @@ END SUBROUTINE
99999 FORMAT (/, ' DIMENSIONS IN COVARIANCE FILE ARE NOT EQUAL TO', &
1X, 'DIMENSIONS IN PARAMETER FILE')
WRITE (6,99998) (Llf(I),I=1,50)
- WRITE (6,99997) (Lf(I),I=1,50)
+ WRITE (6,99997) (Lfdim(I),I=1,50)
99998 FORMAT (/, ' Jvpall,...', 10I5, /, (11X,10I5))
99997 FORMAT (/, ' Nvpall,...', 10I5, /, (11X,10I5))
RETURN
@@ -279,7 +279,7 @@ END SUBROUTINE
99999 FORMAT (/, ' DIMENSIONS IN COVARIANCE FILE ARE NOT EQUAL TO DIMENS &
IONS IN PARAMETER FILE')
WRITE (6,99998) (LLF(I),I=1,20)
- WRITE (6,99997) (LF(I),I=1,20)
+ WRITE (6,99997) (LFdim(I),I=1,20)
99998 FORMAT (/, ' Jvpres,...', 10I5, /, (11X,10I5))
99997 FORMAT (/, ' Nvpres,...', 10I5, /, (11X,10I5))
Ifff = 1
@@ -594,8 +594,7 @@ END SUBROUTINE
Ipar = 0
DO Ires=1,resParData%getNumResonances()
call resParData%getResonanceInfo(resInfo, Ires)
- Iflr = resInfo%getEnergyFitOption()
- IF (Iflr.GE.0) THEN
+ IF (resInfo%getIncludeInCalc()) THEN
Igr = resInfo%getSpinGroupIndex()
call resParData%getResonance(resonance, resInfo)
E = resonance%getEres()
diff --git a/sammy/src/old/mold8.f b/sammy/src/old/mold8.f
index 61930e562559b9a101ddb25b7ccc4472198dad17..3352e6aead3778ed67b725e22460d9ab31566112 100644
--- a/sammy/src/old/mold8.f
+++ b/sammy/src/old/mold8.f
@@ -8,7 +8,7 @@ C
* Parmsc, Iflmsc, Delmsc, Iradms, Iflpmc, Delpmc,
* Iflorr, Delorr, Iflrpi, Delrpi, Ifludr, Deludr,
* Iflnbk, Delnbk, Iflbgf, Delbgf, Ifldtp, Deldtp,
- * Ddcov, Nn, Mm, Kk, Ll, Vv, Diag,
+ * Nn, Mm, Kk, Ll, Vv, Diag,
* Runcs, Juncs, Prior, Iprior, Jprior,
* Noffv, Non, Nuncer, Nprior)
C
@@ -35,7 +35,6 @@ C
* Iflorr(*), Delorr(*), Iflrpi(*), Delrpi(*),
* Ifludr(*), Deludr(*), Iflnbk(*), Delnbk(*),
* Iflbgf(*), Delbgf(*), Ifldtp(*), Deldtp(*),
- * Ddcov(*),
* Nn(*), Mm(*), Kk(*), Ll(*), Vv(*),
* Diag(*), Runcs(Ntotc2+1,*), Juncs(Ntotc2,*),
* Prior(*), Iprior(*), Jprior(Ntotc2,*) ,Parmsc(*)
@@ -50,7 +49,7 @@ C * Iflpmc(4,Numpmc), Delpmc(4,Numpmc),
C * Iflorr(Numorr), Delorr(Numorr), Iflrpi(Numrpi), Delrpi(Numrpi),
C * Iflrpi(Numudr), Deludr(Numudr), IFlnbk(Numnbk), Delnbk(Numnbk),
C * Iflbgf(Numbgf), Delbgf(Numbgf), Ifldtp(Numdtp), Deldtp(Numdtp),
-C * Ddcov(Nres), Nn(Noffv), Mm(Noffv), Kk(Noffv), Ll(Noffv),
+C * Nn(Noffv), Mm(Noffv), Kk(Noffv), Ll(Noffv),
C * Vv(Noffv), Diag(Nfpall),
C * Runcs(Ntotc2+1,Nuncer), Juncs(Ntotc2,Nuncer),
C * Prior(Nprior), Iprior(Nprior), Jprior(Ntotc2,Nres)
diff --git a/sammy/src/old/mold9.f b/sammy/src/old/mold9.f
index 600f9dbd86c793cdf5b342b5421841464542c5c1..35ed7b5a2ba5510158922bf80384daeae7fed3ae 100644
--- a/sammy/src/old/mold9.f
+++ b/sammy/src/old/mold9.f
@@ -53,7 +53,7 @@ C
C *** First -- resonance parameters
DO Ires=1,resParData%getNumResonances()
call resParData%getResonanceInfo(resInfo, Ires)
- IF (resInfo%getEnergyFitOption().GE.0) THEN
+ IF (resInfo%getIncludeInCalc()) THEN
call resParData%getRedResonance(resonance, resInfo)
igr = resInfo%getSpinGroupIndex()
diff --git a/sammy/src/orr/morr1.f90 b/sammy/src/orr/morr1.f90
index 477eefa2da62cecd0f72d740c1484bdd6d95e7ce..3cc46d42f61a3d06c387c8d7ba0c6913243caa7f 100644
--- a/sammy/src/orr/morr1.f90
+++ b/sammy/src/orr/morr1.f90
@@ -176,7 +176,7 @@ module orr1_m
SUBROUTINE Xorres (Wts, Weight, Sigxxx, Dasigx, Dbsigx, &
Vsigxx, Vdasig, Vdbsig, Em, Parorr, Iflorr, Ecrnch, Sigmns, Sigpls, Dist)
!
- use fixedi_m, only : Nnnsig, Ndasig, Ndaxxx, Ndbsig, Ndbxxx, Nfporr, Numorr, Nvadif
+ use fixedi_m, only : Nnnsig, Ndasig, Ndaxxx, Ndbsig, Ndbxxx, Nfporr, Numorr
use ifwrit_m, only : Kdebug, Ksolve
use brdd_common_m, only : Ipnts, Kc
use orr2_m
@@ -262,7 +262,7 @@ module orr1_m
B = Zero
END IF
DO N=1,Nnnsig
- Dbsigx(n,Iflorr(I)-Nvadif-Ndasig) = B
+ Dbsigx(n,Iflorr(I)-Ndasig) = B
END DO
IF (Kdebug.NE.0) THEN
IF (Kwarn.LE.100) THEN
diff --git a/sammy/src/par/mpar0.f90 b/sammy/src/par/mpar0.f90
index a1453bcb72e5955cb1aebde6a34aca434435a9cd..3c99b968e28b0f63b2e108124a48ad8f64f36529 100644
--- a/sammy/src/par/mpar0.f90
+++ b/sammy/src/par/mpar0.f90
@@ -141,7 +141,7 @@ module par_m
!
Nunit = 21
IF (Kdecpl.NE.0) CALL Outddc (Nunit)
- CALL Order (A_Iprmsc , I_Irdmsc , A_Iddcov)
+ CALL Order (A_Iprmsc , I_Irdmsc)
! *** Sub routine Order reorders resonances according to J-Pi groups
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
!
@@ -154,9 +154,8 @@ module par_m
!
IF (Kpolar.EQ.1.AND. Nres.NE.0) CALL Flgpol (I_Iflpol )
!
- IF (Kdecpl.NE.0.AND. Nres.NE.0) CALL Dddcov (A_Iddcov, A_Idcov )
-! *** Routine Dddcov puts background covariance in terms of Nvpres instead
-! *** of Nres
+ IF (Kdecpl.NE.0.AND. Nres.NE.0) CALL Dddcov
+! *** Routine Dddcov updates zero uncertainties in resInfo%getXVal
!
IF (Nudwhi.NE.0) THEN
CALL Read_User (I_Inud_E , I_Inud_T , A_Iude , A_Iudr ,A_Iudt )
diff --git a/sammy/src/par/mpar01.f90 b/sammy/src/par/mpar01.f90
index 3210b195f046a2a1c96254682d7afee312f990f5..8a373ec96619714079e36ad5bfec6ed8628541c2 100644
--- a/sammy/src/par/mpar01.f90
+++ b/sammy/src/par/mpar01.f90
@@ -81,13 +81,6 @@ module par1_m
! *** eleven
N = Nres
IF (Kdecpl.EQ.0 .AND. Kenunc.EQ.0) N = 1
- IF (Nres.EQ.0) N = 1
- call make_A_Iddcov(N)
-!
-! *** twelve
- N = Nvpres
- IF (Kdecpl.EQ.0) N = 1
- call make_A_Idcov(N)
!
! *** thirteen
K = Nfpall
@@ -187,4 +180,4 @@ module par1_m
I5, ' but you need', I6, '... ERROR')
RETURN
END
-end module par1_m
\ No newline at end of file
+end module par1_m
diff --git a/sammy/src/par/mpar04.f90 b/sammy/src/par/mpar04.f90
index 91fa53e38d494bc41684b26f4517af84795c6a23..f7cbb76bd1e8c3ba68d03c4ec2cd932971a66bf9 100644
--- a/sammy/src/par/mpar04.f90
+++ b/sammy/src/par/mpar04.f90
@@ -457,19 +457,7 @@ module par4_m
ELSE IF (Xx.EQ.Concrz) THEN
! *** Line # xx *** Constant cross section added to what's calculated
! *** NOTE THAT THIS OPTION IS NOT COMPLETED, NOT USED ANYWHERE!
- Parmsc(N+1) = A
- Parmsc(N+2) = C
- Delmsc(N+1) = B
- Delmsc(N+2) = D
- Iflmsc(N+1) = I
- Iflmsc(N+2) = J
- Nammsc(N+1) = Concrz
- Nammsc(N+2) = Concry
- Kconcr = N + 1
- Kcontr = N + 2
- Concro = A
- Contot = C
- N = N + 2
+ stop 'Adding of a constant cross section is not supported'
!
END IF
GO TO 10
diff --git a/sammy/src/par/mpar11.f90 b/sammy/src/par/mpar11.f90
index 2a98c2a318f3d2718d0e06618fbce787247d4090..b14387cb9a89757a922a0b40800c6cb6764b5470 100644
--- a/sammy/src/par/mpar11.f90
+++ b/sammy/src/par/mpar11.f90
@@ -163,7 +163,7 @@ module par11_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Order (Parmsc, Iradms, Ddcov)
+ SUBROUTINE Order (Parmsc, Iradms)
!
! *** Purpose -- Reorder resonance parameters by energy (low to high) and
! *** by J-pi groups
@@ -179,14 +179,14 @@ module par11_m
use EndfData_common_m, only : covData, resParData
IMPLICIT NONE
!
- real(kind=8)::Parmsc(*), Ddcov(*)
+ real(kind=8)::Parmsc(*)
Integer::Iradms(*)
!
type(SammyResonanceInfo)::resInfo
type(SammySpinGroupInfo)::spinInfo
type(RMatResonance)::resonance
real(kind=8)::Zero
- integer::I, ier, iffres, igrp, iopt, J, ntot, numChan
+ integer::I, ier, igrp, iopt, J, ntot, numChan
integer::jpar, jres, jgroup, jparAll, jpup
DATA Zero /0.0d0/
!
@@ -262,35 +262,10 @@ module par11_m
WRITE (21,99997) igrp, Ntot, numChan
STOP '[STOP in Order in par/mpar11.f # 3]'
end if
-
- iffres = 0 ! count number of varied parameters
IF (Iradms(igrp).NE.0) then
call resonance%setWidth(1, Parmsc(Iradms(igrp)))
- end if
- iffres = iffres + resInfo%getEnergyFitOption()
-
- iffres = iffres + resInfo%getChannelFitOption(1)
- do i = 2, resonance%getNumChan()
- iffres = iffres + resInfo%getChannelFitOption(i)
- if (i.eq.2.and.spinInfo%getGammWidthParIndex().gt.0) then
- iffres = iffres + spinInfo%getGammWidthParIndex()
- end if
- end do
-
-
- if( .not.resInfo%getIncludeInCalc()) then
- iopt = resInfo%getEnergyFitOption()
- iopt = iopt - 3 ! flag that we do not want to vary any data
- call resInfo%setEnergyFitOption(iopt)
- else
- if (iffres.eq.0) then ! no variead parameters
- call resInfo%setEnergyFitOption(-1) ! flag that we do not want to vary any data
- end if
- end if
-
- IF (Kenunc.NE.0 .OR. Kdecpl.NE.0) then
- Ddcov(j) = resInfo%getXVal()
+ call resInfo%setChannelFitOption(1, spinInfo%getGammWidthParIndex())
end if
end do
@@ -382,7 +357,7 @@ module par11_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Dddcov (Ddcov, Dcov)
+ SUBROUTINE Dddcov
!
use fixedi_m
use ifwrit_m
@@ -391,7 +366,6 @@ module par11_m
use EndfData_common_m
IMPLICIT none
!
- real(kind=8):: Dcov(*), Ddcov(*)
real(kind=8):: Zero
type(SammyResonanceInfo)::resInfo
type(RMatResonance)::resonance
@@ -403,31 +377,12 @@ module par11_m
! *** Adjust Dcov to be with respect to Nfpall not Nres
IF (Kdecpl.NE.1) THEN
DO N=1,resParData%getNumResonances()
- IF (Ddcov(N).EQ.Zero) Ddcov(N) = 1.d-6
+ call resParData%getResonanceInfo(resInfo, N)
+ IF (resInfo%getXVal().EQ.Zero) then
+ call resInfo%setXVal(1.d-6)
+ end if
END DO
END IF
- Ipar = 0
- DO N=1,resParData%getNumResonances()
- call resParData%getResonanceInfo(resInfo, N)
- if ( resInfo%getEnergyFitOption().le.0) cycle ! this resonance is ignored in the fit
- call resParData%getResonance(resonance, resInfo)
-
- II = 0
-
- ! count energy fit options
- Ipar = Ipar + 1
- II = II + 1
- IF (II.EQ.1) Dcov(Ipar) = Ddcov(N)
- IF (II.NE.1) Dcov(Ipar) = Zero
-
- ! and the rest of the channels
- do M = 1, resonance%getNumChan()
- Ipar = Ipar + 1
- II = II + 1
- IF (II.EQ.1) Dcov(Ipar) = Ddcov(N)
- IF (II.NE.1) Dcov(Ipar) = Zero
- end do
- END DO
RETURN
END
end module par11_m
diff --git a/sammy/src/rec/mrec3.f b/sammy/src/rec/mrec3.f
index 4b82287eb5b8323ca6e2d420a20e8edb693df5d3..981894b9fe88064a7d28d506f44eeb25168ce3e4 100644
--- a/sammy/src/rec/mrec3.f
+++ b/sammy/src/rec/mrec3.f
@@ -23,7 +23,6 @@ C
Squ = dSQRT(Su)
C
Ks_Res = 2
- Ifres = 1
Ifcap = 1
Ifzzz = 1
Ifext = 1
@@ -97,7 +96,7 @@ C --------------------------------------------------------------
C
SUBROUTINE Uuuset (Difmax)
C
-C *** PURPOSE -- GENERATE Uup, Udown, Iuif, Nnpar, Difmax
+C *** PURPOSE -- GENERATE Uup, Udown, Nnpar, Difmax
C *** modified from program Uset in mthe1
C
use fixedi_m
diff --git a/sammy/src/ref/mrfs0.f b/sammy/src/ref/mrfs0.f
index 8008f344230f4bfa75ec73d0cb76a8af527e4a17..bc32c7d9d682ca8686834564b08717a25a36fdb9 100644
--- a/sammy/src/ref/mrfs0.f
+++ b/sammy/src/ref/mrfs0.f
@@ -66,8 +66,7 @@ C *** collect values needed for parameter file
* A_Iprnbk , I_Iflnbk , A_Idenbk ,
* A_Iprbgf , I_Iflbgf , A_Idebgf , I_Indbgf , A_Ibgfma ,
* A_Ibgfma , A_Iprdtp , I_Ifldtp , A_Idedtp ,
- * A_Iprusd , A_Iprbag , I_Iflbag ,
- * A_Iddcov)
+ * A_Iprusd , A_Iprbag , I_Iflbag)
C
I = Idimen (0, 0, '0, 0')
CALL Write_Commons_Few
diff --git a/sammy/src/ref/mrfs4.f b/sammy/src/ref/mrfs4.f
index 733358c91670e5b0e28a514afbdb36dbbd96aaa1..48d47216452e58ba77602396b280053b35adef67 100644
--- a/sammy/src/ref/mrfs4.f
+++ b/sammy/src/ref/mrfs4.f
@@ -12,7 +12,7 @@ C
* parrpi, Iflrpi, Delrpi, Parnbk, Iflnbk, Delnbk,
* Parbgf, Iflbgf, Delbgf, Kndbgf, Bgfmin, Bgfmax,
* Pardtp, Ifldtp, Deldtp,
- * Parusd, Parbag, Iflbag, Ddcov )
+ * Parusd, Parbag, Iflbag)
C
C *** purpose -- convert from REFIT to SAMMY parameters
C
@@ -47,7 +47,7 @@ C
* Parnbk(*), Iflnbk(*), Delnbk(*),
* Parbgf(*), Iflbgf(*), Delbgf(*), Kndbgf(*), Bgfmin(*),
* Bgfmax(*), Pardtp(*), Ifldtp(*), Deldtp(*), Parusd(*),
- * ParBAG(*), Iflbag(*), Ddcov(*)
+ * ParBAG(*), Iflbag(*)
C
C DIMENSION Parbrd(Numbrd), Iflbrd(Numbrd),
C * Igrrad(Ntotc,Ngroup),
@@ -66,8 +66,7 @@ C * Parbgf(Numbgf), Iflbgf(Numbgf), Delbgf(Numbgf),
C * Kndbgf(Numbgf), Bgfmin(Numbgf), Bgfmax(Numbgf),
C * Pardtp(Numdtp), Namdtp(Numdtp), Ifldtp(Numdtp),
C * Parusd(Numusd), Namusd(Numusd),
-C * Parbag(Numusd), Iflbag(Numusd),
-C * Ddcov(Nres)
+C * Parbag(Numusd), Iflbag(Numusd)
C
C
IF (Nres.NE.0) THEN
diff --git a/sammy/src/ref/mwrt0.f b/sammy/src/ref/mwrt0.f
index c95fc70de19ad49f0497fb11a7e1f60ade6bfc32..a42fd8cdcec9e4b46e75af7233ec0a5254641a81 100644
--- a/sammy/src/ref/mwrt0.f
+++ b/sammy/src/ref/mwrt0.f
@@ -66,7 +66,7 @@ C *** Write Parameter file
* A_Iprbgf , I_Iflbgf , A_Idebgf , I_Indbgf , A_Ibgfmi ,
* A_Ibgfma , A_Iprdtp , I_Ifldtp , A_Idedtp ,
* A_Iprusd , A_Iprbag , I_Iflbag ,
- * A_Iddcov , A_I3 , A_I4 ,
+ * A_I3 , A_I4 ,
* 0, 0, relevantData, .true.)
C *** Routine Oldord reorders Parameters into original order,
C *** and writes the new Parameter file
diff --git a/sammy/src/rpi/mrpi7.f90 b/sammy/src/rpi/mrpi7.f90
index 7ff629355ad3cea19a162f827e15eab5f90a6378..467d40328010002d194cc3870d82a9f863b991a0 100644
--- a/sammy/src/rpi/mrpi7.f90
+++ b/sammy/src/rpi/mrpi7.f90
@@ -210,7 +210,7 @@ module rpi7_m
!
use rpi5_m
use rpi8_m
- use fixedi_m, only : Nnnsig, Lother, Ndasig, Nvadif
+ use fixedi_m, only : Nnnsig, Lother, Ndasig
use ifwrit_m, only : Kdebug
use rpijnk_common_m
use rpires_common_m
@@ -281,7 +281,7 @@ module rpi7_m
! *** Note that Wtsx assume a factor of 1/Www is missing from d(I)/d(www).
! *** Also note that Www=S4ln2/p and p is the variable of interest.
Der = - Der*Www /Thous/S4ln2
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der
END DO
@@ -296,7 +296,7 @@ module rpi7_m
!
use rpi5_m
use rpi8_m
- use fixedi_m, only : Nnnsig, Ndasig, Nvadif
+ use fixedi_m, only : Nnnsig, Ndasig
use ifwrit_m, only : Kdebug, Midrpi
use rpijnk_common_m
use rpires_common_m
@@ -353,7 +353,7 @@ module rpi7_m
Irpi = 2
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = dEXP(-Taub*Em)/Thous
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -361,7 +361,7 @@ module rpi7_m
Irpi = 3
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = -Taua*Em*dEXP(-Taub*Em)
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -369,7 +369,7 @@ module rpi7_m
Irpi = 4
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = dEXP(-Taud*Em)/Thous
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -377,7 +377,7 @@ module rpi7_m
Irpi = 5
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = -Tauc*Em*dEXP(-Taud*Em)
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -385,7 +385,7 @@ module rpi7_m
Irpi = 6
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = One/Thous
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -393,7 +393,7 @@ module rpi7_m
Irpi = 7
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = Em**Taug / Thous
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -401,7 +401,7 @@ module rpi7_m
Irpi = 8
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = dLOG(Em)*Tauf*Em**Taug
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -417,7 +417,7 @@ module rpi7_m
!
use rpi5_m
use rpi8_m
- use fixedi_m, only : Nnnsig, Ndasig, Nvadif
+ use fixedi_m, only : Nnnsig, Ndasig
use ifwrit_m, only : Kdebug, Midrpi
use rpijnk_common_m
use rpires_common_m
@@ -472,7 +472,7 @@ module rpi7_m
Dl = dLOG(Em)
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = One/Thous
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -480,7 +480,7 @@ module rpi7_m
Irpi = 10
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = Dl/Thous
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -488,7 +488,7 @@ module rpi7_m
Irpi = 11
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = Dl**2/Thous
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -496,7 +496,7 @@ module rpi7_m
Irpi = 12
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = Em**El4/Thous
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -504,7 +504,7 @@ module rpi7_m
Irpi = 13
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = El3 * Em**El4 * Dl
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
Do N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -519,7 +519,7 @@ module rpi7_m
Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
!
use rpi5_m
- use fixedi_m, only : Nnnsig, Ndasig, Nvadif
+ use fixedi_m, only : Nnnsig, Ndasig
use ifwrit_m, only : Kdebug, Midrpi
use rpijnk_common_m
use rpires_common_m
@@ -578,7 +578,7 @@ module rpi7_m
Irpi = 14
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = dEXP(-A1b*Em)*Thous
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -586,7 +586,7 @@ module rpi7_m
Irpi = 15
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = -A1a*Em*dEXP(-A1b*Em)
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -594,7 +594,7 @@ module rpi7_m
Irpi = 16
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = dEXP(-A1d*Em)*Thous
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -602,7 +602,7 @@ module rpi7_m
Irpi = 17
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = -A1c*Em*dEXP(-A1d*Em)
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -610,7 +610,7 @@ module rpi7_m
Irpi = 18
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = One*Thous
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -618,7 +618,7 @@ module rpi7_m
Irpi = 19
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = Em**A1g*Thous
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -626,7 +626,7 @@ module rpi7_m
Irpi = 20
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = A1f * Em**A1g * dLOG(Em)
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Fudgex
END DO
@@ -641,7 +641,7 @@ module rpi7_m
Vsigxx, Em, Parrpi, Iflrpi, Sigt)
!
use rpi5_m
- use fixedi_m, only : Nnnsig, Ndasig, Nvadif
+ use fixedi_m, only : Nnnsig, Ndasig
use ifwrit_m, only : Kdebug, Midrpi
use rpijnk_common_m
use rpires_common_m
@@ -691,7 +691,7 @@ module rpi7_m
Timej = F
Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(21), A, Kdebug, &
Kwarn, Irpi, Em)
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der/Thous
END DO
@@ -705,7 +705,7 @@ module rpi7_m
Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
!
use rpi5_m
- use fixedi_m, only : Nnnsig, Ndasig, Nvadif
+ use fixedi_m, only : Nnnsig, Ndasig
use ifwrit_m, only : Kdebug, Midrpi
use rpijnk_common_m
use rpires_common_m
@@ -764,7 +764,7 @@ module rpi7_m
T2 = H
Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(22), A, Kdebug, &
Kwarn, Irpi, Em)
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der
END DO
@@ -778,7 +778,7 @@ module rpi7_m
Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
!
use rpi5_m
- use fixedi_m, only : Nnnsig, Medrpi, Ndasig, Nvadif
+ use fixedi_m, only : Nnnsig, Medrpi, Ndasig
use ifwrit_m, only : Kdebug, Midrpi
use rpijnk_common_m
use rpires_common_m
@@ -841,7 +841,7 @@ module rpi7_m
Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(23), A, Kdebug, &
Kwarn, Irpi, Em)
IF (Medrpi.EQ.0) THEN
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Thous
END DO
@@ -850,49 +850,49 @@ module rpi7_m
IF (Parrpi(23).LT.-One) Sqe = dSQRT(Em)
Sqe = Sqe * Thous
IF (Iflrpi(26).GT.0) THEN
- Kkk = Iflrpi(26) - Nvadif - Ndasig
+ Kkk = Iflrpi(26) - Ndasig
X = Sqe*dEXP(-Parrpi(27)*Em)
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
END DO
END IF
IF (Iflrpi(27).GT.0) THEN
- Kkk = Iflrpi(27) - Nvadif - Ndasig
+ Kkk = Iflrpi(27) - Ndasig
X = - Sqe*dEXP(-Parrpi(27)*Em)*Parrpi(26)*Em
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
END DO
END IF
IF (Iflrpi(28).GT.0) THEN
- Kkk = Iflrpi(28) - Nvadif - Ndasig
+ Kkk = Iflrpi(28) - Ndasig
X = Sqe*dEXP(-Parrpi(29)*Em)
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
END DO
END IF
IF (Iflrpi(29).GT.0) THEN
- Kkk = Iflrpi(29) - Nvadif - Ndasig
+ Kkk = Iflrpi(29) - Ndasig
X = - Sqe*dEXP(-Parrpi(29)*Em)*Parrpi(28)*Em
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
END DO
END IF
IF (Iflrpi(30).GT.0) THEN
- Kkk = Iflrpi(30) - Nvadif - Ndasig
+ Kkk = Iflrpi(30) - Ndasig
X = Sqe
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
END DO
END IF
IF (Iflrpi(31).GT.0) THEN
- Kkk = Iflrpi(31) - Nvadif - Ndasig
+ Kkk = Iflrpi(31) - Ndasig
X = Sqe*Em**(Parrpi(32))
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
END DO
END IF
IF (Iflrpi(32).GT.0) THEN
- Kkk = Iflrpi(32) - Nvadif - Ndasig
+ Kkk = Iflrpi(32) - Ndasig
X = Parrpi(31)*Sqe*Em**(Parrpi(32))*dlog(Em)
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
@@ -909,7 +909,7 @@ module rpi7_m
Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
!
use rpi5_m
- use fixedi_m, only : Nnnsig, Ndasig, Nvadif
+ use fixedi_m, only : Nnnsig, Ndasig
use ifwrit_m, only : Kdebug, Midrpi
use rpijnk_common_m
use rpires_common_m
@@ -968,7 +968,7 @@ module rpi7_m
T2 = H
Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(24), A, Kdebug, &
Kwarn, Irpi, Em)
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der
END DO
@@ -982,7 +982,7 @@ module rpi7_m
Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
!
use rpi5_m
- use fixedi_m, only : Nnnsig, Mmmrpi, Ndasig, Nvadif
+ use fixedi_m, only : Nnnsig, Mmmrpi, Ndasig
use ifwrit_m, only : Kdebug, Midrpi
use rpijnk_common_m
use rpires_common_m
@@ -1043,7 +1043,7 @@ module rpi7_m
Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(25), A, Kdebug, Kwarn, Irpi,Em)
IF (Mmmrpi.EQ.0) THEN
Irpi = 25
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*Thous
END DO
@@ -1052,49 +1052,49 @@ module rpi7_m
IF (Parrpi(25).LT.Zero) Sqe = dSQRT(Em)
Sqe = Sqe * Thous
IF (Iflrpi(33).GT.0) THEN
- Kkk = Iflrpi(33) - Nvadif - Ndasig
+ Kkk = Iflrpi(33) - Ndasig
X = Sqe*dEXP(-Parrpi(34)*Em)
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
END DO
END IF
IF (Iflrpi(34).GT.0) THEN
- Kkk = Iflrpi(34) - Nvadif - Ndasig
+ Kkk = Iflrpi(34) - Ndasig
X = - Sqe*dEXP(-Parrpi(34)*Em)*Parrpi(33)*Em
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
END DO
END IF
IF (Iflrpi(35).GT.0) THEN
- Kkk = Iflrpi(35) - Nvadif - Ndasig
+ Kkk = Iflrpi(35) - Ndasig
X = Sqe*dEXP(-Parrpi(36)*Em)
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
END DO
END IF
IF (Iflrpi(36).GT.0) THEN
- Kkk = Iflrpi(36) - Nvadif - Ndasig
+ Kkk = Iflrpi(36) - Ndasig
X = - Sqe*dEXP(-Parrpi(36)*Em)*Parrpi(35)*Em
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
END DO
END IF
IF (Iflrpi(37).GT.0) THEN
- Kkk = Iflrpi(37) - Nvadif - Ndasig
+ Kkk = Iflrpi(37) - Ndasig
X = Sqe
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
END DO
END IF
IF (Iflrpi(38).GT.0) THEN
- Kkk = Iflrpi(38) - Nvadif - Ndasig
+ Kkk = Iflrpi(38) - Ndasig
X = Sqe*Em**(Parrpi(39))
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
END DO
END IF
IF (Iflrpi(39).GT.0) THEN
- Kkk = Iflrpi(39) - Nvadif - Ndasig
+ Kkk = Iflrpi(39) - Ndasig
X = Parrpi(38)*Sqe*Em**(Parrpi(39))*dlog(Em)
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der*X
@@ -1112,7 +1112,7 @@ module rpi7_m
!
use rpi5_m
use rpi8_m
- use fixedi_m, only : Nnnsig, Lother, Medrpi, Nvadif, Ndasig
+ use fixedi_m, only : Nnnsig, Lother, Medrpi, Ndasig
use ifwrit_m, only : Kdebug, Midrpi
use rpijnk_common_m
use rpires_common_m
@@ -1231,7 +1231,7 @@ module rpi7_m
10 CONTINUE
END DO
IF (Iflrpi(Irpi+1).NE.0) THEN
- Kkk = Iflrpi(Irpi+1) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi+1) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der1*Thous
END DO
@@ -1239,7 +1239,7 @@ module rpi7_m
IF (Ifx.GT.0) THEN
DO Im=2,8
If (Iflrpi(Irpi+Im).GT.0) THEN
- Kkk = Iflrpi(Irpi+Im) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi+Im) - Ndasig
IF (Im.EQ.2) THEN
Q = dEXP(-Parrpi(Irpi+3)*Em)
ELSE IF (Im.EQ.3) THEN
@@ -1276,7 +1276,7 @@ module rpi7_m
CALL Rpi_Br_Der (Weight, Wtsx, Wts_Norm, &
Jjjder)
Der = Sumupd (Wtsx, Vsigxx)
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
Der = Der*Thous
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der
@@ -1299,7 +1299,7 @@ module rpi7_m
DO Im=2,8
Irpi = Irpi + 1
IF (Iflrpi(Irpix).NE.0) THEN
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
IF (Im.EQ.2 .OR. Im.EQ.4 .OR. Im.EQ.6 .OR. &
Im.EQ.7) Der = Der*Thous
DO N=1,Nnnsig
@@ -1322,7 +1322,7 @@ module rpi7_m
!
use rpi5_m
use rpi8_m
- use fixedi_m, only : Nnnsig, Ndasig, Nvadif
+ use fixedi_m, only : Nnnsig, Ndasig
use ifwrit_m, only : Kdebug
use rpijnk_common_m
use rpires_common_m
@@ -1362,7 +1362,7 @@ module rpi7_m
Irpi, Em)
END IF
Der = Der/Thous
- Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
+ Kkk = Iflrpi(Irpi) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der
END DO
diff --git a/sammy/src/rsl/mrsl1.f90 b/sammy/src/rsl/mrsl1.f90
index b195a1449d23f197c204090b5889fd0b71488df2..ff8e1940464ef62b8d54dd561420ccaa76d2abcf 100644
--- a/sammy/src/rsl/mrsl1.f90
+++ b/sammy/src/rsl/mrsl1.f90
@@ -230,7 +230,7 @@ module rsl1_m
SUBROUTINE Xresol (auxGrid, Wts, Weight, Sigxxx, Dasigx, Dbsigx, &
Vsigxx, Vdasig, Vdbsig, Iflmsc, Widgau, Widexp, Est, Em, Ifirst)
!
- use fixedi_m, only : Nnnsig, Ndaxxx, Ndbsig, Ndasig, Ndbxxx, Nvadif
+ use fixedi_m, only : Nnnsig, Ndaxxx, Ndbsig, Ndasig, Ndbxxx
use ifwrit_m, only : Kdebug, Kjdele, Ksolve, Kvdell, Kvdlt2, Kvdlte, Kvdltg, Kjdell, Kvdltc
use broad_common_m, only : Ao2, Bo2, DeltaE, Deltag, deltal, Deltc1, Deltc2
use brdd_common_m, only : Ipnts, Kc
@@ -326,7 +326,7 @@ module rsl1_m
IF (Kvdell.GT.0) THEN
! *** Here we generate derivative wrt Delta-L
B = A*Bo2/Deltal
- K = Kvdell - Nvadif - Ndasig
+ K = Kvdell - Ndasig
DO N=1,Nnnsig
Dbsigx(N,K) = B
END DO
@@ -337,13 +337,13 @@ module rsl1_m
! *** energy-dependent
B = A*Bo2/Deltal
IF (Iflmsc(Kjdell).GT.0) THEN
- K = Iflmsc(Kjdell) - Nvadif - Ndasig
+ K = Iflmsc(Kjdell) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,K) = B*Em
END DO
END IF
IF (Iflmsc(Kjdell+1).GT.0) THEN
- K = Iflmsc(Kjdell+1) - Nvadif - Ndasig
+ K = Iflmsc(Kjdell+1) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,K) = B
END DO
@@ -352,7 +352,7 @@ module rsl1_m
!
IF (Kvdltg.GT.0) THEN
! *** Here generate derivative wrt Delta-t-sub-G
- K = Kvdltg - Nvadif - Ndasig
+ K = Kvdltg - Ndasig
DO N=1,Nnnsig
Dbsigx(N,K) = A*Em*Ao2/dABS(Deltag)
END DO
@@ -361,7 +361,7 @@ module rsl1_m
IF (Kvdltc.GT.0) THEN
! *** Here generate derivative wrt Delta-t-sub-C1
Deltac = Deltc1 + Em*Deltc2
- K = Kvdltc - Nvadif - Ndasig
+ K = Kvdltc - Ndasig
DO N=1,Nnnsig
Dbsigx(N,K) = Dergau * Deltac/Widgau
END DO
@@ -370,7 +370,7 @@ module rsl1_m
IF (Kvdlt2.GT.0) THEN
! *** Here generate derivative wrt Delta-t-sub-C2
Deltac = Deltc1 + Em*Deltc2
- K = Kvdlt2 - Nvadif - Ndasig
+ K = Kvdlt2 - Ndasig
DO N=1,Nnnsig
Dbsigx(N,K) = Dergau * Em*Deltac/Widgau
END DO
@@ -382,7 +382,7 @@ module rsl1_m
A = ( 0.5d0*(Esigp-Esigm) / (Edel*DeltaE) )
IF (Kvdlte.GT.0) THEN
! *** Here generate derivative wrt Delta-t-sub-E
- K = Kvdlte - Nvadif - Ndasig
+ K = Kvdlte - Ndasig
DO N=1,Nnnsig
Dbsigx(N,K) = A
END DO
@@ -392,19 +392,19 @@ module rsl1_m
! *** Here generate derivative wrt Delta-e when Delta-e is
! *** energy-dependent
IF (Iflmsc(Kjdele).GT.0) THEN
- K = Iflmsc(Kjdele) - Nvadif - Ndasig
+ K = Iflmsc(Kjdele) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,K) = A*Em
END DO
END IF
IF (Iflmsc(Kjdele+1).GT.0) THEN
- K = Iflmsc(Kjdele+1) - Nvadif - Ndasig
+ K = Iflmsc(Kjdele+1) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,K) = A
END DO
END IF
IF (Iflmsc(Kjdele+2).GT.0) THEN
- K = Iflmsc(Kjdele+2) - Nvadif - Ndasig
+ K = Iflmsc(Kjdele+2) - Ndasig
DO N=1,Nnnsig
Dbsigx(N,K) = A*dLOG(Em)
END DO
@@ -432,7 +432,7 @@ module rsl1_m
END IF
!
IF (Kvdlte.GT.0) THEN
- Derexp = Dbsigx(1,(Kvdlte-Nvadif-Ndasig))
+ Derexp = Dbsigx(1,(Kvdlte-Ndasig))
Sigt = Sigxxx(1)
Derex1 = (Esigp-Sigt)/(Edel*DeltaE)
Derex2 = (Sigt-Esigm)/(Edel*DeltaE)
diff --git a/sammy/src/rsl/mrsl2.f90 b/sammy/src/rsl/mrsl2.f90
index 0b5efa2b0333fa360aa286537346674474e1952d..5c18daefcbd314eae58794642fbe6527e01de05e 100644
--- a/sammy/src/rsl/mrsl2.f90
+++ b/sammy/src/rsl/mrsl2.f90
@@ -47,7 +47,7 @@ module rsl2_m
!
! *** purpose -- convert from transmission back to cross sections
!
- use fixedi_m, only : Nnnsig, Ndasig, Ndbsig, Nvadif
+ use fixedi_m, only : Nnnsig, Ndasig, Ndbsig
use ifwrit_m, only : Ksolve, Kvthck
use abro_common_m, only : Thck
@@ -82,7 +82,7 @@ module rsl2_m
END DO
IF (Ksolve.NE.2) THEN
IF (Kvthck.GT.0) THEN
- K = Kvthck - Nvadif - Ndasig
+ K = Kvthck - Ndasig
DO n=1,Nnnsig
Dbsigx(n,K) = Dbsigx(n,K) + A*Sigxxx(n)
END DO
diff --git a/sammy/src/sammy/CMakeLists.txt b/sammy/src/sammy/CMakeLists.txt
index cac32a9e942175e8357279f2f2cfa321e635e3b3..e6c16d1887eeac3612ee2557e9c249066ad8e4dd 100644
--- a/sammy/src/sammy/CMakeLists.txt
+++ b/sammy/src/sammy/CMakeLists.txt
@@ -476,7 +476,7 @@ APPEND_SET(SAMMY_SOURCES
../xct/mxct08.f
../xct/mxct09.f
../xct/mxct10.f
- ../xct/mxct11.f
+ ../xct/mxct11.f90
../xct/mxct12.f
../xct/mxct13.f
../xct/mxct14.f90
diff --git a/sammy/src/squ/msqu0.f b/sammy/src/squ/msqu0.f
index db8a84af55c37229363334926adea6c437222382..6b76bfe1d6c5300d0a55cfa7b57c60b0420e579b 100644
--- a/sammy/src/squ/msqu0.f
+++ b/sammy/src/squ/msqu0.f
@@ -14,6 +14,7 @@ C
use sammy_ipq_common_m, only : N1, N2, nimplgiven, nimplict
use SammyFlowControl_M, only : fitOption, Where_To_Next
use SammyLptPrinting_m
+ use EndfData_common_m, only : covData
IMPLICIT DOUBLE PRECISION (a-h,o-z)
character(len=80)::line
C
@@ -47,7 +48,7 @@ C
IF (Kaverg.NE.0) GO TO 110
Nnndat = Numcro*Ndat
Numidc = Kumidc
- Kkkidc = Kumidc + Numpup
+ Kkkidc = Kumidc + covData%getPupedParam()
C
Numidc = nimplgiven
Kkkidc = nimplict
diff --git a/sammy/src/ssm/mssm00.f90 b/sammy/src/ssm/mssm00.f90
index 9ae3d2fa37f92a6422ad062d45080e86fc547c55..7d7561db789297d70c2b237f6544a45665572b24 100644
--- a/sammy/src/ssm/mssm00.f90
+++ b/sammy/src/ssm/mssm00.f90
@@ -244,9 +244,9 @@ module ssm_m
IF (Nx.EQ.0) THEN
Nx = 1
ELSE
- IF (Kvthck-Nvadif.GT.Nx) Nx = Kvthck - Nvadif
+ IF (Kvthck.GT.Nx) Nx = Kvthck
END IF
- IF (Debug) WRITE (6,12345) Kvthck, Nvadif, Nx
+ IF (Debug) WRITE (6,12345) Kvthck, 0, Nx
12345 FORMAT (' Kvthck, Nvadif, Nx=', 3I5)
Nnx = Nx
IF (Kssdbl.NE.1) Nnx = 1
diff --git a/sammy/src/ssm/mssm11.f90 b/sammy/src/ssm/mssm11.f90
index 8365f837df32f7796c39057b8b71f993e29c43cf..3ff8a5e56a4d9c88d7c0d95917dd8dda8aecf7ff 100644
--- a/sammy/src/ssm/mssm11.f90
+++ b/sammy/src/ssm/mssm11.f90
@@ -36,7 +36,7 @@ module ssm_11_m
DATA Zero /0.0d0/
!
Izero = 1
- Kv = Kvthck - Nvadif
+ Kv = Kvthck
!
! *** Find differential elastic scattering cross section Elas and
! *** derivatives Delas at Energy Em and angle Theta
@@ -113,7 +113,7 @@ module ssm_11_m
DATA Zero /0.0d0/
!
Izero = 1
- Kv = Kvthck - Nvadif
+ Kv = Kvthck
!
! *** Find differential elastic scattering cross section Elas and
! *** derivatives Delas at Energy Em and angle Theta
@@ -192,7 +192,7 @@ module ssm_11_m
DATA Zero /0.0d0/
!
Izero = 1
- Kv = Kvthck - Nvadif
+ Kv = Kvthck
!
! *** Find differential elastic scattering cross section Elas and
! *** derivatives Delas at Energy Em and angle Theta
@@ -317,7 +317,7 @@ module ssm_11_m
DATA Zero /0.0d0/
!
Izero = 1
- Kv = Kvthck - Nvadif
+ Kv = Kvthck
!
! *** Find differential elastic scattering cross section Elas and
! *** derivatives Delas at Energy Em and angle Theta
diff --git a/sammy/src/ssm/mssm18.f90 b/sammy/src/ssm/mssm18.f90
index 0b38602f3a4e72975038f9ef9875e8e4da75c4dd..e9a7ff2249af94d6a739b35beea0cf85c0a713ab 100644
--- a/sammy/src/ssm/mssm18.f90
+++ b/sammy/src/ssm/mssm18.f90
@@ -21,7 +21,7 @@ module ssm_18_m
!
DATA Zero /0.0d0/, Half /0.5d0/, One /1.0d0/
!
- Kv = Kvthck - Nvadif
+ Kv = Kvthck
tttppp=totalp
CALL Xsect22 (Dy2ddd, Dy2ddq, Y2cccc, Dy2ccc, Y2dddd, &
Y2dddq, Ep, Nx, Ientrp, Nn, Non_Quad)
diff --git a/sammy/src/ssm/mssm19.f90 b/sammy/src/ssm/mssm19.f90
index 812239de5e1e221d0297650682c2a9c40f0d5fbd..e1c030276b827cfcd5a1083a7e44f12e55f11abd 100644
--- a/sammy/src/ssm/mssm19.f90
+++ b/sammy/src/ssm/mssm19.f90
@@ -87,7 +87,7 @@ module ssm_19_m
!
IF (Kvthck.GT.0) THEN
! *** Add deriv of Y0 wrt Thickness
- Kv = Kvthck - Nvadif - Ndasig
+ Kv = Kvthck - Ndasig
IF (yld%normTypeIsSelfShielded()) THEN
IF (Noyzer.EQ.0) THEN
Dbsigx(Kv) = Exp1*Cap + Dbsigx(Kv)
@@ -119,7 +119,7 @@ module ssm_19_m
if ( .not.yld%normTypeIsSelfShielded() .and. &
.not.yld%normTypeIsTimesSigTot() ) n_sensitivity = Asensn
! *** Add deriv of Y0 wrt neutron sensitivity multiplier
- Kv = Ksensc - Nvadif - Ndasig
+ Kv = Ksensc - Ndasig
Dbsigx(Kv) = n_sensitivity
END IF
diff --git a/sammy/src/ssm/mssm20.f90 b/sammy/src/ssm/mssm20.f90
index 543c6ddc3fc843f186dcdadf1218fba4cae322cd..9607f5e4bc4b04f0638bcfdaf5bc044e1412265f 100644
--- a/sammy/src/ssm/mssm20.f90
+++ b/sammy/src/ssm/mssm20.f90
@@ -263,7 +263,7 @@ module ssm_20_m
!
IF (Kvthck.GT.0) THEN
! *** Add deriv of Y0 wrt Thickness; modify deriv of Y1 & Y2 wrt Thick
- Kv = Kvthck - Nvadif - Ndasig
+ Kv = Kvthck - Ndasig
IF (yld%normTypeIsSelfShielded()) THEN
IF (Noyzer.EQ.0) THEN
Dbsigx(Kv) = Exp1*Cap + Dbsigx(Kv)
@@ -295,7 +295,7 @@ module ssm_20_m
if ( .not.yld%normTypeIsSelfShielded() .and. &
.not.yld%normTypeIsTimesSigTot() ) n_sensitivity = Asensn
! *** Add deriv of Y0 wrt neutron sensitivity multiplier
- Kv = Ksensc - Nvadif - Ndasig
+ Kv = Ksensc - Ndasig
Dbsigx(Kv) = n_sensitivity
END IF
@@ -440,7 +440,7 @@ module ssm_20_m
!
IF (Kv.GT.0) THEN
! *** Add deriv of Y0 wrt Thickness of transmission sample
- Kv = Kv - Nvadif - Ndasig
+ Kv = Kv - Ndasig
Dbsigx(Kv) = Dbsigx(Kv) - Sigxxx(1)*Total2
END IF
RETURN
diff --git a/sammy/src/ssm/mssm21.f90 b/sammy/src/ssm/mssm21.f90
index 88babadd8d5d246ad1b84f88bfbc53f0cd627c3b..a89e1a059a8b11b37a24d4cbcadca918651aaed4 100644
--- a/sammy/src/ssm/mssm21.f90
+++ b/sammy/src/ssm/mssm21.f90
@@ -164,7 +164,7 @@ module ssm_21_m
!
IF (Kvthck.GT.0) THEN
! *** Add deriv of Y0 wrt Thickness; modify deriv of Y1 & Y2 wrt Thick
- Kv = Kvthck - Nvadif - Ndasig
+ Kv = Kvthck - Ndasig
IF (yld%normTypeIsSelfShielded()) THEN
IF (Noyzer.EQ.0) THEN
Dbsigx(Kv) = Exp1*Cap + Dbsigx(Kv)
@@ -195,7 +195,7 @@ module ssm_21_m
IF (yld%normTypeIsSelfShielded()) Asensn = Asensn * Dthick
IF (yld%normTypeIsTimesSigTot()) Asensn = Asensn * Dthick * Total
! *** Add deriv of Y0 wrt neutron sensitivity multiplier
- Kv = Ksensc - Nvadif - Ndasig
+ Kv = Ksensc - Ndasig
Dbsigx(Kv) = Asensn
END IF
diff --git a/sammy/src/the/mthe0.f b/sammy/src/the/mthe0.f
index 80164a2c47a1e7edff8a91ad9a4a93e6ee8f56f1..05384bb5bc7631fa3de5cc1c154f7fde54dd3537 100644
--- a/sammy/src/the/mthe0.f
+++ b/sammy/src/the/mthe0.f
@@ -11,11 +11,11 @@ C
use oopsch_common_m, only : Nowwww, Segmen
use AllocateFunctions_m
use SammyLptPrinting_m
+ use EndfData_common_m, only : covData
IMPLICIT None
- real(kind=8),allocatable,dimension(:)::A_Iudown, A_Ivarda, A_Idum
- real(kind=8),allocatable,dimension(:)::A_Iuup,A_Idum2
+ real(kind=8),allocatable,dimension(:)::A_Idum, A_Idum2
real(kind=8)::Emax, Emin
- integer::N, N1, N2, N3, Ndatnu, Ndatt
+ integer::N, N1, N2, N3, Ndatnu, Ndatt, Nn
character(len=80)::line
C
WRITE (line,99999)
@@ -47,34 +47,25 @@ C aray
Ndatnu = max(Ndatnu, Ndatb*N)
call allocate_real_data(A_Ith, Ndatnu)
call allocate_real_data(A_Idifma, Nres)
- call make_I_Iiuif(N1)
+ A_Idifma = 1.d30
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- call allocate_real_data(A_Iudown, max(1,N1))
- call allocate_real_data(A_Iuup, max(1,N1))
C
- call allocate_real_data(A_Ivarda, ndatt)
- call allocate_real_data(A_Idum, ndat)
C
- CALL Uset (A_Ibcf , A_Icf2 ,
- * A_Idcov , A_Iudown , A_Iuup , I_Iiuif , A_Idifma ,
- * A_Ivarda , A_Idum)
-C *** Uset determines Napres, sets up arrays Udown, Uup,
-C *** Iuif, and modifies Vardat
+ CALL Uset (A_Ibcf , A_Icf2 , A_Idifma)
+C *** Uset determines which parameters need derivatives
C
CALL Set5
C *** Set5 initializes Napxxx variables
C
C
IF (Kdecpl.NE.0 .AND. Kdata.NE.0 .AND. Ksolve.NE.2) THEN
+ call allocate_real_data(A_Idum, ndat)
call allocate_real_data(A_Idum2, Ndat)
- CALL Out_Mod (A_Ivarda , A_Idum , A_Idum2, Ndat)
+ CALL Out_Mod (A_Idum , A_Idum2, Ndat)
deallocate(A_Idum2)
+ deallocate(A_Idum)
END IF
- deallocate(A_Iudown)
- deallocate(A_Ivarda)
- deallocate(A_Idum)
- deallocate(A_Iuup)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
C
@@ -104,7 +95,7 @@ C
SUBROUTINE Estthe (N1, N2, N3, Ndatt)
C
use fixedi_m, only : Mres, Nfpdtp, Nfpres, Nres, Numcro,
- * Nummsc, Nxxres
+ * Nummsc
use ifwrit_m, only : Kdata, Kdatv, Kdecpl, Kfake, Krdmsc, Ksolve,
* Ndat, Ndatb
IMPLICIT None
@@ -117,7 +108,6 @@ C
N1 = 0
IF (Nummsc.GT.0 .AND. Krdmsc.NE.0) N1 = Nres
N1 = Nfpres + N1
- Nxxres = N1
IF (N1.EQ.0) N1 = 1
Ndatt = (Ndat*(Ndat+1))/2
IF (Kdatv.EQ.0) Ndatt = Ndat
diff --git a/sammy/src/the/mthe1.f b/sammy/src/the/mthe1.f
index 947809d2a944deab92a1754a06bc3c842cec1923..2354777ab212d29205439c752360ee542eafbf31 100644
--- a/sammy/src/the/mthe1.f
+++ b/sammy/src/the/mthe1.f
@@ -2,17 +2,18 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Uset (Bcf, Cf2,
- * Dcov, Udown, Uup, Iuif, Difmax,
- * Vardat, Dum)
+ SUBROUTINE Uset (Bcf, Cf2, Difmax)
C
-C *** PURPOSE -- GENERATE Uup, Udown, Iuif, Nnpar, and Difmax
+C *** PURPOSE -- GENERATE Nnpar, and Difmax
C
- use fixedi_m, only : Napres, Nfpres, Numcro, Nvadif,
- * Nxxres, Nvpres
+ use fixedi_m, only : Nfpres, Numcro, Nvpres, Ntotc,
+ * needResDerivs
use fixedr_m, only : Emax, Emin
- use ifwrit_m, only : Kdecpl, Krdmsc, Kscut, Ksolve, ktzero, Ndat
+ use ifwrit_m, only : Kdecpl, Kscut, Ksolve, ktzero, Ndat
use broad_common_m, only : Dopple, Iesopr
+ use templc_common_m, only : I_Inotu, A_Ibr, A_Ibi,
+ * A_Ipr, A_Ipi, Upi, Upr
+ use AllocateFunctions_m
use EndfData_common_m
use SammyResonanceInfo_M
use RMatResonanceParam_M
@@ -27,118 +28,134 @@ C
type(SammyChannelInfo)::channelInfo
type(SammyGridAccess)::gridAccess
type(GridData)::grid
- real(kind=8)::Bcf(*), Cf2(*),
- * Dcov(*),
- * Udown(*), Uup(*), Difmax(*), Vardat(*),
- * Dum(*)
- integer::Iuif(*)
+ real(kind=8)::Bcf(*), Cf2(*), Difmax(*)
real(kind=8)::Zero, One, Two, Three
real(kind=8)::ener, eres, G, P, val, Widgau
real(kind=8)::Wdop, Widexp, Wlow, Wup, X, Y
- integer::I, idat, Ie, iela, igr, II, Iipar, Ipos
- integer::J, K_Use, Kdown, Kup, M, Mmax, Mmax2, N
- integer::Ipar, Kwhere
- external Kwhere
+ real(kind=8)::Udown, Uup
+ logical::combined, havePups
+ integer::I, idat, Ie, iela, igr, II, Iflr, icomp, Iuif
+ integer::J, K_Use, Kdown, Kup, M, Mmax, Mmax2, N, ntotres
+ integer::Napres
DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/, Three /3.0d0/
C
C
- IF ( (Ksolve.NE.2 .AND. Nfpres.NE.0) .OR.
- * (Ksolve.EQ.2 .AND. Nfpres.NE.Nvpres) ) THEN
- DO Ipar=1,Nxxres
- Udown(Ipar) = Zero
- Uup(Ipar) = 1.d30
- END DO
- END IF
-
call gridAccess%initialize()
call gridAccess%setParameters(numcro, ktzero)
call gridAccess%setToExpGrid(expData)
-C
+ call covData%clearIrrelevant()
- IF (Kscut.EQ.-1) THEN
-C *** No cutoff on cross sections or derivatives
- IF (resParData%getNumResonances().GT.0) THEN
- DO N=1,resParData%getNumResonances()
- Difmax(N) = 1.d30
- END DO
- END IF
- DO Ipar=1,Nxxres
- Iuif(Ipar) = 0
- END DO
- Napres = Nvpres
- ELSE
+
+ IF (Kdecpl.Ne.0) then
+ call expData%getGrid(grid, 1)
+ idat = grid%getLength()
+ END If
+C
+ Napres = 0
+ needResDerivs = .false.
+ havePups = .false.
+ icomp = 0
C *** Use cutoff on derivatives
X = Two
Y = One
P = Zero
G = Zero
- Ipar = 0
+ ntotres = 0
IF (resParData%getNumResonances().GT.0) THEN
+ call allocate_integer_data(I_Inotu,
+ * covData%getNumTotalParam())
DO N=1,resParData%getNumResonances()
call resParData%getResonanceInfo(resInfo, N)
call resParData%getResonance(resonance, resInfo)
eres = resonance%getEres()
igr = resInfo%getSpinGroupIndex()
-
+
IF (resInfo%getIncludeInCalc()) THEN
call resParData%getSpinGroupInfo(spinInfo, igr)
+ combined = spinInfo%getGammWidthParIndex().gt.0
Mmax = spinInfo%getNumChannels()
Mmax2 = spinInfo%getNumResPar()
- IF (spinInfo%getIncludeInCalc()) THEN
- Difmax(N) = 1.d30
+ if ((Mmax2-1).gt.ntotres) then
+ ntotres = Mmax2-1
+ end if
+
+ IF (.not. spinInfo%getIncludeInCalc()) cycle
+
iela = spinInfo%getElasticChannel()
call spinInfo%getChannelInfo(channelInfo, iela)
call resParData%getChannel(channel, channelInfo)
- IF (Kscut.NE.0 .OR. channel%getL().NE.0) THEN
- P = eres
- IF (P.GE.Zero) THEN
- G = 0.0d0
- DO M=1,resonance%getNumChan()
- G = G + dABS(resonance%getWidth(M))
- END DO
- G = G*0.02d0
+ if (Kscut.ne.-1) then
+ IF (Kscut.NE.0 .OR. channel%getL().NE.0) THEN
+ P = eres
+ IF (P.GE.Zero) THEN
+ G = 0.0d0
+ DO M=1,resonance%getNumChan()
+ G = G + dABS(resonance%getWidth(M))
+ END DO
+ G = G*0.02d0
C 0.02 is 20*(width) and 1/1000 =
C conversion from meV to eV
- IF (Iesopr.NE.0) THEN
- IF (eres.GE.Zero) THEN
- Wdop = Dopple*dSQRT(eres)
- CALL Wdsint (Bcf, Cf2, eres, Widgau,
- * Widexp, Wlow, Wup)
- G = G + (Wdop+Widgau+Widexp)*Three
- END IF
- END IF
- IF (Kscut.NE.0 .AND. channel%getL().EQ.0)
- * G = G*two
- Difmax(N) = G
+ IF (Iesopr.NE.0) THEN
+ IF (eres.GE.Zero) THEN
+ Wdop = Dopple*dSQRT(eres)
+ CALL Wdsint (Bcf, Cf2, eres, Widgau,
+ * Widexp, Wlow, Wup)
+ G = G + (Wdop+Widgau+Widexp)*Three
+ END IF
+ END IF
+ IF (Kscut.NE.0 .AND. channel%getL().EQ.0)
+ * G = G*two
+ Difmax(N) = G
+ End if
END IF
END IF
- END IF
+
DO M=1,Mmax2
if (m.eq.1) then
- Ipar = resInfo%getEnergyFitOption()
+ Iflr = resInfo%getEnergyFitOption()
else
- Ipar = resInfo%getChannelFitOption(M-1)
+ Iflr = resInfo%getChannelFitOption(M-1)
+ end if
+ if (Iflr.gt.0) then
+ if (.not.(M.EQ.2 .AND. combined)) then
+ icomp = icomp + 1
+ end if
end if
- IF (Ipar.GT.0) THEN
- IF (Ksolve.EQ.2) THEN
+ IF (Iflr.GT.0) THEN
+ Napres = Napres + 1
+ ! this should always be big enough as we
+ ! sized it to number of varied parameters
+ ! Exception: If gamma width data are combined
+ ! we have more varied (but linked) resonance
+ ! parameters than flagged
+ call reallocate_integer_data(I_Inotu,
+ * Napres, Mmax2)
+ I_Inotu(Napres) = Iflr
+ if (combined.and.m.eq.2) then
+ I_Inotu(Napres) = -1 * Iflr
+ end if
+ Iuif = 0 ! assume it does contribute
+
+ ! if not solving bayes equation, it only contributes if pup'ed
+ ! otherwise we check
+ K_use = 0
+ IF (Ksolve.EQ.2) THEN
K_Use = 1
- IF (covData%isPupedParameter(Ipar)) K_Use = 0
- ELSE
- K_Use = 0
+ IF (covData%isPupedParameter(Iflr)) K_Use = 0
END IF
- IF (M.EQ.2 .AND. Krdmsc.NE.0) THEN
- Ipar = Nfpres + N
+ ! and always use if gamma width are fitted together
+ IF (M.EQ.2 .AND. combined) THEN
K_Use = 0
-C *** This is not correct for PUPd constant-Gamma-gamma
END IF
- IF (Ipar.GT.Nxxres) THEN
- STOP '[Ipar.GT.Nxxres in mthe1.f]'
- END IF
- IF (K_Use.EQ.1) THEN
- Udown(Ipar) = 1.D30
- Uup(Ipar) = Zero
+
+ IF (K_Use.EQ.1) THEN
+ Udown = 1.D30
+ Uup = Zero
+ Iuif = 1
ELSE
- IF (spinInfo%getIncludeInCalc()) THEN
+ Udown = 0.0
+ Uup = 1.d30
+ IF (spinInfo%getIncludeInCalc()) THEN
iela = spinInfo%getElasticChannel()
call spinInfo%getChannelInfo(channelInfo,
* iela)
@@ -147,101 +164,179 @@ C *** This is not correct for PUPd constant-Gamma-gamma
IF (Kscut.NE.0 .OR.
* channel%getL().NE.0) THEN
IF (eres.GE.Zero) THEN
- Udown(Ipar) = P - G
- Uup(Ipar) = P + G
+ Udown = P - G
+ Uup = P + G
END IF
END IF
+ Iuif = 1
+ IF (Udown.LT.Emax) THEN
+ IF (Uup.GT.Emin) THEN
+ Iuif = 0
+ if (m.eq.1) then
+ call UpdateExperimentalMatrix(resInfo,
+ * Udown, Uup, idat,
+ * gridAccess)
+ end if
+ END IF
+ END IF
+ IF (M.EQ.2 .AND. combined) THEN
+ Iuif= 0 ! always use for combined gamma width
+ END IF
+ if (Kscut.eq.-1) Iuif = 0 ! always use
ELSE
-C ************* Here this spin group is excluded, so we
-C ************* never want to use this parameter
+ Iuif = 1
END IF
END IF
- END IF
+ if (Iuif.eq.1) then
+ call covData%addToIrrelevant(Iflr)
+ I_Inotu(Napres) = 0
+ else
+ if (covData%isPupedParameter(Iflr)) then
+ havePups = .true.
+ end if
+ end if
+ END IF
END DO
END IF
END DO
END IF
+
+ if (napres.gt.0) then
+ needResDerivs = .true.
+ end if
+
+ ! todo: Sometimes ntotc is set wrong
+ ! and A_Ibr, A_Ibi, A_Ipr, and A_Ipi
+ ! are queried up to that number
+ if( ntotres.lt.Ntotc) then
+ ntotres = Ntotc
+ end if
+ ntotres = (ntotres*(ntotres+1))/2
+ if (Napres.eq.0) ntotres = 0
+ call reallocate_real_data_2d(A_Ibr, ntotres, 0, Napres, 0)
+ call reallocate_real_data_2d(A_Ibi, ntotres, 0, Napres, 0)
+ call reallocate_real_data_2d(A_Ipr, ntotres, 0, Napres, 0)
+ call reallocate_real_data_2d(A_Ipi, ntotres, 0, Napres, 0)
+ call allocate_real_data(Upi, Napres)
+ call allocate_real_data(Upr, Napres)
+
C
- DO Ipar=1,Nxxres
- Iuif(Ipar) = 1
- END DO
- Napres = 0
- IF ( (Ksolve.NE.2 .AND. Nfpres.NE.0) .OR.
- * (Ksolve.EQ.2 .AND. Nfpres.NE.Nvpres) ) THEN
- Iipar = 0
- DO Ipar=1,Nxxres
- IF (Udown(Ipar).LT.Emax) THEN
- IF (Uup(Ipar).GT.Emin) THEN
- Iuif(Ipar) = 0
- GO TO 100
- END IF
- END IF
- 100 CONTINUE
- END DO
- DO Ipar=1,Nfpres
- IF (Iuif(Ipar).EQ.0) Iipar = Iipar + 1
- END DO
- Napres = Iipar
- END IF
- END IF
- Nvadif = Nfpres - Napres
-C
-C
- IF (Kdecpl.EQ.0) RETURN
-C
- IF (Nfpres.GT.0) THEN
-C
- call expData%getGrid(grid, 1)
- ipos = grid%getDataColumn()
- idat = grid%getLength()
-C This was wrong - but is never called in any
-C of the SAMMY tests
- do J = 1, Ndat
- Dum(J) = grid%getData(J, ipos)
- val = expData%getExperimentalCov(J, J)
- Vardat(J) = val
- end do
-C
- DO Ipar=1,Nfpres
- IF (Udown(Ipar).NE.Zero) THEN
- IF (Iuif(Ipar).NE.1) THEN
- IF (Dcov(Ipar).NE.Zero) THEN
- Ie = 1
- Kdown = Kwhere (gridAccess, Udown(Ipar), Ndat, Ie)
- Kup = Kwhere (gridAccess, Uup (Ipar), Ndat, Ie)
- IF (Kup.NE.Ndat) THEN
- ener = gridAccess%getEnergy(Kup+Ie, expData)
- IF (ener.EQ.Uup(Ipar)) Kup = Kup+1
- END IF
- Kup = Kup + Ie - 1
- Kdown = Kdown + Ie - 1
- II = 0
- DO I=1,Ndat
- IF (I.LT.Kdown .OR. I.GT.Kup) THEN
- II = II + I
- ELSE
-C ELSE IF (I.GE.Kdown .AND. I.LE.Kup) THEN
- DO J=1,I
- II = II + 1
- IF (J.GE.Kdown.AND.J.LE.Kup) Vardat(II)
- * = Vardat(II) + Dcov(Ipar)
- END DO
- END IF
- END DO
- END IF
- END IF
- END IF
- END DO
-C
- do J = 1, Ndat
- val = Vardat(J)
- call expData%addExperimentalCov(J, J, val)
- end do
- END IF
+ if( Ksolve.eq.2) then
+ needResDerivs = .false.
+ if (havePups) needResDerivs = .true.
+ end if
+
C
call gridAccess%destroy()
RETURN
END
+
+ subroutine UpdateExperimentalMatrix(resInfo, udown, uup, ndat,
+ * gridAccess)
+ use SammyResonanceInfo_M
+ use EndfData_common_m, only : expData
+ use ifwrit_m, only : Kdecpl
+ use SammyGridAccess_M
+ implicit none
+ real(kind=8)::Udown, Uup
+ integer::ires, ndat
+ type(SammyGridAccess)::gridAccess
+ type(SammyResonanceInfo)::resInfo
+ integer::Ie, Kdown, Kup, I, II, J
+ real(kind=8)::val, ener
+ integer::Kwhere
+ external Kwhere
+
+ IF (Kdecpl.EQ.0) RETURN
+
+ Ie = 1
+ Kdown = Kwhere (gridAccess, Udown, Ndat, Ie)
+ Kup = Kwhere (gridAccess, Uup , Ndat, Ie)
+ IF (Kup.NE.Ndat) THEN
+ ener = gridAccess%getEnergy(Kup+Ie, expData)
+ IF (ener.EQ.Uup) Kup = Kup+1
+ END IF
+ Kup = Kup + Ie - 1
+ Kdown = Kdown + Ie - 1
+ II = 0
+ DO I=1,Ndat
+ if (I.LT.Kdown .OR. I.GT.Kup) then
+ II = II + I
+ else
+ DO J=1,I
+ II = II + 1
+ IF (J.GE.Kdown.AND.J.LE.Kup) then
+ val = expData%getExperimentalCov(II, II)
+ val = val + resInfo%getXVal()
+ call expData%addExperimentalCov(II, II, val)
+ end if
+ END DO
+ END IF
+ END DO
+ end subroutine UpdateExperimentalMatrix
+
+ subroutine getParamPerSpinGroup(ires, igr, npr, needDeriv,
+ * Kstart, ifcap)
+ use EndfData_common_m, only : covData, resParData
+ use SammySpinGroupInfo_M
+ use SammyResonanceInfo_M
+ use templc_common_m, only : I_Inotu
+ use fixedi_m, only : needResDerivs
+ implicit none
+ integer,intent(inout)::ires ! on input the last resonance in previous spin group.
+ ! on output the last resonance in this spin group
+ integer,intent(inout)::npr ! number of flagged parameters in this spin group
+ integer,intent(in)::igr ! spin group for which to get the number of varied parameters
+ integer,intent(in)::Kstart ! the number of flagged paramters up to this spin group
+ logical,intent(out)::needDeriv ! do any matter enough to need derivatives
+ logical,intent(out)::ifcap ! are there any combined gamma width data that matter
+
+ type(SammySpinGroupInfo)::spinInfo
+ type(SammyResonanceInfo)::resInfo
+ integer::Iflr, M, Mmax2, i, start
+ logical::combined, includeGrp
+
+ call resParData%getSpinGroupInfo(spinInfo, igr)
+ Mmax2 = spinInfo%getNumResPar()
+ combined = spinInfo%getGammWidthParIndex().gt.0
+
+ Npr = 0
+ needDeriv = .false.
+ ifcap = .false.
+
+ includeGrp = spinInfo%getIncludeInCalc()
+ start = ires + 1
+ do i = start, resParData%getNumResonances()
+ call resParData%getResonanceInfo(resInfo, i)
+ if( resInfo%getSpinGroupIndex().ne.igr) exit
+ ires = i
+ if( .not.needResDerivs) cycle
+ if( .not.includeGrp) cycle
+ if( .not.resInfo%getIncludeInCalc()) cycle
+
+ DO M=1,Mmax2
+ if(m.eq.1) then
+ Iflr = resInfo%getEnergyFitOption()
+ else
+ Iflr = resInfo%getChannelFitOption(m-1)
+ end if
+ IF (Iflr.GT.0) THEN
+ Npr = Npr + 1
+ if(covData%contributes(Iflr)) then
+ needDeriv = .true.
+ if (Iflr.ne.
+ * abs(I_Inotu(Npr + Kstart))) then
+ STOP
+ * 'wrong number of varied getParamPerSpinGroup6'
+ end if
+ if (m.eq.2.and.combined) then
+ ifcap = .true.
+ end if
+ end if
+ END IF
+ END DO
+ end do
+ end subroutine getParamPerSpinGroup
C
C
C --------------------------------------------------------------
@@ -297,14 +392,15 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Out_Mod (V, S, Ic, N)
+ SUBROUTINE Out_Mod (S, Ic, N)
C
C *** PURPOSE -- OUTPUT TRIANGULAR VARIANCE V AS STD. DEV. AND Correlation
C
+ use EndfData_common_m, only : expData
IMPLICIT None
- real(kind=8):: V(*), S(*)
+ real(kind=8):: S(*)
integer::IC(*), N
- real(kind=8)::Zero, Half
+ real(kind=8)::Zero, Half, val
real(kind=8)::D, SI
integer::I,IL, Imax, Imin, J, JJ, Jjp, Jmax
integer::L, M, Many, Max, Min, Mm, NN, Not
@@ -316,16 +412,15 @@ C
C
IL = 0
DO I=1,N
- IL = IL + I
- S(I) = dSQRT(V(IL))
+ S(I) = dSQRT(expData%getExperimentalCov(I,I))
END DO
C
IL = 0
DO I=1,N
DO L=1,I
- IL = IL + 1
IF (I.NE.L) THEN
- IF (V(IL).NE.Zero) GO TO 40
+ val = expData%getExperimentalCov(I,L)
+ IF (val.NE.Zero) GO TO 40
END IF
END DO
END DO
@@ -361,8 +456,8 @@ C
SI = S(I)
IL = Min - 1
DO L=Imin,Jmax
- IL = IL + 1
- D = V(IL)*100./(S(L)*SI)
+ val = expData%getExperimentalCov(I,L)
+ D = val*100./(S(L)*SI)
IF (D.GT.Zero) D = D + half
IF (D.LT.Zero) D = D - half
IC(L) = D
@@ -450,31 +545,30 @@ C --------------------------------------------------------------
C
SUBROUTINE Set5
C
- use fixedi_m, only : Napres, Napthe, Nfpbgf, Nfpbrd, Nfpdet,
- * Nfpdtp, Nfpext, Nfpiso, Nfpmsc, Nfpnbk,
- * Nfporr, Nfppmc, Nfprad, Nfprpi, Nfpudr,
- * Numpup
+ use fixedi_m, only : Numusd
use ifwrit_m, only : Ksolve, Nnpar
use lbro_common_m, only : Debug
+ use EndfData_common_m, only : covData
IMPLICIT None
+ integer::naffected,nn
C
C
- IF (Ksolve.EQ.2 .AND. Numpup.EQ.0) THEN
- Napthe = 0
+ IF (Ksolve.EQ.2 .AND. covData%getPupedParam().eq.0) THEN
Nnpar = 0
RETURN
C
ELSE
C
- Napthe = Napres + Nfpext + Nfprad + Nfpiso + Nfpdet + Nfpbrd +
- * Nfpmsc + Nfppmc + Nfporr + Nfprpi + Nfpudr + Nfpnbk +
- * Nfpbgf
- Nnpar = Napthe + Nfpdtp
- IF (Debug) WRITE (6,99999) Nnpar
- WRITE (21,99999) Nnpar
+ Nnpar = covData%getNumTotalParam() - Numusd
+ naffected = covData%getNumTotalParam() -
+ * covData%getNumIrrelevant() -
+ * Numusd
+ if(naffected.lt.0) naffected = 0
+ IF (Debug) WRITE (6,99999) naffected
+ WRITE (21,99999) naffected
99999 FORMAT (' Number of parameters affected by this data set=', I5)
C
- IF (Ksolve.NE.2 .AND. Nnpar.EQ.0) THEN
+ IF (Ksolve.NE.2 .AND. naffected.EQ.0) THEN
WRITE (21,99998)
WRITE ( 6,99998)
99998 FORMAT (' Oops--Data has no affect on any of the specified',
diff --git a/sammy/src/udr/mudr1.f b/sammy/src/udr/mudr1.f
index 46428393da9629b4226a72736fbef118d000fb98..8b1700d1618e77a78fe564fc95fd269c38acd315 100644
--- a/sammy/src/udr/mudr1.f
+++ b/sammy/src/udr/mudr1.f
@@ -168,7 +168,7 @@ C
* Ide_X, Ecrnch, Sigmns, Sigpls)
C
use fixedi_m, only : Nnnsig, Ndasig, Ndbsig, Ndaxxx, Ndbxxx,
- * Numudr, Nvadif, Nvpudr
+ * Numudr, Nvpudr
use ifwrit_m, only : Kdebug, Ksolve
use brdd_common_m, only : Ipnts, Kc
IMPLICIT None
@@ -253,7 +253,7 @@ C
B = Zero
END IF
DO N=1,Nnnsig
- Dbsigx(N,Ifludr(I)-Nvadif-Ndasig) = B
+ Dbsigx(N,Ifludr(I)-Ndasig) = B
END DO
IF (Kdebug.NE.0) THEN
IF (Kwarn.LE.100) THEN
diff --git a/sammy/src/xct/mxct0.f90 b/sammy/src/xct/mxct0.f90
index 55162b69a2140a91d3d919a130242d818dca7963..33d302292f688160004244a76e1a44aef955ea33 100644
--- a/sammy/src/xct/mxct0.f90
+++ b/sammy/src/xct/mxct0.f90
@@ -128,16 +128,14 @@ module xct_m
! come back to it later via "I = Idimen (Ifinal, -1)"
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- IF (Ksolve.NE.2 .OR. Numpup.GT.0) THEN
+ IF (Ksolve.NE.2 .OR. covData%getPupedParam().GT.0) THEN
Ks_Res = 0
ng = resParData%getNumSpinGroups()
- call allocate_integer_data(I_Inprdr, Ng)
call allocate_integer_data(I_Inpxdr, Ng)
Krext = Nrext
IF (Nrext.EQ.0) Krext = 1
- CALL Ppar ( I_Iflext , &
- I_Iiuif , I_Inprdr , I_Inpxdr, Krext)
-! *** Sbroutine Ppar Sets Nprdr and Npxdr
+ CALL Ppar ( I_Iflext, I_Inpxdr, Krext)
+! *** Sbroutine Ppar Sets Npxdr
ELSE
Ks_Res = 2
END IF
@@ -176,20 +174,16 @@ module xct_m
!
! *** four ***
N = Nfour
-! Nfour = (Ntriag) * (Napres)
- call allocate_real_data(A_Ibr, N)
- call allocate_real_data(A_Ibi, N)
- call allocate_real_data(A_Ipr, N)
- call allocate_real_data(A_Ipi, N)
+! Nfour = (Ntriag) * (Nfpres)
N = Nfour1
call allocate_real_data(A_Ibga, N)
N = Nfour2
call allocate_real_data(A_Ipgar, N)
call allocate_real_data(A_Ipgai, N)
!
- IF (Napres.NE.0) THEN
+ IF (needResDerivs) THEN
CALL Babb ( A_Ipolar , I_Iflpol , &
- I_Iiuif , A_Ibr , A_Ibi , XxTmp, .true.)
+ A_Ibr , A_Ibi , XxTmp, .true.)
! *** SBROUTINE Babb GENERATES ENERGY-INDEPENDENT PORTION OF
! *** PARTIAL DERIVATIVES
END IF
@@ -230,8 +224,7 @@ module xct_m
call allocate_real_data(A_Ialphr, Mres)
call allocate_real_data(A_Ialphi, Mres)
call allocate_integer_data(I_Inot, Mres)
- call allocate_integer_data(I_Inotu, Nsix)
-! Nsix = Napres
+! Nsix = Nfpres
IF (IfCoul.GT.0) THEN
ng = resParData%getNumSpinGroups()
call allocate_real_data(A_Icx, Ntotc*Ng)
@@ -355,7 +348,7 @@ module xct_m
Ks_Res = Ksolve
Ksolve = 0
IF (Ks_Res.EQ.2) THEN
- IF (Nfpall.EQ.Nvpall) Ksolve = 2
+ IF (covData%getPupedParam().eq.0) Ksolve = 2
END IF
!
Ifinal = Idimen (Ifinal, -1, ' Ifinal, -1')
@@ -441,9 +434,7 @@ module xct_m
!
! *** four
Nfour = 1
- Nyyres = Napres
- IF (Krdmsc.NE.0) Nyyres = Napres + resParData%getNumResonances()
- IF (Napres.NE.0) Nfour = Ntriag*Nyyres
+ IF (needResDerivs) Nfour = Ntriag*Nfpres
Nfour1 = Ntriag*Ntotc*resParData%getNumResonances()
IF (Nfour1.EQ.0) Nfour1 = 1
Nfprrr = Nfprad
@@ -482,7 +473,7 @@ module xct_m
!
! *** six
nsix = 0
- IF (Nyyres.NE.0) Nsix = Nyyres
+ IF (needResDerivs) Nsix = Nfpres
IF (Nsix.EQ.0) Nsix = 1
K6 = 3*Mres + Nsix
!
diff --git a/sammy/src/xct/mxct01.f90 b/sammy/src/xct/mxct01.f90
index 0e3a3a2b43839f18042e5d59b157d16f39604300..2fa76fc4b74ae5d87719d741f0f836801691aee9 100755
--- a/sammy/src/xct/mxct01.f90
+++ b/sammy/src/xct/mxct01.f90
@@ -4,11 +4,9 @@ module xct1_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Ppar (Iflext, Iuif, Nprdr, &
- Npxdr, Krext)
+ SUBROUTINE Ppar (Iflext, Npxdr, Krext)
!
! *** Purpose --
-! *** Set Nprdr(K) = number of varied resonance parameters in group K
! *** and Npxdr(K) = number of varied external parameters in group K
!
use fixedi_m
@@ -19,42 +17,12 @@ module xct1_m
!
type(SammyResonanceInfo)::resInfo
type(SammySpinGroupInfo)::spinInfo
- DIMENSION Iflext(Krext,Ntotc,*), &
- Iuif(*), Nprdr(*), Npxdr(*)
+ DIMENSION Iflext(Krext,Ntotc,*), Npxdr(*)
!
-! DIMENSION Iflext(.,.,Ngroup),
-! * Iuif(Nxxres), Nprdr(Ngroup), Npxdr(Ngroup)
+! DIMENSION Iflext(.,.,Ngroup)
!
!
- CALL Zero_Integer (Nprdr, resParData%getNumSpinGroups())
CALL Zero_Integer (Npxdr, resParData%getNumSpinGroups())
-!
- Ipar = 0
- Iipar = 0
- DO Ires=1,resParData%getNumResonances()
- call resParData%getResonanceInfo(resInfo, Ires)
- IF (resInfo%getIncludeInCalc()) THEN
- igr = resInfo%getSpinGroupIndex()
- call resparData%getSpinGroupInfo(spinInfo, igr)
- Mmax = spinInfo%getNumChannels()
- Mmax2 = spinInfo%getNumResPar()
- DO M=1,Mmax2
- if(m.eq.1) then
- Iflr = resInfo%getEnergyFitOption()
- else
- Iflr = resInfo%getChannelFitOption(m-1)
- end if
- IF (Iflr.GT.0 .AND. Iflr.LE.Nfpres) THEN
- Ipar = Ipar + 1
- IF (Iuif(Ipar).NE.1) THEN
- Iipar = Iipar + 1
- Nprdr(Igr) = Nprdr(Igr) + 1
- END IF
- END IF
- END DO
- END IF
- END DO
-!
!
IF (Nfpext.GT.0) THEN
DO Igr=1,resParData%getNumSpinGroups()
@@ -65,40 +33,6 @@ module xct1_m
END DO
END DO
END IF
-!
-!
- IF (Ipar.NE.Nfpres) THEN
- WRITE (6,99998) Ipar, Nfpres
- WRITE (21,99998) Ipar, Nfpres
-99998 FORMAT (' Problem in Ppar -- Nfpres is not correct', 2I5)
- DO Ires=1,resParData%getNumResonances()
- call resParData%getResonanceInfo(resInfo, Ires)
- igrp = resInfo%getSpinGroupIndex()
- call resparData%getSpinGroupInfo(spinInfo, igr)
- ntot = spinInfo%getAllChannels()
- WRITE (21,99997) Ires,resInfo%getEnergyFitOption(), &
- (resInfo%getChannelFitOption(m), &
- M=1,Ntot)
- END DO
- STOP '[STOP in Ppar in xct/mxct01.f]'
- END IF
-!
- IF (Iipar.NE.Napres) THEN
- WRITE (6,99999) Iipar, Napres
- WRITE (21,99999) Iipar, Napres
-99999 FORMAT (' Problem in Ppar -- Napres is not correct', 2I5)
- DO Ires=1,resParData%getNumResonances()
- call resParData%getResonanceInfo(resInfo, Ires)
- igrp = resInfo%getSpinGroupIndex()
- call resparData%getSpinGroupInfo(spinInfo, igr)
- ntot = spinInfo%getAllChannels()
- WRITE (21,99997) Ires,resInfo%getEnergyFitOption(), &
- (resInfo%getChannelFitOption(m), &
- M=1,Ntot)
-99997 FORMAT ('Iflres(M,', I4, ') =', 10I4)
- END DO
- STOP '[STOP in Ppar in xct/mxct01.f # 2]'
- END IF
!
RETURN
!
@@ -108,76 +42,69 @@ module xct1_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Babb (Polar, Iflpol, Iuif, Br, Bi, Xx, numDiff)
+ SUBROUTINE Babb (Polar, Iflpol, Br, Bi, Xx, xct)
!
! *** Purpose -- Generate energy-independent portion of partial
! *** derivatives of R with respect to U-parameters
!
use fixedi_m
use ifwrit_m
+ use templc_common_m, only : I_Inotu
use EndfData_common_m
use SammyResonanceInfo_M
use RMatResonanceParam_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ IMPLICIT None
!
type(SammyResonanceInfo)::resInfo
type(RMatResonance)::resonance
type(SammySpinGroupInfo)::spinInfo
- logical::numDiff
- DIMENSION Polar(2,*), &
- Iflpol(2,*), Iuif(*), Br(Ntriag,*), Bi(Ntriag,*), Xx(*)
-!
-! DIMENSION Polar(2,Nres), Iflpol(2,Nres),
-! * Iuif(Nxxres), Br(Ntriag,Nyyres), Bi(Ntriag,Nyyres)
+ logical::xct
+ integer::Iuse
+ real(kind=8)::Br(:,:), Bi(:,:)
+ real(kind=8):: Polar(2,*), Xx(*)
+ integer:: Iflpol(2,*)
+ real(kind=8)::Zero, Two
+ real(kind=8)::Aa, arg, Bb, D, D1, f1, f2
+ integer::ichan, iFis1, iFis2, Iflr, Igam, Igr, Ipar, Index
+ integer::Ires, J, Jk, K, Kj, Kk, M, Mmax, Mmax2, Mmm
+ real(kind=8)::W2, W3
+!
+! DIMENSION Polar(2,Nres), Iflpol(2,Nres)
!
DATA Zero /0.0d0/, Two /2.0d0/
!
- CALL Zero_Array (Br, Nyyres*Ntriag)
- CALL Zero_Array (Bi, Nyyres*Ntriag)
!
Ipar = 0
- Iipar = 0
- Iiparx = 0
+ Br = 0.0d0
+ Bi = 0.0d0
DO Ires=1,resParData%getNumResonances()
call resParData%getResonanceInfo(resInfo, Ires)
Igr = resInfo%getSpinGroupIndex()
IF (resInfo%getIncludeInCalc()) THEN
call resParData%getRedResonance(resonance, resInfo)
call resparData%getSpinGroupInfo(spinInfo, igr)
+ IF (.not.spinInfo%getIncludeInCalc()) cycle
+
Mmax = spinInfo%getNumChannels()
Mmax2 = spinInfo%getNumResPar()
iGam = spinInfo%getGammaWidthIndex()
!
DO M=1,Mmax2
if(m.eq.1) then
- ifl = resInfo%getEnergyFitOption()
+ iflr = resInfo%getEnergyFitOption()
else
- ifl = resInfo%getChannelFitOption(m-1)
+ iflr = resInfo%getChannelFitOption(m-1)
end if
- IF (Ifl.GT.0) THEN
- Ipar = ifl
- if (numDiff) then
- IF (M.EQ.2 .AND. Krdmsc.NE.0) Ipar = Nfpres + Ires
- end if
- IF (Iuif(Ipar).NE.1) THEN
- if( numDiff) then
- IF (M.EQ.2 .AND. Krdmsc.NE.0) THEN
- Iiparx = Napres + Ires
- ELSE
- Iipar = Iipar + 1
- Iiparx = Iipar
- END IF
- else
- IF (M.NE.2 .OR. Ifl.LE.Nvpres) Iipar = &
- Iipar + 1
- Iiparx = Iipar
- IF (M.EQ.2 .AND. Ifl.GT.Nvpres) &
- Iiparx = Napres + Ires
- end if
+ IF (Iflr.GT.0) THEN
+ Ipar = Ipar + 1 ! count all
+ IF (covData%contributes(Iflr)) THEN ! but don't calculate all
+ if (Iflr.ne.abs(I_Inotu(Ipar))) then
+ STOP 'Count of varied resonance parameter inconsistent in mxct01'
+ end if
!
IF (M.EQ.1) THEN
! *** HERE U-PARAMETER IS RESONANCE ENERGY
- if (numDiff) then
+ if (xct) then
arg = resonance%getEres()
else
arg = resonance%getEres() + Xx(Ires)
@@ -192,8 +119,8 @@ module xct1_m
f2 = resonance%getWidth(ichan)
Kj = Kj + 1
D = f1*f2*D1
- Br(Kj,Iiparx) = D
- Bi(Kj,Iiparx) = -D - D
+ Br(Kj,Ipar) = D
+ Bi(Kj,Ipar) = -D - D
END DO
END DO
!
@@ -210,8 +137,8 @@ module xct1_m
Kj = Kj + 1
D = f1*f2*D1
D = D + D
- Br(Kj,Iiparx) = - D - D
- Bi(Kj,Iiparx) = D
+ Br(Kj,Ipar) = - D - D
+ Bi(Kj,Ipar) = D
END DO
END DO
!
@@ -226,8 +153,8 @@ module xct1_m
ichan = spinInfo%getWidthForChannel(k)
D = resonance%getWidth(ichan)
IF (K.EQ.Mmm) D = D + D
- Br(Kj,Iiparx) = D
- Bi(Kj,Iiparx) = D
+ Br(Kj,Ipar) = D
+ Bi(Kj,Ipar) = D
END IF
END DO
IF (K.NE.Mmax) THEN
@@ -239,52 +166,47 @@ module xct1_m
spinInfo%getWidthForChannel(k)
D = resonance%getWidth(ichan)
IF (K.EQ.Mmm) D = D + D
- Br(Jk,Iiparx) = D
- Bi(Jk,Iiparx) = D
+ Br(Jk,Ipar) = D
+ Bi(Jk,Ipar) = D
END IF
END DO
END IF
END DO
!
- IF (Kpolar.NE.0 .AND. Mmm.EQ.3) THEN ! >>> mmm.eq.3 (numdiff) mmm.gt.1 otherwise
+ IF (Kpolar.NE.0 .AND. Mmm.EQ.3) THEN ! >>> mmm.eq.3 (xct) mmm.gt.1 otherwise
! *** Here we use polar coordinants for fission
-! *** channels
- if (numdiff) then
- index =iiparx
- else
- index = Iipar
- end if
+! ***
Kj = 0
iFis1 = spinInfo%getFirstFissionChannel()
iFis1 = spinInfo%getWidthForChannel(iFis1)
iFis2 = spinInfo%getSecondFissionChannel()
- iFis2 = spinInfo%getWidthForChannel(iFis2)
+ iFis2 = spinInfo%getWidthForChannel(iFis2)
DO K=1,Mmax
DO J=1,K
Kj = Kj + 1
- Aa = Br(Kj,index-1)
- Bb = Br(Kj,index)
+ Aa = Br(Kj,Ipar-1)
+ Bb = Br(Kj,Ipar)
IF (Aa.NE.Zero .OR. Bb.NE.Zero) THEN
W2 = resonance%getWidth(iFis1)
W3 = resonance%getWidth(iFis2)
- Br(KJ,index-1) = -W3* Aa +W2*Bb
+ Br(KJ,Ipar-1) = -W3* Aa +W2*Bb
IF (Iflpol(2,Ires).EQ.0) THEN
- Br(Kj,index) = Zero
+ Br(Kj,Ipar) = Zero
ELSE
- Br(Kj,index) = ( W2*Aa + w3*Bb ) &
+ Br(Kj,Ipar) = ( W2*Aa + w3*Bb ) &
/ Polar(2,Ires)
END IF
END IF
- Aa = Bi(Kj,index-1)
- Bb = Bi(Kj,index)
+ Aa = Bi(Kj,Ipar-1)
+ Bb = Bi(Kj,Ipar)
IF (Aa.NE.Zero .OR. Bb.NE.Zero) THEN
W2 = resonance%getWidth(iFis1)
W3 = resonance%getWidth(iFis2)
- Bi(Kj,index-1) = -W3*Aa + W2*Bb
+ Bi(Kj,Ipar-1) = -W3*Aa + W2*Bb
IF (Iflpol(2,Ires).EQ.0) THEN
- Bi(Kj,index) = Zero
+ Bi(Kj,Ipar) = Zero
ELSE
- Bi(Kj,index) = ( W2* Aa + W3*Bb ) &
+ Bi(Kj,Ipar) = ( W2* Aa + W3*Bb ) &
/ Polar(2,Ires)
END IF
END IF
@@ -298,16 +220,16 @@ module xct1_m
END IF
END DO
!
- if (numDiff) then
- DO Iipar=1,Nyyres
+ if (xct) then
+ DO m=1,Ipar
Kj = 0
DO K=1,Ntotc
DO J=1,K
Kj = Kj + 1
- IF (Br(Kj,Iipar).NE.Zero) Br(Kj,Iipar) = &
- Two*Br(Kj,Iipar)
- IF (Bi(Kj,Iipar).NE.Zero) Bi(Kj,Iipar) = &
- Two*Bi(Kj,Iipar)
+ IF (Br(Kj,M).NE.Zero) Br(Kj,M) = &
+ Two*Br(Kj,m)
+ IF (Bi(Kj,M).NE.Zero) Bi(Kj,M) = &
+ Two*Bi(Kj,M)
END DO
END DO
END DO
@@ -364,7 +286,7 @@ module xct1_m
else
Iflr = resInfo%getChannelFitOption(m-1)
end if
- IF (Iflr.LE.0 .OR. Iflr.GT.Nfpres) THEN
+ IF (Iflr.LE.0) THEN
call spinInfo%getChannelInfo(channelInfo, Mmm)
call resParData%getChannel(channel, channelInfo)
call resParData%getParticlePairInfo( &
diff --git a/sammy/src/xct/mxct02.f90 b/sammy/src/xct/mxct02.f90
index 419297820f4d8f800862ece3ae72d2d4653f065c..e58cc943f28dbd9ea4e42da107f86710dc3cdfdf 100644
--- a/sammy/src/xct/mxct02.f90
+++ b/sammy/src/xct/mxct02.f90
@@ -101,9 +101,6 @@ module xct2_m
Kkkkkk = 0
Kkkmin = 0
!
-!ccc Nfpall = Nfpres + Nfpext + Nfprad + Nfpiso + Nfpdet + Nfpbrd +
-!ccc Nfpmsc + Nfppmc + Nfporr + Nfprpi + Nfpudr + Nfpnbk +
-!ccc Nfpbgf
! *** (ordering is as variable # is assigned)
!
!
@@ -163,7 +160,7 @@ module xct2_m
!
! ************ Generate cross sections and derivatives
IF (Nd_Xct.NE.0 .AND. Ksolve.NE.2) THEN
- CALL N_D_Zcross (I_Iiuif , Kount_Helmut)
+ CALL N_D_Zcross (Kount_Helmut)
ELSE
CALL Zcross (Nnndrc, Ipoten, Kount_Helmut)
END IF
@@ -250,10 +247,6 @@ module xct2_m
Sigxxx, Dbsigx, Su, Nnnsig)
END IF
!
-! ********* If adding a constant cross section, do so now
-! IF (Concro.NE.Zero) CALL Addcon (Sigxxx, Dbsigx,
-! * Ifl_msc, Nnnsig)
-!
! ********* write results onto theory if there is no broadening etc
IF (Jjjdop.NE.1) THEN
Kkkkkk = Kkkkkk + 1
diff --git a/sammy/src/xct/mxct03.f90 b/sammy/src/xct/mxct03.f90
index 70a9367ac931f47fc04d2f2e8adc9da9902697ab..b35a6b3509b6f9c2f24abf65a76751cb273019e0 100644
--- a/sammy/src/xct/mxct03.f90
+++ b/sammy/src/xct/mxct03.f90
@@ -4,7 +4,7 @@ module xct3_m
!
! --------------------------------------------------------------
!
- SUBROUTINE N_D_Zcross (Iuif, Kount_Helmut)
+ SUBROUTINE N_D_Zcross (Kount_Helmut)
!
! *** PURPOSE -- Calculate numerically the partial derivatives
! *** of the cross section wrt R-matrix parameters
@@ -26,7 +26,6 @@ module xct3_m
type(RMatResonance)::resonance
type(SammySpinGroupInfo)::spinInfo
real(kind=8)::XxTmp(1)
- DIMENSION Iuif(*)
!
DATA Zero /0.0d0/, One /1.0d0/
DATA U_Increment /0.0001d0/
@@ -46,21 +45,21 @@ module xct3_m
! *** Generate energy-independent pieces
! True is passed to babb since it is used to set parameters for numerical differentiation
CALL Babb ( &
- A_Ipolar , I_Iflpol , I_Iiuif , A_Ibr, &
+ A_Ipolar , I_Iflpol , A_Ibr, &
A_Ibi , Xxtmp, .true.)
CALL Abpart ( &
A_Ialphr , A_Ialphi , A_Ibr , &
A_Ibi , A_Ipr , A_Ipi , A_Idifen , A_Ixden , &
- I_Iiuif , A_Idifma , I_Inot , I_Inotu , A_Ixx , &
+ A_Idifma , I_Inot , I_Inotu , A_Ixx , &
A_Iprer , A_Iprei )
!
! *** Form the cross section Crss
- CALL Crosss ( &
+ CALL Crosss ( &
I_Ifexcl , &
A_Ibound , A_Iechan , I_Ifcros , &
A_Iprmsc , I_Iflmsc , I_Ijkmsc , A_Izke , &
A_Izkte , A_Izkfe , A_Izeta , I_Ifzke , I_Ifzkte , &
- I_Ifzkfe , I_Inprdr , I_Inpxdr , A_Icrss , A_Ideriv , &
+ I_Ifzkfe , I_Inpxdr , A_Icrss , A_Ideriv , &
A_Icrssx , A_Idervx , A_Iprer , A_Iprei , A_Ixdrcp , &
I_Indrcp , Nnndrc, 0, Kount_Helmut)
!
@@ -74,8 +73,6 @@ module xct3_m
END IF
!
! *** Now vary parameters one-by-one to get derivatives
- Ipar = 0
- Iipar = 0
DO Ires=1,resParData%getNumResonances()
call resParData%getResonanceInfo(resInfo, Ires)
@@ -83,6 +80,10 @@ module xct3_m
IF (resInfo%getEnergyFitOption().GE.0) THEN
Igrp = resInfo%getSpinGroupIndex()
call resparData%getSpinGroupInfo(spinInfo, Igrp)
+ if (spinInfo%getGammaWidthIndex().gt.0) then
+ write(0,*)" Combined gamma width and numerical derivatives are not supported"
+ stop
+ end if
Ntotn = spinInfo%getNumChannels()
Ntotn2 = spinInfo%getNumResPar()
iGam = spinInfo%getGammaWidthIndex()
@@ -95,16 +96,8 @@ module xct3_m
else
Iflr = resInfo%getChannelFitOption(m-1)
end if
- IF (Iflr.GT.0) THEN
- Ipar = Ipar + 1
- IF (Iflr.NE.Ipar) THEN
- WRITE (6,10000) M, Ires, Iflr, Ipar
-10000 FORMAT(' Iflres(',I1,',',I3,')=',I5,'.NE.Ipar=',I5)
- STOP '[STOP in N_D_Zcross in xct/mxct03.f # 2]'
- END IF
- IF (Iuif(Ipar).NE.1) THEN
- IF (M.NE.2 .OR. Krdmsc.EQ.0) THEN
- Iipar = Iipar + 1
+ IF (Iflr.GT.0) THEN
+ IF (covData%contributes(Iflr)) THEN
!
!
IF (M.EQ.1) THEN
@@ -139,25 +132,24 @@ module xct3_m
END IF
!
END IF
- END IF
!
! *** Generate energy-independent pieces with new parameter
CALL Babb ( A_Ipolar , &
- I_Iflpol , I_Iiuif , A_Ibr , A_Ibi, &
+ I_Iflpol , A_Ibr , A_Ibi, &
Xxtmp, .true.)
CALL Abpart (A_Ialphr , &
A_Ialphi , A_Ibr , A_Ibi , A_Ipr , &
A_Ipi , A_Idifen , A_Ixden , &
- I_Iiuif , A_Idifma , I_Inot , &
+ A_Idifma , I_Inot , &
I_Inotu , A_Ixx , A_Iprer , A_Iprei )
!
! *** Form the cross section Crss with new parameter value
- CALL Crosss ( &
+ CALL Crosss ( &
I_Ifexcl , A_Ibound , A_Iechan , &
I_Ifcros , &
A_Iprmsc , I_Iflmsc , I_Ijkmsc , A_Izke , &
A_Izkte , A_Izkfe , A_Izeta , I_Ifzke , &
- I_Ifzkte , I_Ifzkfe , I_Inprdr , I_Inpxdr , &
+ I_Ifzkte , I_Ifzkfe , I_Inpxdr , &
A_Icrsnd , A_Ideriv , A_Icrxnd , A_Idervx , &
A_Iprer , A_Iprei , A_Ixdrcp , I_Indrcp , &
Nnndrc, 0, Kount_Helmut)
@@ -165,7 +157,7 @@ module xct3_m
! *** Generate numerical derivatives
CALL Fix_N_D (A_Icrss , A_Icrssx , A_Ideriv , &
A_Idervx , A_Icrsnd , A_Icrxnd , X, &
- Iipar, Igrp, Ntotn)
+ Iflr, Igrp, Ntotn)
!
! *** Reset original parameters
IF (M.EQ.1) THEN
diff --git a/sammy/src/xct/mxct04.f90 b/sammy/src/xct/mxct04.f90
index 08b8b29051809888233dd62fb56c5ae9d7b58e60..c73b691e843b59cbc3316c5f650b56ea4074df87 100644
--- a/sammy/src/xct/mxct04.f90
+++ b/sammy/src/xct/mxct04.f90
@@ -23,12 +23,12 @@ module xct4_m
!
!
! *** Generate Pr and Pi = Partial of R wrt U-parameters
-! *** from Upr and Upi = energy-dependent pieces of those derivs
+! *** from Upr and Upi = energy-dependent pieces of those derivs
IF (resParData%getNumResonances().NE.0) then
CALL Abpart ( &
A_Ialphr , A_Ialphi , A_Ibr , &
A_Ibi , A_Ipr , A_Ipi , A_Idifen , A_Ixden , &
- I_Iiuif , A_Idifma , I_Inot , I_Inotu , A_Ixx , &
+ A_Idifma , I_Inot , I_Inotu , A_Ixx , &
A_Iprer , A_Iprei )
end if
!
@@ -47,12 +47,12 @@ module xct4_m
!
! *** FORM THE CROSS SECTION Crss AND THE ( PARTIAL DERIVATIVES OF THE
! *** CROSS SECTION WITH RESPECT TO THE VARIED PARAMETERS ) = Deriv
- CALL Crosss ( &
+ CALL Crosss ( &
I_Ifexcl , &
A_Ibound , A_Iechan , I_Ifcros , &
A_Iprmsc , I_Iflmsc , I_Ijkmsc , A_Izke , &
A_Izkte , A_Izkfe , A_Izeta , I_Ifzke , I_Ifzkte , &
- I_Ifzkfe , I_Inprdr , I_Inpxdr , A_Icrss , A_Ideriv , &
+ I_Ifzkfe , I_Inpxdr , A_Icrss , A_Ideriv , &
A_Icrssx , A_Idervx , A_Iprer , A_Iprei , A_Ixdrcp , &
I_Indrcp , Nnndrc, Ipoten, Kount_Helmut)
!
diff --git a/sammy/src/xct/mxct05.f90 b/sammy/src/xct/mxct05.f90
index c41d2bb1e2e8f2952e5a9187d81eaa1606af51e7..fdc48521337554aa775cdea29172fdd2fb1e0288 100644
--- a/sammy/src/xct/mxct05.f90
+++ b/sammy/src/xct/mxct05.f90
@@ -6,7 +6,7 @@ module xct5_m
!
SUBROUTINE Abpart ( &
Alphar, Alphai, Br, Bi, Pr, Pi, Difen, Xden, &
- Iuif, Difmax, Not, Notu, Xx, Prer, Prei)
+ Difmax, Not, Notu, Xx, Prer, Prei)
!
! *** Purpose -- Generate Alphar & Alphai = energy-independent bits
! *** and Upr and Upi = Energy-dependent pieces of Pr & Pi
@@ -21,24 +21,27 @@ module xct5_m
use RMatResonanceParam_M
use SammySpinGroupInfo_M
use templc_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ IMPLICIT None
!
!
- DIMENSION &
+ real(kind=8)::Bi(:,:), Br(:,:), Pr(:, :), Pi(:,:)
+ real(kind=8):: &
Alphar(*), Alphai(*), &
- Br(Ntriag,*), Bi(Ntriag,*), Pr(Ntriag,*), Pi(Ntriag,*), &
- Difen(*), Xden(*), Iuif(*), Difmax(*), &
- Not(*), Notu(*), Xx(*), Prer(Ntriag,*), Prei(Ntriag,*)
+ Difen(*), Xden(*), Difmax(*), &
+ Xx(*), Prer(Ntriag,*), Prei(Ntriag,*)
+ integer:: Not(*), Notu(*)
type(SammyResonanceInfo)::resInfo
type(SammySpinGroupInfo)::spinInfo
type(RMatResonance)::resonance
+ real(kind=8)::Zero, One, Two
+ real(kind=8)::Aa, Bb, channelWidthC, channelWidthCPrime, G2, G3
+ integer::I, ichan, Ig, igrp, Ij, Ijk, Ijl, Iflr, Ipar, J, M, N, N2, K
!
! DIMENSION
-! * Alphar(Nres), Alphai(Nres), Br(Ntriag,Nyyres),
-! * Bi(Ntriag,Nyyres), Pr(Ntriag,Nyyres),
-! * Pi(Ntriag,Nyyres), Difen(Nres), Xden(Nres),
-! * Iuif(Nyyres), Difmax(Nres),
-! * Not(Nres) , Notu(Nyyres), Xx(Nres), Prer(Ntriag,Ngroup),
+! * Alphar(Nres), Alphai(Nres),
+! * Difen(Nres), Xden(Nres),
+! * Difmax(Nres),
+! * Not(Nres) , Xx(Nres), Prer(Ntriag,Ngroup),
! * Prei(Ntriag,Ngroup)
!
DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/
@@ -77,33 +80,29 @@ module xct5_m
!
! *** Generate Upr and Upi = Energy-Dependent part of partial derivs
!
- Iiparx = 0
- Iipar = 0
!
! *** if ( (do not solve) or (no resonance parameters are varied) )
-! *** then don't do this
- IF (Napres.NE.0) THEN
- call allocate_real_data(Upr, Nyyres)
- call allocate_real_data(Upi, Nyyres)
+! *** then don't do this
+ IF (needResDerivs) THEN
+ Upr = 0.0d0
+ Upi = 0.0d0
!
-! Napres is the number of resonance paramaeters that are varied.
! If the gamma width data for one or more spingroup are fitted together
-! the value for UPI and UPR is stored at index Napres + N, where
+! the value for UPI and UPR include this information.
! N is the index of the resonance. This ensures that all values are calculated for
! all resonance in the group while using the correct parameter value.
! Later in the routine the varied parameters are tallied, relaying on
-! Upr and/or UpI to be zero. This should happen with the lines
-! Upr(Iiparx) = Zero and Upi(Iiparx) = Zero. The count does not measure up,
-! as the gamma width is counted in Napres.
+! Upr and/or UpI to be zero.
!
! The allocate function automatically sets the arrays to zero
!
-
+ Ipar = 0
DO N=1,resParData%getNumResonances()
call resParData%getResonanceInfo(resInfo, N)
- IF (resInfo%getEnergyFitOption().GE.0) THEN
+ IF (resInfo%getIncludeInCalc()) THEN
igrp = resInfo%getSpinGroupIndex()
call resParData%getSpinGroupInfo(spinInfo, igrp)
+ IF (.not.spinInfo%getIncludeInCalc()) cycle
!
! resonance has spinInfo%getNumChannels() + 1 width associated with it
! as gamma width does not have a channel number
@@ -111,36 +110,29 @@ module xct5_m
N2 = spinInfo%getNumResPar()
DO M=1,N2
if(m.eq.1) then
- Ipar = resInfo%getEnergyFitOption()
+ Iflr = resInfo%getEnergyFitOption()
else
- Ipar = resInfo%getChannelFitOption(m-1)
- end if
- IF (Ipar.GT.0) THEN
- IF (M.EQ.2 .AND. Krdmsc.NE.0) Ipar = Nfpres + N
- IF (Iuif(Ipar).NE.1) THEN
- IF (M.EQ.2 .AND. Krdmsc.NE.0) THEN
- Iiparx = Napres + N
- ELSE
- Iipar = Iipar + 1
- Iiparx = Iipar
- END IF
- Notu(Iiparx) = 1
- Upr(Iiparx) = Zero
- Upi(Iiparx) = Zero
- IF (Dabs(Difen(N)).LE.Difmax(N)) THEN
- Notu(Iiparx) = 0
- Upr(Iiparx) = Alphar(N)
- Upi(Iiparx) = Alphai(N)
+ Iflr = resInfo%getChannelFitOption(m-1)
+ end if
+ IF (Iflr.GT.0) THEN
+ Ipar = Ipar + 1
+ IF (covData%contributes(Iflr)) THEN
+ if (Iflr.ne.abs(notu(Ipar))) then
+ STOP 'Count of varied resonance parameter inconsistent in mxct05'
+ end if
+ IF (Dabs(Difen(N)).LE.Difmax(N)) THEN
+ Upr(Ipar) = Alphar(N)
+ Upi(Ipar) = Alphai(N)
IF (M.EQ.1) THEN
! Variable is resonance-energy
- Upi(Iiparx) = Upr(Iiparx)*Upi(Iiparx)
- Upr(Iiparx) = Xden(N) - &
- Two*Upr(Iiparx)*Upr(Iiparx)
+ Upi(Ipar) = Upr(Ipar)*Upi(Ipar)
+ Upr(Ipar) = Xden(N) - &
+ Two*Upr(Ipar)*Upr(Ipar)
ELSE IF (M.EQ.2) THEN
! Variable is capture width
- Upr(Iiparx) = Upr(Iiparx)*Upi(Iiparx)
- Upi(Iiparx) = Xden(N) - &
- Two*Upi(Iiparx)*Upi(Iiparx)
+ Upr(Ipar) = Upr(Ipar)*Upi(Ipar)
+ Upi(Ipar) = Xden(N) - &
+ Two*Upi(Ipar)*Upi(Ipar)
END IF
END IF
END IF
@@ -152,10 +144,10 @@ module xct5_m
!
! *** Multiply by Br and Bi to give partial of R wrt U-parameters
!
- CALL Zero_Array (Pr, Nyyres*Ntriag)
- CALL Zero_Array (Pi, Nyyres*Ntriag)
!
- DO K=1,Nyyres
+ Pr = 0.0D0
+ Pi = 0.0d0
+ DO K=1,Ipar
IF (Upr(K).NE.Zero .OR. Upi(K).NE.Zero) THEN
IJ = 0
DO I=1,Ntotc
diff --git a/sammy/src/xct/mxct06.f b/sammy/src/xct/mxct06.f
index 23bce6eef0c5ec82d70989ae948a7a98cb150621..581454701e07adf2bc5dd717d34713698219c007 100644
--- a/sammy/src/xct/mxct06.f
+++ b/sammy/src/xct/mxct06.f
@@ -5,7 +5,7 @@ C
SUBROUTINE Crosss (
* Jfexcl, Bound , Echan ,
* Jfcros, Parmsc, Jflmsc , Jjkmsc , Zke ,
- * Zkte , Zkfe , Zeta , If_Zke, If_Zkte, If_Zkfe, Nprdr ,
+ * Zkte , Zkfe , Zeta , If_Zke, If_Zkte, If_Zkfe,
* Npxdr , Crss , Deriv , Crssx , Derivx , Prer , Prei ,
* Xdrcpt, Ndrcpt, Nnndrc, Ipoten, Kount_Helmut)
C
@@ -28,16 +28,18 @@ C
use SammyResonanceInfo_M
use ifsubs_common
use par_parameter_names_common_m
+ use templc_common_m, only : I_Inotu
use Derrho_m
use xct7_m
+ use mxct11_m
implicit none
real(8), intent(in):: Bound, Echan, Parmsc, Zke, Zkte, Zkfe, Zeta,
* Crssx, Derivx, Prer, Prei, Xdrcpt
real(8), intent(out):: Crss, Deriv
integer(4), intent(in):: Jfexcl, Jfcros, Jflmsc, Jjkmsc, If_Zke,
- * If_Zkte, If_Zkfe, Nprdr, Npxdr, Ndrcpt,
+ * If_Zkte, If_Zkfe, Npxdr, Ndrcpt,
* Nnndrc, Ipoten, Kount_Helmut
real(8):: Zero, Dgoj
@@ -46,7 +48,7 @@ C
C
DIMENSION Jfexcl(Ntotc,*),
* Bound(Ntotc,*), Echan(Ntotc,*),
- * Jfcros(*), Nprdr(*), Npxdr(*),
+ * Jfcros(*), Npxdr(*),
* Parmsc(*), Jflmsc(*), Jjkmsc(*),
* Crss(Ncrsss,*), Deriv(Ncrsss,Nnpar,*), Crssx(2,Ntotc,Ntotc,*),
* Derivx(2,Ntotc,Ntotc,Nnpar,*), Zke(Ntotc,*), Zkte(Ntotc,*),
@@ -57,7 +59,7 @@ C
C DIMENSION
C * Jfexcl(Ntotc,Ngroup), Bound(Ntotc,Ngroup),
C * Echan(Ntotc,Ngroup), Jfcros(Ncrsss),
-C * Nprdr(Ngroup), Npxdr(Ngroup),
+C * Npxdr(Ngroup),
C * Crss(Ncrsss,Ngroup), Deriv(Ncrsss,Nnpar,Ngroup),
C * Crssx(2,Ntotc,Ntotc,Ngroup), Derivx(2,Ntotc,Ntotc,Nnpar,Ngroup),
C * Zke(Ntotc,Ngroup), Zkte(Ntotc,Ngroup), Zkfe(Ntotc,Ngroup),
@@ -66,6 +68,8 @@ C * Prer(Ntriag,Ngroup), Prei(Ntriag,Ngroup)
C
type(SammySpinGroupInfo)::spinInfo
type(SammyResonanceInfo)::resInfo
+ integer::M
+ logical::needDeriv,ifcap
DATA Zero /0.0d0/
C
C
@@ -85,7 +89,7 @@ C
C
Nn2 = 0
Kstart = 0
- Jstart = Napres
+ Jstart = Nfpres ! Jstart+1 starts derivatives external R-Matrix
IF (Ncrssx.NE.0) THEN
CALL Zero_Array (Crss, Ngroup*Ncrsss)
END IF
@@ -97,35 +101,21 @@ C
C *** DO LOOP OVER GROUPS (IE SPIN-PARITY GROUPS) -
C *** GOES TO END OF ROUTINE
C
- maxr = 0
+ maxr = 0
DO N=1,resParData%getNumSpinGroups()
+ call resParData%getSpinGroupInfo(spinInfo, N)
+ minr = maxr + 1
+ call getParamPerSpinGroup(maxr, N, Npr, needDeriv,
+ * Kstart, ifcap)
- ! determine minimum and maximum resonance
- IF (resParData%getNumResonances().GT.0) THEN
- minr = maxr + 1
- do i = minr, resParData%getNumResonances()
- call resParData%getResonanceInfo(resInfo, i)
- if( resInfo%getSpinGroupIndex().ne.n) exit
- maxr = i
- end do
- ELSE
- Minr = 0
- Maxr = 0
- END IF
-
- Nnnn = N
- call resParData%getSpinGroupInfo(spinInfo, N)
+ Nnnn = N
Ntotnn = spinInfo%getNumChannels()
IF (Ifdif.NE.0) CALL Zero_Array (A_Icscs, 2*Ntriag)
- IF (.not.spinInfo%getIncludeInCalc()) THEN
- If (Ks_Res.NE.2) Kstart = Kstart + Nprdr(N)
- ELSE
+ IF (spinInfo%getIncludeInCalc()) THEN
VarAbn = spinInfo%getAbundance()
C
Nnnn = N
- Npx = 0
- Npr = 0
- IF (Ks_Res.NE.2) Npr = Nprdr(N)
+ Npx = 0
IF (Ks_Res.NE.2) Npx = Npxdr(N)
Nn2 = Ntotnn*(Ntotnn+1)
Nn = Nn2/2
@@ -179,7 +169,7 @@ C *** generate cross section pieces
C
IF (Ks_Res.NE.2) THEN
IF ( Lrmat.EQ.0 .AND.
- * ( (Npr.NE.0 .AND. Ifres .EQ.0) .OR.
+ * ( needDeriv .OR.
* (Npx.NE.0 .AND. Ifext .EQ.0) .OR.
* Ifzzz.EQ.0 .OR. Ifradt.EQ.0 ) ) THEN
C
@@ -196,7 +186,7 @@ C *** T = [ partial (sigma) wrt X ] * Q
* A_Iqi, A_Itr, A_Iti, A_Itx, Ntotnn)
END IF
C
- IF (Lrmat.EQ.0 .AND. Npr.NE.0 .AND. Ifres.EQ.0) THEN
+ IF (Lrmat.EQ.0 .AND. needDeriv) THEN
C *** Find derivatives of cross sections wrt res pars
CALL Derres (Nentnn, Jfexcl(:,N), Jfcros,
* A_Ipr , A_Ipi , Deriv(:,:,N), Derivx(:,:,:,:,N),
@@ -204,7 +194,7 @@ C *** Find derivatives of cross sections wrt res pars
* Ntotnn, Minr, Maxr)
END IF
C
- IF (Lrmat.EQ.0 .AND. Ifcap.EQ.0) THEN
+ IF (Lrmat.EQ.0 .AND. Ifcap) THEN
C *** Find derivatives of cs wrt universal capture width
CALL Dercap (Nentnn, Jfexcl(:,N), Jfcros,
* A_Ipr , A_Ipi , Deriv(:,:,N), Derivx(:,:,:,:,N),
@@ -289,7 +279,7 @@ C *** Find derivative of Crss wrt isotopic abundance
CALL Deriso (If_Zke(n), Crss(:,N),Deriv(:,:,N),VarAbn)
END IF
C
- IF (Ks_Res.NE.2) Kstart = Kstart + Npr
+
END IF
C
END IF
@@ -306,7 +296,7 @@ C
Crss(2:Ncrsss,N) = Crss(2:Ncrsss,N) +
* Xdrcpt(Iiidrc)*Parmsc(Ijk)
IF (Ks_Res.NE.2 .AND. Jflmsc(Ijk).GT.0) THEN
- Ipar = Jflmsc(Ijk) - Nvadif
+ Ipar = Jflmsc(Ijk)
Deriv(2:Ncrsss,Ipar,N) = Xdrcpt(Iiidrc)
GO TO 10
END IF
@@ -320,6 +310,7 @@ C
END IF
10 CONTINUE
C
+ Kstart = Kstart + Npr
END DO
C
RETURN
@@ -333,28 +324,17 @@ C
use ifwrit_m
use EndfData_common_m
use ifsubs_common
+ use SammySpinGroupInfo_M
implicit none
+ integer::n, ifgam
+ type(SammySpinGroupInfo)::spinInfo
C
C *** Purpose -- Set flags = 0 if (maybe) calculate derivatives
C *** = 1 if do not calculate derivatives
C
- IF (Ksolve.EQ.2 .AND. Nfpres.NE.Nvpres) THEN
- Ifres = 0
- ELSE IF (Ksolve.NE.2 .AND. Nfpres.NE.0) THEN
- Ifres = 0
- ELSE
- Ifres = 1
- END IF
-C
- Ifcap = 1
- IF (Ksolve.EQ.2 .AND. Krdmsc.GT.0) THEN
- IF (covData%isPupedParameter(Krdmsc)) THEN
- Ifcap = 0
- END IF
- ELSE IF (Ksolve.NE.2 .AND. Krdmsc.NE.0) THEN
- Ifcap = 0
- END IF
+C Need combined capture width derivatives if any gamma width is a
+C combined gamma width
C
Ifzzz = 1
IF (Itzero.GT.0) THEN
diff --git a/sammy/src/xct/mxct11.f b/sammy/src/xct/mxct11.f
deleted file mode 100644
index 11bcc909c9c69a8e9e6c9ced5fc0d06004276b03..0000000000000000000000000000000000000000
--- a/sammy/src/xct/mxct11.f
+++ /dev/null
@@ -1,320 +0,0 @@
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Derres (Nent,If_Excl, Ifcros, Pr, Pi, Deriv,
- * Derivx, Tr, Ti, Tx, Notu, Ddddd, Dgoj, Ntot, Minres, Maxres)
-C
-C *** Purpose -- Generate Deriv(k,ipar) = partial Crss(k) wrt U(ipar) for
-C resonance params
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION If_Excl(*), Ifcros(*), Pr(Ntriag,*),
- * Pi(Ntriag,*), Deriv(Ncrsss,*), Derivx(2,Ntotc,Ntotc,*),
- * Tr(Ncrsss,*), Ti(Ncrsss,*), Tx(2,Ntriag,*), Notu(*), Ddddd(*)
-C
-C DIMENSION Ifcros(Ncrsss), Pr(Ntriag,Nyyres), Pi(Ntriag,Nyyres),
-C * Deriv(Ncrsss,Nyyres), Derivx(2,Ntotc,Ntotc,Nnpar),
-C * Tr(Ncrsss,Nn), Ti(Ncrsss,Nn), Tx(2,Ntriag,Ntriag),
-C * Notu(Nyyres), Ddddd(Ncrsss)
-C
- DATA Zero /0.0d0/
-C
-C
- IF (Ncrssx.NE.0) THEN
- DO Mm=1,Npr
- M = Kstart + Mm
-C Note that M = parameter number
- IF (Notu(M).NE.1) THEN
- IJ = 0
- DO K=1,Ncrsss
- Ddddd(K) = Zero
- END DO
- DO I=1,Ntot
- DO J=1,I
- IJ = IJ + 1
- IF (Pi(Ij,M).NE.Zero) THEN
- DO K=1,Ncrsss
- IF (Ifcros(K).NE.0) THEN
- IF (K.LE.2 .OR.
- * If_Excl(K-2+Nent).EQ.Kaptur) THEN
-C *** Kaptur=1 and If_Excl=1 means subtract this excluded channel from
-C *** absorption to give the eliminated gamma channel contribution
- Ddddd(K) = Ddddd(K) - Pi(Ij,M)*Ti(K,Ij)
- END IF
- END IF
- END DO
- END IF
- IF (Pr(Ij,M).NE.Zero) THEN
- DO K=1,Ncrsss
- IF (Ifcros(K).NE.0) THEN
- IF (K.LE.2 .OR.
- * If_Excl(K-2+Nent).EQ.Kaptur) THEN
- Ddddd(K) = Ddddd(K) + Pr(Ij,M)*Tr(K,Ij)
- END IF
- END IF
- END DO
- END IF
- END DO
- END DO
- DO K=1,Ncrsss
- IF (Ifcros(K).NE.0) THEN
- IF (K.LE.2 .OR. If_Excl(K-2+Nent).EQ.Kaptur) THEN
- Deriv(K,M) = Dgoj*Ddddd(K) + Deriv(K,M)
- END IF
- END IF
- END DO
- END IF
- END DO
- END IF
-C
-C
- IF (Ifdif.NE.0) THEN
- DO Mm=1,Npr
- M = Kstart + Mm
- IF (Notu(M).NE.1) THEN
- DO IJ=1,NN
- IF (Pi(Ij,M).NE.Zero .OR. Pr(Ij,M).NE.Zero) THEN
- DO Ichan=1,Ntot
- Ifs = If_Stay (Ichan, Ifdif, Nent,
- * If_Excl(Ichan), Kaptur)
- IF (Ifs.EQ.0) THEN
- DO Ichanx=1,Nent
- IF (Ichanx.LE.Ichan) THEN
- Kl = (Ichan*(Ichan-1))/2 + Ichanx
- ELSE
- Kl = (Ichanx*(Ichanx-1))/2 + Ichan
- END IF
- Derivx(1,Ichanx,Ichan,M) =
- * Derivx(1,Ichanx,Ichan,M) +
- * Pr(Ij,M)*Tx(1,Ij,KL) -
- * Pi(Ij,M)*Tx(2,Ij,KL)
- Derivx(2,Ichanx,Ichan,M) =
- * Derivx(2,Ichanx,Ichan,M) +
- * Pr(Ij,M)*Tx(2,Ij,KL) +
- * Pi(Ij,M)*Tx(1,Ij,KL)
- END DO
- END IF
- END DO
- END IF
- END DO
- END IF
- END DO
- END IF
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Dercap (Nent, If_Excl, Ifcros, Pr, Pi, Deriv,
- * Derivx, Tr, Ti, Tx, Notu, Ddddd, Dgoj, Ntot, Minres, Maxres)
-C
-C *** Here only if treating all capture-widths as one variable
-C *** Generate Deriv(k,ipar) = partial Crss(k) wrt U(ipar) for
-C resonance params
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- use EndfData_common_m
- use SammyResonanceInfo_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION If_Excl(*), Ifcros(*), Pr(Ntriag,*),
- * Pi(Ntriag,*), Deriv(Ncrsss,*), Derivx(2,Ntotc,Ntotc,*),
- * Tr(Ncrsss,*), Ti(Ncrsss,*), Tx(2,Ntriag,*), Notu(*), Ddddd(*)
-C
-C DIMENSION Ifcros(Ncrsss), Pr(Ntriag,Nyyres), Pi(Ntriag,Nyyres),
-C * Deriv(Ncrsss,Nyyres), Derivx(2,Ntotc,Ntotc,Nnpar),
-C * Tr(Ncrsss,Nn), Ti(Ncrsss,Nn), Tx(2,Ntriag,Ntriag),
-C * Notu(Nyyres), Ddddd(Ncrsss)
-C
- type(SammyResonanceInfo)::resInfo
- DATA Zero /0.0d0/
-C
- call resParData%getResonanceInfo(resInfo, Minres)
- Ifl = resInfo%getChannelFitOption(1)
- if( Ifl.eq.0) return ! user linked gamma width either for one channel only, or linked and did not fit
-
- IF (Ncrssx.NE.0) THEN
- DO Mm=Minres,Maxres
- M = Napres + Mm
- DO K=1,Ncrsss
- Ddddd(K) = Zero
- END DO
- Ij = 0
- DO I=1,Ntot
- DO J=1,I
- Ij = Ij + 1
- IF (Pi(Ij,M).NE.Zero) THEN
- DO K=1,Ncrsss
- IF (Ifcros(K).NE.0) THEN
- IF (K.LE.2 .OR.
- * If_Excl(K-2+Nent).EQ.Kaptur) THEN
- Ddddd(K) = Ddddd(K) - Pi(Ij,M)*Ti(K,Ij)
- END IF
- END IF
- END DO
- END IF
- IF (Pr(Ij,M).NE.Zero) THEN
- DO K=1,Ncrsss
- IF (Ifcros(K).NE.0) THEN
- IF (K.LE.2 .OR.
- * If_Excl(K-2+Nent).EQ.Kaptur) THEN
- Ddddd(K) = Ddddd(K) + Pr(Ij,M)*Tr(K,Ij)
- END IF
- END IF
- END DO
- END IF
- END DO
- END DO
- DO K=1,Ncrsss
- IF (Ifcros(K).NE.0) THEN
- IF (K.LE.2 .OR. If_Excl(K-2+Nent).EQ.Kaptur) THEN
- Deriv(K,Ifl) = Dgoj*Ddddd(K) + Deriv(K,Ifl)
- END IF
- END IF
- END DO
- END DO
- END IF
-C
-C
- IF (Ifdif.NE.0) THEN
- DO Mm=Minres,Maxres
- M = Napres + Mm
- DO IJ=1,NN
- IF (Pi(Ij,M).NE.Zero .OR. Pr(Ij,M).NE.Zero) THEN
- KL = 0
- DO Ichan=1,Ntot
- DO Ichanx=1,Ichan
- KL = KL + 1
- Ifs = If_Stay (Ichan, Ifdif, Nent,
- * If_Excl(Ichan), Kaptur)
- IF (Ifs.EQ.0 .AND. Ichanx.LE.Nent) THEN
- Derivx(1,Ichanx,Ichan,Ifl) =
- * Derivx(1,Ichanx,Ichan,Ifl) +
- * Pr(Ij,M)*Tx(1,Ij,KL) -
- * Pi(Ij,M)*Tx(2,Ij,KL)
- Derivx(2,Ichanx,Ichan,Ifl) =
- * Derivx(2,Ichanx,Ichan,Ifl) +
- * Pr(Ij,M)*Tx(2,Ij,KL) +
- * Pi(Ij,M)*Tx(1,Ij,KL)
- END IF
- END DO
- END DO
- END IF
- END DO
- END DO
- END IF
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Dereee (Nent, If_Excl, Ifcros, Derivx, Tr, Ti,
- * Tx, Prer, Prei, Ddddtl, Ntot)
-C
-C *** generate Deriv(k,Itzero) & Deriv(k,Ilzero); ditto Derivx
-C *** ie Deriv(k,i) = partial Crss(k) wrt either Tzero or LZero
-C
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION If_Excl(*), Ifcros(*), Prer(Ntriag), Prei(Ntriag),
- * Derivx(2,Ntotc,Ntotc,*), Tr(Ncrsss,*), Ti(Ncrsss,*),
- * Tx(2,Ntriag,*), Ddddtl(*)
-C
-C DIMENSION Ifcros(Ncrsss), Prer(Ntriag), Prei(Ntriag),
-C * Deriv(Ncrsss,Nyyres), Derivx(2,Ntotc,Ntotc,Nnpar),
-C * Tr(Ncrsss,Nn), Ti(Ncrsss,Nn), Tx(2,Ntriag,Ntriag),
-C * Notu(Nyyres), Ddddtl(Ncrsss)
-C
- DATA Zero /0.0d0/
-C
- Itz = Itzero - Nvadif
- Ilz = IlZero - Nvadif
- IF (Ncrssx.NE.0) THEN
-C *** Calculating Deriv(K,I?z) = (2T)(Pre)(Z)(E?z), where
-C *** Tr + i Ti = (partial sigmaX wrt R) * Half
-C *** Prer + i Prei = partial R wrt E
-C *** Z = partial E wrt sqrt(E) = 2*Squ
-C *** Etz = partial sqrt(E) wrt tzero
-C *** ELz = partial sqrt(E) wrt eLzero
-C *** but do not include the E?z part yet, or missing {dgoj * 1/E^2},
-C *** and store in Ddddtl
- Zz = Squ*4.0D0
- DO K=1,Ncrsss
- Ddddtl(K) = Zero
- END DO
- Ij = 0
- DO I=1,Ntot
- DO J=1,I
- Ij = Ij + 1
- IF (Prei(Ij).NE.Zero) THEN
- DO K=1,Ncrsss
- IF (Ifcros(K).NE.0) THEN
- IF (K.LE.2 .OR. If_Excl(K-2+Nent).EQ.0) THEN
- Ddddtl(K) = Ddddtl(K) - Prei(Ij)*Ti(K,Ij)*Zz
- END IF
- END IF
- END DO
- END IF
- IF (Prer(Ij).NE.Zero) THEN
- DO K=1,Ncrsss
- IF (Ifcros(K).NE.0) THEN
- IF (K.LE.2 .OR. If_Excl(K-2+Nent).EQ.0) THEN
- Ddddtl(K) = Ddddtl(K) + Prer(Ij)*Tr(K,Ij)*Zz
- END IF
- END IF
- END DO
- END IF
- END DO
- END DO
- END IF
-C
-C
- IF (Ifdif.NE.0) THEN
-C *** careful... i don't believe the following yet !!
- DO Ij=1,NN
- IF (PreI(Ij).NE.Zero .OR. PreR(Ij).NE.Zero) THEN
- KL = 0
- DO Ichan=1,Ntot
- DO Ichanx=1,Ichan
- KL = KL + 1
- Ifs = If_Stay (Ichan, Ifdif, Nent,
- * If_Excl(Ichan), Kaptur)
- IF (Ifs.EQ.0 .AND. Ichanx.LE.Nent) THEN
- IF (Itz.GT.0) THEN
- Derivx(1,Ichanx,Ichan,Itz) =
- * Derivx(1,Ichanx,Ichan,Itz) +
- * Prer(Ij)*Tx(1,Ij,KL) -
- * Prei(Ij)*Tx(2,Ij,KL)*Etz
- Derivx(2,Ichanx,Ichan,Itz) =
- * Derivx(2,Ichanx,Ichan,Itz) +
- * Prer(Ij)*Tx(2,Ij,KL) +
- * Prei(Ij)*Tx(1,Ij,KL)*Etz
- END IF
- IF (iLz.GT.0) THEN
- Derivx(1,Ichanx,Ichan,iLz) =
- * Derivx(1,Ichanx,Ichan,iLz) +
- * Prer(Ij)*Tx(1,Ij,KL) -
- * Prei(Ij)*Tx(2,Ij,KL)*Elz
- Derivx(2,Ichanx,Ichan,iLz) =
- * Derivx(2,Ichanx,Ichan,iLz) +
- * Prer(Ij)*Tx(2,Ij,KL) +
- * Prei(Ij)*Tx(1,Ij,KL)*Elz
- END IF
- END IF
- END DO
- END DO
- END IF
- END DO
- END IF
- RETURN
- END
diff --git a/sammy/src/xct/mxct11.f90 b/sammy/src/xct/mxct11.f90
new file mode 100644
index 0000000000000000000000000000000000000000..010adc890a8ceefc4754a4ce7956aa8ed22b301b
--- /dev/null
+++ b/sammy/src/xct/mxct11.f90
@@ -0,0 +1,337 @@
+module mxct11_m
+
+contains
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Derres (Nent,If_Excl, Ifcros, Pr, Pi, Deriv, &
+ Derivx, Tr, Ti, Tx, Notu, Ddddd, Dgoj, Ntot, Minres, Maxres)
+!
+! *** Purpose -- Generate Deriv(k,ipar) = partial Crss(k) wrt U(ipar) for
+! resonance params
+ use fixedi_m
+ use ifwrit_m
+ use varyr_common_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ real(kind=8)::Pr(:,:), Pi(:,:)
+ integer::Notu(:)
+!
+ DIMENSION If_Excl(*), Ifcros(*), &
+ Deriv(Ncrsss,*), Derivx(2,Ntotc,Ntotc,*), &
+ Tr(Ncrsss,*), Ti(Ncrsss,*), Tx(2,Ntriag,*), Ddddd(*)
+ integer::idPos
+!
+! Napres -> all parameters for which derivatives are needed
+! not restricted to resonance parameters
+! only distantly related to the parameter of the same
+! name that was in fixedi_m
+! DIMENSION Ifcros(Ncrsss),
+! * Deriv(Ncrsss,Napres), Derivx(2,Ntotc,Ntotc,Nnpar),
+! * Tr(Ncrsss,Nn), Ti(Ncrsss,Nn), Tx(2,Ntriag,Ntriag),
+! * Ddddd(Ncrsss)
+!
+ DATA Zero /0.0d0/
+!
+!
+ IF (Ncrssx.NE.0) THEN
+ DO Mm=1,Npr
+ M = Kstart + Mm
+ idPos = Notu(M)
+! Note that M = parameter number
+ IF (idPos.gt.0) THEN
+ IJ = 0
+ DO K=1,Ncrsss
+ Ddddd(K) = Zero
+ END DO
+ DO I=1,Ntot
+ DO J=1,I
+ IJ = IJ + 1
+ IF (Pi(Ij,M).NE.Zero) THEN
+ DO K=1,Ncrsss
+ IF (Ifcros(K).NE.0) THEN
+ IF (K.LE.2 .OR.If_Excl(K-2+Nent).EQ.Kaptur) THEN
+! *** Kaptur=1 and If_Excl=1 means subtract this excluded channel from
+! *** absorption to give the eliminated gamma channel contribution
+ Ddddd(K) = Ddddd(K) - Pi(Ij,M)*Ti(K,Ij)
+ END IF
+ END IF
+ END DO
+ END IF
+ IF (Pr(Ij,M).NE.Zero) THEN
+ DO K=1,Ncrsss
+ IF (Ifcros(K).NE.0) THEN
+ IF (K.LE.2 .OR.If_Excl(K-2+Nent).EQ.Kaptur) THEN
+ Ddddd(K) = Ddddd(K) + Pr(Ij,M)*Tr(K,Ij)
+ END IF
+ END IF
+ END DO
+ END IF
+ END DO
+ END DO
+ DO K=1,Ncrsss
+ IF (Ifcros(K).NE.0) THEN
+ IF (K.LE.2 .OR. If_Excl(K-2+Nent).EQ.Kaptur) THEN
+ Deriv(K,idPos) = Dgoj*Ddddd(K) + Deriv(K,idPos)
+ END IF
+ END IF
+ END DO
+ END IF
+ END DO
+ END IF
+!
+!
+ IF (Ifdif.NE.0) THEN
+ DO Mm=1,Npr
+ M = Kstart + Mm
+ idPos = Notu(M)
+ IF (idPos.gt.0) THEN
+ DO IJ=1,NN
+ IF (Pi(Ij,M).NE.Zero .OR. Pr(Ij,M).NE.Zero) THEN
+ DO Ichan=1,Ntot
+ Ifs = If_Stay (Ichan, Ifdif, Nent, &
+ If_Excl(Ichan), Kaptur)
+ IF (Ifs.EQ.0) THEN
+ DO Ichanx=1,Nent
+ IF (Ichanx.LE.Ichan) THEN
+ Kl = (Ichan*(Ichan-1))/2 + Ichanx
+ ELSE
+ Kl = (Ichanx*(Ichanx-1))/2 + Ichan
+ END IF
+ Derivx(1,Ichanx,Ichan,idPos) = &
+ Derivx(1,Ichanx,Ichan,idPos) + &
+ Pr(Ij,M)*Tx(1,Ij,KL) - &
+ Pi(Ij,M)*Tx(2,Ij,KL)
+ Derivx(2,Ichanx,Ichan,idPos) = &
+ Derivx(2,Ichanx,Ichan,idPos) + &
+ Pr(Ij,M)*Tx(2,Ij,KL) + &
+ Pi(Ij,M)*Tx(1,Ij,KL)
+ END DO
+ END IF
+ END DO
+ END IF
+ END DO
+ END IF
+ END DO
+ END IF
+ RETURN
+ END SUBROUTINE Derres
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Dercap (Nent, If_Excl, Ifcros, Pr, Pi, Deriv, &
+ Derivx, Tr, Ti, Tx, Notu, Ddddd, Dgoj, Ntot, Minres, Maxres)
+!
+! *** Here only if treating all capture-widths as one variable
+! *** Generate Deriv(k,ipar) = partial Crss(k) wrt U(ipar) for
+! resonance params
+ use fixedi_m
+ use ifwrit_m
+ use varyr_common_m
+ use EndfData_common_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+!
+ type(SammyResonanceInfo)::resInfo
+ real(kind=8)::Pr(:,:), Pi(:,:)
+ DIMENSION If_Excl(*), Ifcros(*), &
+ Deriv(Ncrsss,*), Derivx(2,Ntotc,Ntotc,*), &
+ Tr(Ncrsss,*), Ti(Ncrsss,*), Tx(2,Ntriag,*), Notu(*), Ddddd(*)
+
+ DATA Zero /0.0d0/
+!
+! Napres -> all parameters for which derivatives are needed
+! not restricted to resonance parameters
+! only distantly related to the parameter of the same
+! name that was in fixedi_m
+! DIMENSION Ifcros(Ncrsss),
+! * Deriv(Ncrsss,Napres), Derivx(2,Ntotc,Ntotc,Nnpar),
+! * Tr(Ncrsss,Nn), Ti(Ncrsss,Nn), Tx(2,Ntriag,Ntriag),
+! * Ddddd(Ncrsss)
+!
+ IF (Ncrssx.NE.0) THEN
+ DO Mm=1,Npr
+ M = Kstart + Mm
+ if (Notu(M).ge.0) cycle
+ Ifl = -1 * Notu(M)
+ DO K=1,Ncrsss
+ Ddddd(K) = Zero
+ END DO
+ Ij = 0
+ DO I=1,Ntot
+ DO J=1,I
+ Ij = Ij + 1
+ IF (Pi(Ij,M).NE.Zero) THEN
+ DO K=1,Ncrsss
+ IF (Ifcros(K).NE.0) THEN
+ IF (K.LE.2 .OR.If_Excl(K-2+Nent).EQ.Kaptur) THEN
+ Ddddd(K) = Ddddd(K) - Pi(Ij,M)*Ti(K,Ij)
+ END IF
+ END IF
+ END DO
+ END IF
+ IF (Pr(Ij,M).NE.Zero) THEN
+ DO K=1,Ncrsss
+ IF (Ifcros(K).NE.0) THEN
+ IF (K.LE.2 .OR.If_Excl(K-2+Nent).EQ.Kaptur) THEN
+ Ddddd(K) = Ddddd(K) + Pr(Ij,M)*Tr(K,Ij)
+ END IF
+ END IF
+ END DO
+ END IF
+ END DO
+ END DO
+ DO K=1,Ncrsss
+ IF (Ifcros(K).NE.0) THEN
+ IF (K.LE.2 .OR. If_Excl(K-2+Nent).EQ.Kaptur) THEN
+ Deriv(K,Ifl) = Dgoj*Ddddd(K) + Deriv(K,Ifl)
+ END IF
+ END IF
+ END DO
+ END DO
+ END IF
+!
+!
+ IF (Ifdif.NE.0) THEN
+ DO Mm=1,Npr
+ M = Kstart + Mm
+ if (Notu(M).ge.0) cycle
+ Ifl = -1 * Notu(M)
+ DO IJ=1,NN
+ IF (Pi(Ij,M).NE.Zero .OR. Pr(Ij,M).NE.Zero) THEN
+ KL = 0
+ DO Ichan=1,Ntot
+ DO Ichanx=1,Ichan
+ KL = KL + 1
+ Ifs = If_Stay (Ichan, Ifdif, Nent, If_Excl(Ichan), Kaptur)
+ IF (Ifs.EQ.0 .AND. Ichanx.LE.Nent) THEN
+ Derivx(1,Ichanx,Ichan,Ifl) = &
+ Derivx(1,Ichanx,Ichan,Ifl) + &
+ Pr(Ij,M)*Tx(1,Ij,KL) - &
+ Pi(Ij,M)*Tx(2,Ij,KL)
+ Derivx(2,Ichanx,Ichan,Ifl) = &
+ Derivx(2,Ichanx,Ichan,Ifl) + &
+ Pr(Ij,M)*Tx(2,Ij,KL) + &
+ Pi(Ij,M)*Tx(1,Ij,KL)
+ END IF
+ END DO
+ END DO
+ END IF
+ END DO
+ END DO
+ END IF
+ RETURN
+ END SUBROUTINE Dercap
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Dereee (Nent, If_Excl, Ifcros, Derivx, Tr, Ti, &
+ Tx, Prer, Prei, Ddddtl, Ntot)
+!
+! *** generate Deriv(k,Itzero) & Deriv(k,Ilzero); ditto Derivx
+! *** ie Deriv(k,i) = partial Crss(k) wrt either Tzero or LZero
+!
+ use fixedi_m
+ use ifwrit_m
+ use varyr_common_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+!
+ DIMENSION If_Excl(*), Ifcros(*), Prer(Ntriag), Prei(Ntriag), &
+ Derivx(2,Ntotc,Ntotc,*), Tr(Ncrsss,*), Ti(Ncrsss,*), &
+ Tx(2,Ntriag,*), Ddddtl(*)
+!
+! Napres -> all parameters for which derivatives are needed
+! not restricted to resonance parameters
+! only distantly related to the parameter of the same
+! name that was in fixedi_m
+!
+! DIMENSION Ifcros(Ncrsss), Prer(Ntriag), Prei(Ntriag),
+! * Deriv(Ncrsss,Napres), Derivx(2,Ntotc,Ntotc,Nnpar),
+! * Tr(Ncrsss,Nn), Ti(Ncrsss,Nn), Tx(2,Ntriag,Ntriag),
+! * Ddddtl(Ncrsss)
+!
+ DATA Zero /0.0d0/
+!
+ Itz = Itzero
+ Ilz = IlZero
+ IF (Ncrssx.NE.0) THEN
+! *** Calculating Deriv(K,I?z) = (2T)(Pre)(Z)(E?z), where
+! *** Tr + i Ti = (partial sigmaX wrt R) * Half
+! *** Prer + i Prei = partial R wrt E
+! *** Z = partial E wrt sqrt(E) = 2*Squ
+! *** Etz = partial sqrt(E) wrt tzero
+! *** ELz = partial sqrt(E) wrt eLzero
+! *** but do not include the E?z part yet, or missing {dgoj * 1/E^2},
+! *** and store in Ddddtl
+ Zz = Squ*4.0D0
+ DO K=1,Ncrsss
+ Ddddtl(K) = Zero
+ END DO
+ Ij = 0
+ DO I=1,Ntot
+ DO J=1,I
+ Ij = Ij + 1
+ IF (Prei(Ij).NE.Zero) THEN
+ DO K=1,Ncrsss
+ IF (Ifcros(K).NE.0) THEN
+ IF (K.LE.2 .OR. If_Excl(K-2+Nent).EQ.0) THEN
+ Ddddtl(K) = Ddddtl(K) - Prei(Ij)*Ti(K,Ij)*Zz
+ END IF
+ END IF
+ END DO
+ END IF
+ IF (Prer(Ij).NE.Zero) THEN
+ DO K=1,Ncrsss
+ IF (Ifcros(K).NE.0) THEN
+ IF (K.LE.2 .OR. If_Excl(K-2+Nent).EQ.0) THEN
+ Ddddtl(K) = Ddddtl(K) + Prer(Ij)*Tr(K,Ij)*Zz
+ END IF
+ END IF
+ END DO
+ END IF
+ END DO
+ END DO
+ END IF
+!
+!
+ IF (Ifdif.NE.0) THEN
+! *** careful... i don't believe the following yet !!
+ DO Ij=1,NN
+ IF (PreI(Ij).NE.Zero .OR. PreR(Ij).NE.Zero) THEN
+ KL = 0
+ DO Ichan=1,Ntot
+ DO Ichanx=1,Ichan
+ KL = KL + 1
+ Ifs = If_Stay (Ichan, Ifdif, Nent, If_Excl(Ichan), Kaptur)
+ IF (Ifs.EQ.0 .AND. Ichanx.LE.Nent) THEN
+ IF (Itz.GT.0) THEN
+ Derivx(1,Ichanx,Ichan,Itz) = &
+ Derivx(1,Ichanx,Ichan,Itz) + &
+ Prer(Ij)*Tx(1,Ij,KL) - &
+ Prei(Ij)*Tx(2,Ij,KL)*Etz
+ Derivx(2,Ichanx,Ichan,Itz) = &
+ Derivx(2,Ichanx,Ichan,Itz) + &
+ Prer(Ij)*Tx(2,Ij,KL) + &
+ Prei(Ij)*Tx(1,Ij,KL)*Etz
+ END IF
+ IF (iLz.GT.0) THEN
+ Derivx(1,Ichanx,Ichan,iLz) = &
+ Derivx(1,Ichanx,Ichan,iLz) + &
+ Prer(Ij)*Tx(1,Ij,KL) - &
+ Prei(Ij)*Tx(2,Ij,KL)*Elz
+ Derivx(2,Ichanx,Ichan,iLz) = &
+ Derivx(2,Ichanx,Ichan,iLz) + &
+ Prer(Ij)*Tx(2,Ij,KL) + &
+ Prei(Ij)*Tx(1,Ij,KL)*Elz
+ END IF
+ END IF
+ END DO
+ END DO
+ END IF
+ END DO
+ END IF
+ RETURN
+ END SUBROUTINE Dereee
+
+end module mxct11_m
diff --git a/sammy/src/xct/mxct15.f b/sammy/src/xct/mxct15.f
index 3acf3c532478ec0fc303de8ee3fa2a95e0ddbb45..3c2f1af169fd1322f4cc9c0f52177778e60e8e47 100644
--- a/sammy/src/xct/mxct15.f
+++ b/sammy/src/xct/mxct15.f
@@ -27,7 +27,7 @@ C *** derivatives of elastic cross section wrt effective radius
C *** [d sigma-el/d phi] * [d phi/d effective radius]
DO Ichan=1,Nent
IF (IF_Zkfe(Ichan).GT.0) THEN
- Ifzk = IF_Zkfe(Ichan) - Nvadif
+ Ifzk = IF_Zkfe(Ichan)
IF (Su.GT.Echan(Ichan)) THEN
Zz = Dgoj * dSQRT(Su-Echan(Ichan))*Zke(Ichan)
C *** Note that Dgoj * {partial rho wrt a, for channel
@@ -48,7 +48,7 @@ C *** derivatives of elastic & absorption wrt true radius
IF (IF_Zkte(Ichan).GT.0 .AND.
* Su.GT.Echan(Ichan)) THEN
Zz = Dgoj * dSQRT(Su-Echan(Ichan))*Zke(Ichan)
- Ifzk = If_Zkte(Ichan) - Nvadif
+ Ifzk = If_Zkte(Ichan)
Deriv(k,Ifzk) = Deriv(k,Ifzk) +
* Dst(k,Ichan)*zz
END IF
@@ -67,7 +67,7 @@ C *** (true) radius
END DO
IF (Ifc.EQ.1) THEN
DO Ichan=1,Nent
- Ifzk = If_Zkte(Ichan) - Nvadif
+ Ifzk = If_Zkte(Ichan)
IF (Su.LE.Echan(Ichan)) THEN
Zz = Zero
ELSE
@@ -81,7 +81,7 @@ C *** (true) radius
* Deriv(Jj+2,Ifzk) = Deriv(Jj+2,Ifzk) +
* Dstt(Jj,Ichan)*Zz
IF (If_Zkte(Jchan).GT.0) THEN
- Ifzkj = If_Zkte(Jchan) - Nvadif
+ Ifzkj = If_Zkte(Jchan)
IF (Su.GT.Echan(Jchan)) THEN
Zzj = Dgoj*Zke(Jchan)*
* Dsqrt(Su-Echan(Jchan))
@@ -107,7 +107,7 @@ C *** effective radius; First, diagonal pieces
IF (Ifdif.EQ.1) THEN
DO Ichan=1,Nent
IF (If_Zkfe(Ichan).GT.0) THEN
- Ifzk = If_Zkfe(Ichan) - Nvadif
+ Ifzk = If_Zkfe(Ichan)
Zz = Zke(Ichan)*Squ
Derivx(1,Ichan,Ichan,Ifzk) =
* Derivx(1,Ichan,Ichan,Ifzk) +
@@ -128,7 +128,7 @@ C *** effective radius; Now, off-diagonal pieces
* (Ifdif.EQ.2 .AND. Ichan.GT.Nent .AND.
* If_Excl(Ichan).EQ.Kaptur) ) THEN
IF (If_Zkfe(Ichan).GT.0) THEN
- Ifzk = If_Zkfe(Ichan) - Nvadif
+ Ifzk = If_Zkfe(Ichan)
Zz = Zke(Ichan)*Squ
Derivx(1,Jchan,Ichan,Ifzk) =
* Derivx(1,Jchan,Ichan,Ifzk) +
@@ -138,7 +138,7 @@ C *** effective radius; Now, off-diagonal pieces
* Zz*Dsfx(2,Jchan,Ichan)
END IF
IF (If_Zkfe(Jchan).GT.0) THEN
- Ifzk = If_Zkfe(Jchan) - Nvadif
+ Ifzk = If_Zkfe(Jchan)
Zz = Zke(Jchan)*Squ
Derivx(1,Jchan,Ichan,Ifzk) =
* Derivx(1,Jchan,Ichan,Ifzk) +
@@ -157,7 +157,7 @@ C
IF (Kvprrt.GT.0) THEN
C *** derivatives of pieces of angular distribution wrt true radius
DO Ichan=1,Ntot
- Ifzk = If_Zkte(Ichan) - Nvadif
+ Ifzk = If_Zkte(Ichan)
Zz = Zero
IF (If_Zkte(Ichan).GT.0) THEN
Zz = Zke(Ichan)*Squ
@@ -184,7 +184,7 @@ C *** derivatives of pieces of angular distribution wrt true radius
* Zz*Dstx(2,Jchan,Ichan)
END IF
IF (If_Zkte(Jchan).GT.0) THEN
- Ifzkj = If_Zkte(Jchan) - Nvadif
+ Ifzkj = If_Zkte(Jchan)
Z = Zke(Jchan)*Squ
Derivx(1,Jchan,Ichan,Ifzkj) =
* Derivx(1,Jchan,Ichan,Ifzkj) +
diff --git a/sammy/src/xct/mxct16.f b/sammy/src/xct/mxct16.f
index a6cb70d7451d1ca6e200e157e9078d62a745b4c3..aade390bae6f921b5a52ebac63e508ae08d83719 100644
--- a/sammy/src/xct/mxct16.f
+++ b/sammy/src/xct/mxct16.f
@@ -61,7 +61,6 @@ C
ELSE
M = Kvcrfn
END IF
- M = M - Nvadif
DO K=1,2
IF (Ifcros(K).NE.0) Deriv(K,M) = Dgoj*Ddddd(K)
* + Deriv(K,M)
@@ -86,7 +85,7 @@ C *** now for differential elastic cross sections
Ix = Ifltru(Ir)
IF (Ix.GT.0) THEN
Ix = Ix - Nfpres - Nfpext
- M = Ifltru(Ir) - Nvadif
+ M = Ifltru(Ir)
Ij = 0
DO Ij=1,NN
IF (Pgai(Ij,Ix,Nnnn).NE.Zero .OR.
diff --git a/sammy/src/xct/mxct17.f b/sammy/src/xct/mxct17.f
index 62da9cfaffdc9cc01beb7aab16c3f044ff6f21f0..7d869761a3ca788dee45348dfff6a724d2fe54b6 100644
--- a/sammy/src/xct/mxct17.f
+++ b/sammy/src/xct/mxct17.f
@@ -236,11 +236,15 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
DIMENSION Crss(*), Deriv(Ncrsss,*), Ddddtl(*)
-C DIMENSION Crss(Ncrsss), Deriv(Ncrsss,Nyyres)
+ ! Napres -> all parameters for which derivatives are needed
+ ! not restricted to resonance parameters
+ ! only distantly related to the parameter of the same
+ ! name that was in fixedi_
+C DIMENSION Crss(Ncrsss), Deriv(Ncrsss,Napres)
DATA Two/2.0d0/
C
- Itz = Itzero - Nvadif
- ILz = Ilzero - Nvadif
+ Itz = Itzero
+ ILz = Ilzero
DO I=1,Ncrsss
A = Ddddtl(I)*Dgoj - Crss(I)*Two/Squ
IF (Itz.GT.0) Deriv(I,Itz) = A*Etz
@@ -261,10 +265,14 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
DIMENSION Crss(*), Deriv(Ncrsss,*)
-C DIMENSION Crss(Ncrsss), Deriv(Ncrsss,Nyyres), Ifzke
+ ! Napres -> all parameters for which derivatives are needed
+ ! not restricted to resonance parameters
+ ! only distantly related to the parameter of the same
+ ! name that was in fixedi_
+C DIMENSION Crss(Ncrsss), Deriv(Ncrsss,Napres), Ifzke
C
IF (Ifzke.LE.0) RETURN
- Ifzk = Ifzke - Nvadif
+ Ifzk = Ifzke
DO I=1,Ncrsss
Deriv(I,Ifzk) = Crss(I)/AbnVal
END DO
diff --git a/sammy/src/xct/mxct19.f b/sammy/src/xct/mxct19.f
index 245aceeee23f75d42379829cb5efae4b3328c3ea..3f478ee866bd80533bc68a3557a4a8d0fd9ff27c 100644
--- a/sammy/src/xct/mxct19.f
+++ b/sammy/src/xct/mxct19.f
@@ -303,7 +303,7 @@ C
IF (Kcros.EQ.6) THEN
IF (Kefcap.NE.0) THEN
IF (Iflmsc(Kefcap).GT.0) THEN
- Nd = Iflmsc(Kefcap) - Nvadif - Ndasig
+ Nd = Iflmsc(Kefcap) - Ndasig
IF (Nd.LT.0) STOP '[STOP in Prtclr in mxct19.f #4]'
D = F + C
IF (Dbsigx(1,Nd,Iso).EQ.Zero) THEN
@@ -313,7 +313,7 @@ C
END IF
END IF
IF (Iflmsc(Keffis).GT.0) THEN
- Nd = Iflmsc(Keffis) - Nvadif - Ndasig
+ Nd = Iflmsc(Keffis) - Ndasig
IF (Nd.LT.0) STOP '[STOP in Prtclr in mxct19.f #6]'
D = F + C
IF (Dbsigx(1,Nd,Iso).EQ.Zero) THEN
@@ -324,7 +324,7 @@ C
END IF
END IF
IF (Iflmsc(K1+Kjetan-1).GT.0) THEN
- Nd = Iflmsc(K1+Kjetan-1) - Nvadif - Ndasig
+ Nd = Iflmsc(K1+Kjetan-1) - Ndasig
IF (Nd.LT.0) STOP '[STOP in Prtclr in mxct19.f # 8]'
IF (Dbsigx(1,Nd,Iso).EQ.Zero) THEN
Dbsigx(1,Nd,Iso) = A1*A3
@@ -333,7 +333,7 @@ C
END IF
END IF
IF (K2.GT.0 .AND. Iflmsc(K2+Kjetan-1).GT.0) THEN
- Nd = Iflmsc(K2+Kjetan-1) - Nvadif - Ndasig
+ Nd = Iflmsc(K2+Kjetan-1) - Ndasig
IF (Nd.LT.0) STOP '[STOP in Prtclr in mxct19.f # 9]'
IF (Dbsigx(1,Nd,Iso).EQ.Zero) THEN
Dbsigx(1,Nd,Iso) = A2*A3
diff --git a/sammy/src/xct/mxct22.f b/sammy/src/xct/mxct22.f
index 3a5c6541f768c59107671ec1b3fbb117a2525044..fc3fb3f72a93c90b2e59861e67ecd52e3bf6398c 100644
--- a/sammy/src/xct/mxct22.f
+++ b/sammy/src/xct/mxct22.f
@@ -126,7 +126,7 @@ C ##################### maybe NOT CORRECT YET FOR Iq_Val>0
DO Iso=1,Numiso
Ifl = Ifliso(Iso)
IF (Ifl.GT.0) THEN
- Ifl = Ifl - Nvadif
+ Ifl = Ifl
Isopar(Ifl) = Iso
DO L=1,Lllmax
Dddlll(L,Ifl) = Ccclll(L,Iso)/
diff --git a/sammy/src/xct/mxct23.f b/sammy/src/xct/mxct23.f
index 6d8fb0732b1bc4af7a723a9e99fe3747802df7bd..159c7e3e2f590dc0803c48bb3079861fe3cde0c6 100644
--- a/sammy/src/xct/mxct23.f
+++ b/sammy/src/xct/mxct23.f
@@ -32,7 +32,7 @@ C *** beginning with self-indication transmission
Ik = Ik + 1
Iipars = Iflmsc(ik)
IF (Iipars.GT.0) THEN
- Ipars = Iipars - Nvadif - Ndasig
+ Ipars = Iipars - Ndasig
DO N=1,Ngroup
call resParData%getSpinGroupInfo(spinInfo, N)
IF (spinInfo%getIncludeInCalc()) THEN
@@ -54,14 +54,14 @@ C *** si2 now do derivatives wrt resonance parameters et al
Ik = Ik + 1
Iipars = Iflmsc(ik)
Ipars = 0
- IF (Iipars.GT.0) Ipars = Iipars - Nvadif - Ndasig
+ IF (Iipars.GT.0) Ipars = Iipars - Ndasig
Lk = Ifliso(Iso)
DO N=1,Ngroup
call resParData%getSpinGroupInfo(spinInfo, N)
isoN = spinInfo%getIsotopeIndex()
IF (isoN.EQ.Iso .AND. Ndasig.GT.0) THEN
DO Iipar=1,Ndasig
- IF (Lk.LE.0 .OR. Lk-Nvadif.NE.Iipar) THEN
+ IF (Lk.LE.0 .OR. Lk.NE.Iipar) THEN
C *** If this parameter is an abundance for the capture
C *** sample, then derivatives here are zero
Dasigs(Iipar) = Dasigs(Iipar) +
@@ -73,7 +73,7 @@ C *** sample, then derivatives here are zero
DO Iipar=1,Ndbsig
IF (Ipars.NE.Iipar) THEN
C *** IF (this is self-indication Abndnc) it's already done
- IF (Lk.LE.0 .OR. Lk-Nvadif.NE.Iipar) THEN
+ IF (Lk.LE.0 .OR. Lk.NE.Iipar) THEN
C *** If this parameter is an abundance for the capture
C *** sample, then derivatives here are zero
Dbsigs(Iipar,Iso) = Dbsigs(Iipar,Iso) +
@@ -150,7 +150,7 @@ C
DO Isox=1,Nnnnis
Lkk = Lkk + 1
Lk = Iflmsc(lkk)
- IF (Lk.GT.0 .AND. Lk-Nvadif.EQ.Iipar) GO TO 80
+ IF (Lk.GT.0 .AND. Lk.EQ.Iipar) GO TO 80
END DO
END IF
C
diff --git a/sammy/src/xct/mxct24.f b/sammy/src/xct/mxct24.f
index e4708892c9bc34379fec55aa8def51321bcadc40..97f5766ef046f85d39233b5d187fc72b407e5cf6 100644
--- a/sammy/src/xct/mxct24.f
+++ b/sammy/src/xct/mxct24.f
@@ -73,7 +73,7 @@ C
IF (Iflpmc(1,Ipmcs).GT.0) THEN
X = Abx*Parpmc(1,Ipmcs)*F**2*Two
IF (Eb.LT.Zero) X = -X
- Ifl = Iflpmc(1,Ipmcs) - Nvadif
+ Ifl = Iflpmc(1,Ipmcs)
IF (Ifl.LE.Ndasig) THEN
STOP '[STOP Ifl.LE.Ndasig in Dddpmc in xct/mxct24.f]'
ELSE
@@ -92,7 +92,7 @@ C
Df = X*Two*F*Df
Df = Df/Parpmc(2,Ipmcs)
IF (Eb.LT.Zero) Df = -Df
- Ifl = Iflpmc(2,Ipmcs) - Nvadif
+ Ifl = Iflpmc(2,Ipmcs)
IF (Ifl.LE.Ndasig) THEN
STOP '[Ifl.LE.Ndasig in Dddpmc in xct/mxct24.f # 2]'
ELSE
@@ -111,7 +111,7 @@ C
Df = X*Two*F*Df
Df = Df*dLOG(Su)
IF (Eb.LT.Zero) Df = -Df
- Ifl = Iflpmc(3,Ipmcs) - Nvadif
+ Ifl = Iflpmc(3,Ipmcs)
IF (Ifl.LE.Ndasig) THEN
STOP '[Ifl.LE.Ndasig in Dddpmc in xct/mxct24.f # 3]'
ELSE
@@ -127,7 +127,7 @@ C
X = Abx*(Parpmc(1,Ipmcs)*F)**2
Df = X/Parpmc(4,Ipmcs)
IF (Eb.LT.Zero) Df = -Df
- Ifl = Iflpmc(4,Ipmcs) - Nvadif
+ Ifl = Iflpmc(4,Ipmcs)
IF (Ifl.LE.Ndasig) THEN
STOP '[Ifl.LE.Ndasig in Dddpmc in xct/mxct24.f # 4]'
ELSE
diff --git a/sammy/src/xct/mxct32.f b/sammy/src/xct/mxct32.f
index 4960e65e7c745e97621a2b22cc1864b4b2c6ba1c..108e07890c014da3e0cc75e21369eb83fef1227b 100644
--- a/sammy/src/xct/mxct32.f
+++ b/sammy/src/xct/mxct32.f
@@ -124,7 +124,7 @@ C ##################### maybe NOT CORRECT YET FOR Iq_Val>0
DO Iso=1,Numiso
Ifl = Ifliso(Iso)
IF (Ifl.GT.0) THEN
- Ifl = Ifl - Nvadif
+ Ifl = Ifl
Isopar(Ifl) = Iso
DO L=1,Lllmax
Dddlll(L,Ifl) = Ccclll(L,Iso)/