From 3d69ad00a923dac638565ff72909d6b2c1757cad Mon Sep 17 00:00:00 2001
From: Wiarda <wiardada@ornl.gov>
Date: Fri, 1 Oct 2021 11:51:14 -0400
Subject: [PATCH] Remove Termf and termfx arrays and use data in XctCalc Remove
Dasig and co from xct Convert to the one and only getParamPerSpinGroup method
for consistency throughtout Change function signatures for xct derivatives
Move Qr and Qi to XctCalc Move array for derivx Move of eta calculation
---
sammy/src/ang/mang1.f | 8 +-
sammy/src/blk/Exploc_common.f90 | 6 -
sammy/src/blk/Fixedi_common.f90 | 3 +-
sammy/src/blk/Templc_common.f90 | 53 +--
sammy/src/blk/Varyr_common.f90 | 3 -
sammy/src/blk/ifsubs_common.f90 | 14 -
sammy/src/cro/CroCrossCalcImpl_M.f90 | 13 -
sammy/src/cro/CroCrossCalc_M.f90 | 1 +
sammy/src/cro/mcro0.f90 | 13 -
sammy/src/cro/mcro2.f90 | 57 +--
sammy/src/cro/mcro2a.f90 | 53 +--
sammy/src/cro/mcro4.f90 | 194 +++++----
sammy/src/cro/mcro6.f90 | 6 +-
sammy/src/endf/VariedParameterInfo.cpp | 45 +-
sammy/src/fin/mfin3.f90 | 16 +-
sammy/src/inp/minp15.f | 1 -
sammy/src/rec/mrec0.f | 55 +--
sammy/src/rec/mrec2.f90 | 15 +-
sammy/src/rec/{mrec3.f => mrec3.f90} | 139 +++----
sammy/src/salmon/DerivativeList.cpp | 2 +-
.../fortran/DerivativeListHolder_M.f90 | 1 +
sammy/src/sammy/CMakeLists.txt | 3 +-
sammy/src/the/CrossSectionCalcDriver_M.f90 | 15 +-
sammy/src/the/CrossSectionCalculator_M.f90 | 56 ++-
sammy/src/the/ZeroKCrossCorrections_M.f90 | 323 ++++++++++-----
sammy/src/the/mthe0.f90 | 20 +-
sammy/src/the/mthe1.f90 | 91 +---
sammy/src/xct/XctCrossCalc_M.f90 | 302 ++++++++++++--
sammy/src/xct/mxct0.f90 | 119 +-----
sammy/src/xct/mxct02.f90 | 120 +++---
sammy/src/xct/mxct03.f90 | 148 +++----
sammy/src/xct/mxct04.f90 | 21 +-
sammy/src/xct/mxct05.f90 | 87 ++--
sammy/src/xct/mxct06.f90 | 390 ++++-------------
sammy/src/xct/mxct07.f90 | 301 +++++++-------
sammy/src/xct/mxct08.f90 | 83 ++--
sammy/src/xct/mxct09.f90 | 207 ++++-----
sammy/src/xct/mxct10.f90 | 244 +++++------
sammy/src/xct/mxct11.f90 | 386 ++++++-----------
sammy/src/xct/mxct12.f90 | 236 +++++------
sammy/src/xct/mxct13.f90 | 61 +--
sammy/src/xct/mxct14.f90 | 200 ++++-----
sammy/src/xct/mxct15.f90 | 215 +++++-----
sammy/src/xct/mxct16.f90 | 151 +++----
sammy/src/xct/mxct17.f90 | 335 +++++++--------
sammy/src/xct/mxct18.f90 | 55 +--
sammy/src/xct/mxct19.f90 | 392 ++++++------------
sammy/src/xct/mxct20.f90 | 150 ++++---
sammy/src/xct/mxct21.f90 | 281 ++++++-------
sammy/src/xct/mxct22.f90 | 328 +++++++--------
sammy/src/xct/mxct23.f90 | 335 ++++++---------
sammy/src/xct/mxct24.f90 | 4 -
sammy/src/xct/mxct26.f90 | 43 +-
sammy/src/xct/mxct27.f90 | 23 +-
sammy/src/xct/mxct28.f90 | 44 +-
sammy/src/xct/mxct31.f90 | 150 +++----
sammy/src/xct/mxct32.f90 | 313 +++++++-------
57 files changed, 3167 insertions(+), 3763 deletions(-)
delete mode 100644 sammy/src/blk/ifsubs_common.f90
rename sammy/src/rec/{mrec3.f => mrec3.f90} (61%)
diff --git a/sammy/src/ang/mang1.f b/sammy/src/ang/mang1.f
index b5e4ddb44..b4aac1292 100644
--- a/sammy/src/ang/mang1.f
+++ b/sammy/src/ang/mang1.f
@@ -572,8 +572,8 @@ C
* Dasigx(Iangle,Iipar) + val
else
Iparx = Iipar - Ndasig
- Dbsigx(Iangle,Iipar) =
- * Dbsigx(Iangle,Iipar) + val
+ Dbsigx(Iangle,Iparx) =
+ * Dbsigx(Iangle,Iparx) + val
end if
END DO
END DO
@@ -597,8 +597,8 @@ C
* Dasigx(Iangle,Iipar) + val
else
Iparx = Iipar - Ndasig
- Dbsigx(Iangle,Iipar) =
- * Dbsigx(Iangle,Iipar) + val
+ Dbsigx(Iangle,Iparx) =
+ * Dbsigx(Iangle,Iparx) + val
end if
end do
END DO
diff --git a/sammy/src/blk/Exploc_common.f90 b/sammy/src/blk/Exploc_common.f90
index b41b922da..15bea3f25 100644
--- a/sammy/src/blk/Exploc_common.f90
+++ b/sammy/src/blk/Exploc_common.f90
@@ -112,7 +112,6 @@ module exploc_common_m
! old group 9
real(kind=8),allocatable,dimension(:)::A_Iresol
- integer,allocatable,dimension(:)::I_Iisopa
real(kind=8),allocatable,dimension(:)::A_Iccoul
real(kind=8),allocatable,dimension(:)::A_Idcoul
@@ -511,11 +510,6 @@ module exploc_common_m
call allocate_real_data(A_Iresol,want)
end subroutine make_A_Iresol
- subroutine make_I_Iisopa(want)
- integer::want
- call allocate_integer_data(I_Iisopa,want)
- end subroutine make_I_Iisopa
-
subroutine make_A_Iccoul(want)
integer::want
call allocate_real_data(A_Iccoul,want)
diff --git a/sammy/src/blk/Fixedi_common.f90 b/sammy/src/blk/Fixedi_common.f90
index bc9aee8cd..8644a6243 100644
--- a/sammy/src/blk/Fixedi_common.f90
+++ b/sammy/src/blk/Fixedi_common.f90
@@ -93,8 +93,7 @@ module fixedi_m
! 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
+ ! and Nfpres counts none of them
integer, pointer :: Nppall => lfdim(55)
integer, pointer :: Npar => lfdim(57)
! indexer on lfdim covers up to 57 (next should be 58
diff --git a/sammy/src/blk/Templc_common.f90 b/sammy/src/blk/Templc_common.f90
index 2f191b75e..fec21230b 100644
--- a/sammy/src/blk/Templc_common.f90
+++ b/sammy/src/blk/Templc_common.f90
@@ -6,62 +6,11 @@ module templc_common_m
! *** For use in xct and rec
!
IMPLICIT NONE
-
- real(kind=8),allocatable,dimension(:)::A_Ipgar
- real(kind=8),allocatable,dimension(:)::A_Ipgai
- real(kind=8),allocatable,dimension(:)::A_Isinsq
- real(kind=8),allocatable,dimension(:)::A_Isinph
- real(kind=8),allocatable,dimension(:)::A_Icscs
- real(kind=8),allocatable,dimension(:)::A_Irmat
- real(kind=8),allocatable,dimension(:)::A_Iyinv
- real(kind=8),allocatable,dimension(:)::A_Iymat
- real(kind=8),allocatable,dimension(:)::A_Ixqr
- real(kind=8),allocatable,dimension(:)::A_Ixqi
- real(kind=8),allocatable,dimension(:)::A_Irootp
- real(kind=8),allocatable,dimension(:)::A_Linvr
- real(kind=8),allocatable,dimension(:)::A_Linvi
- real(kind=8),allocatable,dimension(:)::A_Itermf
- real(kind=8),allocatable,dimension(:)::A_Icrss
- real(kind=8),allocatable,dimension(:)::A_Ideriv
- real(kind=8),allocatable,dimension(:)::A_Icrssx
- real(kind=8),allocatable,dimension(:)::A_Idervx
- real(kind=8),allocatable,dimension(:)::A_Iqr
- real(kind=8),allocatable,dimension(:)::A_Iqi
- real(kind=8),allocatable,dimension(:)::A_Itr
- real(kind=8),allocatable,dimension(:)::A_Iti
- real(kind=8),allocatable,dimension(:)::A_Itx
- real(kind=8),allocatable,dimension(:)::A_Idpdr
- real(kind=8),allocatable,dimension(:)::A_Idsdr
- real(kind=8),allocatable,dimension(:)::A_Ixden
- integer,allocatable,dimension(:)::I_Inotu
- real(kind=8),allocatable,dimension(:)::A_Idphi
- real(kind=8),allocatable,dimension(:)::A_Ipxrr
- real(kind=8),allocatable,dimension(:)::A_Ipxri
- real(kind=8),allocatable,dimension(:)::A_Ixxxxr
- real(kind=8),allocatable,dimension(:)::A_Ixxxxi
- real(kind=8),allocatable,dimension(:)::A_Icccll
- real(kind=8),allocatable,dimension(:)::A_Idddll
- real(kind=8),allocatable,dimension(:)::A_Idsf
- real(kind=8),allocatable,dimension(:)::A_Idst
- real(kind=8),allocatable,dimension(:)::A_Idstt
- real(kind=8),allocatable,dimension(:)::A_Idsfx
- real(kind=8),allocatable,dimension(:)::A_Idstx
- real(kind=8),allocatable,dimension(:)::A_Iprer
- real(kind=8),allocatable,dimension(:)::A_Iprei
- real(kind=8),allocatable,dimension(:)::A_Iddddd
- real(kind=8),allocatable,dimension(:)::A_Iterfx
- real(kind=8),allocatable,dimension(:)::A_Ipsmal
- integer, save :: Nfprrr
- real(kind=8),allocatable,dimension(:)::A_Icx
- real(kind=8),allocatable,dimension(:)::A_Iss
- real(kind=8),allocatable,dimension(:)::A_Icc
- real(kind=8),allocatable,dimension(:)::A_Icrsnd
- real(kind=8),allocatable,dimension(:)::A_Icrxnd
+
real(kind=8),allocatable,dimension(:)::A_Iedrcp
real(kind=8),allocatable,dimension(:)::A_Icdrcp
real(kind=8),allocatable,dimension(:)::A_Ixdrcp
integer,allocatable,dimension(:)::I_Indrcp
- real(kind=8),allocatable,dimension(:)::A_Iddtlz
! cro and mlb
real(kind=8),allocatable,dimension(:)::A_Ics
diff --git a/sammy/src/blk/Varyr_common.f90 b/sammy/src/blk/Varyr_common.f90
index 0f2f3b058..78555cd69 100644
--- a/sammy/src/blk/Varyr_common.f90
+++ b/sammy/src/blk/Varyr_common.f90
@@ -11,9 +11,6 @@ module varyr_common_m
double precision, save :: Etz
double precision, save :: Elz
- integer, save :: Kstart
- integer, save :: Jstart
- integer, save :: Npr
logical::resDeriv
integer, save :: Npx
integer, save :: Nnnn
diff --git a/sammy/src/blk/ifsubs_common.f90 b/sammy/src/blk/ifsubs_common.f90
deleted file mode 100644
index 8554cff7c..000000000
--- a/sammy/src/blk/ifsubs_common.f90
+++ /dev/null
@@ -1,14 +0,0 @@
-
-module ifsubs_common
-
- ! used in xct: 02, 06 and rec3
-
- implicit none
-
- integer(4):: Ifzzz
- integer(4):: Ifext
- integer(4):: Ifrad
- integer(4):: Ifiso
- integer(4):: Ifradt
-
-end module ifsubs_common
diff --git a/sammy/src/cro/CroCrossCalcImpl_M.f90 b/sammy/src/cro/CroCrossCalcImpl_M.f90
index bdc67ace1..5f5ccce75 100644
--- a/sammy/src/cro/CroCrossCalcImpl_M.f90
+++ b/sammy/src/cro/CroCrossCalcImpl_M.f90
@@ -151,7 +151,6 @@ contains
!
! - - - - - - - - - - - - - - - - <
! *** six ***
- call allocate_real_data(A_Ixden, Nres)
! CALL Abpart
! - - - - - - - - - - - - - - - - >
!
@@ -159,32 +158,20 @@ contains
N = Ntotc
call allocate_real_data(A_Ics, N)
call allocate_real_data(A_Isi, N)
- call allocate_real_data(A_Idphi, N)
call allocate_real_data(A_Iz, N)
N = Nn
call allocate_real_data(A_Iwr, N)
call allocate_real_data(A_Iwi, N)
- call allocate_real_data(A_Ixxxxr, N)
- call allocate_real_data(A_Ixxxxi, N)
N = Nn*2
- call allocate_real_data(A_Irmat, N)
call allocate_real_data(A_Irinv, N)
N = Ntotc*Ntotc
call allocate_real_data(A_Ipwrr, N)
call allocate_real_data(A_Ipwri, N)
- call allocate_real_data(A_Ixqr, N)
- call allocate_real_data(A_Ixqi, N)
- call allocate_real_data(A_Itr, N)
- call allocate_real_data(A_Iti, N)
N = Ntotc
call allocate_real_data(A_Isphr, N)
call allocate_real_data(A_Isphi, N)
call allocate_real_data(A_Iphr, N)
call allocate_real_data(A_Iphi, N)
- N = Nn*Nn
- call allocate_real_data(A_Iqr, N)
- call allocate_real_data(A_Iqi, N)
- N = N6
end subroutine
end module CroCrossCalcImpl_M
diff --git a/sammy/src/cro/CroCrossCalc_M.f90 b/sammy/src/cro/CroCrossCalc_M.f90
index 2d7aa1cc6..1d328af49 100644
--- a/sammy/src/cro/CroCrossCalc_M.f90
+++ b/sammy/src/cro/CroCrossCalc_M.f90
@@ -10,6 +10,7 @@ module CroCrossCalc_M
implicit none
type, extends(XctCrossCalc) :: CroCrossCalc
+ real(kind=8),allocatable,dimension(:)::A_Isigxx, A_Idasig, A_Idbsig
contains
procedure, pass(this) :: setUpDerivativeList => CroCrossCalc_setUpDerivativeList ! set up crossData, depending on number of isotopes
procedure, pass(this) :: initialize => CroCrossCalc_initialize
diff --git a/sammy/src/cro/mcro0.f90 b/sammy/src/cro/mcro0.f90
index 0435f407c..a4223d1e5 100644
--- a/sammy/src/cro/mcro0.f90
+++ b/sammy/src/cro/mcro0.f90
@@ -88,7 +88,6 @@
!
! - - - - - - - - - - - - - - - - <
! *** six ***
- !call allocate_real_data(A_Ixden, Nres)
! CALL Abpart
! - - - - - - - - - - - - - - - - >
!
@@ -96,31 +95,20 @@
N = Ntotc
!call allocate_real_data(A_Ics, N)
!call allocate_real_data(A_Isi, N)
- !call allocate_real_data(A_Idphi, N)
!call allocate_real_data(A_Iz, N)
N = Nn
!call allocate_real_data(A_Iwr, N)
!call allocate_real_data(A_Iwi, N)
- !call allocate_real_data(A_Ixxxxr, N)
- !call allocate_real_data(A_Ixxxxi, N)
N = Nn*2
- !call allocate_real_data(A_Irmat, N)
!call allocate_real_data(A_Irinv, N)
N = Ntotc*Ntotc
!call allocate_real_data(A_Ipwrr, N)
!call allocate_real_data(A_Ipwri, N)
- !call allocate_real_data(A_Ixqr, N)
- !call allocate_real_data(A_Ixqi, N)
- !call allocate_real_data(A_Itr, N)
- !call allocate_real_data(A_Iti, N)
N = Ntotc
!call allocate_real_data(A_Isphr, N)
!call allocate_real_data(A_Isphi, N)
!call allocate_real_data(A_Iphr, N)
!call allocate_real_data(A_Iphi, N)
- N = Nn*Nn
- !call allocate_real_data(A_Iqr, N)
- !call allocate_real_data(A_Iqi, N)
N = N6
! CALL Parsh
! - - - - - - - - - - - - - - - - - - - - - - >
@@ -132,7 +120,6 @@
!
!deallocate(A_Ics)
!deallocate(A_Isi)
- !deallocate(A_Idphi)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
!
!
diff --git a/sammy/src/cro/mcro2.f90 b/sammy/src/cro/mcro2.f90
index 9719f6c6c..897d34d57 100644
--- a/sammy/src/cro/mcro2.f90
+++ b/sammy/src/cro/mcro2.f90
@@ -30,45 +30,45 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Rinvrs (Rmat, Rinv, Sphr, Sphi, Xqr, Xqi, Ntot)
+ SUBROUTINE Rinvrs (calc, Rinv, Sphr, Sphi,Ntot)
!
! *** PURPOSE -- INVERT Rmat TO GIVE Rinv
!
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Rmat(2,*), Rinv(2,*), Sphr(*), Sphi(*), &
- Xqr(Ntot,*), Xqi(Ntot,*)
+ class(CroCrossCalc)::calc
+ DIMENSION Rinv(2,*), Sphr(*), Sphi(*)
!
IF (Ntot.LE.3) THEN
!
IF (Ntot.EQ.1) THEN
! *** ONE CHANNEL -- (inverse of Rmat) = Rinv
- CALL Onech (Rmat, Rinv)
+ CALL Onech (calc%Rmat, Rinv)
!
ELSE IF (Ntot.EQ.2) THEN
! *** TWO CHANNELS -- (inverse of Rmat) = Rinv
- CALL Twoch (Rmat, Rinv)
+ CALL Twoch (calc%Rmat, Rinv)
!
ELSE IF (Ntot.EQ.3) THEN
! *** THREE CHANNELS -- (inverse of Rmat) = Rinv
- CALL Three (Rmat, Rinv)
+ CALL Three (calc%Rmat, Rinv)
!
END IF
Ij = 0
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- Xqr(J,I) = Rinv(1,Ij)*Sphr(I) - Rinv(2,Ij)*Sphi(I)
- Xqi(J,I) = Rinv(1,Ij)*Sphi(I) + Rinv(2,Ij)*Sphr(I)
+ calc%Xqr(J,I) = Rinv(1,Ij)*Sphr(I) - Rinv(2,Ij)*Sphi(I)
+ calc%Xqi(J,I) = Rinv(1,Ij)*Sphi(I) + Rinv(2,Ij)*Sphr(I)
IF (I.NE.J) THEN
- Xqr(I,J) = Rinv(1,Ij)*Sphr(J) - Rinv(2,Ij)*Sphi(J)
- Xqi(I,J) = Rinv(1,Ij)*Sphi(J) + Rinv(2,Ij)*Sphr(J)
+ calc%Xqr(I,J) = Rinv(1,Ij)*Sphr(J) - Rinv(2,Ij)*Sphi(J)
+ calc%Xqi(I,J) = Rinv(1,Ij)*Sphi(J) + Rinv(2,Ij)*Sphr(J)
END IF
END DO
END DO
!
ELSE
! *** INVERT Rmat TO GIVE Rinv FOR MORE THAN THREE CHANNELS
- CALL Four (Rmat, Rinv, Sphr, Sphi, Xqr, Xqi, Ntot)
+ CALL Four (calc%Rmat, Rinv, Sphr, Sphi, calc%Xqr, calc%Xqi, Ntot)
!
END IF
!
@@ -85,8 +85,9 @@ contains
!
! NML, October 1993; based on LINPACK routines but for complex arrays.
!
+ use Xspfa_Xspsl_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Rmat(2,*), Dummy(2,*), Iii(100), Sphr(*), Sphi(*), &
+ DIMENSION Rmat(:,:), Dummy(2,*), Iii(100), Sphr(*), Sphi(*), &
Xqr(Ntot,*), Xqi(Ntot,*)
DATA Maxaa /100/, Zero /0.0d0/
!
@@ -116,7 +117,7 @@ contains
!
SUBROUTINE Setr_Cro (calc, Ntot, Bound, Echan, &
Min, igr, &
- Z, Rmat, Sphr, Sphi, Phr, Phi, Zke, Lrmat)
+ Z, Sphr, Sphi, Phr, Phi, Zke, Lrmat)
!
! *** PURPOSE -- GENERATE Rmat = 1/(S-B+IP)
! *** - Sum Beta*Beta/((DEL E)**2-(Gamgam/2)**2)
@@ -148,7 +149,7 @@ contains
real(kind=8)::Parext(7)
DIMENSION &
Bound(Ntotc,*), Echan(Ntotc,*), &
- Rmat(2,*), Sphr(*), Sphi(*), Phr(*), Phi(*), Z(*), &
+ Sphr(*), Sphi(*), Phr(*), Phi(*), Z(*), &
Zke(*)
!
! DIMENSION Ishift(Ntotc,Ngroup), Lpent(Ntotc,Ngroup),
@@ -182,12 +183,12 @@ contains
end if
DO L=1,K
KL = KL + 1
- Rmat(1,KL) = Zero
- Rmat(2,KL) = Zero
+ calc%Rmat(1,KL) = Zero
+ calc%Rmat(2,KL) = Zero
IF (L.EQ.K .AND. hasRext) THEN
- Rmat(1,KL) = -(Parext(3)+Parext(4)*Su) + &
+ calc%Rmat(1,KL) = -(Parext(3)+Parext(4)*Su) + &
Parext(5)*Aloge
- IF (Nrext.EQ.7) Rmat(1,KL) = Rmat(1,KL) - &
+ IF (Nrext.EQ.7) calc%Rmat(1,KL) = calc%Rmat(1,KL) - &
Parext(7)*Su**2 + Parext(6)* &
(Parext(2)-Parext(1)) + &
Parext(6)*Aloge*(Su)
@@ -209,9 +210,9 @@ contains
beta = channelWidthC * channelWidthCPrime
KL = KL + 1
IF (Beta.NE.Zero) THEN
- Rmat(1,KL) = Rmat(1,KL) - calc%Alphar(I)*Beta
+ calc%Rmat(1,KL) = calc%Rmat(1,KL) - calc%Alphar(I)*Beta
IF (calc%needAlphai(I)) THEN
- Rmat(2,KL) = Rmat(2,KL) - calc%Alphai(I)*Beta
+ calc%Rmat(2,KL) = calc%Rmat(2,KL) - calc%Alphai(I)*Beta
END IF
END IF
END DO
@@ -223,8 +224,8 @@ contains
DO K=1,Ntot
DO L=1,K
KL = KL + 1
- IF (Rmat(1,KL).NE.Zero) GO TO 63
- IF (Rmat(2,KL).NE.Zero) GO TO 63
+ IF (calc%Rmat(1,KL).NE.Zero) GO TO 63
+ IF (calc%Rmat(2,KL).NE.Zero) GO TO 63
END DO
END DO
Lrmat = 1
@@ -285,8 +286,8 @@ contains
Sphi(I) = Hi*Ps
Phr(I) = Hr*P
Phi(I) = Hi*P
- Rmat(1,Ii) = Hr + Rmat(1,II)
- Rmat(2,Ii) = Hi + Rmat(2,II)
+ calc%Rmat(1,Ii) = Hr + calc%Rmat(1,II)
+ calc%Rmat(2,Ii) = Hi + calc%Rmat(2,II)
Z(I) = Dp/P
END IF
!
@@ -296,11 +297,11 @@ contains
Sphi(I) = -One
! Phr(I) = Zero
Phi(I) = -One
-! Rmat(1,II) = Rmat(1,II)
- Rmat(2,II) = Rmat(2,II) - One
+! calc%Rmat(1,II) = calc%Rmat(1,II)
+ calc%Rmat(2,II) = calc%Rmat(2,II) - One
IF (Iffy.NE.0) THEN
- Rmat(1,II) = Zero
- Rmat(2,II) = -One
+ calc%Rmat(1,II) = Zero
+ calc%Rmat(2,II) = -One
END IF
! Z(I) = Zero
END IF
diff --git a/sammy/src/cro/mcro2a.f90 b/sammy/src/cro/mcro2a.f90
index dee459d3b..a17ef6666 100644
--- a/sammy/src/cro/mcro2a.f90
+++ b/sammy/src/cro/mcro2a.f90
@@ -18,7 +18,7 @@ contains
class(CroCrossCalc)::calc
!
!
- CALL Abpart_Cro ( calc, A_Ixden, A_Idifma)
+ CALL Abpart_Cro (calc)
!
CALL Parsh ( calc, &
A_Izke , &
@@ -29,7 +29,7 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Abpart_Cro (calc, Xden, Difmax)
+ SUBROUTINE Abpart_Cro (calc)
!
! *** PURPOSE -- GENERATE Upr AND Upi = ENERGY-DEPENDENT Pieces OF
! *** PR AND PI = PARTIAL OF R WRT U-PARAMETERS
@@ -49,17 +49,10 @@ contains
type(SammyResonanceInfo)::resInfo
type(SammySpinGroupInfo)::spinInfo
type(RMatResonance)::resonance
- real(kind=8):: &
- Xden(*), &
- Difmax(*)
real(kind=8)::Zero, Two
real(kind=8)::Aa, G2, G3
integer::I, Igam, igr, Ij, Ipar, J, K, M, N2, N, Iflr, ires
real(kind=8)::Upr, Upi
-!
-! DIMENSION
-! * Xden(Nres),
-! * Difmax(Nres), Xx(Nres)
!
DATA Zero /0.0d0/, Two /2.0d0/
!
@@ -70,14 +63,14 @@ contains
DO I=1,resParData%getNumResonances()
call resParData%getResonanceInfo(resInfo, I)
call resParData%getRedResonance(resonance, resInfo)
- Xden(I) = Zero
+ calc%Xden(I) = Zero
calc%Alphar(I)= Zero
calc%Alphai(I)= Zero
calc%Difen(I) = resonance%getEres() - Su
if (calc%doResShift) then
calc%Difen(I) = calc%Difen(I) + calc%Xx(I)
end if
- IF (dABS(calc%Difen(I)).LT.100.0D0*Difmax(I)) calc%needAlphai(I) = .true.
+ IF (dABS(calc%Difen(I)).LT.100.0D0*calc%Difmax(I)) calc%needAlphai(I) = .true.
call resParData%getResonanceInfo(resInfo, I)
igr = resInfo%getSpinGroupIndex()
@@ -87,9 +80,9 @@ contains
G2 = resonance%getWidth(igam)**2
G3 = G2**2
Aa = calc%Difen(I)**2 + G3
- Xden(I) = 1.0D0/Aa
- calc%Alphar(I) = calc%Difen(I)*Xden(I)
- IF (calc%needAlphai(I)) calc%Alphai(I) = G2*Xden(I)
+ calc%Xden(I) = 1.0D0/Aa
+ calc%Alphar(I) = calc%Difen(I)*calc%Xden(I)
+ IF (calc%needAlphai(I)) calc%Alphai(I) = G2*calc%Xden(I)
END IF
END DO
!
@@ -119,15 +112,15 @@ contains
N = calc%Inum(K,3) ! index of resonance
Upr = 0.0d0
Upi = 0.0d0
- IF (dABS(calc%Difen(N)).LE.Difmax(N)) THEN
+ IF (dABS(calc%Difen(N)).LE.calc%Difmax(N)) THEN
Upr = calc%Alphar(N)
Upi = calc%Alphai(N)
IF (M.LT.2) THEN
Upi = Upr*Upi
- Upr = -Two*Upr*Upr + Xden(N)
+ Upr = -Two*Upr*Upr + calc%Xden(N)
ELSE IF (M.EQ.2) THEN
Upr = Upr*Upi
- Upi = -Two*Upi*Upi + Xden(N)
+ Upi = -Two*Upi*Upi + calc%Xden(N)
ELSE
END IF
END IF
@@ -250,7 +243,7 @@ contains
! *** CALCULATE SIN AND COS OF POTENTIAL SCATTERING PHASE SHIFT,
! *** AND R-EXTERNAL PHASE SHIFT
CALL Cossin (resparData, Zke(1,N), &
- A_Ics, A_Isi, A_Idphi, Nnnn, Ipoten, &
+ A_Ics, A_Isi, calc%Dphi, Nnnn, Ipoten, &
Squ, Su)
END IF
!
@@ -262,7 +255,7 @@ contains
Lrmat = 0
CALL Setr_Cro (calc, Ntotnn, &
A_Ibound , A_Iechan , Min, n, &
- A_Iz , A_Irmat , A_Isphr , A_Isphi , A_Iphr , A_Iphi , &
+ A_Iz , A_Isphr , A_Isphi , A_Iphr , A_Iphi , &
Zke(1,N), Lrmat)
!
IF (Lrmat.EQ.1) THEN
@@ -270,18 +263,17 @@ contains
Ntotnn)
ELSE
! *** INVERT R-MATRIX; generate Xqr & Xqi
- CALL Rinvrs (A_Irmat , A_Irinv , A_Isphr , A_Isphi , &
- A_Ixqr , A_Ixqi, Ntotnn)
+ CALL Rinvrs (calc, A_Irinv , A_Isphr , A_Isphi , Ntotnn)
! *** GENERATE WR AND WI MATRICES
- CALL Wrwi (calc, Ntotnn, A_Iwr , A_Iwi, A_Ixxxxr , A_Ixxxxi , &
- A_Ixqr , A_Ixqi , A_Isphr , A_Isphi , A_Iphr ,A_Iphi )
+ CALL Wrwi (calc, Ntotnn, A_Iwr , A_Iwi, &
+ A_Isphr , A_Isphi , A_Iphr ,A_Iphi )
END IF
!
! *** QUANTITIES NEEDED FOR GENERATING PARTIAL DERIVATIVES OF
! *** THE CROSS SECTIONS
IF (Lrmat.EQ.0 .AND. Ksolve.NE.2) CALL Partls (calc, Ntotnn, &
- A_Iz , A_Ixxxxr , A_Ixxxxi , A_Ipwrr , A_Ipwri , &
- A_Ixqr , A_Ixqi , A_Iphr , A_Iphi , A_Iqr , A_Iqi, N )
+ A_Iz , A_Ipwrr , A_Ipwri , &
+ A_Iphr , A_Iphi , N )
!
Agoj = VarAbn*spinInfo%getGFactor()
! *** TOTAL CROSS SECTIONS
@@ -289,16 +281,15 @@ contains
next = spinInfo%getNumExitChannels()
IF (Kcros.EQ.1) CALL Total (calc, spinInfo, &
A_Ics, A_Isi, &
- A_Idphi , A_Iwr , A_Iwi , A_Ipwrr , A_Ipwri , A_Itr , &
- A_Iti , A_Iqr , A_Iqi , Lrmat, &
+ A_Iwr , A_Iwi , A_Ipwrr , A_Ipwri , Lrmat, &
N, Zke(1,N), &
iflAbund, ipar)
!
! *** SCATTERING (ELASTIC) CROSS SECTION
IF (Kcros.EQ.2) CALL Elastc (calc, spinInfo, &
A_Ics, &
- A_Isi, A_Idphi , A_Iwr , A_Iwi, A_Ipwrr , A_Ipwri , &
- A_Itr , A_Iti , A_Iqr , A_Iqi , Lrmat, &
+ A_Isi, A_Iwr , A_Iwi, A_Ipwrr , A_Ipwri , &
+ Lrmat, &
N, Zke(1,N), &
iflAbund, ipar)
!
@@ -306,7 +297,7 @@ contains
IF (Kcros.EQ.3 .OR. Kcros.EQ.5 .OR. Kcros.EQ.6) CALL Reactn &
( calc, spinInfo, &
A_Iwr, A_Iwi, A_Ipwrr , &
- A_Ipwri , A_Itr , A_Iti , A_Iqr , A_Iqi , &
+ A_Ipwri , &
Lrmat, N, &
Zke(1,N), iflAbund, ipar)
!
@@ -314,7 +305,7 @@ contains
IF (Kcros.EQ.4 .OR. Kcros.EQ.5 .OR. Kcros.EQ.6) CALL Captur &
( calc, spinInfo, &
A_Iwr, A_Iwi, A_Ipwrr , &
- A_Ipwri , A_Itr , A_Iti , A_Iqr , A_Iqi, &
+ A_Ipwri , &
Lrmat, N, &
Zke(1,N), iflAbund, ipar)
!
diff --git a/sammy/src/cro/mcro4.f90 b/sammy/src/cro/mcro4.f90
index 9d61d79ab..e549200d2 100644
--- a/sammy/src/cro/mcro4.f90
+++ b/sammy/src/cro/mcro4.f90
@@ -5,7 +5,7 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Wrwi (calc, Ntot, Wr, Wi, Xxxxr, Xxxxi, Xqr, Xqi, Sphr, Sphi, &
+ SUBROUTINE Wrwi (calc, Ntot, Wr, Wi, Sphr, Sphi, &
Phr, Phi)
!
! *** PURPOSE -- use Xqr AND Xqi MATRICES, WHERE
@@ -24,11 +24,9 @@ contains
!
class(CroCrossCalc)::calc
integer ::ntot
- real(kind=8) :: Phr(*), Phi(*), Sphr(*), Sphi(*), Xqr(Ntot,*), &
- Xqi(Ntot,*), Wr(*), Wi(*), Xxxxr(*), Xxxxi(*)
+ real(kind=8) :: Phr(*), Phi(*), Sphr(*), Sphi(*), Wr(*), Wi(*)
! DIMENSION Rinv(2,NN), Phr(Ntotc), Phi(Ntotc),
-! * Sphr(Ntotc), Sphi(Ntotc), Xqr(Ntot,Ntot),
-! * Xqi(Ntot,Ntot), Wr(NN), Wi(NN), Xxxxr(NN), Xxxxi(NN)
+! * Sphr(Ntotc), Sphi(Ntotc), Wr(NN), Wi(NN)
real(kind=8), parameter :: One = 1.0d0, Two = 2.0d0
integer :: I, Ij, J
@@ -38,10 +36,10 @@ contains
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- Xxxxi(Ij) = Sphi(J)*Xqr(J,I) + Sphr(J)*Xqi(J,I)
- Xxxxr(Ij) = Sphr(J)*Xqr(J,I) - Sphi(J)*Xqi(J,I)
- Wr(Ij) = -Two*Xxxxi(Ij)
- Wi(Ij) = Two*Xxxxr(Ij)
+ calc%Xxxxi(Ij) = Sphi(J)*calc%Xqr(J,I) + Sphr(J)*calc%Xqi(J,I)
+ calc%Xxxxr(Ij) = Sphr(J)*calc%Xqr(J,I) - Sphi(J)*calc%Xqi(J,I)
+ Wr(Ij) = -Two*calc%Xxxxi(Ij)
+ Wi(Ij) = Two*calc%Xxxxr(Ij)
IF (J.EQ.I) THEN
Wr(Ij) = Wr(Ij) + One + Two*Phi(I)
Wi(Ij) = Wi(Ij) - Two*Phr(I)
@@ -54,8 +52,8 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Partls (calc, Ntot, Z, Xxxxr, Xxxxi, Pwrhor, Pwrhoi, &
- Xqr, Xqi, Phr, Phi, Qr, Qi, igr)
+ SUBROUTINE Partls (calc, Ntot, Z, Pwrhor, Pwrhoi, &
+ Phr, Phi, igr)
!
! *** PURPOSE -- GENERATE Qr,Qi =
! *** SQRT(P)/(S-B+IP) * (Rinv*Rinv
@@ -74,11 +72,10 @@ contains
!
class(CroCrossCalc)::calc
integer :: ntot
- real(kind=8) :: Qr(NN,*), Qi(NN,*), Xqr(Ntot,*), Xqi(Ntot,*), &
- Xxxxr(*), Xxxxi(*), Pwrhor(*), Pwrhoi(*), Phr(*), Phi(*), Z(*)
+ real(kind=8) :: Pwrhor(*), Pwrhoi(*), Phr(*), Phi(*), Z(*)
!
-! DIMENSION Qr(NN,NN), Qi(NN,NN), Xqr(Ntot,Ntot), Xqi(Ntot,Ntot),
-! * Xxxxr(NN), Xxxxi(NN), Pwrhor(NN), Pwrhoi(NN),
+! DIMENSION
+! * Pwrhor(NN), Pwrhoi(NN),
! * Phr(Ntot), Phi(Ntot), Z(Ntot)
!
real(kind=8), parameter :: Zero = 0.0d0, One = 1.0d0, Two = 2.0d0
@@ -99,13 +96,13 @@ contains
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- Qr(Ij,Kl) = Xqr(I,K)*Xqr(J,L) - Xqi(I,K)*Xqi(J,L)
- Qi(Ij,Kl) = Xqr(I,K)*Xqi(J,L) + Xqi(I,K)*Xqr(J,L)
+ calc%Qr(Ij,Kl) = calc%Xqr(I,K)*calc%Xqr(J,L) - calc%Xqi(I,K)*calc%Xqi(J,L)
+ calc%Qi(Ij,Kl) = calc%Xqr(I,K)*calc%Xqi(J,L) + calc%Xqi(I,K)*calc%Xqr(J,L)
IF (I.NE.J) THEN
- Qr(Ij,Kl) = Qr(Ij,Kl) + Xqr(J,K)*Xqr(I,L) - &
- Xqi(J,K)*Xqi(I,L)
- Qi(Ij,Kl) = Qi(Ij,Kl) + Xqr(J,K)*Xqi(I,L) + &
- Xqi(J,K)*Xqr(I,L)
+ calc%Qr(Ij,Kl) = calc%Qr(Ij,Kl) + calc%Xqr(J,K)*calc%Xqr(I,L) - &
+ calc%Xqi(J,K)*calc%Xqi(I,L)
+ calc%Qi(Ij,Kl) = calc%Qi(Ij,Kl) + calc%Xqr(J,K)*calc%Xqi(I,L) + &
+ calc%Xqi(J,K)*calc%Xqr(I,L)
END IF
END DO
END DO
@@ -127,12 +124,12 @@ contains
Pwrhor(Ii) = -Two*Z(I)*(Phr(I)*Phr(I)-Phi(I)* (Phi(I)+One))
Pwrhoi(Ii) = -Two*Z(I)*( Two*Phr(I)*Phi(I) + Phr(I) )
IF (Z(I).NE.Zero) THEN
- AR = Two*Phr(I) - Xxxxr(Ii)
- AI = One + Two*Phi(I) - Xxxxi(Ii)
+ AR = Two*Phr(I) - calc%Xxxxr(Ii)
+ AI = One + Two*Phi(I) - calc%Xxxxi(Ii)
Pwrhor(Ii) = Pwrhor(Ii) + &
- Two*(Xxxxr(Ii)*AR-Xxxxi(Ii)*AI)*Z(I)
+ Two*(calc%Xxxxr(Ii)*AR-calc%Xxxxi(Ii)*AI)*Z(I)
Pwrhoi(Ii) = Pwrhoi(Ii) + &
- Two*(Xxxxr(Ii)*AI+Xxxxi(Ii)*AR)*Z(I)
+ Two*(calc%Xxxxr(Ii)*AI+calc%Xxxxi(Ii)*AR)*Z(I)
END IF
DO J=1,I
Ij = Ij + 1
@@ -141,17 +138,17 @@ contains
AR = Two*Phr(I)
AI = One + Two*Phi(I)
Pwrhor(Ij) = Pwrhor(Ij) + Z(I)* &
- (AR*Xxxxr(Ij)-AI*Xxxxi(Ij))
+ (AR*calc%Xxxxr(Ij)-AI*calc%Xxxxi(Ij))
Pwrhoi(Ij) = Pwrhoi(Ij) + Z(I)* &
- (AR*Xxxxi(Ij)+AI*Xxxxr(Ij))
+ (AR*calc%Xxxxi(Ij)+AI*calc%Xxxxr(Ij))
END IF
IF (Z(J).NE.Zero) THEN
AR = Two*Phr(J)
AI = One + Two*Phi(J)
Pwrhor(Ij) = Pwrhor(Ij) + Z(J)* &
- (AR*Xxxxr(Ij)-AI*Xxxxi(Ij))
+ (AR*calc%Xxxxr(Ij)-AI*calc%Xxxxi(Ij))
Pwrhoi(Ij) = Pwrhoi(Ij) + Z(J)* &
- (AR*Xxxxi(Ij)+AI*Xxxxr(Ij))
+ (AR*calc%Xxxxi(Ij)+AI*calc%Xxxxr(Ij))
END IF
END IF
DO M=1,Ntot
@@ -167,9 +164,9 @@ contains
JM = (M*(M-1))/2 + J
END IF
Pwrhor(Ij) = Pwrhor(Ij) - Two*Z(M)* &
- (Xxxxr(IM)*Xxxxr(JM)-Xxxxi(IM)*Xxxxi(JM))
+ (calc%Xxxxr(IM)*calc%Xxxxr(JM)-calc%Xxxxi(IM)*calc%Xxxxi(JM))
Pwrhoi(Ij) = Pwrhoi(Ij) - Two*Z(M)* &
- (Xxxxr(IM)*Xxxxi(JM)+Xxxxi(IM)*Xxxxr(JM))
+ (calc%Xxxxr(IM)*calc%Xxxxi(JM)+calc%Xxxxi(IM)*calc%Xxxxr(JM))
END IF
END DO
END DO
@@ -207,7 +204,7 @@ contains
! --------------------------------------------------------------
!
SUBROUTINE Total (calc, spinInfo, &
- Cs, Si, Dphi, Wr, Wi, Pwrhor, Pwrhoi, TR, TI, Qr, Qi, &
+ Cs, Si, Wr, Wi, Pwrhor, Pwrhoi, &
Lrmat, igr, Zke, If_Zke, ipar)
!
! *** PURPOSE -- GENERATE CROSS SECTION and
@@ -229,16 +226,14 @@ contains
!
type(SammySpinGroupInfo)::spinInfo
real(kind=8) :: &
- Cs(*), Si(*), Dphi(*), &
- Wr(*), Wi(*), Pwrhor(*), Pwrhoi(*), Tr(*), Ti(*), Qr(NN,*), &
- Qi(NN,*), Zke(*)
+ Cs(*), Si(*), &
+ Wr(*), Wi(*), Pwrhor(*), Pwrhoi(*), Zke(*)
real(kind=8)::val
!
! DIMENSION
-! * Cs(Ntotc), Si(Ntotc), Dphi(Ntotc), Wr(NN), Wi(NN),
-! * Pwrhor(NN), Pwrhoi(NN), Tr(NN), Ti(NN), Qr(NN,NN),
-! * Qi(NN,NN), Zke(Ntotc)
+! * Cs(Ntotc), Si(Ntotc), Wr(NN), Wi(NN),
+! * Pwrhor(NN), Pwrhoi(NN), Zke(Ntotc)
!
real(kind=8), parameter :: Zero = 0.0d0, One = 1.0d0, Two = 2.0d0
!
@@ -265,7 +260,7 @@ contains
END IF
Keff = radFitFlags%getEffFitFlag(Igr, I)
IF (Keff.GT.0.and.calc%wantDerivs) THEN
- val = - Two*B* ( Cs(I)*Wi(Ij)-Si(I)*Wr(Ij) )*Dphi(I)/Zke(I)
+ val = - Two*B* ( Cs(I)*Wi(Ij)-Si(I)*Wr(Ij) )*calc%Dphi(I)/Zke(I)
call calc%crossData%setSharedValNs(calc%row, 1, Keff, val)
END IF
END DO
@@ -282,9 +277,10 @@ contains
IF (Lrmat.EQ.1) RETURN
IF (Ksolve.EQ.2) RETURN
IF (.not.calc%wantDerivs) RETURN
+ if (.not.allocated(calc%tr)) return
!
- CALL Zero_Array (Tr, Ntriag)
- CALL Zero_Array (Ti, Ntriag)
+ calc%Tr(1,:) = 0.0d0
+ calc%Ti(1,:) = 0.0d0
!
! *** GENERATE TR AND TI, WHERE
! *** Tr(Ij) = REAL PART OF PARTIAL (CROSS SECTION) WiTH
@@ -297,17 +293,17 @@ contains
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- Ti(Ij) = Ti(Ij) + Qr(Ij,Kl)*Cs(K) + &
- Qi(Ij,Kl)*Si(K)
- Tr(Ij) = Tr(Ij) + Qi(Ij,Kl)*Cs(K) - &
- Qr(Ij,Kl)*Si(K)
+ calc%Ti(1,Ij) = calc%Ti(1, Ij) + calc%Qr(Ij,Kl)*Cs(K) + &
+ calc%Qi(Ij,Kl)*Si(K)
+ calc%Tr(1,Ij) = calc%Tr(1,Ij) + calc%Qi(Ij,Kl)*Cs(K) - &
+ calc%Qr(Ij,Kl)*Si(K)
END DO
END DO
END DO
!
- CALL Derres_Cro (calc, spinInfo, Igr, Tr, Ti, ipar)
+ CALL Derres_Cro (calc, spinInfo, Igr, ipar)
!
- CALL Derext_Cro(calc, spinInfo, Igr, TR)
+ CALL Derext_Cro(calc, spinInfo, Igr)
!
RETURN
END
@@ -316,7 +312,7 @@ contains
! --------------------------------------------------------------
!
SUBROUTINE Elastc (calc, spinInfo, &
- Cs, Si, Dphi, Wr, Wi, Pwrhor, Pwrhoi, Tr, Ti, Qr, Qi, &
+ Cs, Si, Wr, Wi, Pwrhor, Pwrhoi, &
Lrmat, igr, Zke, If_Zke, ipar)
!
! *** PURPOSE -- GENERATE CROSS SECTION
@@ -337,17 +333,15 @@ contains
integer :: Nent, Ntot, Lrmat, igr, If_Zke, ipar
real(kind=8) :: &
- Cs(*), Si(*), Dphi(*), &
- Wr(*), Wi(*), Pwrhor(*), Pwrhoi(*), Tr(*), Ti(*), Qr(NN,*), &
- Qi(NN,*), Zke(*)
+ Cs(*), Si(*), &
+ Wr(*), Wi(*), Pwrhor(*), Pwrhoi(*), Zke(*)
real(kind=8) :: val
logical(C_BOOL)::accu
!
! DIMENSION
-! * Cs(Ntotc), Si(Ntotc), Dphi(Ntotc), Wr(NN), Wi(NN),
-! * Pwrhor(NN), Pwrhoi(NN), Tr(NN), Ti(NN), Qr(NN,NN),
-! * Qi(NN,NN), Zke(Ntotc)
+! * Cs(Ntotc), Si(Ntotc), Wr(NN), Wi(NN),
+! * Pwrhor(NN), Pwrhoi(NN), Zke(Ntotc)
!
real(kind=8),parameter :: Zero = 0.0d0, One = 1.0d0, Two = 2.0d0
!
@@ -385,7 +379,7 @@ contains
call calc%crossData%setSharedValNs(calc%row, 1, Ktru, val)
END IF
IF (Keff.GT.0) THEN
- val = Two*( Cs(I)*Wi(Ii)-Si(I)*Wr(Ii) )*Dphi(I)*B
+ val = Two*( Cs(I)*Wi(Ii)-Si(I)*Wr(Ii) )*calc%Dphi(I)*B
call calc%crossData%setSharedValNs(calc%row, 1, Keff, val)
END IF
else
@@ -422,9 +416,10 @@ contains
IF (Lrmat.EQ.1) RETURN
IF (Ksolve.EQ.2) RETURN
IF (.not.calc%wantDerivs) RETURN
+ if (.not.allocated(calc%tr)) return
!
- CALL Zero_Array (TR, Ntriag)
- CALL Zero_Array (TI, Ntriag)
+ calc%Tr(1,:) = 0.0d0
+ calc%Ti(1,:) = 0.0d0
!
Kl = 0
DO K=1,Nent
@@ -443,16 +438,16 @@ contains
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- Ti(Ij) = Ti(Ij) + Qr(Ij,Kl)*A + Qi(Ij,Kl)*B
- Tr(Ij) = Tr(Ij) + Qi(Ij,Kl)*A - Qr(Ij,Kl)*B
+ calc%Ti(1, Ij) = calc%Ti(1, Ij) + calc%Qr(Ij,Kl)*A + calc%Qi(Ij,Kl)*B
+ calc%Tr(1, Ij) = calc%Tr(1, Ij) + calc%Qi(Ij,Kl)*A - calc%Qr(Ij,Kl)*B
END DO
END DO
END DO
END DO
!
- CALL Derres_Cro (calc, spinInfo, Igr, Tr, Ti, ipar)
+ CALL Derres_Cro (calc, spinInfo, Igr, ipar)
!
- CALL Derext_Cro (calc, spinInfo, Igr, TR)
+ CALL Derext_Cro (calc, spinInfo, Igr)
!
RETURN
END
@@ -461,7 +456,7 @@ contains
! --------------------------------------------------------------
!
SUBROUTINE Reactn (calc, spinInfo, &
- Wr, Wi, Pwrhor, Pwrhoi, Tr, Ti, Qr, Qi, Lrmat, &
+ Wr, Wi, Pwrhor, Pwrhoi, Lrmat, &
igr, Zke, If_Zke, ipar)
!
! *** PURPOSE -- GENERATE CROSS SECTION
@@ -485,12 +480,12 @@ contains
real(kind=8) :: &
Wr(*), Wi(*), Pwrhor(*), &
- Pwrhoi(*), Tr(*), Ti(*), Qr(NN,*), Qi(NN,*), Zke(*)
+ Pwrhoi(*), Zke(*)
real(kind=8) :: val
!
! DIMENSION
! * Wr(NN), Wi(NN),
-! * Pwrhor(NN), Pwrhoi(NN), Tr(NN), Ti(NN), Qr(NN,NN), Qi(NN,NN)
+! * Pwrhor(NN), Pwrhoi(NN)
!
real(kind=8) :: Zero = 0.0d0, One = 1.0d0, Two = 2.0d00
@@ -585,9 +580,10 @@ contains
IF (Lrmat.EQ.1) RETURN
IF (Ksolve.EQ.2) RETURN
IF (.not.calc%wantDerivs) RETURN
+ if (.not.allocated(calc%tr)) return
!
- CALL Zero_Array (Tr, Ntriag)
- CALL Zero_Array (Ti, Ntriag)
+ calc%Tr(1,:) = 0.0d0
+ calc%Ti(1,:) = 0.0d0
!
IF (Next.GE.1) THEN
DO Ll=1,Next
@@ -600,10 +596,10 @@ contains
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- Ti(Ij) = Ti(Ij) - Qr(Ij,Kl)*Wr(Kl) &
- - Qi(Ij,Kl)*Wi(Kl)
- Tr(Ij) = Tr(Ij) - Qi(Ij,Kl)*Wr(Kl) &
- + Qr(Ij,Kl)*Wi(Kl)
+ calc%Ti(1,Ij) = calc%Ti(1, Ij) - calc%Qr(Ij,Kl)*Wr(Kl) &
+ - calc%Qi(Ij,Kl)*Wi(Kl)
+ calc%Tr(1,Ij) = calc%Tr(1, Ij) - calc%Qi(Ij,Kl)*Wr(Kl) &
+ + calc%Qr(Ij,Kl)*Wi(Kl)
END DO
END DO
END DO
@@ -612,9 +608,9 @@ contains
END DO
END IF
!
- CALL Derres_Cro (calc, spinInfo, Igr, Tr, Ti, ipar)
+ CALL Derres_Cro (calc, spinInfo, Igr, ipar)
!
- CALL Derext_Cro (calc, spinInfo, igr, Tr)
+ CALL Derext_Cro (calc, spinInfo, igr)
!
RETURN
END
@@ -623,7 +619,7 @@ contains
! --------------------------------------------------------------
!
SUBROUTINE Captur (calc, spinInfo, &
- Wr, Wi, Pwrhor, Pwrhoi, Tr, Ti, Qr, Qi, &
+ Wr, Wi, Pwrhor, Pwrhoi, &
Lrmat, igr, Zke, If_Zke, ipar)
!
! *** PURPOSE -- GENERATE CROSS SECTION
@@ -648,13 +644,12 @@ contains
real(kind=8):: &
Wr(*), Wi(*), &
- Pwrhor(*), Pwrhoi(*), Tr(*), Ti(*), Qr(NN,*), &
- Qi(NN,*), Zke(*)
+ Pwrhor(*), Pwrhoi(*), Zke(*)
real(kind=8)::val
!
! DIMENSION
-! * Cs(Ntotc), Si(Ntotc), Dphi(Ntotc), Wr(NN), Wi(NN),
-! * Pwrhor(NN), Pwrhoi(NN), Tr(NN), Ti(NN), Qr(NN,NN), Qi(NN,NN)
+! * Cs(Ntotc), Si(Ntotc), Wr(NN), Wi(NN),
+! * Pwrhor(NN), Pwrhoi(NN)
!
real(kind=8),parameter :: Zero = 0.0d0, One = 1.0d0, Two = 2.0d0
@@ -704,9 +699,10 @@ contains
IF (Lrmat.EQ.1) RETURN
IF (Ksolve.EQ.2) RETURN
IF (.not.calc%wantDerivs) RETURN
+ if (.not.allocated(calc%tr)) return
!
- CALL Zero_Array (Tr, Ntriag)
- CALL Zero_Array (Ti, Ntriag)
+ calc%Tr(1,:) = 0.0d0
+ calc%Ti(1,:) = 0.0d0
!
Kl = 0
DO K=1,Nent
@@ -720,8 +716,8 @@ contains
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- Ti(Ij) = Ti(Ij) + Qr(Ij,Kl)*A + Qi(Ij,Kl)*B
- Tr(Ij) = Tr(Ij) + Qi(Ij,Kl)*A - Qr(Ij,Kl)*B
+ calc%Ti(1,Ij) = calc%Ti(1,Ij) + calc%Qr(Ij,Kl)*A + calc%Qi(Ij,Kl)*B
+ calc%Tr(1,Ij) = calc%Tr(1,Ij) + calc%Qi(Ij,Kl)*A - calc%Qr(Ij,Kl)*B
END DO
END DO
END DO
@@ -741,8 +737,8 @@ contains
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- Ti(Ij) = Ti(Ij) + Qr(Ij,Kl)*A + Qi(Ij,Kl)*B
- Tr(Ij) = Tr(Ij) + Qi(Ij,Kl)*A - Qr(Ij,Kl)*B
+ calc%Ti(1,Ij) = calc%Ti(1,Ij) + calc%Qr(Ij,Kl)*A + calc%Qi(Ij,Kl)*B
+ calc%Tr(1,Ij) = calc%Tr(1,Ij) + calc%Qi(Ij,Kl)*A - calc%Qr(Ij,Kl)*B
END DO
END DO
END DO
@@ -750,16 +746,16 @@ contains
END DO
END IF
!
- CALL Derres_Cro (calc, spinInfo, Igr, Tr, Ti, ipar)
+ CALL Derres_Cro (calc, spinInfo, Igr, ipar)
!
- CALL Derext_Cro (calc, spinInfo, Igr, Tr)
+ CALL Derext_Cro (calc, spinInfo, Igr)
RETURN
END
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Derres_Cro (calc, spinInfo, Igr, Tr, Ti, ipar)
+ SUBROUTINE Derres_Cro (calc, spinInfo, Igr, ipar)
!
use SammySpinGroupInfo_M
use constn_common_m, only : Fourpi
@@ -770,7 +766,6 @@ contains
real(kind=8) :: agoj
integer :: Ntot, igr, ipar
- real(kind=8) :: Tr(*), Ti(*)
real(kind=8)::val
real(kind=8),parameter :: Zero = 0.0d0, One = 1.0d0
@@ -799,10 +794,10 @@ contains
DO J=1,I
Ij = Ij + 1
IF (calc%Pi(Ij,M).NE.Zero) THEN
- S = S + calc%Pi(Ij,M)*Ti(Ij)*A
+ S = S + calc%Pi(Ij,M)*calc%Ti(1, Ij)*A
END IF
IF (calc%Pr(Ij,M).NE.Zero) THEN
- S = S + calc%Pr(Ij,M)*Tr(Ij)*A
+ S = S + calc%Pr(Ij,M)*calc%Tr(1, Ij)*A
END IF
END DO
END DO
@@ -818,7 +813,7 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Derext_Cro (calc, spinInfo, igr, Tr)
+ SUBROUTINE Derext_Cro (calc, spinInfo, igr)
!
use constn_common_m, only : Fourpi
use SammyRExternalInfo_M
@@ -831,7 +826,6 @@ contains
real(kind=8) :: Agoj
integer :: Ntot, igr
- real(kind=8) :: Tr(*)
type(SammyRExternalInfo)::rextInfo
type(RExternalFunction)::rext
real(kind=8)::Parext(7)
@@ -865,10 +859,10 @@ contains
IF (Ifl.GT.0) THEN
val = 0.0d0
IF (Nrext.EQ.5) val = &
- - Tr(Ij)*B*Parext(5)/ &
+ - calc%Tr(1,Ij)*B*Parext(5)/ &
(Su-Parext(1))
IF (Nrext.EQ.7) val = val &
- - Tr(Ij)*B* (Parext(5) + &
+ - calc%Tr(1,Ij)*B* (Parext(5) + &
Parext(6)*Parext(1))/ &
(Su-Parext(1))
call calc%crossData%setSharedValNs(calc%row, 1, Ifl, val)
@@ -877,32 +871,32 @@ contains
IF (Ifl.GT.0) THEN
val = 0.0d0
IF (Nrext.EQ.5) val = &
- - Tr(Ij)*B*Parext(5)/(Parext(2)-Su)
- IF (Nrext.EQ.7) val = -Tr(Ij)*B* &
+ - calc%Tr(1,Ij)*B*Parext(5)/(Parext(2)-Su)
+ IF (Nrext.EQ.7) val = -calc%Tr(1,Ij)*B* &
(Parext(5)+Parext(6)*Parext(2))/ &
(Parext(2)-Su) + val
call calc%crossData%setSharedValNs(calc%row, 1, Ifl, val)
END IF
Ifl = rextInfo%getIflSammyIndex(3)
IF (Ifl.GT.0) THEN
- val = Tr(Ij)*B
+ val = calc%Tr(1,Ij)*B
call calc%crossData%setSharedValNs(calc%row, 1, Ifl, val)
END IF
Ifl = rextInfo%getIflSammyIndex(4)
IF (Ifl.GT.0) THEN
- val = Tr(Ij)*B*Su
+ val = calc%Tr(1, Ij)*B*Su
call calc%crossData%setSharedValNs(calc%row, 1, Ifl, val)
END IF
Ifl = rextInfo%getIflSammyIndex(5)
IF (Ifl.GT.0) THEN
- val = -Two*Tr(Ij)*B * dSQRT(Parext(5))* &
+ val = -Two*calc%Tr(1,Ij)*B * dSQRT(Parext(5))* &
dLOG( (Parext(2)-Su)/(Su-Parext(1)) )
call calc%crossData%setSharedValNs(calc%row, 1, Ifl, val)
END IF
IF (rextInfo%getNrext().GT.5) THEN
Ifl = rextInfo%getIflSammyIndex(6)
IF (Ifl.GT.0) THEN
- val = - Tr(Ij)*B* &
+ val = - calc%Tr(1, Ij)*B* &
( (Parext(2)-Parext(1))+ &
Su*dLOG((Parext(2)-Su)/ &
(Su-Parext(1))) )
@@ -910,7 +904,7 @@ contains
END IF
Ifl = rextInfo%getIflSammyIndex(7)
IF (Ifl.GT.0) THEN
- val = Tr(Ij)*B*Su**2
+ val = calc%Tr(1, Ij)*B*Su**2
call calc%crossData%setSharedValNs(calc%row, 1, Ifl, val)
END IF
END IF
diff --git a/sammy/src/cro/mcro6.f90 b/sammy/src/cro/mcro6.f90
index 8c17e91c4..2ad610a74 100755
--- a/sammy/src/cro/mcro6.f90
+++ b/sammy/src/cro/mcro6.f90
@@ -1,3 +1,6 @@
+module Xspfa_Xspsl_m
+private Ixamax, Xaxpy, Xdot, Xswap
+contains
!
!
! --------------------------------------------------------------
@@ -5,7 +8,7 @@
SUBROUTINE Xspfa (Ap, N, Kpvt, Info)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INTEGER N, Kpvt(*), Info
- DIMENSION Ap(2,*)
+ real(kind=8)::Ap(2,*)
!
! *** modified October 14, 1993, by NML to use for complex arrays
!
@@ -755,3 +758,4 @@
END IF
RETURN
END
+end module Xspfa_Xspsl_m
diff --git a/sammy/src/endf/VariedParameterInfo.cpp b/sammy/src/endf/VariedParameterInfo.cpp
index 8495fd8e9..684e21904 100644
--- a/sammy/src/endf/VariedParameterInfo.cpp
+++ b/sammy/src/endf/VariedParameterInfo.cpp
@@ -37,6 +37,7 @@ void VariedParameterInfo::getNumCombined(int & total, int & pup) const{
void VariedParameterInfo::getNumRext(int & total, int & pup) const{
total = pup = 0;
+
for (int i = 0; i < resPar.getNumRext(); i++){
sammy::SammyRExternalInfo * info = resPar.getRextInfo(i);
int iflr = 0;
@@ -66,10 +67,12 @@ void VariedParameterInfo::getNumRext(int & total, int & pup) const{
default:
throw std::runtime_error("Number of external R-Matrix parameters greater than 7 not implemented");
}
- }
- if (iflr > 0){
- total++;
- if (covData.isPupedParameter(iflr - 1)) pup++;
+
+
+ if (iflr > 0){
+ total++;
+ if (covData.isPupedParameter(iflr - 1)) pup++;
+ }
}
}
}
@@ -244,23 +247,29 @@ double VariedParameterInfo::getEchan(int grp, int nchan) const{
int VariedParameterInfo::getNumUniqEchanIncludedChannels() const{
std::vector<double> values;
-
- for (int igr = 0; igr < resPar.getNumSpinGroups(); igr++){
- sammy::SammySpinGroupInfo *info = resPar.getSpinGroupInfo(igr);
- int ntot = info->getNumChannels();
- int nentp = info->getNumEntryChannels();
-
- for (int ichan = nentp; ichan < ntot; ichan++){
- sammy::SammyChannelInfo * chanInfo = info->getChannelInfo(ichan);
- if (!chanInfo->getIncludeInCalc()) continue;
-
- double echan = getEchan(igr, ichan);
- if (std::find( values.begin(), values.end(), echan) == values.end()){
- values.push_back(echan);
+ int num = 0;
+
+ for (int iso = 0; iso < resPar.getNumIso(); iso++){
+ values.clear();
+ for (int igr = 0; igr < resPar.getNumSpinGroups(); igr++){
+ sammy::SammySpinGroupInfo *info = resPar.getSpinGroupInfo(igr);
+ if (info->getIsotopeIndex() != iso) continue;
+ int ntot = info->getNumChannels();
+ int nentp = info->getNumEntryChannels();
+
+ for (int ichan = nentp; ichan < ntot; ichan++){
+ sammy::SammyChannelInfo * chanInfo = info->getChannelInfo(ichan);
+ if (!chanInfo->getIncludeInCalc()) continue;
+
+ double echan = getEchan(igr, ichan);
+ if (std::find( values.begin(), values.end(), echan) == values.end()){
+ values.push_back(echan);
+ }
}
}
+ num += (int)values.size();
}
- return (int)values.size();
+ return num;
}
double VariedParameterInfo::getBounds(int grp, int nchan, double Twomhb, int kwcoul, double Etac) const{
diff --git a/sammy/src/fin/mfin3.f90 b/sammy/src/fin/mfin3.f90
index 77babde1c..70c40b847 100644
--- a/sammy/src/fin/mfin3.f90
+++ b/sammy/src/fin/mfin3.f90
@@ -393,10 +393,15 @@ module fin3
Ntotc, Kdecpl, Kenunc, Kkkgrp, Iunit)
use SammyResonanceInfo_M
use RMatResonanceParam_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Ifits(*), Aaa(5), Iii(5)
+ IMPLICIT none
+ real(kind=8)::pken, Ddcov
+ integer::igroup, Ntotc, Kdecpl, Kenunc, Kkkgrp, Iunit
+ integer::Ifits(*)
+ real(kind=8)::Aaa(5), Z
+ integer::Iii(5)
type(RMatResonance)::resonance
- DATA Zero /0.0d0/
+ real(kind=8),parameter::Zero=0.0d0
+ integer:: I, Ix, Iz, Line, m, Max, Min, Nline, Ntotc2, Kddddd
!
Iz = 0
Z = Zero
@@ -404,6 +409,7 @@ module fin3
IF (Kdecpl.NE.0 .OR. Kenunc.NE.0) THEN
IF (Ddcov.NE.Zero) Kddddd = 1
END IF
+ Aaa = 0.0d0
!
10000 FORMAT ('#', I2, 5F30.15, 6I2, F30.15)
20000 FORMAT ('#', I2, 5F30.15, 5I2, I4, F30.15)
@@ -565,10 +571,10 @@ module fin3
WRITE (Iunit,20000) Ix, Aaa, Iii, Igroup, Ddcov
END IF
ELSE
- IF (Kkkgrp.EQ.50) THEN
+ IF (Kkkgrp.EQ.50) THEN
WRITE (Iunit,10000) Ix, Aaa, Iii, Igroup
ELSE
- Ix = Ix + 3
+ Ix = Ix + 3
WRITE (Iunit,20000) Ix, Aaa, Iii, Igroup
END IF
END IF
diff --git a/sammy/src/inp/minp15.f b/sammy/src/inp/minp15.f
index 6ec1cfb78..b071b1fa8 100644
--- a/sammy/src/inp/minp15.f
+++ b/sammy/src/inp/minp15.f
@@ -194,7 +194,6 @@ C
END DO
- write(0,*)" Huh min15 ",resParData%getSpinIncident()
CALL Organize_Bound_Etc (Bound)
diff --git a/sammy/src/rec/mrec0.f b/sammy/src/rec/mrec0.f
index 915f5015c..5363ede9a 100644
--- a/sammy/src/rec/mrec0.f
+++ b/sammy/src/rec/mrec0.f
@@ -21,6 +21,7 @@ C
use mrec8_m
use mdata_M
use mrec2_m
+ use mrec3_m
use mthe0_M
use Tab1_M
use mcro8_m
@@ -68,78 +69,29 @@ C *** zero ***
C
C *** one ***
C *** initialize difmax
- call allocate_real_data(A_Idifma, Mres)
- CALL Uuuset (A_Idifma )
+ CALL Uuuset (zeroKCalc%driver%calculator%Difmax)
C
C *** two ***
Maxnpu = Nemax
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - <
C - - - - - - - - - - - - - - - - - - - - - - - - - - - <
-C
-C *** five ***
- call allocate_real_data(A_Icrss, N3)
-C
-C - - - - - - - - - - - - - - - - - - - - - - <
-C *** six ***
-C
C *** seven ***
- call allocate_real_data(A_Ixden, Mres)
C CALL Abpart
C
C *** eight ***
C CALL Fixn
C
-C *** nine ***
- N = Ntotc
- call allocate_real_data(A_Isinsq, N)
- call allocate_real_data(A_Isinph, N)
- call allocate_real_data(A_Idphi, N)
- call allocate_real_data(A_Idpdr, N)
- call allocate_real_data(A_Idsdr, N)
- call allocate_real_data(A_Icc, N)
- call allocate_real_data(A_Iss, N)
C CALL Sinsin
-C
-C *** ten ***
- N = Ntotc
- call allocate_real_data(A_Ipsmal, N)
- call allocate_real_data(A_Irootp, N)
- call allocate_real_data(A_Linvr, N)
- call allocate_real_data(A_Linvi, N)
- N = NN
- call allocate_real_data(A_Ixxxxr, N)
- call allocate_real_data(A_Ixxxxi, N)
- N = Ntotc*Ntotc
- call allocate_real_data(A_Ixqr, N)
- call allocate_real_data(A_Ixqi, N)
- call allocate_real_data(A_Iyinv, 4*NN)
C - - - - - - - - - - - - - - - - <
-C *** eleven ***
- call allocate_real_data(A_Irmat, 4*NN)
- call allocate_real_data(A_Iymat, 4*NN)
C CALL Setr
C CALL Yinvrs
C CALL Setxqx
C - - - - - - - - - - - - - - - - >
C
C *** twelve ***
- N = Ncrsss - 2
- IF (N.EQ.0) N = 1
- call allocate_real_data(A_Itermf, N)
- call allocate_real_data(A_Iterfx, N)
C CALL Sectio
-C
- N = NN*NN
- call allocate_real_data(A_Iqr, N)
- call allocate_real_data(A_Iqi, N)
- call allocate_real_data(A_Ipxrr, N)
- call allocate_real_data(A_Ipxri, N)
C CALL Setqri
-C
- N = Ncrsss*NN
- call allocate_real_data(A_Itr, N)
- call allocate_real_data(A_Iti, N)
C CALL Settri
C
C *** thirteen ***
@@ -148,7 +100,8 @@ C *** thirteen ***
CALL Eorder (A_Ienode, A_Iwnode , Node)
Kadddc = 0
Nnndrc = 1
- CALL Grid (A_Icrss , A_Ienode, A_Iwnode,
+ CALL Grid (zeroKCalc%driver%xctCalc,
+ * A_Ienode, A_Iwnode,
* A_Ietab2 , A_Isig2 , Node,
* Nemax, Nesave, Nreact)
deallocate(A_Ienode)
diff --git a/sammy/src/rec/mrec2.f90 b/sammy/src/rec/mrec2.f90
index 79a0b1a45..93a99092b 100644
--- a/sammy/src/rec/mrec2.f90
+++ b/sammy/src/rec/mrec2.f90
@@ -5,7 +5,7 @@ contains
!
! ------------------------------------------------------------------------
!
- SUBROUTINE Grid (Crss, Enode, Widnod, &
+ SUBROUTINE Grid (xct, Enode, Widnod, &
Etab2, Sig2, Node, Nemax, Nesave, Nreact)
!
! *** Generate an energy-grid suitable for producing pointwise cross sections.
@@ -18,10 +18,13 @@ contains
use fixedi_m
use fixedr_m
use AllocateFunctions_m
- use mrec6_m
+ use mrec6_m
+ use mrec3_m
+ use XctCrossCalc_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
- DIMENSION Crss(*), Enode(*), Widnod(*)
+ class(XctCrossCalc)::xct
+ DIMENSION Enode(*), Widnod(*)
DIMENSION Sigmid(4)
real(kind=8),allocatable,dimension(:)::Etab2, Esave, Esub
real(kind=8),allocatable,dimension(:)::Sigsav(:,:), Sig2(:,:)
@@ -98,7 +101,7 @@ contains
Etab2(Kpntp1) = Esub(1)
IF (Kpoint.GT.0 .AND. Etab2(Kpntp1).LE.Etab2(Kpoint)) GO TO 140
! *** CALCULATE CROSS SECTION AT NEXT ENERGY
- CALL Sigmax (Etab2(Kpntp1), Sig2(1,Kpntp1), Crss)
+ CALL Sigmax (Etab2(Kpntp1), Sig2(1,Kpntp1), xct)
! *** SAVE STARTING POINT (NO CONVERGENCE TESTS UNTIL 2ND POINT IS
! *** GENERATED).
Kpoint = Kpntp1
@@ -118,7 +121,7 @@ contains
call reallocate_real_data_2d(Sig2, nreact, 0, max(Kpntp1, Kpoint), 1000)
Etab2(Kpntp1) = Esub(Isub)
! *** CALCULATE CROSS SECTION AT END OF SUB-INTERVAL.
- CALL Sigmax (Etab2(Kpntp1), Sig2(1,Kpntp1), Crss)
+ CALL Sigmax (Etab2(Kpntp1), Sig2(1,Kpntp1), xct)
!
! *** DEFINE ENERGY AT MIDPOINT AND TEST FOR CONVERGENCE BASED
! *** ON SHORT ENERGY INTERVAL.
@@ -136,7 +139,7 @@ contains
IF ((Emid-Ea).LE.Eb*Tiny/2.0d0) GO TO 70
!
! *** DEFINE CROSS SECTION AT MIDPOINT.
- CALL Sigmax (Emid, Sigmid, Crss)
+ CALL Sigmax (Emid, Sigmid, xct)
!
40 CONTINUE
! *** test for convergence
diff --git a/sammy/src/rec/mrec3.f b/sammy/src/rec/mrec3.f90
similarity index 61%
rename from sammy/src/rec/mrec3.f
rename to sammy/src/rec/mrec3.f90
index 2e27395e3..b4851722e 100644
--- a/sammy/src/rec/mrec3.f
+++ b/sammy/src/rec/mrec3.f90
@@ -1,122 +1,115 @@
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Sigmax (Eee, Ssseee, Crss)
-C
-C *** PURPOSE -- Generate cross section Ssseee(I), at energy Eee, where
-C *** I=1 means elastic, I=2 means absorption, I=3 means fission
-C
-C *** This file is modified from routines in segment XCT, to generate
-C *** cross sections one energy at a time, with no derivatives wanted
-C
+module mrec3_m
+contains
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Sigmax (Eee, Ssseee, xct)
+!
+! *** PURPOSE -- Generate cross section Ssseee(I), at energy Eee, where
+! *** I=1 means elastic, I=2 means absorption, I=3 means fission
+!
+! *** This file is modified from routines in segment XCT, to generate
+! *** cross sections one energy at a time, with no derivatives wanted
+!
use oops_common_m
use exploc_common_m
use varyr_common_m
- use ifsubs_common
use xct4_m
- use array_sizes_common_m, only : zeroKCalc
+ use XctCrossCalc_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Ssseee(*), Crss(*)
-C
+!
+ class(XctCrossCalc)::xct
+ DIMENSION Ssseee(*)
+!
Su = Eee
Squ = dSQRT(Su)
-C
- Ks_Res = 2
- Ifcap = 1
- Ifzzz = 1
- Ifext = 1
- Ifrad = 1
- Ifiso = 1
- Ifradt = 1
+!
I = 0
-C *** generate cross sections pieces
- CALL Zcross (zeroKCalc%driver%xctCalc, Nnndrc, I, Kount_Helmut)
-C
-C *** set the individual cross sections
- CALL Indivi (Crss, Ssseee, Su)
-C
+! *** generate cross sections pieces
+ xct%ener = Eee
+ CALL Zcross (xct, Nnndrc, I)
+!
+! *** set the individual cross sections
+ CALL Indivi (xct, Ssseee, Su)
+!
RETURN
END
-C
-C
-C ______________________________________________________________________
-C
- SUBROUTINE Indivi (Crss, Sig, Su)
-C
-C *** Purpose -- Set Sig(I) = the individual cross sections
-C
-C *** Note -- changes made here may also need to be made in sbroutine
-C *** PRTCLR in mxct7.f
-C
+!
+!
+! ______________________________________________________________________
+!
+ SUBROUTINE Indivi (xct, Sig, Su)
+!
+! *** Purpose -- Set Sig(I) = the individual cross sections
+!
+! *** Note -- changes made here may also need to be made in sbroutine
+! *** PRTCLR in mxct7.f
+!
use fixedi_m
use constn_common_m
use EndfData_common_m
use SammySpinGroupInfo_M
+ use XctCrossCalc_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Crss(Ncrsss,*), Sig(*)
+!
+ class(XctCrossCalc)::xct
+ DIMENSION Sig(*)
type(SammySpinGroupInfo)::spinInfo
DATA Zero /0.0d0/
-C
+!
IF (Su.EQ.Zero) THEN
Sig(1) = Zero
Sig(2) = Zero
IF (Ncrsss.GE.3) Sig(3) = Zero
RETURN
END IF
-C
-C *** first, set the cross sections:
+!
+! *** first, set the cross sections:
Termn = Zero
Terma = Zero
Termf = Zero
DO N=1,resParData%getNumSpinGroups()
call resParData%getSpinGroupInfo(spinInfo, N)
abnSpin = spinInfo%getAbundance()
- Termn = Termn + Crss(1,N)*AbnSpin
- Terma = Terma + Crss(2,N)*AbnSpin
-cx Termn = Termn + Crss(1,N)
-cx Terma = Terma + Crss(2,N)
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
-cx Termf = Termf + Crss(I+2,N)
- Termf = Termf + Crss(I+2,N)*AbnSpin
- END DO
- END IF
+ Termn = Termn + xct%crossInternal(1, N, 0)*AbnSpin
+ Terma = Terma + xct%crossInternal(2, N, 0)*AbnSpin
+ DO I=3,Ncrsss
+ Termf = Termf + xct%crossInternal(I, N, 0)*AbnSpin
+ END do
END DO
-C
+!
Sig(1) = Termn*Fourpi/Su
Sig(2) = Terma*Fourpi/Su
IF (Ncrsss.GE.3) Sig(3) = Termf*Fourpi/Su
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Uuuset (Difmax)
-C
-C *** PURPOSE -- GENERATE Uup, Udown, Nnpar, Difmax
-C *** modified from program Uset in mthe1
-C
+!
+! *** PURPOSE -- GENERATE Uup, Udown, Nnpar, Difmax
+! *** modified from program Uset in mthe1
+!
use fixedi_m
use ifwrit_m
use SammyResonanceInfo_M
use EndfData_common_m
use RMatResonanceParam_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(SammyResonanceInfo)::resInfo
type(RMatResonance)::resonance
type(SammySpinGroupInfo)::spinInfo
type(RMatChannelParams)::channel
type(SammyChannelInfo)::channelInfo
DIMENSION Difmax(*)
-C
-C DIMENSION Difmax(Nres)
+!
+! DIMENSION Difmax(Nres)
DATA Zero /0.0d0/, Two /2.0d0/
-C
+!
Ks_Res = Ksolve
Ipar = 0
DO N=1,resParData%getNumResonances()
@@ -140,14 +133,14 @@ C
DO M=1,resonance%getNumChan()
G = G + dABS(resonance%getWidth(M))
END DO
- IF (Kscut.NE.0 .AND. channel%getL().EQ.0) G =
- * G * Two
+ IF (Kscut.NE.0 .AND. channel%getL().EQ.0) G = G * Two
Difmax(N) = G
END IF
END IF
END IF
END IF
END DO
-C
+!
RETURN
END
+end module mrec3_m
diff --git a/sammy/src/salmon/DerivativeList.cpp b/sammy/src/salmon/DerivativeList.cpp
index 1caac597f..588520980 100644
--- a/sammy/src/salmon/DerivativeList.cpp
+++ b/sammy/src/salmon/DerivativeList.cpp
@@ -217,7 +217,7 @@ namespace sammy {
if (gridData.getLength() > 0) {
throw std::runtime_error("Can't add shared column if we already have data");
}
- if (getLength() > 0){
+ if (getLength() > 0){
throw std::runtime_error("Can't add shared column if we already have data");
}
sharedIndices.push_back(std::make_pair(col, iso));
diff --git a/sammy/src/salmon/interface/fortran/DerivativeListHolder_M.f90 b/sammy/src/salmon/interface/fortran/DerivativeListHolder_M.f90
index 6b19cf04d..c01245e96 100644
--- a/sammy/src/salmon/interface/fortran/DerivativeListHolder_M.f90
+++ b/sammy/src/salmon/interface/fortran/DerivativeListHolder_M.f90
@@ -166,6 +166,7 @@ subroutine DerivativeListHolder_addSharedColumn(this, col, iso)
class(DerivativeListHolder)::this
integer(C_INT)::col
integer(C_INT)::iso
+ if (this%getIsotopeForShared(col).le.0) return
call f_DerivativeListHolder_addSharedColumn(this%instance_ptr, col,iso-1)
end subroutine
subroutine DerivativeListHolder_setNotSetReturnsZero(this, empty)
diff --git a/sammy/src/sammy/CMakeLists.txt b/sammy/src/sammy/CMakeLists.txt
index 06282178c..3efca439c 100644
--- a/sammy/src/sammy/CMakeLists.txt
+++ b/sammy/src/sammy/CMakeLists.txt
@@ -392,7 +392,7 @@ APPEND_SET(SAMMY_SOURCES
../rec/mrec0.f
../rec/mrec1.f
../rec/mrec2.f90
- ../rec/mrec3.f
+ ../rec/mrec3.f90
../rec/mrec4.f
../rec/mrec5.f
../rec/mrec6.f90
@@ -531,7 +531,6 @@ APPEND_SET(SAMMY_SOURCES
../blk/Over_common.f90
../blk/Oops_common.f90
../blk/Fixedi_common.f90
- ../blk/ifsubs_common.f90
../blk/Ifwrit_common.f90
../blk/Exploc_common.f90
../blk/Samxxx_common.f90
diff --git a/sammy/src/the/CrossSectionCalcDriver_M.f90 b/sammy/src/the/CrossSectionCalcDriver_M.f90
index 0819414fe..c5ee33828 100644
--- a/sammy/src/the/CrossSectionCalcDriver_M.f90
+++ b/sammy/src/the/CrossSectionCalcDriver_M.f90
@@ -144,6 +144,7 @@ module CrossSectionCalcDriver_M
end if
allocate(this%xctCalc)
call this%xctCalc%initialize(resParData, covData, radFitFlags, nisoOur, needAngular, Itzero, Ilzero, doShiftRes)
+ if (niso.eq.1) this%xctCalc%separateIso = .false.
this%calculator => this%xctCalc
this%xctCalc%crossDataSelf%instance_ptr = this%calcDataSelf%instance_ptr
this%xctCalc%Kpolar = Kpolar
@@ -222,8 +223,9 @@ module CrossSectionCalcDriver_M
class(CrossSectionCalcDriver)::this
class(XctCrossCalc)::calc
- integer::Ifc3,nreact, I, Ifdif
+ integer::Ifc3,nreact, I
logical::doSelfIndicate
+ logical::addElimKapt
doSelfIndicate = .false.
if (associated(this%xctCalc)) doSelfIndicate = this%xctCalc%wantSelfIndicate
@@ -303,11 +305,14 @@ module CrossSectionCalcDriver_M
! differential elastic cross section .or. multiple-scattering
! corrections for which we need differential elastic
- IF (this%Kcros.EQ.7 .OR. this%Kssmsc.GT.0) Ifdif = 1
- IF (this%Kcros.EQ.11) Ifdif = 2 ! angular distribution for reaction cross section
+ IF (this%Kcros.EQ.7 .and. this%Kssmsc.GT.0) then
+ calc%Ifcros(1) = .true.
+ end if
- if (associated(this%xctCalc)) this%xctCalc%Ifdif = Ifdif
- if (associated(this%croCalc)) this%croCalc%Ifdif = Ifdif
+ addElimKapt = .false.
+ if (this%Kaptur.eq.1) addElimKapt = .true.
+ if (associated(this%croCalc)) this%croCalc%addElimKapt = addElimKapt
+ if (associated(this%xctCalc)) this%xctCalc%addElimKapt = addElimKapt
end subroutine
diff --git a/sammy/src/the/CrossSectionCalculator_M.f90 b/sammy/src/the/CrossSectionCalculator_M.f90
index 6769fc53f..aeccd8aaf 100644
--- a/sammy/src/the/CrossSectionCalculator_M.f90
+++ b/sammy/src/the/CrossSectionCalculator_M.f90
@@ -16,6 +16,7 @@ module CrossSectionCalculator_M
type(DerivativeHandler)::crossData ! the cross section and derivative calculated for a given energy
integer::row ! the row index for crossData (calcuated data for ener will be put here)
logical::wantDerivs ! do we need derivatives
+ logical::onlyPupDerivs ! if wantDerivs is true, do we only need derivatives for the pup'ed parameters
logical::hasPuped, hasParams ! are there any pup'ed or varied parameters
integer::reactType ! the type of reaction to calculate
real(kind=8)::ener, enerSq ! the energy and square at which to calculate the cross section
@@ -48,6 +49,7 @@ module CrossSectionCalculator_M
! Inum(Npr,1) = fit flag, i.e. position (fortran counting) into covariance matrix
! Inum(Npr,2) = 1 -> energy, 2 elaststic channel, 3... other channels
! Inum(Npr,3) = the index of the resonance
+ real(kind=8),allocatable,dimension(:)::Difmax ! if Difen for a given resonance is less than Difmax, we set needAlphai true
integer::inumSize ! if filling Inum for a specific spin group, the number of parameters for that group
logical::getAbundanceFromSpinGroup ! should we get the abundance from the spin group instead of the isotope?
@@ -68,7 +70,8 @@ module CrossSectionCalculator_M
procedure, pass(this) :: setRange => CrossSectionCalculator_setRange ! set the range and reserve enough space in crossData (the latter for efficiency only)
procedure, pass(this) :: initialize => CrossSectionCalculator_initialize
procedure, pass(this) :: destroy => CrossSectionCalculator_destroy
- procedure, pass(this) :: calcCross => CrossSectionCalculator_calcCross
+ procedure, pass(this) :: calcCross => CrossSectionCalculator_calcCross
+ procedure, pass(this) :: setDerivFlag => CrossSectionCalculator_setDerivFlag
end type CrossSectionCalculator
contains
@@ -151,8 +154,6 @@ real(kind=8) function CrossSectionCalculator_getAbundance(this, igr) result(abun
call this%resData%getSpinGroupInfo(info, igr)
if (this%getAbundanceFromSpinGroup) then
abund = info%getAbundance()
-
- isoN = info%getIsotopeIndex()
else
isoN = info%getIsotopeIndex()
abund = this%resData%getAbundanceByIsotope(isoN)
@@ -170,9 +171,12 @@ subroutine CrossSectionCalculator_setWantDeriv(this, wantDerivs)
logical::wantDerivs
this%wantDerivs = .false.
+ this%onlyPupDerivs = .false.
if (this%hasPuped) this%wantDerivs = .true.
if (wantDerivs) then
if (this%hasParams) this%wantDerivs = .true.
+ else
+ if (this%hasPuped) this%onlyPupDerivs = .true.
end if
end subroutine
@@ -263,6 +267,20 @@ subroutine CrossSectionCalculator_getParamPerSpinGroup(this, ires, igr, fillIt)
END DO
end do
end subroutine
+
+logical function CrossSectionCalculator_setDerivFlag(this, iflag, doSolve) result(set)
+ class(CrossSectionCalculator) :: this
+ integer::iflag
+ logical::doSolve
+
+ set = .false.
+ if (iflag.le.0) return
+ set = .true.
+ if (doSolve) return
+ set = .false.
+ if (this%covariance%isPupedParameter(iflag)) set = .true.
+end function CrossSectionCalculator_setDerivFlag
+
!!
!! Determine which derivatives need to be calculated,
!! i.e. resonances only, radii, ...
@@ -278,20 +296,31 @@ subroutine CrossSectionCalculator_Which_Derivs(this)
integer::Itzero, Ilzero
integer::ig, ich, is
type(SammyRExternalInfo)::rextInfo
+ logical::set
+ this%Ifext = .false.
+ this%Ifiso = .false.
+ this%Ifrad = .false.
+ this%Ifradt = .false.
+ this%Ifzzz = .false.
+ if (.not.this%wantDerivs) return
- if (this%Itzero.gt.0) this%Ifzzz = .true.
- if (this%Ilzero.gt.0) this%Ifzzz = .true.
+ set = this%setDerivFlag(this%Itzero, this%wantDerivs)
+ if (set) this%Ifzzz = .true.
+ set = this%setDerivFlag(this%Ilzero, this%wantDerivs)
+ if (set) this%Ifzzz = .true.
DO ig=1,this%resData%getNumSpinGroups()
call this%resData%getSpinGroupInfo(spinInfo, ig)
DO Ich=1,spinInfo%getNumChannels()
- if (this%radiusData%getTrueFitFlag(Ig, Ich).gt.0) then
+ set = this%setDerivFlag(this%radiusData%getTrueFitFlag(Ig, Ich), this%wantDerivs)
+ if (set) then
this%Ifrad = .true.
this%Ifradt = .true.
end if
if (this%Ifrad.and.this%Ifradt) exit
- if(this%radiusData%getEffFitFlag(Ig, Ich).gt.0) then
+ set = this%setDerivFlag(this%radiusData%getEffFitFlag(Ig, Ich), this%wantDerivs)
+ if(set) then
this%Ifrad = .true.
end if
if (this%Ifrad.and.this%Ifradt) exit
@@ -301,7 +330,8 @@ subroutine CrossSectionCalculator_Which_Derivs(this)
do is = 1, this%resData%getNumIso()
call this%resData%getIsoInfo(isoInfo, Is)
- if (isoInfo%getFitOption().gt.0) then
+ set = this%setDerivFlag(isoInfo%getFitOption(), this%wantDerivs)
+ if (set) then
this%Ifiso = .true.
exit
end if
@@ -313,7 +343,8 @@ subroutine CrossSectionCalculator_Which_Derivs(this)
if (.not.this%resData%hasRexInfo(ig, Ich)) cycle
call this%resData%getRextInfoByGroup(rextInfo, ig, Ich)
DO Is = 1, rextInfo%getNrext()
- if( rextInfo%getIflSammyIndex(Is).gt.0) then
+ set = this%setDerivFlag(rextInfo%getIflSammyIndex(Is), this%wantDerivs)
+ if( set) then
this%Ifext = .true.
exit
end if
@@ -352,6 +383,8 @@ subroutine CrossSectionCalculator_setEnergyIndependent(this, reactType, Twomhb,
this%reactType = reactType
call this%setZke(Twomhb, Etac)
call this%setEchan()
+
+ call this%Which_Derivs()
end subroutine
!!
!! Set the range and number of energy points
@@ -403,6 +436,7 @@ subroutine CrossSectionCalculator_initialize(this, pars, cov, rad, niso, needAng
logical(C_BOOL)::countCombined
this%wantDerivs = .false.
+ this%onlyPupDerivs = .false.
this%reactType = 0
this%hasPuped = .false.
this%hasParams = .false.
@@ -448,6 +482,8 @@ subroutine CrossSectionCalculator_initialize(this, pars, cov, rad, niso, needAng
call reallocate_real_data_2d(this%Zeta, ntot-1, 0, pars%getNumSpinGroups(), 0)
call reallocate_real_data_2d(this%Echan, ntot-1, 0, pars%getNumSpinGroups(), 0)
+ call allocate_real_data(this%Difmax, pars%getNumResonances())
+
itmp = 0
ires = 0
do n = 1, this%resData%getNumSpinGroups()
@@ -466,7 +502,6 @@ subroutine CrossSectionCalculator_initialize(this, pars, cov, rad, niso, needAng
this%Ifrad = .false.
this%Ifradt = .false.
this%Ifzzz = .false.
- call this%Which_Derivs()
end subroutine
!!
!! Destroy all resources
@@ -476,6 +511,7 @@ subroutine CrossSectionCalculator_destroy(this)
deallocate(this%Zke)
deallocate(this%Zeta)
deallocate(this%Echan)
+ deallocate(this%Difmax)
if(allocated(this%Inum)) deallocate(this%Inum)
end subroutine
end module CrossSectionCalculator_m
diff --git a/sammy/src/the/ZeroKCrossCorrections_M.f90 b/sammy/src/the/ZeroKCrossCorrections_M.f90
index 575c19ea8..ccd575a71 100644
--- a/sammy/src/the/ZeroKCrossCorrections_M.f90
+++ b/sammy/src/the/ZeroKCrossCorrections_M.f90
@@ -37,6 +37,7 @@ module ZeroKCrossCorrections_M
procedure, pass(this) :: AddParam => ZeroKCrossCorrections_AddParam ! add the paramagnetic cross section. This function uses SAMMY global parameters
end type
+ private A_Interp
contains
!!
!! Reconstruct the 0K cross section
@@ -143,12 +144,14 @@ contains
integer::is, id
if (this%moreCorrections) return ! don't need to set theory yet
- !if (.not.this%summedOverIsotopes) then
- ! write(0,*)" Expected only one istope or sum over isotopes completed"
- ! stop
- !end if
+ if (.not.this%summedOverIsotopes) then
+ write(6,*)" Expected only one istope or sum over isotopes completed"
+ write(21,*)" Expected only one istope or sum over isotopes completed"
+ stop
+ end if
if (nnsig.ne.this%driver%calcData%getNnnsig()) then
- write(0,*)" Number of cross sections do not agree "
+ write(6,*)" Number of cross sections do not agree "
+ write(21,*)" Number of cross sections do not agree "
stop
end if
do id = 1, this%dataStart -1
@@ -169,8 +172,9 @@ contains
!! - userGrid grid from which to calculate the emin and emax value
!! - expData needed as an argument for grid and userGrid to get the enery
!! - covariance covariance data, needed to find the position for the derivatives
+ !! - wantDeriv do we need derivatives (i.e. are we solving).
!!
- subroutine ZeroKCrossCorrections_applyNorm(this, grid, expData, covariance)
+ subroutine ZeroKCrossCorrections_applyNorm(this, grid, expData, covariance, wantDeriv)
use lbro_common_m, only : Ynrmbk
use fixedi_m, only : Numnbk, Numbgf
use ifwrit_m, only : Ksolve
@@ -184,51 +188,38 @@ contains
type(SammyGridAccess)::grid
type(GridDataList)::expData
type(CovarianceData)::covariance
+ logical::wantDeriv
integer::numEl
integer::ipos, iel, itot, in
real(kind=8)::ener
- logical::wantDeriv
+ logical::wantDerivLocal, set
if (.not.Ynrmbk) return ! no correction to apply
if ( Numnbk.eq.0.and.Numbgf.eq.0) return ! no normalization to apply
if (this%moreCorrections) return ! don't need apply normalization and background yet
- !if (.not.this%summedOverIsotopes) then
- ! write(0,*)" Expected only one istope or sum over isotopes completed"
- ! stop
- !end if
+ if (.not.this%summedOverIsotopes) then
+ write(6,*)" Expected only one istope or sum over isotopes completed"
+ write(21,*)" Expected only one istope or sum over isotopes completed"
+ stop
+ end if
numEl = grid%getNumEnergies(expData)
ipos = 0
- wantDeriv = this%driver%getWantDerivs()
- if (.not.wantDeriv) then
- if (ksolve.ne.2) then
- if (allocated(I_Iflnbk)) then
- if (sum(I_Iflnbk).gt.0) wantDeriv = .true.
- end if
- if (allocated(I_Iflbgf)) then
- if (sum(I_Iflbgf).gt.0) wantDeriv = .true.
- end if
- else
- if (allocated(I_Iflnbk)) then
- do in = 1, size(I_Iflnbk)
- if ( I_Iflnbk(in).le.0) cycle
- if ( covariance%isPupedParameter(I_Iflnbk(in))) then
- wantDeriv = .true.
- exit
- end if
- end do
- end if
+ wantDerivLocal = this%driver%calculator%wantDerivs
+ if (.not.wantDerivLocal) then
+ if (allocated(I_Iflnbk)) then
+ do in = 1, size(I_Iflnbk)
+ set = this%driver%calculator%setDerivFlag(I_Iflnbk(in), wantDeriv)
+ if (set) wantDerivLocal = .true.
+ end do
if (allocated(I_Iflbgf)) then
do in = 1, size(I_Iflbgf)
- if ( I_Iflbgf(in).le.0) cycle
- if ( covariance%isPupedParameter(I_Iflbgf(in))) then
- wantDeriv = .true.
- exit
- end if
+ set = this%driver%calculator%setDerivFlag(I_Iflbgf(in), wantDeriv)
+ if (set) wantDerivLocal = .true.
end do
end if
end if
@@ -258,8 +249,9 @@ contains
!! - userGrid grid from which to calculate the emin and emax value
!! - expData needed as an argument for grid and userGrid to get the enery
!! - covariance covariance data, needed to find the position for the derivatives
+ !! - wantDeriv do we need derivatives (i.e. are we solving).
!!
- subroutine ZeroKCrossCorrections_convertToTrans(this, grid, expData, covariance)
+ subroutine ZeroKCrossCorrections_convertToTrans(this, grid, expData, covariance, wantDeriv)
use CovarianceData_M
use GridData_M
use convert_to_transmission_m
@@ -270,10 +262,11 @@ contains
type(SammyGridAccess)::grid
type(GridDataList)::expData
type(CovarianceData)::covariance
+ logical::wantDeriv
integer::iel, numEl, itot, ipos
real(kind=8)::ener
- logical::wantDeriv
+ logical::wantDerivLocal, set
if (.not.this%wantTrans) return ! don't need to do transformation to transmission yet
@@ -281,18 +274,12 @@ contains
ipos = 0
itot = 0
- wantDeriv = this%driver%getWantDerivs()
- if (.not.wantDeriv.and.Kvthck.gt.0) then
- if (ksolve.ne.2) then
- wantDeriv = .true.
- else
- if ( covariance%isPupedParameter(Kvthck)) then
- wantDeriv = .true.
- end if
- end if
- end if
+ wantDerivLocal = wantDeriv
+ set = this%driver%calculator%setDerivFlag(Kvthck, wantDeriv)
+ if (set) wantDerivLocal = .true.
+
itot = 0
- if (wantDeriv) itot = covariance%getNumTotalParam()
+ if (wantDerivLocal) itot = covariance%getNumTotalParam()
do iel = 1, numEl
ener = grid%getEnergy(iel, expData)
@@ -314,26 +301,67 @@ contains
!! - userGrid grid from which to calculate the emin and emax value
!! - expData needed as an argument for grid and userGrid to get the enery
!! - covariance covariance data, needed to find the position for the derivatives
+ !! - wantDeriv do we need derivatives (i.e. are we solving).
!!
- subroutine ZeroKCrossCorrections_Fix_Eta(this, grid, expData, covariance)
+ subroutine ZeroKCrossCorrections_Fix_Eta(this, grid, expData, covariance, wantDeriv)
use CovarianceData_M
use GridData_M
- use exploc_common_m, only : I_Iflmsc
- use ifwrit_m, only : Ksolve, Kjetan
- use fixedr_m, only : Etanuu
+ use exploc_common_m, only : I_Iflmsc, A_Iprmsc, A_Ietaee
+ use ifwrit_m, only : Ksolve, Keffis, Kefcap, Kfake, Kjetan, Mjetan
+ use fixedr_m, only : Effcap, Efffis, Etanuu
class(ZeroKCrossCorrections)::this
type(SammyGridAccess)::grid
type(GridDataList)::expData
type(CovarianceData)::covariance
+ logical::wantDeriv
+ real(kind=8),pointer,dimension(:)::A_Ietax
integer::iel, numEl, itot, ipos
real(kind=8)::ener
- logical::wantDeriv
- integer::niso, is, id
- real(kind=8)::Sigma, F, A, v1, v2
- integer::iflKjetan
-
-
+ logical::wantDerivLocal
+ integer::niso, is, id, isize, K1, K2, k
+ real(kind=8)::Sigma, F, A, v1, v2, A1, A2, A3, Etan, D, C
+ real(kind=8)::sigFis, sigAbs, sigEta, val
+ real(kind=8)::dsigFis, dsigAbs, dsigEta
+ integer::ifl
+ logical::set
+
+
+ !
+ ! eta = fis_det_eff * sigma_fis/(Sigma_cap *cap_det_eff + fis_det_eff * sigma_fis) *etanu
+ ! where etan can be energy dependent
+ ! fis_det_eff, cap_det_eff (detector efficiencies) can be varied, etanu can be varied
+ !
+ ! At the beginning of the routine sigma_fis is stored in this%driver%calcData%getDataNs(*, 1, 0 , iso)
+ ! sigma_abs is stored in this%driver%calcData%getDataNs(*, 2, 0 , iso)
+ ! and Nnnsig=2
+ ! at the end eta is stored in
+ ! this%driver%calcData%getDataNs(*, 1, 0 , iso)
+ ! and Nnnsig=1
+
+ isize = size(A_Iprmsc)
+ A_Ietax => A_Iprmsc(Kjetan:isize)
+ if (size(A_Ietax).lt.mjetan) then
+ STOP '[STOP in ZeroKCrossCorrections_Fix_Eta A_Iprmsc is too small ]'
+ end if
+ wantDerivLocal = this%driver%calculator%wantDerivs
+ if (.not.wantDerivLocal) then
+ IF (Kefcap.NE.0) THEN
+ set = this%driver%calculator%setDerivFlag(I_Iflmsc(Kefcap), wantDeriv)
+ if (set) wantDerivLocal = .true.
+ end if
+ IF (Keffis.NE.0) THEN
+ set = this%driver%calculator%setDerivFlag(I_Iflmsc(Keffis), wantDeriv)
+ if (set) wantDerivLocal = .true.
+ end if
+ do k = 1,Mjetan
+ Ifl = K+Kjetan-1
+ if (Ifl.gt.0.and.ifl.le.size(I_Iflmsc)) then
+ set = this%driver%calculator%setDerivFlag(I_Iflmsc(Ifl), wantDeriv)
+ if (set) wantDerivLocal = .true.
+ end if
+ end do
+ end if
numEl = grid%getNumEnergies(expData)
ipos = 0
@@ -341,55 +369,152 @@ contains
niso = this%driver%calcData%getNumberIsotopes()
if (this%driver%calcData%getNnnsig().lt.2) then
- write(0,*)" Need Nnnsig=2 if calculating eta"
+ write(6,*)" Need Nnnsig=2 if calculating eta"
+ write(21,*)" Need Nnnsig=2 if calculating eta"
stop
end if
- wantDeriv = this%driver%getWantDerivs()
- iflKjetan = Kjetan
- if (iflKjetan.ne.0) then
- iflKjetan = I_Iflmsc(Kjetan)
- end if
- if (.not.wantDeriv.and.iflKjetan.gt.0) then
- if (ksolve.ne.2) then
- wantDeriv = .true.
- else
- if ( covariance%isPupedParameter(iflKjetan)) then
- wantDeriv = .true.
- end if
- end if
- end if
-
- if (wantDeriv) itot = covariance%getNumTotalParam()
+ if (wantDerivLocal) itot = covariance%getNumTotalParam()
do iel = 1, numEl
ener = grid%getEnergy(iel, expData)
if (ener.lt.0.0d0.and..not.this%wantNeg) cycle
+
ipos = ipos + 1
+ IF (Mjetan.GT.1) THEN
+ Etan = A_Interp (dAbs(ener), A_Ietax, A_Ietaee, Mjetan, A1, A2, K1,K2)
+ ELSE
+ Etan = Etanuu
+ A1 = 1.0d0
+ A2 = 0.0d0
+ K1 = 1
+ K2 = 0
+ END IF
+
do is = 1, niso
- Sigma = this%driver%calcData%getDataNs(ipos, 1, 0 , is)
- F = this%driver%calcData%getDataNs(ipos, 2, 0 , is)
- A = Sigma - F
+ sigFis = this%driver%calcData%getDataNs(ipos, 1, 0 , is)
+ sigAbs = this%driver%calcData%getDataNs(ipos, 2, 0 , is)
+
+ if(sigFis.eq.0.0d0.and.sigAbs.eq.0.0d0) cycle
+
+ IF (Kefcap.EQ.0) THEN
+ A3 = sigFis/sigAbs
+ sigEta = A3*Etan
+ ELSE
+ C = (sigAbs-sigFis)*Effcap
+ F = sigFis*Efffis
+ A3 = F/(F+C)
+ sigEta = A3*Etan
+ END IF
+ val = sigEta
+ if (ener.lt.0) val = -val
+ call this%driver%calcData%addData(ipos, 0, Is, val)
+
do id = 1, itot
- v1 = this%driver%calcData%getDataNs(ipos, 1, id , is)
- v2 = this%driver%calcData%getDataNs(ipos, 2, id , is)
- v1 = Etanuu * ( v2*(A/Sigma) - v1*(F/Sigma) )/Sigma
- if (v1.ne.0.0d0) then
- call this%driver%calcData%addDataNs(ipos, 1, id, is, v1)
- end if
+ dsigFis = this%driver%calcData%getDataNs(ipos, 1, id , is)
+ dsigAbs = this%driver%calcData%getDataNs(ipos, 2, id , is)
+
+ if (dsigFis.eq.0.0d0.and.dsigAbs.eq.0.0d0) cycle
+
+ IF (Kefcap.EQ.0) THEN
+ dsigEta=Etan*(dsigFis-dsigAbs*sigFis/sigAbs)/sigAbs
+ else
+ D = sigAbs*Effcap + sigFis*(Efffis-Effcap)
+ dsigEta = Etan/D * ( dsigFis*Efffis - &
+ sigFis*Efffis/D* (dsigAbs*Effcap + &
+ dsigFis*(Efffis-Effcap)) )
+ END IF
+ val = dsigEta
+ if (ener.lt.0) val = -val
+ call this%driver%calcData%addData(ipos, Id, Is, val)
end do
- if (wantDeriv.and.iflKjetan.gt.0) then
- v1 = Sigma/Etanuu
- call this%driver%calcData%addDataNs(ipos, 1, iflKjetan, is, v1)
+ IF (Kefcap.NE.0) THEN
+ Ifl = I_Iflmsc(Kefcap)
+ IF (Ifl.GT.0) THEN
+ D = F + C
+ val = - sigEta*(sigAbs-sigFis)/D
+ call this%driver%calcData%addData(ipos, ifl, Is, val)
+ END IF
+ Ifl = I_Iflmsc(Keffis)
+ IF (Ifl.GT.0) THEN
+ D = F + C
+ val =sigEta*C/(D*Efffis)
+ call this%driver%calcData%addData(ipos, ifl, Is, val)
+ END IF
+ END IF
+ Ifl = K1+Kjetan-1
+ if (Ifl.gt.0.and.ifl.le.size(I_Iflmsc)) then
+ Ifl = I_Iflmsc(Ifl)
+ else
+ Ifl = 0
+ end if
+ IF (Ifl.GT.0) THEN
+ val = A1*A3
+ call this%driver%calcData%addData(ipos, Ifl, Is, val)
+ END IF
+ if (K2.gt.0) then
+ Ifl = K2+Kjetan-1
+ if (Ifl.gt.0.and.ifl.le.size(I_Iflmsc)) then
+ Ifl = I_Iflmsc(Ifl)
+ else
+ Ifl = 0
+ end if
+ IF (Ifl.GT.0) THEN
+ val = A2 * A3
+ call this%driver%calcData%addData(ipos, Ifl, Is, val)
+ END IF
end if
end do
end do
+ call this%driver%calcData%setNnsig(1)
end subroutine
-
- subroutine ZeroKCrossCorrections_AddParam(this, grid, expData, covariance)
+ Double Precision Function A_Interp (Su, Etanux, Etaeee, Mjetan, &
+ A1, A2, Keta1, Keta2)
+!
+! *** Purpose -- Find A_Interp = value of Etanux (nu) at energy Su
+! *** for this run.
+!
+ real(kind=8):: Etanux(*), Etaeee(*)
+ real(kind=8)::Su, A1, A2
+ integer::Mjetan, Keta1, Keta2
+ real(kind=8)::A, De, E1, E2
+ integer::K
+
+ IF (Su.LT.Etaeee(1)) THEN
+ A_Interp = Etanux(1)
+ Keta1 = 1
+ Keta2 = 0
+ A1 = 1.0d0
+ A2 = 0.0d0
+ RETURN
+ END IF
+ DO K=2,Mjetan
+ IF (Su.LT.Etaeee(K)) GO TO 10
+ END DO
+ A_Interp = Etanux(Mjetan)
+ Keta1 = Mjetan
+ Keta2 = 0
+ A1 = 1.0d0
+ A2 = 0.0d0
+ RETURN
+10 CONTINUE
+ E1 = Etaeee(K-1)
+ E2 = Etaeee(K )
+ De = E2 - E1
+ A1 = (E2-Su)/De
+ A2 = (Su-E1)/De
+ A = A1*Etanux(K) + A2*Etanux(K-1)
+ A_Interp = A
+ Keta1 = K - 1
+ Keta2 = K
+ RETURN
+ END function
+
+
+ subroutine ZeroKCrossCorrections_AddParam(this, grid, expData, covariance, wantDeriv)
use SammyGridAccess_M
use paramagnetic_cross_m
use GridData_M
@@ -401,11 +526,12 @@ contains
type(SammyGridAccess)::grid
type(GridDataList)::expData
type(CovarianceData)::covariance
+ logical::wantDeriv
integer::iel, numEl, ipos, iso, numIso, ns
real(kind=8)::ener, abund, pmc
integer::ourIso, ii, Ifl, i
- logical::wantPara, wantDeriv
+ logical::wantPara, wantDerivLocal, set
logical(C_BOOL)::accu
@@ -424,20 +550,13 @@ contains
call this%driver%calcData%setAccumulate(accu)
call this%driver%calcDataSelf%setAccumulate(accu)
- wantDeriv = this%driver%getWantDerivs()
-
- if (.not.wantDeriv) then ! check for pup'ed
+ wantDerivLocal = wantDeriv
+ if (.not.wantDerivLocal) then ! check for pup'ed
do ii = 1,Numpmc
do i = 1, 4
Ifl = I_Iflpmc(i, ii)
- if (Ifl.le.0) cycle
- if (ksolve.ne.2) then
- wantDeriv = .true.
- else
- if ( covariance%isPupedParameter(Ifl)) then
- wantDeriv = .true.
- end if
- end if
+ set = this%driver%calculator%setDerivFlag(ifl, wantDeriv)
+ if (set) wantDerivLocal = .true.
end do
end do
end if
@@ -459,7 +578,7 @@ contains
call this%driver%calcDataSelf%addDataNs(ipos, 1, 0, ii, pmc)
end if
- if (wantDeriv) then
+ if (wantDerivLocal) then
if (this%driver%calculator%reactType.eq.1) then
call Dddpmc (A_Iprpmc, I_Iflpmc, I_Isopmc, Numpmc, iso, ii, abund, ener, this%driver%calcData, ipos, Ns)
else if (this%driver%calculator%reactType.eq.8) then
diff --git a/sammy/src/the/mthe0.f90 b/sammy/src/the/mthe0.f90
index 7a05f90ce..73befac0a 100644
--- a/sammy/src/the/mthe0.f90
+++ b/sammy/src/the/mthe0.f90
@@ -97,6 +97,8 @@ module mthe0_M
call Orgbro ! set up which segment to call and some other global parameters
call setup_zeroK ! initialize the object that does the 0k reconstruction
+ ! todo: Change the code so we don't actually allocate A_Idifma and Difmax
+ zeroKCalc%driver%calculator%Difmax(1:Nres) = A_Idifma(1:Nres)
! set up the energy grid on which the data are calculated
call grid%initialize()
@@ -129,15 +131,21 @@ module mthe0_M
STOP '[STOP in Samthe_0 in the/mthe0.f]'
END If
- if (kcros.eq.6.and.Krmatx.ne.2) then
- call zeroKCalc%Fix_Eta(grid, expData, covData) ! calculate eta if needed
+ if (Ksolve.eq.2) then
+ wantDeriv = .false.
+ else
+ wantDeriv = .true.
+ end if
+
+ if (kcros.eq.6) then
+ call zeroKCalc%Fix_Eta(grid, expData, covData, wantDeriv) ! calculate eta if needed
end if
if (Kfake.ne.1) then ! normal additional correction as needed
- call zeroKCalc%AddParam(grid, expData, covData) ! add paramagnetic cross section if desired
- call zeroKCalc%addFile3(grid, expData) ! add file 3 data if needed
- call zeroKCalc%convertToTrans(grid, expData, covData) ! convert to transmission if needed
- call zeroKCalc%applyNorm(grid, expData, covData) ! apply normalization and background if needed
+ call zeroKCalc%AddParam(grid, expData, covData, wantDeriv) ! add paramagnetic cross section if desired
+ call zeroKCalc%addFile3(grid, expData) ! add file 3 data if needed
+ call zeroKCalc%convertToTrans(grid, expData, covData, wantDeriv) ! convert to transmission if needed
+ call zeroKCalc%applyNorm(grid, expData, covData, wantDeriv) ! apply normalization and background if needed
end if
call zeroKCalc%setTheory(A_Ith, Nnnsig) ! set theory if no further work is required
if (Kfake.eq.1) then
diff --git a/sammy/src/the/mthe1.f90 b/sammy/src/the/mthe1.f90
index 294df9b36..f6bdbddda 100644
--- a/sammy/src/the/mthe1.f90
+++ b/sammy/src/the/mthe1.f90
@@ -8,13 +8,10 @@ module mthe1_m
!
! *** PURPOSE -- GENERATE Nnpar, and Difmax
!
- use fixedi_m, only : Nfpres, Numcro, Nvpres, Ntotc, &
- needResDerivs
+ use fixedi_m, only : Numcro
use fixedr_m, only : Emax, Emin
use ifwrit_m, only : Kdecpl, Kscut, Ksolve, ktzero, Ndat
use broad_common_m, only : Dopple, Iesopr
- use templc_common_m, only : I_Inotu
- use AllocateFunctions_m
use EndfData_common_m
use SammyResonanceInfo_M
use RMatResonanceParam_M
@@ -52,7 +49,6 @@ module mthe1_m
END If
!
Napres = 0
- needResDerivs = .false.
havePups = .false.
icomp = 0
! *** Use cutoff on derivatives
@@ -62,8 +58,6 @@ module mthe1_m
G = Zero
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)
@@ -123,16 +117,7 @@ module mthe1_m
end if
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
@@ -184,8 +169,7 @@ module mthe1_m
END IF
END IF
if (Iuif.eq.1) then
- call covData%addToIrrelevant(Iflr)
- I_Inotu(Napres) = 0
+ call covData%addToIrrelevant(Iflr)
else
if (covData%isPupedParameter(Iflr)) then
havePups = .true.
@@ -197,15 +181,6 @@ module mthe1_m
END DO
END IF
- if (napres.gt.0) then
- needResDerivs = .true.
- end if
-
- if( Ksolve.eq.2) then
- needResDerivs = .false.
- if (havePups) needResDerivs = .true.
- end if
-
!
call gridAccess%destroy()
RETURN
@@ -252,66 +227,6 @@ module mthe1_m
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
!
!
! --------------------------------------------------------------
diff --git a/sammy/src/xct/XctCrossCalc_M.f90 b/sammy/src/xct/XctCrossCalc_M.f90
index c18f7aaab..8897a3acb 100644
--- a/sammy/src/xct/XctCrossCalc_M.f90
+++ b/sammy/src/xct/XctCrossCalc_M.f90
@@ -12,8 +12,10 @@ module XctCrossCalc_M
! do we need the cross sections for a given channel
! this is assuming first width is gamma and is not counted, and all other width are as in normal sammy definition
logical,allocatable,dimension(:)::Ifcros(:)
+ logical::separateIso
type(DerivativeHandler)::crossDataSelf ! the self indicated cross section and derivative calculated for a given energy
+ logical,allocatable,dimension(:)::crossSelfWhy ! reproduce a SAMMY bug for self-indication experiments. To Do fix the bug instead
integer::lllmax = 0 ! maximum number of Clebsch-Gordon coefficients
integer::Kfinit = 0 ! finite-size corrections flag
@@ -29,8 +31,8 @@ module XctCrossCalc_M
integer::Kslow = 0 ! should we use the slow or fast version of Clebsch-Gordon calculation
integer::C_G_Kxlmn = 1
- integer::Ifdif = 0 ! Ifdif = 1 if need differential elastic, Ifdif = 2 if need differential reaction
integer::Ifcoul = 0 ! do we need to calculate coulomb data
+ logical::addElimKapt !ADD ELIMINATED CAPTURE CHANNEL TO FINA
real(kind=8),allocatable,dimension(:,:)::Alj ! used to count the number of Clebsch-Gordon coefficients
real(kind=8),allocatable,dimension(:)::Xx ! 0.0 or if SHIFT RESONANCE ENERGIES VIA SHIFT FACTOR, the factor
@@ -40,23 +42,55 @@ module XctCrossCalc_M
real(kind=8),allocatable,dimension(:,:)::Br, Bi ! energy independent part of derivatives for resonance parameters
real(kind=8),allocatable,dimension(:,:,:)::Bga !E ENERGY-INDEPENDENT PORTION OF PARTIAL of R wrt reduced-width-amplitudes (for those which are not varied)
+ real(kind=8),allocatable,dimension(:,:,:)::Pgar, Pgai ! ENERGY-INDEPENDENT PORTION OF PARTIAL of R wrt reduced-width-amplitudes (for those which are not varied)
real(kind=8),allocatable,dimension(:)::Alphar ! (DEL E) / ( (DEL E)**2 + (Gamgam/2)**2 )
real(kind=8),allocatable,dimension(:)::Alphai ! Gamgam/2 / ( (DEL E)**2 + (Gamgam/2)**2 )
logical,allocatable,dimension(:)::needAlphai ! is Alphai big enough that it needs to be calculated and added
real(kind=8),allocatable,dimension(:)::Difen ! resonance energy minus currrent energy or 0 if resonance is not included in calculation
- real(kind=8),allocatable,dimension(:)::Difmax ! if Difen for a given resonance is less than Difmax, we set needAlphai true
+
real(kind=8),allocatable,dimension(:,:)::Pi, Pr
- ! note these are temporary also here so that we can
- ! refactor without dependencies on array_sizes_common
- real(kind=8),allocatable,dimension(:)::A_Isigxx, A_Idasig, A_Idbsig
- real(kind=8),allocatable,dimension(:)::A_Isigsi, A_Idasis, A_Idbsis
+ real(kind=8),allocatable,dimension(:,:)::Cscs
+ real(kind=8),allocatable,dimension(:)::Sinsqr ! sin^2( phase shift )
+ real(kind=8),allocatable,dimension(:)::Sin2ph ! sin( 2 * phase shift )
+ real(kind=8),allocatable,dimension(:)::Dphi
+ real(kind=8),allocatable,dimension(:)::Sinphi, Cosphi
+ real(kind=8),allocatable,dimension(:)::Dpdr ! partial P wrt Rho
+ real(kind=8),allocatable,dimension(:)::Dsdr ! partial S wrt Rho
+
+ real(kind=8),allocatable,dimension(:,:)::Rmat, Ymat, Yinv
+ real(kind=8),allocatable,dimension(:)::Rootp
+ real(kind=8),allocatable,dimension(:)::Elinvr,Elinvi
+ real(kind=8),allocatable,dimension(:)::Psmall
+ real(kind=8),allocatable,dimension(:)::Xxxxr, Xxxxi
+ real(kind=8),allocatable,dimension(:,:)::Xqr,Xqi
+ real(kind=8),allocatable,dimension(:,:)::Pxrhor, Pxrhoi
+ real(kind=8),allocatable,dimension(:,:)::Qr, Qi
+ real(kind=8),allocatable,dimension(:,:)::Tr, Ti
+ real(kind=8),allocatable,dimension(:,:,:)::Tx
+ real(kind=8),allocatable,dimension(:)::Ddddd, Ddddtl
+ logical,allocatable, dimension(:,:)::useChannel
+ real(kind=8),allocatable,dimension(:,:)::Prei, Prer
+ real(kind=8),allocatable,dimension(:)::Dsf
+ real(kind=8),allocatable,dimension(:,:,:)::Dsfx, Dstx
+ real(kind=8),allocatable,dimension(:,:)::Dstt, Dst
+ real(kind=8),allocatable,dimension(:)::Xden
+
+ real(kind=8),allocatable,dimension(:)::termf, termfx
+
+ real(kind=8),allocatable,dimension(:,:,:)::crossInternal ! used to keep track of cross section+deriv for one row and all channels
+ real(kind=8),allocatable,dimension(:,:,:,:,:)::angInternal ! used to keep track of angula section+deriv for one row and all channels
+ real(kind=8),allocatable,dimension(:)::uniqueEchan ! the unique value of echan for a given isotope, used as a scratch array during calculation
+ integer,allocatable,dimension(:)::iradIndex ! map radius id
+
+ real(kind=8),allocatable,dimension(:,:)::Ccoulx
contains
procedure, pass(this) :: setUpDerivativeList => XctCrossCalc_setUpDerivativeList ! set up crossData, depending on number of isotopes
procedure, pass(this) :: setAddtionalParams => XctCrossCalc_setAddtionalParams
procedure, pass(this) :: setEnergyIndependent => XctCrossCalc_setEnergyIndependent ! set energy independent values using current parameter values
+ procedure, pass(this) :: getParamPerSpinGroup => XctCrossCalc_getParamPerSpinGroup ! also fill useChannel
procedure, pass(this) :: calcCross => XctCrossCalc_calcCross
procedure, pass(this) :: initialize => XctCrossCalc_initialize
procedure, pass(this) :: destroy => XctCrossCalc_destroy
@@ -89,6 +123,7 @@ subroutine XctCrossCalc_setAddtionalParams(this, lllmax, Kfinit, wantSelfIndica
end if
this%Kfinit = Kfinit
+ if (Kfinit.ne.0) this%Ifcros = .true. ! need all cross sections
this%lllmax = lllmax
this%Kssmsc = Kssmsc
@@ -131,13 +166,23 @@ subroutine XctCrossCalc_setEnergyIndependent(this, reactType, Twomhb, kwcoul, Et
call CrossSectionCalculator_setEnergyIndependent(this, reactType, Twomhb, kwcoul, Etac)
+ ! set bounds
+ call this%setBound(Twomhb, kwcoul, Etac)
+
! calculate energy shift if needed
if (this%doResShift) then
call Fixx (this, this%XX, this%XxHelper)
end if
! determine whether we need coulomb interaction
- call Find_If_Coulomb (this, this%IfCoul, this%Ifdif)
+ call Find_If_Coulomb (this, this%IfCoul)
+
+ if (this%Ifcoul.gt.0) then
+ if (.not.allocated(this%Ccoulx)) then
+ allocate(this%Ccoulx(this%ntotc, this%resData%getNumSpinGroups()))
+ end if
+ call Start_Coul (this%Zke, this%Ccoulx, this%resData)
+ end if
end subroutine
subroutine XctCrossCalc_calcCross(this, ener, Ipoten)
class(XctCrossCalc):: this
@@ -160,27 +205,85 @@ subroutine XctCrossCalc_setUpDerivativeList(this)
call CrossSectionCalculator_setUpDerivativeList(this)
-
- ! initially set all shared isotope IDs to 1
- numIso = this%crossData%getNumberIsotopes()
- if (numIso.gt.1) then
- itot = this%covariance%getNumTotalParam() + 1
- do i = 1, itot
- ii = this%crossData%getIsotopeForShared(i)
- if (ii.gt.0) then
- call this%crossData%addSharedColumn(i, 1)
- if (this%wantSelfIndicate) then
- call this%crossDataSelf%addSharedColumn(i, 1)
- end if
- end if
- end do
- end if
-
if (this%wantSelfIndicate) then
call this%crossDataSelf%nullify()
call this%crossDataSelf%setNnsig(1)
end if
end subroutine
+subroutine XctCrossCalc_getParamPerSpinGroup(this, ires, igr, fillIt)
+ class(XctCrossCalc) :: this
+ integer,intent(inout)::ires ! starting resonance for this group
+ integer,intent(in)::igr ! spin group for which to get the number of varied parameters
+ logical,intent(in)::fillIt
+
+ type(SammySpinGroupInfo):: spinInfo
+ type(SammyChannelInfo)::channelInfo
+ integer::Ichan
+ integer::k, nent
+ logical::inc, fillLocal
+ optional fillIt
+
+ fillLocal = .true.
+ if (present(fillIt)) fillLocal = fillIt
+ call CrossSectionCalculator_getParamPerSpinGroup(this, ires, igr, fillLocal)
+ if (.not.fillLocal) return ! for getting the number of parameters, not for filling data
+
+ this%useChannel(:,1) = .false.
+ call this%resData%getSpinGroupInfo(spinInfo, igr)
+ nent = spinInfo%getNumEntryChannels()
+
+ ! 1-d data
+ do ichan = 1, this%ntotc + 1
+ if (.not.this%Ifcros(ichan)) cycle
+
+ if (ichan.le.2) then
+ this%useChannel(ichan, 1) = .true.
+ cycle
+ end if
+
+ k = Ichan-2+Nent
+ inc = .true.
+ if (k.le.spinInfo%getNumChannels()) then
+ call spinInfo%getChannelInfo(channelInfo, k)
+ inc = channelInfo%getIncludeInCalc()
+ end if
+ if (inc) then
+ if (.not.this%addElimKapt) then
+ this%useChannel(ichan, 1) = .true.
+ end if
+ else
+ if (this%addElimKapt) then
+ this%useChannel(ichan, 1) = .true.
+ end if
+ end if
+ end do
+
+ ! 2-d data
+ if (.not.this%needAngular) return
+ this%useChannel(:,2) = .true.
+ do ichan = 1, this%ntotc + 1
+ IF (this%reactType.ne.11) then ! elastic
+ if(Ichan.GT.Nent) this%useChannel(ichan, 2) = .false. ! but not an elastic channel
+ ELSE ! reaction of some kind
+ inc = .true.
+ if (ichan.le.spinInfo%getNumChannels()) then
+ call spinInfo%getChannelInfo(channelInfo, ichan)
+ inc = channelInfo%getIncludeInCalc()
+ if (channelInfo%getExcludeCompletely()) then
+ this%useChannel(ichan, 2) = .false. ! Do not want it anywhere
+ cycle
+ end if
+ end if
+ IF (Ichan.LE.Nent) THEN
+ this%useChannel(ichan, 2) = .false. ! Do not want elastic
+ else if (channelInfo%getIncludeInCalc()) then
+ if ( this%addElimKapt) this%useChannel(ichan, 2) = .false. ! Will subtract only excluded channels from absorption
+ else ! normally excclude but calc%addElimKapt.eq.true overrides exclusion
+ IF (.not.this%addElimKapt) this%useChannel(ichan, 2) = .false. ! Do not want excluded channel in final state
+ END IF
+ END IF
+ end do
+end subroutine
subroutine XctCrossCalc_initialize(this, pars, cov, rad, niso, needAngular, Itzero, Ilzero, doShiftRes)
class(XctCrossCalc) :: this
type(SammyRMatrixParameters)::pars
@@ -191,10 +294,14 @@ subroutine XctCrossCalc_initialize(this, pars, cov, rad, niso, needAngular, Itze
integer::ntot
logical,intent(in)::needAngular, doShiftRes
- integer::itot, ipup, irad, nres
+ integer::itot, ipup, irad, nres, ngroup, igr, ichan, ifl
logical(C_BOOL)::countCombined
+ type(SammySpinGroupInfo)::spinInfo
call CrossSectionCalculator_initialize(this, pars, cov, rad, niso, needAngular, Itzero, Ilzero, doShiftRes)
+ this%separateIso = .true.
+ this%addElimKapt = .false.
+ if (niso.eq.1) this%separateIso = .false.
call info%initialize(pars, cov, rad)
ntot = info%getMaxChannel()
@@ -202,18 +309,38 @@ subroutine XctCrossCalc_initialize(this, pars, cov, rad, niso, needAngular, Itze
allocate(this%Ifcros(ntot))
this%Ifcros = .true. ! assume cross sections are to be calculated for all channels
+ call allocate_real_data(this%termf, max(2,ntot))
+ call allocate_real_data(this%termfx, max(2,ntot))
+
this%ntotc = info%getMaxChannel() -1 ! for most of the internal arrays the gamma channel is not used in the internal arrays
this%ntriag = (this%ntotc*(this%ntotc+1))/2
countCombined = .true.
call info%getNumAll(itot, ipup, countCombined)
+ if(this%Itzero.gt.0 .or. this%Ilzero.gt.0) itot = itot + 2
irad = this%radiusData%getNumTotalVaried()
nres = this%resData%getNumResonances()
+ ngroup = this%resData%getNumSpinGroups()
call info%destroy()
call allocate_real_data(this%Alphai, nres)
call allocate_real_data(this%Alphar, nres)
allocate(this%needAlphai(nres))
call allocate_real_data(this%Difen, nres)
+ call allocate_real_data(this%Xden, nres)
+
+ if (this%Itzero.gt.0 .or. this%Ilzero.gt.0) then
+ call reallocate_real_data_2d(this%Prer, this%ntriag, 0, ngroup, 0)
+ call reallocate_real_data_2d(this%Prei, this%ntriag, 0, ngroup, 0)
+ end if
+ if (this%Itzero.gt.0 .or. this%Ilzero.gt.0.or.irad.gt.0) then
+ allocate(this%Dstt(this%ntotc, this%ntotc))
+ allocate(this%Dst(2, this%ntotc))
+ call allocate_real_data(this%Dsf, this%ntotc+1) ! for all reacttions
+ if (this%needAngular) then
+ allocate(this%Dsfx(2, this%ntotc, this%ntotc))
+ allocate(this%Dstx(2, this%ntotc, this%ntotc))
+ end if
+ end if
if (doShiftRes) then
call allocate_real_data(this%Xx, pars%getNumResonances())
@@ -225,17 +352,100 @@ subroutine XctCrossCalc_initialize(this, pars, cov, rad, niso, needAngular, Itze
call reallocate_real_data_2d(this%Bi, this%ntriag, 0, itot, 0)
call reallocate_real_data_2d(this%Pr, this%ntriag, 0, itot, 0)
call reallocate_real_data_2d(this%Pi, this%ntriag, 0, itot, 0)
+ call reallocate_real_data_2d(this%Qr, this%ntriag, 0, this%ntriag, 0)
+ call reallocate_real_data_2d(this%Qi, this%ntriag, 0, this%ntriag, 0)
+ call reallocate_real_data_2d(this%Tr, this%ntotc+1, 0, this%ntriag, 0)
+ call reallocate_real_data_2d(this%Ti, this%ntotc+1, 0, this%ntriag, 0)
+ call allocate_real_data(this%Ddddd, this%ntotc+1) ! derivative calculated for all entry channels
+ call allocate_real_data(this%Ddddtl, this%ntotc+1)
+ if (this%needAngular) then
+ allocate(this%Tx(2, this%ntriag, this%ntriag))
+ end if
+ end if
+ allocate(this%useChannel(this%ntotc+1,2))
+ allocate(this%crossSelfWhy(this%covariance%getNumTotalParam()+1))
+
+
+ call reallocate_real_data_2d(this%Rmat, 2, 0, this%ntriag, 0)
+ call reallocate_real_data_2d(this%Ymat, 2, 0, this%ntriag, 0)
+ call reallocate_real_data_2d(this%Yinv, 2, 0, this%ntriag, 0)
+
+ call allocate_real_data(this%Xxxxr, this%ntriag)
+ call allocate_real_data(this%Xxxxi, this%ntriag)
+ call reallocate_real_data_2d(this%Xqr, this%ntotc, 0, this%ntotc, 0)
+ call reallocate_real_data_2d(this%Xqi, this%ntotc, 0, this%ntotc, 0)
+
+
+ call reallocate_real_data_2d(this%Bound, this%ntotc, 0, ngroup, 0)
+
+ if (this%needAngular) then
+ call reallocate_real_data_2d(this%Cscs, 2, 0, this%ntriag, 0)
+ end if
+
+ call allocate_real_data(this%Sinsqr, this%ntotc)
+ call allocate_real_data(this%Sin2ph, this%ntotc)
+ call allocate_real_data(this%Dphi, this%ntotc)
+ call allocate_real_data(this%Sinphi, this%ntotc)
+ call allocate_real_data(this%Cosphi, this%ntotc)
+ call allocate_real_data(this%Rootp, this%ntotc)
+ call allocate_real_data(this%Elinvr, this%ntotc)
+ call allocate_real_data(this%Elinvi, this%ntotc)
+ call allocate_real_data(this%Psmall, this%ntotc)
+
+
+ if (this%Itzero.ne.0 .or. this%Ilzero.ne.0 .OR. irad.gt.0) then
+ call allocate_real_data(this%Dpdr, this%ntotc)
+ call allocate_real_data(this%Dsdr, this%ntotc)
+ call reallocate_real_data_2d(this%Pxrhor, this%ntriag, 0, this%ntotc, 0)
+ call reallocate_real_data_2d(this%Pxrhoi, this%ntriag, 0, this%ntotc, 0)
end if
if (irad.gt.0) then
if( nres.gt.0) allocate(this%Bga(this%ntriag, this%ntotc, nres))
+
+ ! collect the unique fit flags for the true radius
+ ! in iradIndex
+ allocate(this%iradIndex(irad))
+ this%iradIndex = 0
+ irad = 0
+ do igr = 1, ngroup
+ call this%resData%getSpinGroupInfo(spinInfo,igr)
+ DO ichan=1, spinInfo%getNumChannels()
+ ifl = this%radiusData%getTrueFitFlag(Igr, Ichan)
+ if (ifl.eq.0) cycle
+ ! check whether we need to add it
+ if (.not.any(this%iradIndex.eq.ifl)) then
+ irad = irad + 1
+ this%iradIndex(irad) = ifl
+ end if
+ end do
+ end do
+ ! the new irad might be smaller than the first irad in case some of the true radii are linked
+ if (irad.ne.0) then ! none of the true radii is fitted
+ allocate(this%Pgar(this%ntriag, irad, ngroup))
+ allocate(this%Pgai(this%ntriag, irad, ngroup))
+ end if
end if
+
+ allocate(this%crossInternal(ntot, this%resData%getNumSpinGroups(), 0:this%covariance%getNumTotalParam()))
+
+ if (this%needAngular) then
+ allocate(this%angInternal(2, ntot, ntot, this%resData%getNumSpinGroups(), 0:this%covariance%getNumTotalParam()))
+ allocate(this%uniqueEchan(this%numIso))
+ end if
+
end subroutine
subroutine XctCrossCalc_destroy(this)
class(XctCrossCalc) :: this
call CrossSectionCalculator_destroy(this)
deallocate(this%Ifcros)
+ deallocate(this%termf)
+ deallocate(this%termfx)
+ deallocate(this%crossInternal)
+ if (allocated(this%angInternal)) deallocate(this%angInternal)
+ if (allocated(this%uniqueEchan)) deallocate(this%uniqueEchan)
+ deallocate(this%Bound)
if (allocated(this%Alj)) deallocate(this%Alj)
if (allocated(this%Xx)) deallocate(this%Xx)
@@ -247,10 +457,54 @@ subroutine XctCrossCalc_destroy(this)
if (allocated(this%Pr)) deallocate(this%Pr)
if (allocated(this%Pi)) deallocate(this%Pi)
if (allocated(this%Bga)) deallocate(this%Bga)
+ if(allocated(this%Pgar)) deallocate(this%Pgar)
+ if(allocated(this%Pgai)) deallocate(this%Pgai)
if (allocated(this%Alphai)) deallocate(this%Alphai)
if (allocated(this%Alphar)) deallocate(this%Alphar)
if (allocated(this%needAlphai)) deallocate(this%needAlphai)
if (allocated(this%Difen)) deallocate(this%Difen)
+ if (allocated(this%iradIndex)) deallocate(this%iradIndex)
+ if (allocated(this%Cscs)) deallocate(this%Cscs)
+ deallocate(this%Sinsqr)
+ deallocate(this%Sin2ph)
+ deallocate(this%Dphi)
+ deallocate(this%Sinphi)
+ deallocate(this%Cosphi)
+ if (allocated(this%Dpdr)) deallocate(this%Dpdr)
+ if (allocated(this%Dsdr)) deallocate(this%Dsdr)
+ if( allocated(this%Ddddd)) deallocate(this%Ddddd)
+ if( allocated(this%Ddddtl)) deallocate(this%Ddddtl)
+ if( allocated(this%useChannel)) deallocate(this%useChannel)
+ if(allocated(this%Prer)) deallocate(this%Prer)
+ if(allocated(this%Prei)) deallocate(this%Prei)
+ if (allocated(this%Dsf)) deallocate(this%Dsf)
+ if (allocated(this%Dsfx)) deallocate(this%Dsfx)
+ if (allocated(this%Dsf)) deallocate(this%Dsf)
+ if (allocated(this%Dstx)) deallocate(this%Dstx)
+ if (allocated(this%Dstt)) deallocate(this%Dstt)
+ if (allocated(this%Dst)) deallocate(this%Dst)
+ deallocate(this%Rmat)
+ deallocate(this%Ymat)
+ deallocate(this%Yinv)
+ deallocate(this%Rootp)
+ deallocate(this%Elinvr)
+ deallocate(this%Elinvi)
+ deallocate(this%Psmall)
+ deallocate(this%Xxxxr)
+ deallocate(this%Xxxxi)
+ deallocate(this%Xqr)
+ deallocate(this%Xqi)
+ deallocate(this%Xden)
+ if(allocated(this%Qr))deallocate(this%Qr)
+ if(allocated(this%Qi)) deallocate(this%Qi)
+ if(allocated(this%Tr)) deallocate(this%Tr)
+ if(allocated(this%Ti)) deallocate(this%Ti)
+ if(allocated(this%Tx)) deallocate(this%Tx)
+ if(allocated(this%Pxrhor)) deallocate(this%Pxrhor)
+ if(allocated(this%Pxrhoi)) deallocate(this%Pxrhoi)
+ if(allocated(this%Ccoulx)) deallocate(this%Ccoulx)
+
+ if (allocated(this%crossSelfWhy)) deallocate(this%crossSelfWhy)
end subroutine
end module XctCrossCalc_M
diff --git a/sammy/src/xct/mxct0.f90 b/sammy/src/xct/mxct0.f90
index c116e4e16..cca0ec9a4 100644
--- a/sammy/src/xct/mxct0.f90
+++ b/sammy/src/xct/mxct0.f90
@@ -33,9 +33,9 @@ module xct_m
character(len=80)::line
integer::iflagMatch
integer::Idimen
- integer::K_Coul_N, Kslow, Lllmmm, Mxany, N, Neight, Nfive1, Nfive1x, Nfive2, Nfive3, Nfive3x, Nfive4, Nfour
- integer::Ifinal, Krext, Nfour1, Nfour2, Ng, Nnine, Nsix, Nthr1, Nthr2, Nthr3, ntwo1, numElAux, Nw1
- integer::Nnndrc
+ integer::K_Coul_N, Lllmmm, Mxany, N, Neight, Nfive1, Nfive1x, Nfive2, Nfive3, Nfive3x, Nfive4, Nfour
+ integer::Ifinal, Krext, Nfour1, Nfour2, Ng, Nnine, Nsix, Nthr1, Nthr2, Nthr3, ntwo1, numElAux, Nw1, NcrssxO
+ integer::Nnndrc, Nfprrr
class(XctCrossCalc)::xct ! temporarily here so that energy indepdent code can move in steps
external Idimen
!
@@ -47,6 +47,8 @@ module xct_m
Segmen(2) = 'C'
Segmen(3) = 'T'
Nowwww = 0
+ NcrssxO = 0
+ if (any(xct%Ifcros)) NcrssxO = 1
call grid%initialize()
call grid%setParameters(numcro, ktzero)
@@ -87,7 +89,6 @@ module xct_m
!
! *** Count how many non-zero elements are in Xlmn
Kkxlmn = xct%C_G_Kxlmn
- Kslow = xct%Kslow
!
IF (Kadddc.NE.0) THEN
! *** Scan direct-capture file, figure dimensions et al
@@ -98,15 +99,12 @@ module xct_m
!
! *** GUESSTIMATE SIZE OF ARRAY NEEDED FOR SAMMY-XCT
Ifcoul = xct%IfCoul
- CALL Estxct (Ntwo1, Nthr1, Nthr2, Nthr3, Nfour, Nfour1, Nfour2, &
+ CALL Estxct (xct, Ntwo1, Nthr1, Nthr2, Nthr3, Nfour, Nfour1, Nfour2, &
Nfive1, Nfive2, Nfive3, Nfive4, Nfive1x, Nfive3x, Nsix, Neight, &
- Nnine, Nw1, Mxany, Nfprrr, K_Coul_N, numElAux)
+ Nnine, Nw1, Mxany, Nfprrr, K_Coul_N, numElAux, NcrssxO)
!
! *** Zero ***
N = Ndasig
- IF (N.ne.0) THEN
- call make_I_Iisopa(N)
- END IF
!
IF (Ifcoul.NE.0) THEN
call make_A_Iccoul(K_Coul_N)
@@ -143,31 +141,9 @@ module xct_m
! - - - - - - - - - - - - - - - - <
! - - - - - - - - - - - - - - - - >
!
-!
-! *** Generate coefficients of Legendre polynomials for the various spin
-! *** group pairs, if differential cross sections are needed (if
-! *** Kcros=7 .OR. Kcros=11 .OR. Kssmsc>0)
-! *** three ***
- call allocate_real_data(A_Icccll, Nthr1)
- call allocate_real_data(A_Idddll, Nthr2)
-!
! *** four ***
- N = Nfour
-! Nfour = (Ntriag) * (Nfpres)
- N = Nfour1
- N = Nfour2
- call allocate_real_data(A_Ipgar, N)
- call allocate_real_data(A_Ipgai, N)
-!
-
!
! *** five ***
- call allocate_real_data(A_Icrss, Nfive1)
- call allocate_real_data(A_Ideriv, Nfive2)
- call allocate_real_data(A_Icrssx, Nfive3)
- call allocate_real_data(A_Idervx, Nfive4)
- call allocate_real_data(A_Icrsnd, Nfive1x)
- call allocate_real_data(A_Icrxnd, Nfive3x)
!
IF (Kadddc.EQ.1) THEN
call allocate_real_data(A_Iedrcp, Nucdrc*Numdrc)
@@ -183,50 +159,19 @@ module xct_m
! - - - - - - - - - - - - - - - - - - - - - - <
! *** six ***
! Nsix = Nfpres
- IF (IfCoul.GT.0) THEN
- ng = resParData%getNumSpinGroups()
- call allocate_real_data(A_Icx, Ntotc*Ng)
- END IF
! - - - - - - - - - - - - - - - - <
-! *** seven ***
- call allocate_real_data(A_Ixden, Mres)
! CALL Abpart, Abpga
! - - - - - - - - - - - - - - - - >
! *** eight ***
!
! *** nine ***
- N = Ntotc
- call allocate_real_data(A_Isinsq, N)
- call allocate_real_data(A_Isinph, N)
- call allocate_real_data(A_Idphi, N)
- call allocate_real_data(A_Idpdr, N)
- call allocate_real_data(A_Idsdr, N)
IF (Ifdif.NE.0.and.2*Ntriag.gt.N) then
N = 2*Ntriag
ENd if
- call allocate_real_data(A_Icscs, N)
N = Ntotc
- call allocate_real_data(A_Icc, N)
- call allocate_real_data(A_Iss, N)
! CALL Sinsix
-!
-! *** ten ***
- N = Ntotc
- call allocate_real_data(A_Irootp, N)
- call allocate_real_data(A_Linvr, N)
- call allocate_real_data(A_Linvi, N)
- call allocate_real_data(A_Ipsmal, N)
- N = Ntriag
- call allocate_real_data(A_Ixxxxr, N)
- call allocate_real_data(A_Ixxxxi, N)
- N = Ntotc*Ntotc
- call allocate_real_data(A_Ixqr, N)
- call allocate_real_data(A_Ixqi, N)
- call allocate_real_data(A_Iyinv, 2*Ntriag)
! - - - - - - - - - - - - - - - - <
! *** eleven ***
- call allocate_real_data(A_Irmat, 2*Ntriag)
- call allocate_real_data(A_Iymat, 2*Ntriag)
! CALL Setr
! CALL Yinvrs
! CALL Setxqx
@@ -235,40 +180,15 @@ module xct_m
! *** twelve ***
N = (Ncrsss-2)
IF (N.EQ.0) N = 1
- IF (Ncrssx.EQ.0) N = 1
+ IF (NcrssxO.EQ.0) N = 1
if (n.lt.ntotc) n = ntotc
- call allocate_real_data(A_Itermf, N)
- call allocate_real_data(A_Iterfx, N)
! CALL Sectio
-!
- N = Ntriag*Ntriag
- call allocate_real_data(A_Iqr, N)
- call allocate_real_data(A_Iqi, N)
! CALL Setqri
-!
- N = Ncrsss*Ntriag
- IF (Ncrssx.EQ.0) N = 1
- call allocate_real_data(A_Itr, N)
- call allocate_real_data(A_Iti, N)
- N = 2*Ntriag**2
- call allocate_real_data(A_Itx, N)
! CALL Settri
- call allocate_real_data(A_Iddddd, Ncrsss)
! CALL Derres
! CALL Dercap
- call allocate_real_data(A_Iddtlz, Ncrsss)
! CALL Dereee
! CALL Derext
- ng = resParData%getNumSpinGroups()
- call allocate_real_data(A_Ipxrr, Ntriag*Ntotc)
- call allocate_real_data(A_Ipxri, Ntriag*Ntotc)
- call allocate_real_data(A_Idsf, Ntotc)
- call allocate_real_data(A_Idst, Ntotc*2)
- call allocate_real_data(A_Idstt, Ntotc*2*Ntotc)
- call allocate_real_data(A_Idsfx, 2*Ntotc*Ntotc)
- call allocate_real_data(A_Idstx, 2*Ntotc*Ntotc)
- call allocate_real_data(A_Iprer, Ntriag*Ng)
- call allocate_real_data(A_Iprei, Ntriag*Ng)
! CALL Setpxr
! CALL Derrho
! CALL Derrad
@@ -282,10 +202,8 @@ module xct_m
Lllmmm = Lllmax
IF (Lllmax.EQ.0) Lllmmm = 1
CALL Work ( xct, calcData , calcDataSelf, &
- A_Isigxx , A_Idasig , A_Idbsig , A_Isigsi , A_Idasis , &
- A_Idbsis , I_Iisopa , &
A_Iedrcp , A_Icdrcp , &
- A_Ixdrcp , I_Indrcp , Nnndrc , Lllmmm , Kslow)
+ A_Ixdrcp , I_Indrcp , Nnndrc , Lllmmm)
! *** SBROUTINE Work generates theory and derivatives
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
!
@@ -311,25 +229,26 @@ module xct_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Estxct (Ntwo1, Nthr1, Nthr2, Nthr3, Nfour, Nfour1, &
+ SUBROUTINE Estxct (xct, Ntwo1, Nthr1, Nthr2, Nthr3, Nfour, Nfour1, &
Nfour2, Nfive1, Nfive2, Nfive3, Nfive4, Nfive1x, Nfive3x, &
Nsix, Neight, Nnine, Nw1, Mxany, Nfprrr, K_Coul_N, &
- numElAux)
+ numElAux, Ncrssx)
!
! *** GUESSTIMATE SIZE OF ARRAY NEEDED FOR SAMMY-XCT
!
- use fixedi_m, only : Ifdif, Iq_Iso, Iq_Val, Kkxlmn, Lllmax, Nres, Mres, Ncrssx, Ncrsss, &
+ use fixedi_m, only : Ifdif, Iq_Iso, Iq_Val, Kkxlmn, Lllmax, Nres, Mres, Ncrsss, &
Ndasig, Ndbsig, Nfpres, Nnniso, Npfil3, Nrfil3, Ntotc, Ntriag, &
- Kshift, needResDerivs
+ Kshift
use ifwrit_m, only : Ifcoul, Kcros, Kpiece, Ksolve, Kssmsc, Nd_Xct,Nnpar
- !use lbro_common_m
+ use XctCrossCalc_M
use EndfData_common_m, only : resParData, radFitFlags
use rsl7_m, only : Figure_Kws_Xct
IMPLICIT none
+ class(XctCrossCalc)::xct ! temporarily here so that energy indepdent code can move in steps
integer::Ntwo1, Nthr1, Nthr2, Nthr3, Nfour, Nfour1, &
Nfour2, Nfive1, Nfive2, Nfive3, Nfive4, Nfive1x, Nfive3x, &
Nsix, Neight, Nnine, Nw1, Mxany, Nfprrr, K_Coul_N, &
- numElAux
+ numElAux, Ncrssx
integer::Idimen
integer::I,K, K1, K2, K3,K4, K6, K7, K8, Ke, Kw, low, N,Nthr4
external Idimen
@@ -369,7 +288,7 @@ module xct_m
!
! *** four
Nfour = 1
- IF (needResDerivs) Nfour = Ntriag*Nfpres
+ IF (xct%wantDerivs) Nfour = Ntriag*Nfpres
Nfour1 = Ntriag*Ntotc*resParData%getNumResonances()
IF (Nfour1.EQ.0) Nfour1 = 1
Nfprrr = radFitFlags%getNumTotalVaried()
@@ -391,7 +310,7 @@ module xct_m
Nfive3 = 1
IfCoul = 0
ELSE
- Nfive3 = 2*Ntotc*Ntotc*resParData%getNumSpinGroups()
+ Nfive3 = 2*Ntotc*Ntotc*resParData%getNumSpinGroups()
END IF
Nfive4 = Nfive3*Nnpar
IF (Nfive1.EQ.0) Nfive1 = 1
@@ -408,7 +327,7 @@ module xct_m
!
! *** six
nsix = 0
- IF (needResDerivs) Nsix = Nfpres
+ IF (xct%wantDerivs) Nsix = Nfpres
IF (Nsix.EQ.0) Nsix = 1
K6 = 3*Mres + Nsix
!
diff --git a/sammy/src/xct/mxct02.f90 b/sammy/src/xct/mxct02.f90
index 8d94997bb..d40f1bff6 100644
--- a/sammy/src/xct/mxct02.f90
+++ b/sammy/src/xct/mxct02.f90
@@ -5,9 +5,7 @@ module xct2_m
! --------------------------------------------------------------
!
SUBROUTINE Work (calc, derivs, derivsSelf, &
- Sigxxx, Dasigx, Dbsigx, Sigsin, Dasigs, &
- Dbsigs, Isopar, &
- Edrcpt, Cdrcpt, Xdrcpt, Ndrcpt, Nnndrc, Lllmmm, Kslow)
+ Edrcpt, Cdrcpt, Xdrcpt, Ndrcpt, Nnndrc, Lllmmm)
!
! *** PURPOSE -- Generate theoretical cross sections "theory" and partial
! *** Derivatives "dasig"
@@ -23,7 +21,6 @@ module xct2_m
use cbro_common_m
use lbro_common_m
use EndfData_common_m
- use ifsubs_common
use SammyGridAccess_M
use DerivativeHandler_M
use xct3_m
@@ -34,35 +31,30 @@ module xct2_m
use mxct26_m
use mxct06_m
use mxct18_m
+ use Zgauss_m
use XctCrossCalc_M
IMPLICIT none
- real(8), intent(in):: &
- Dasigx, Dbsigx, Sigsin, Dasigs, &
- Dbsigs
- real(8), intent(out):: Sigxxx, Edrcpt, Cdrcpt, Xdrcpt
+ real(8), intent(out):: Edrcpt, Cdrcpt, Xdrcpt
- integer(4), intent(in):: Isopar,Nnndrc, Lllmmm, Kslow
+ integer(4), intent(in):: Nnndrc, Lllmmm
integer(4), intent(out):: Ndrcpt
real(8):: Zero, A, Gbx, Theoryx
integer(4):: Jdat, Idrcp, Ipoten, Iw, irow, istart, &
- Kount_Helmut, ng, numEl, TotalNdasig
+ ng, numEl, TotalNdasig
integer(4) :: Iipar, iso, Jcount, Jsig,isoReal
real(8) :: val
LOGICAL Ywhich
type(SammyGridAccess)::grid
type(DerivativeHandler)::derivs, derivsSelf
- integer::iflagMatch
+ integer::iflagMatch, isoOur, is
logical::wantNegative, wantDeriv
class(XctCrossCalc)::calc
+ logical(C_BOOL)::accu
DIMENSION &
Edrcpt(Nnndrc,*), Cdrcpt(Nnndrc,*), Xdrcpt(*), Ndrcpt(*)
-
- DIMENSION &
- Sigxxx(Nnnsig,*), Dasigx(Nnnsig,*), Dbsigx(Nnnsig,Ndbxxx,*), &
- Sigsin(*), Dasigs(*), Dbsigs(Ndbxxx,*), Isopar(*)
!
! DIMENSION W...(...Ndatb)
!
@@ -80,7 +72,13 @@ module xct2_m
wantNegative = .true.
if (Kkkdop.eq.1) wantNegative = .false.
-
+ accu = .true.
+ call derivs%setAccumulate(accu)
+ call derivsSelf%setAccumulate(accu)
+ calc%crossSelfWhy = .false.
+ do is = Ndasig + 1, Ndbsig
+ calc%crossSelfWhy(is) = .true. ! these should be parameter that are not shared
+ end do
Ywhich = Ydoppr.OR.Yresol.OR.Yangle.OR.Yssmsc.OR.Yaverg.OR. Maxwel.EQ.1 .OR. Knocor.EQ.1
@@ -88,15 +86,22 @@ module xct2_m
if ( covData%getPupedParam().gt.0) wantDeriv = .true.
!
- Kount_Helmut = 0
Iw = 0
IF (Ksindi.GT.0 .AND. Kcros.EQ.8) THEN
Iw = 1
END IF
call derivs%nullify()
call derivs%setNnsig(Nnnsig)
+ if (calc%reactType.eq.6) then
+ if( Nnnsig.ne.1) then
+ write(6,*)" Expected Nnsig to be 1 if calculating eta"
+ write(21,*)" Expected Nnsig to be 1 if calculating eta"
+ stop
+ end if
+ call calc%crossData%setNnsig(2)
+ end if
- call derivs%reserve(numEl * Nnnsig, Ndasig + Ndbsig + 1)
+ call derivs%reserve(numEl * calc%crossData%getNnnsig(), Ndasig + Ndbsig + 1)
IF (Iw.EQ.1.or.Ksitmp.gt.0) THEN
call derivsSelf%nullify()
@@ -104,18 +109,12 @@ module xct2_m
call derivsSelf%reserve(numEl, Ndasig + Ndbsig + 1)
end if
-
-
- CALL Zero_Integer (Isopar, Ndasig)
!
IF (Kadddc.NE.0) THEN
! *** Read and organize direct capture information; Cdrcpt = X/(4pi E)
CALL Read_Direct_Capture (Edrcpt, Cdrcpt, Ndrcpt, &
Nnndrc)
END IF
-!
-! *** Organize for which derivative routines need to be called in Crosss
- CALL Which_Derivs ()
!
irow = 0
istart = 0
@@ -129,8 +128,6 @@ module xct2_m
CALL Zero_Array (A_Iccoul , 2*Ntotc*Ng*numEl)
IF (Nnpar.GT.0) CALL Zero_Array (A_Idcoul , &
2*Ntotc*Ng*numEl*Nnpar)
- CALL Zero_Array (A_Icx, Ntotc*Ng)
- CALL Start_Coul (A_Izke , A_Icx)
END IF
!
Idrcp = 1
@@ -159,20 +156,31 @@ module xct2_m
end if
end if
irow = irow + 1
-
+ calc%row = irow
+ calc%ener = grid%getEnergy(Jdat, expData)
!
IF (Su.GT.Emax .AND. Kartgd.EQ.1) THEN
- Sigxxx(1,1) = Zero
+ ! if Kartgd.EQ.1 and more than one isotope
+ ! SAMMY did not zero the cross section for isotopes 2, 3, ...
+ ! but reused the previous value
+ ! todo: delete this to make the code correct
+ do Iso=2,Iq_Iso
+ do is = 1, Nnnsig
+ val = derivs%getDataNs(irow-1, is, 0, iso)
+ call derivs%addDataNs(irow, is, 0, iso, val)
+ end do
+ end do
GO TO 20
END IF
IF (Su.LT.Zero) Su = - Su
IF (Kadddc.NE.0) CALL Find_Drcpt (Edrcpt, Cdrcpt, Xdrcpt, &
- Ndrcpt, Nnndrc, Idrcp, Su)
+ Ndrcpt, Nnndrc, Idrcp, Su)
!
! ********* Start regular calculation
Squ = dSQRT(Su)
+ calc%enerSq = Squ
! ********* Su = E = m Dist^2 Elzero^2 / [2 (t-Tzero)^2]
! ********* Squ = Tttzzz * Dist * Elzero / (t-Tzero)
! ********* Tttzzz = sqrt(m/2) * conversion factors = 72.3
@@ -191,66 +199,29 @@ module xct2_m
!
IF (Kgauss.EQ.1) THEN
! ************ Want dummy Gaussian resonances
- CALL Zgauss (A, Sigxxx, grid%getEnergy(Jdat, expData))
+ CALL Zgauss (resparData, val, grid%getEnergy(Jdat, expData))
+ call calc%crossData%addDataNs(calc%row, 1, 0, 1, val)
ELSE
!
! ************ Generate cross sections and derivatives
IF (Nd_Xct.NE.0 .AND. Ksolve.NE.2) THEN
- CALL N_D_Zcross (calc, Kount_Helmut)
+ CALL N_D_Zcross (calc)
ELSE
- CALL Zcross (calc, Nnndrc, Ipoten, Kount_Helmut)
+ CALL Zcross (calc, Nnndrc, Ipoten)
END IF
!
! ************ Store Coul if needed
IF (IfCoul.GT.0) THEN
- CALL Store_Coul (A_Iccoul , A_Idcoul , A_Icrssx , &
- A_Idervx , A_Icx , Jdat)
+ CALL Store_Coul (A_Iccoul , A_Idcoul , &
+ calc%angInternal, calc%Ccoulx , Jdat)
END IF
!
! ************ Set the particular cross sections needed for this run
- CALL Zwhich (calc, Sigxxx, Dasigx, Dbsigx, Sigsin, &
- Dasigs, Dbsigs, Theoryx, Su, &
- grid%getEnergy(Jdat, expData), Lllmmm, Kslow)
- IF (Kfake.EQ.1) THEN
- call derivs%addDataNs(Jdat, 1, 0, 1, Theoryx)
- cycle
- END IF
+ CALL Zwhich (calc)
END IF
!
20 CONTINUE
-
- do Iipar = 1, Ndasig
- ! Make sure the isotope indices in derivs are consistent
- ! with the ones given in Isopar.
- ! This only matters if there are more than one isotope
- ! (Iq_Iso > 1) and if we don't already have the same value
- ! (derivs%getIsotopeForShared(Iipar).eq.Isopar(Iipar))
- ! The value for Isopar(Iipar) is not always set, i.e. is 0, in the
- ! subroutines called from this routine (derivative is zero for
- ! example). But the derivs object needs to have a value between 1 <= Iso <= Iq_Iso,
- ! for all parameters <= Ndasig, so we populated it to 1 at the beginning
- ! of this subroutine
- if (Iq_Iso.gt.1.and.Isopar(Iipar).gt.1.and. &
- derivs%getIsotopeForShared(Iipar).ne.Isopar(Iipar)) then
- call derivs%addSharedColumn(Iipar, Isopar(Iipar))
- if (Iw.eq.1.or.Ksitmp.gt.0) THEn
- call derivsSelf%addSharedColumn(Iipar, Isopar(Iipar))
- end if
- end if
- end do
- do Iso=1,Iq_Iso
- call derivs%addCalculatedData(irow, Nnnsig, ndasig, &
- ndbsig, iso, Sigxxx(1:Nnnsig,Iso), Dasigx, Dbsigx(1:Nnnsig,1:Ndbxxx,Iso))
- end do
-
- IF (Iw.EQ.1) THEN
- do Iso=1,Iq_Iso
- call derivsSelf%addCalculatedData(irow, 1, ndasig, &
- ndbsig, Iso, Sigsin(Iso), Dasigs, Dbsigs(1:Ndbxxx,Iso))
- end do
- END IF
-
!
END DO
@@ -258,6 +229,9 @@ module xct2_m
!
!
call grid%destroy()
+ accu = .false.
+ call derivs%setAccumulate(accu)
+ call derivsSelf%setAccumulate(accu)
!
RETURN
diff --git a/sammy/src/xct/mxct03.f90 b/sammy/src/xct/mxct03.f90
index 821a53c77..449ae7cc1 100644
--- a/sammy/src/xct/mxct03.f90
+++ b/sammy/src/xct/mxct03.f90
@@ -1,38 +1,42 @@
!
module xct3_m
+ use XctCrossCalc_M
+
+ real(kind=8),allocatable,dimension(:,:)::unpertCross
+ real(kind=8),allocatable,dimension(:,:,:,:)::unpertAng
+
contains
!
! --------------------------------------------------------------
!
- SUBROUTINE N_D_Zcross (calc, Kount_Helmut)
+ SUBROUTINE N_D_Zcross (calc)
!
! *** PURPOSE -- Calculate numerically the partial derivatives
! *** of the cross section wrt R-matrix parameters
!
- use oops_common_m
- use fixedi_m
- use ifwrit_m
+ use fixedi_m, only : Kpolar
use exploc_common_m
- use fixedr_m
- use broad_common_m
use templc_common_m
- use EndfData_common_m
use SammyResonanceInfo_M
use RMatResonanceParam_M
use xct1_m
use xct5_m
- use mxct06_m
- use XctCrossCalc_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ use mxct06_m
+ use AllocateFunctions_m
+ IMPLICIT none
!
!
type(SammyResonanceInfo)::resInfo
type(RMatResonance)::resonance
type(SammySpinGroupInfo)::spinInfo
class(XctCrossCalc)::calc
+ integer::ng, ir, ir2, ig
+ logical::wantDerivsSave
!
- DATA Zero /0.0d0/, One /1.0d0/
- DATA U_Increment /0.0001d0/
+ real(kind=8),parameter:: Zero = 0.0d0, One = 1.0d0
+ real(kind=8),parameter:: U_Increment = 0.0001d0
+ real(kind=8)::B, eres, G1, G2, G3, X
+ integer::ichan, Iflr, iGam, Igrp, Ires, M, M2, Nnndrc, Ntotn, Ntotn2
!
!
B = Zero
@@ -40,47 +44,52 @@ module xct3_m
G2 = Zero
G3 = Zero
!
- IF (resParData%getNumResonances().EQ.0) &
+ IF (calc%resData%getNumResonances().EQ.0) &
STOP '[No resonances for num derivs in N_D_Zcross in mxct03.f]'
- Ksolve_N_D = Ksolve
- Ksolve = 2
+ wantDerivsSave = calc%wantDerivs
+ calc%wantDerivs = .false.
!
! *** First, for the original parameter values --
! *** Generate energy-independent pieces
! True is passed to babb since it is used to set parameters for numerical differentiation
- CALL Babb ( calc, .true.)
- CALL Abpart ( calc, &
- A_Ixden , &
- A_Idifma , I_Inotu , &
- A_Iprer , A_Iprei )
+ CALL Babb (calc, .true.)
+ CALL Abpart (calc)
!
! *** Form the cross section Crss
CALL Crosss ( calc, &
- I_Ifexcl , &
- A_Ibound , A_Iechan , I_Ifcros , &
- A_Iprmsc , I_Iflmsc , I_Ijkmsc , A_Izke , &
- A_Izeta , &
- A_Icrss , A_Ideriv , &
- A_Icrssx , A_Idervx , A_Iprer , A_Iprei , A_Ixdrcp , &
- I_Indrcp , Nnndrc, 0, Kount_Helmut)
-!
- IF (Ncrssx.NE.0) THEN
- N = Ncrsss*Nnpar*resParData%getNumSpinGroups()
- IF (N.NE.0) CALL Zero_Array (A_Ideriv , N)
- END IF
- IF (Ifdif.NE.0) THEN
- N = 2*Ntotc*Ntotc*Nnpar*resParData%getNumSpinGroups()
- IF (N.NE.0) CALL Zero_Array (A_Idervx , N)
- END IF
+ A_Iprmsc , I_Iflmsc , I_Ijkmsc, &
+ A_Ixdrcp , &
+ I_Indrcp , Nnndrc, 0)
+!
+ ng = calc%resData%getNumSpinGroups()
+ call reallocate_real_data_2d(unpertCross, calc%ntotc+1, 0, ng, 0)
+ do ig = 1, ng
+ do ir = 1, calc%ntotc+1
+ unpertCross(ir, ig) = calc%crossInternal(ir, ig, 0)
+ end do
+ end do
+ if (calc%needAngular) then
+ if (.not.allocated(unpertAng)) then
+ allocate(unpertAng(2, calc%ntotc+1, calc%ntotc+1, ng))
+ end if
+ do ig = 1, ng
+ do ir = 1, calc%ntotc+1
+ do ir2 = 1, calc%ntotc+1
+ unpertAng(1, ir, ir2, ig) = calc%angInternal(1, ir,ir2, ig, 0)
+ unpertAng(2, ir, ir2, ig) = calc%angInternal(2, ir,ir2, ig, 0)
+ end do
+ end do
+ end do
+ end if
!
! *** Now vary parameters one-by-one to get derivatives
- DO Ires=1,resParData%getNumResonances()
- call resParData%getResonanceInfo(resInfo, Ires)
+ DO Ires=1,calc%resData%getNumResonances()
+ call calc%resData%getResonanceInfo(resInfo, Ires)
IF (resInfo%getEnergyFitOption().GE.0) THEN
Igrp = resInfo%getSpinGroupIndex()
- call resparData%getSpinGroupInfo(spinInfo, Igrp)
+ call calc%resData%getSpinGroupInfo(spinInfo, Igrp)
if (spinInfo%getGammaWidthIndex().gt.0) then
write(0,*)" Combined gamma width and numerical derivatives are not supported"
stop
@@ -89,7 +98,7 @@ module xct3_m
Ntotn2 = spinInfo%getNumResPar()
iGam = spinInfo%getGammaWidthIndex()
- call resParData%getRedResonance(resonance, resInfo)
+ call calc%resData%getRedResonance(resonance, resInfo)
DO M=1,Ntotn2
if (m.eq.1) then
@@ -98,7 +107,7 @@ module xct3_m
Iflr = resInfo%getChannelFitOption(m-1)
end if
IF (Iflr.GT.0) THEN
- IF (covData%contributes(Iflr)) THEN
+ IF (calc%covariance%contributes(Iflr)) THEN
!
!
IF (M.EQ.1) THEN
@@ -136,25 +145,16 @@ module xct3_m
!
! *** Generate energy-independent pieces with new parameter
CALL Babb ( calc, .true.)
- CALL Abpart (calc, &
- A_Ixden , &
- A_Idifma , &
- I_Inotu , A_Iprer , A_Iprei )
+ CALL Abpart (calc)
!
! *** Form the cross section Crss with new parameter value
CALL Crosss ( calc, &
- I_Ifexcl , A_Ibound , A_Iechan , &
- I_Ifcros , &
- A_Iprmsc , I_Iflmsc , I_Ijkmsc , A_Izke , &
- A_Izeta , &
- A_Icrsnd , A_Ideriv , A_Icrxnd , A_Idervx , &
- A_Iprer , A_Iprei , A_Ixdrcp , I_Indrcp , &
- Nnndrc, 0, Kount_Helmut)
+ A_Iprmsc , I_Iflmsc , I_Ijkmsc , &
+ A_Ixdrcp , I_Indrcp , &
+ Nnndrc, 0)
!
! *** Generate numerical derivatives
- CALL Fix_N_D (A_Icrss , A_Icrssx , A_Ideriv , &
- A_Idervx , A_Icrsnd , A_Icrxnd , X, &
- Iflr, Igrp, Ntotn)
+ CALL Fix_N_D (calc, X, Iflr, Igrp, Ntotn)
!
! *** Reset original parameters
IF (M.EQ.1) THEN
@@ -176,43 +176,51 @@ module xct3_m
END DO
!
!
- Ksolve = Ksolve_N_D
+ calc%wantDerivs = wantDerivsSave
RETURN
END
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Fix_N_D (Crss, Crssx, Deriv, Derivx, Crss_N_D, &
- Crssx_N_D, X, Iipar, Igrp, Ntotn)
+ SUBROUTINE Fix_N_D (calc, X, Iipar, Igrp, Ntotn)
!
! *** PURPOSE -- Calculate numerically the partial derivatives
!
use fixedi_m
use ifwrit_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ IMPLICIT none
!
- DIMENSION Crss(Ncrsss,*), Crssx(2,Ntotc,Ntotc,*), &
- Crss_N_D(Ncrsss,*), Crssx_N_D(2,Ntotc,Ntotc,*), &
- Deriv(Ncrsss,Nnpar,*), Derivx(2,Ntotc,Ntotc,Nnpar,*)
+ class(XctCrossCalc)::calc
+ real(kind=8)::un, per,val
+ integer::Iipar, Igrp, Ntotn
+ real(kind=8)::X, Two_X
+ integer::K, Nchan, Nchanx
!
IF (Ncrssx.GT.0) THEN
DO K=1,Ncrsss
- Deriv(K,Iipar,Igrp) = - (Crss(K,Igrp)-Crss_N_D(K,Igrp))/X
+ un = unpertCross(k, Igrp)
+ per = calc%crossInternal(K, igrp, 0)
+ val = - (un-per)/X
+ if (val.ne.0) then
+ calc%crossInternal(K, Igrp, Iipar) = val
+ end if
END DO
END IF
!
Two_X = X/2.0d0
! *** Note that factor-of-two is removed when calculate Dddlll
- IF (Ifdif.NE.0) THEN
+ IF (calc%needAngular) THEN
DO Nchan=1,Ntotn
Do Nchanx=1,Ntotn
- Derivx(1,Nchanx,Nchan,Iipar,Igrp) = - ( &
- Crssx(1,Nchanx,Nchan,Igrp) - &
- Crssx_N_D(1,Nchanx,Nchan,Igrp) ) / Two_X
- Derivx(2,Nchanx,Nchan,Iipar,Igrp) = - ( &
- Crssx(2,Nchanx,Nchan,Igrp) - &
- Crssx_N_D(2,Nchanx,Nchan,Igrp) ) / Two_X
+ un = unpertAng(1, Nchanx,Nchan, Igrp)
+ per = calc%angInternal(1, Nchanx,Nchan, Igrp, 0)
+ val = - (un-per)/Two_X
+ calc%angInternal(1,Nchanx,Nchan,Igrp, Iipar) = val
+ un = unpertAng(2, Nchanx,Nchan, Igrp)
+ per = calc%angInternal(2, Nchanx,Nchan, Igrp, 0)
+ val = - (un-per)/Two_X
+ calc%angInternal(2,Nchanx,Nchan,Igrp, Iipar) = val
END DO
END DO
END IF
diff --git a/sammy/src/xct/mxct04.f90 b/sammy/src/xct/mxct04.f90
index 4b90307f6..4995bf7ac 100644
--- a/sammy/src/xct/mxct04.f90
+++ b/sammy/src/xct/mxct04.f90
@@ -4,7 +4,7 @@ module xct4_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Zcross (calc, Nnndrc, Ipoten, Kount_Helmut)
+ SUBROUTINE Zcross (calc, Nnndrc, Ipoten)
!
! *** PURPOSE -- FORM THE CROSS SECTION Crss
! *** AND THE ( PARTIAL DERIVATIVES OF THE CROSS SECTION
@@ -31,11 +31,8 @@ module xct4_m
!
! *** Generate Pr and Pi = Partial of R wrt U-parameters
! *** from Upr and Upi = energy-dependent pieces of those derivs
- IF (resParData%getNumResonances().NE.0) then
- CALL Abpart ( calc, &
- A_Ixden , &
- A_Idifma , I_Inotu , A_Iprer , A_Iprei )
- end if
+
+ CALL Abpart (calc)
!
! *** Generate Pgar & Pgai = partial of R wrt (Gamma-x) *
! *** partial (Gamma_x) wrt radius
@@ -68,19 +65,15 @@ module xct4_m
end if
IF (doRadDeriv) THEN
- CALL Abpga ( calc, A_Ipgar, A_Ipgai, Nfprrr)
+ CALL Abpga (calc)
END IF
!
! *** FORM THE CROSS SECTION Crss AND THE ( PARTIAL DERIVATIVES OF THE
! *** CROSS SECTION WITH RESPECT TO THE VARIED PARAMETERS ) = Deriv
CALL Crosss ( calc, &
- I_Ifexcl , &
- A_Ibound , A_Iechan , I_Ifcros , &
- A_Iprmsc , I_Iflmsc , I_Ijkmsc , A_Izke , &
- A_Izeta , &
- A_Icrss , A_Ideriv , &
- A_Icrssx , A_Idervx , A_Iprer , A_Iprei , A_Ixdrcp , &
- I_Indrcp , Nnndrc, Ipoten, Kount_Helmut)
+ A_Iprmsc , I_Iflmsc , I_Ijkmsc , &
+ A_Ixdrcp , &
+ I_Indrcp , Nnndrc, Ipoten)
!
RETURN
END
diff --git a/sammy/src/xct/mxct05.f90 b/sammy/src/xct/mxct05.f90
index 31fc9648c..fb2083125 100644
--- a/sammy/src/xct/mxct05.f90
+++ b/sammy/src/xct/mxct05.f90
@@ -4,9 +4,7 @@ module xct5_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Abpart (calc, &
- Xden, &
- Difmax, Notu, Prer, Prei)
+ SUBROUTINE Abpart (calc)
!
! *** Purpose -- Generate Alphar & Alphai = energy-independent bits
! *** and Upr and Upi = Energy-dependent pieces of Pr & Pi
@@ -25,10 +23,6 @@ module xct5_m
IMPLICIT None
!
!
- real(kind=8):: &
- Xden(*), Difmax(*), &
- Prer(Ntriag,*), Prei(Ntriag,*)
- integer:: Notu(*)
type(SammyResonanceInfo)::resInfo
type(SammySpinGroupInfo)::spinInfo
type(RMatResonance)::resonance
@@ -38,11 +32,6 @@ module xct5_m
class(XctCrossCalc)::calc
real(kind=8)::Upi, Upr
!
-! DIMENSION
-! * Xden(Nres),
-! * Difmax(Nres),
-! * Prer(Ntriag,Ngroup),
-! * Prei(Ntriag,Ngroup)
!
DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/
!
@@ -51,7 +40,7 @@ module xct5_m
!
calc%needAlphai = .false.
DO N=1,resParData%getNumResonances()
- Xden(N) = Zero
+ calc%Xden(N) = Zero
calc%Alphar(N) = Zero
calc%Alphai(N) = Zero
call resParData%getResonanceInfo(resInfo, N)
@@ -66,14 +55,14 @@ module xct5_m
if (calc%doResShift) then
calc%Difen(N) = calc%Difen(N) + calc%Xx(N)
end if
- IF (Dabs(calc%Difen(N)).LT.1.0D8*Difmax(N)) calc%needAlphai(N) = .true.
+ IF (Dabs(calc%Difen(N)).LT.1.0D8*calc%Difmax(N)) calc%needAlphai(N) = .true.
ichan = spinInfo%getGammaWidthIndex()
G2 = resonance%getWidth(ichan)**2
G3 = G2**2
Aa = calc%Difen(N)**2 + g3
- Xden(N) = One/Aa
- calc%Alphar(N) = calc%Difen(N)*Xden(N)
- calc%Alphai(N) = G2*Xden(N)
+ calc%Xden(N) = One/Aa
+ calc%Alphar(N) = calc%Difen(N)*calc%Xden(N)
+ calc%Alphai(N) = G2*calc%Xden(N)
END IF
END IF
END DO
@@ -83,7 +72,7 @@ module xct5_m
!
! *** if ( (do not solve) or (no resonance parameters are varied) )
! *** then don't do this
- IF (needResDerivs) THEN
+ IF (calc%wantDerivs) THEN
Ipar = 0
ires = 0
@@ -104,15 +93,15 @@ module xct5_m
N = calc%Inum(K,3) ! index of resonance
Upr = 0.0d0
Upi = 0.0d0
- IF (Dabs(calc%Difen(N)).LE.Difmax(N)) THEN
+ IF (Dabs(calc%Difen(N)).LE.calc%Difmax(N)) THEN
Upr = calc%Alphar(N)
Upi = calc%Alphai(N)
IF (M.EQ.1) THEN ! Variable is resonance-energy
Upi = Upr*Upi
- Upr = Xden(N) - Two*Upr*Upr
+ Upr = calc%Xden(N) - Two*Upr*Upr
ELSE IF (M.EQ.2) THEN ! Variable is capture width
Upr = Upr*Upi
- Upi = Xden(N) - Two*Upi*Upi
+ Upi = calc%Xden(N) - Two*Upi*Upi
END IF
end if
@@ -133,8 +122,9 @@ module xct5_m
IF (Itzero.NE.0 .OR. Ilzero.NE.0) THEN
!
- CALL Zero_Array (Prer, resParData%getNumSpinGroups()*Ntriag)
- CALL Zero_Array (Prei, resParData%getNumSpinGroups()*Ntriag)
+ calc%Prer = 0.0d0
+ calc%Prei = 0.0d0
+
DO Ig=1,resParData%getNumSpinGroups()
call resParData%getSpinGroupInfo(spinInfo, ig)
DO N=1,resParData%getNumResonances()
@@ -156,9 +146,9 @@ module xct5_m
Ij = Ij + 1
ichan = spinInfo%getWidthForChannel(Ijl)
channelWidthCPrime = resonance%getWidth(ichan)
- Prer(Ij,Ig) = Prer(Ij,Ig) + &
+ calc%Prer(Ij,Ig) = calc%Prer(Ij,Ig) + &
Aa*channelWidthC*channelWidthCPrime
- Prei(Ij,Ig) = Prei(Ij,Ig) + &
+ calc%Prei(Ij,Ig) = calc%Prei(Ij,Ig) + &
Bb*channelWidthC*channelWidthCPrime
! Pre = partial of R wrt E
! R = sum_N {gamma_i gamma_j / [E_N-E +i gamma_g]}
@@ -175,7 +165,7 @@ module xct5_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Abpga (calc, Pgar, Pgai, Nfprrr)
+ SUBROUTINE Abpga (calc)
!
! *** PURPOSE -- generate Pgar and Pgai = partial of R wrt unvaried
! *** width-parameters
@@ -186,39 +176,54 @@ module xct5_m
use EndfData_common_m
use SammySpinGroupInfo_M
use XctCrossCalc_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ IMPLICIT none
!
!
type(SammyResonanceInfo)::resInfo
type(SammySpinGroupInfo)::spinInfo
class(XctCrossCalc)::calc
- DIMENSION Pgar(Ntriag,Nfprrr,*), Pgai(Ntriag,Nfprrr,*)
+ logical::hasRad
!
- DATA Zero /0.0d0/
+ real(kind=8),parameter:: Zero = 0.0d0
+ integer::ix, Ifl, Ign, Ij, Iz, Mchan, Numrrr, Ires
!
!
- Numrrr = Numrad
- IF (Numrad.EQ.0) Numrrr = Nfprrr
- ng = resParData%getNumSpinGroups()
- CALL Zero_Array (Pgar, Ntriag*Nfprrr*ng)
- CALL Zero_Array (Pgai, Ntriag*Nfprrr*ng)
+ hasRad = .false.
+ if( allocated(calc%iradIndex)) then
+ hasRad = any(calc%iradIndex.ne.0)
+ end if
+ if( .not.hasRad) return ! no radius adjustment
+
+ Numrrr = size(calc%iradIndex)
+ calc%Pgar = 0.0d0
+ calc%Pgai = 0.0d0
+
!
! *** Multiply by Bga to give partial of R wrt radius
!
- DO Ires=1,resParData%getNumResonances()
- call resParData%getResonanceInfo(resInfo, ires)
+ DO Ires=1,calc%resData%getNumResonances()
+ call calc%resData%getResonanceInfo(resInfo, ires)
IF (resInfo%getIncludeInCalc()) THEN
ign = resInfo%getSpinGroupIndex()
call resParData%getSpinGroupInfo(spinInfo, ign)
DO Mchan=1,spinInfo%getNumChannels()
- Ix = radFitFlags%getTrueFitFlag(Ign, Mchan)
- IF (Ix.GT.0) THEN
- Ix = Ix - Nfpres - Nfpext
+ Ifl = calc%radiusData%getTrueFitFlag(Ign, Mchan)
+ IF (Ifl.GT.0) THEN
+ ! It's adjusted, find its position
+ ! in Pgar and Pgai
+ Ix = 0
+ do Iz = 1, Numrrr
+ if (Ifl.eq.calc%iradIndex(Iz)) then
+ Ix = Iz
+ exit
+ end if
+ end do
+
DO Ij=1,Ntriag
IF (calc%Bga(IJ,Mchan,Ires).NE.Zero) THEN
- Pgar(IJ,Ix,Ign) = Pgar(Ij,Ix,Ign) + &
+ calc%Pgar(IJ,Ix,Ign) = calc%Pgar(Ij,Ix,Ign) + &
calc%Bga(IJ,Mchan,Ires)*calc%Alphar(Ires)
- Pgai(IJ,Ix,Ign) = Pgai(Ij,Ix,Ign) + &
+ calc%Pgai(IJ,Ix,Ign) = calc%Pgai(Ij,Ix,Ign) + &
calc%Bga(IJ,Mchan,Ires)*calc%Alphai(Ires)
END IF
END DO
diff --git a/sammy/src/xct/mxct06.f90 b/sammy/src/xct/mxct06.f90
index e54e2a76b..cbd650de4 100644
--- a/sammy/src/xct/mxct06.f90
+++ b/sammy/src/xct/mxct06.f90
@@ -6,296 +6,177 @@ contains
! --------------------------------------------------------------
!
SUBROUTINE Crosss ( calc, &
- Jfexcl, Bound , Echan , &
- Jfcros, Parmsc, Jflmsc , Jjkmsc , Zke , &
- Zeta , &
- Crss , Deriv , Crssx , Derivx , Prer , Prei , &
- Xdrcpt, Ndrcpt, Nnndrc, Ipoten, Kount_Helmut)
+ Parmsc, Jflmsc , Jjkmsc , &
+ Xdrcpt, Ndrcpt, Nnndrc, Ipoten)
!
! *** PURPOSE -- Form the cross sections Crss(Isigma,Igroup) and the
! *** ( partial derivatives of the cross section with respect to
! *** the varied parameters ) = Deriv(Isigma,Iipar,Igroup)
!
- use over_common_m
- use oops_common_m
- use fixedi_m
- use ifwrit_m
- use exploc_common_m
- use fixedr_m
- use broad_common_m
- use varyr_common_m
- use templc_common_m
- use constn_common_m
- use EndfData_common_m
+ use fixedi_m, only : Nucdrc, Nummsc
+ use ifwrit_m, only : Kadddc
+
use SammySpinGroupInfo_M
use SammyResonanceInfo_M
use SammyRExternalInfo_M
- use ifsubs_common
- use par_parameter_names_common_m
- use templc_common_m, only : I_Inotu
+ use par_parameter_names_common_m, only : Nammsc
use Derrho_m
use xct7_m
use mxct11_m
use mxct12_m
+ use mxc15_m
+ use mxct16_m
+ use mxct17_m
use mthe1_m
+ use mxct09_m
+ use mxct10_m
+ use mxct13_m
+ use mxct08_m
implicit none
class(XctCrossCalc)::calc
- real(8), intent(in):: Bound, Echan, Parmsc, Zke, Zeta, &
- Crssx, Derivx, Prer, Prei, Xdrcpt
- real(8), intent(out):: Crss, Deriv
- integer(4), intent(in):: Jfexcl, Jfcros, Jflmsc, Jjkmsc, &
+ real(8), intent(in):: Parmsc, Xdrcpt
+ integer(4), intent(in):: Jflmsc, Jjkmsc, &
Ndrcpt, &
- Nnndrc, Ipoten, Kount_Helmut
+ Nnndrc, Ipoten
- real(8):: Zero, Dgoj
- integer(4):: i, I_Re_Setr, Iiidrc, Ijk, Ipar, Krext, Lrmat, Maxr, &
- Minr, N, Nentnn, Nextnn, Nn2, Nnext, Ntotnn
+ integer(4):: i, Iiidrc, Ijk, Ipar, Lrmat, &
+ Minr, N, Ntotnn
!
- DIMENSION Jfexcl(Ntotc,*), &
- Bound(Ntotc,*), Echan(Ntotc,*), &
- Jfcros(*), &
+ DIMENSION &
Parmsc(*), Jflmsc(*), Jjkmsc(*), &
- Crss(Ncrsss,*), Deriv(Ncrsss,Nnpar,*), Crssx(2,Ntotc,Ntotc,*), &
- Derivx(2,Ntotc,Ntotc,Nnpar,*), Zke(Ntotc,*), &
- Zeta(Ntotc,*),Prer(Ntriag,*), Prei(Ntriag,*), &
Xdrcpt(*), Ndrcpt(*)
-!
-! DIMENSION
-! * Jfexcl(Ntotc,Ngroup), Bound(Ntotc,Ngroup),
-! * Echan(Ntotc,Ngroup), Jfcros(Ncrsss),
-! * Crss(Ncrsss,Ngroup), Deriv(Ncrsss,Nnpar,Ngroup),
-! * Crssx(2,Ntotc,Ntotc,Ngroup), Derivx(2,Ntotc,Ntotc,Nnpar,Ngroup),
-! * Zke(Ntotc,Ngroup),
-! * Prer(Ntriag,Ngroup), Prei(Ntriag,Ngroup)
!
type(SammySpinGroupInfo)::spinInfo
type(SammyResonanceInfo)::resInfo
type(SammyRExternalInfo)::rextInfo
- integer::M,iflabund, j
- logical::needDeriv,ifcap
- DATA Zero /0.0d0/
+ integer::M,iflabund, j, iparStart, istart
+ logical::needDeriv, needDerivPlus
+ real(kind=8)::val
!
!
- IF (Ks_Res.NE.2) THEN
- IF (Ncrssx.NE.0) THEN
- N = Ncrsss*Nnpar*Ngroup
- IF (N.NE.0) CALL Zero_Array (Deriv, N)
- END IF
- IF (Ifdif.NE.0) THEN
- N = 2*Ntotc*Ntotc*Nnpar*Ngroup
- IF (N.NE.0) CALL Zero_Array (Derivx, N)
- END IF
- END IF
-!
- Krext = Nrext
- IF (Krext.EQ.0) Krext = 1
!
- Nn2 = 0
- Kstart = 0
- Jstart = Nfpres ! Jstart+1 starts derivatives external R-Matrix
- IF (Ncrssx.NE.0) THEN
- CALL Zero_Array (Crss, Ngroup*Ncrsss)
- END IF
- IF (Ifdif.NE.0) THEN
- CALL Zero_Array (Crssx, 2*Ntotc**2*Ngroup)
- END IF
+ calc%crossInternal = 0.0d0
+ if (calc%needAngular) then
+ calc%angInternal = 0.0d0
+ end if
!
!
! *** DO LOOP OVER GROUPS (IE SPIN-PARITY GROUPS) -
! *** GOES TO END OF ROUTINE
!
- maxr = 0
- DO N=1,resParData%getNumSpinGroups()
- call resParData%getSpinGroupInfo(spinInfo, N)
- minr = maxr + 1
- call getParamPerSpinGroup(maxr, N, Npr, needDeriv, &
- Kstart, ifcap)
-
- Nnnn = N
- Ntotnn = spinInfo%getNumChannels()
- IF (Ifdif.NE.0) CALL Zero_Array (A_Icscs, 2*Ntriag)
+ istart = 0
+ iparStart = 0
+ DO N=1,calc%resData%getNumSpinGroups()
+ call calc%resData%getSpinGroupInfo(spinInfo, N)
+ minr = istart + 1
+ call calc%getParamPerSpinGroup(istart, N)
+ needDeriv = calc%inumSize.gt.0
+ needDerivPlus = needDeriv.or.calc%Ifzzz.or.calc%Ifext.or.calc%Ifrad.or.calc%Ifradt
+ if (.not.calc%wantDerivs) needDeriv = .false.
+
+ Ntotnn = spinInfo%getNumChannels()
+ if (calc%needAngular) calc%cscs = 0.0d0
IF (spinInfo%getIncludeInCalc()) THEN
- VarAbn = spinInfo%getAbundance()
-!
- Nnnn = N
- Npx = 0
- IF (Ks_Res.NE.2) then
- DO I = 1, Ntotnn
- if (resparData%hasRexInfo(N, I))then
- call resparData%getRextInfoByGroup(rextInfo, N, I)
- do j = 1, rextInfo%getNrext()
- if(rextInfo%getIflSammyIndex(j).gt.0) then
- Npx = 1
- exit
- end if
- end do
- end if
- if (Npx.eq.1) exit
- end do
- end if
- Nn2 = Ntotnn*(Ntotnn+1)
- Nn = Nn2/2
+!
!
!
! *** Set R-Matrix and other necessary arrays
Lrmat = 0
-
- Nentnn = spinInfo%getNumEntryChannels()
- Nextnn = spinInfo%getNumExitChannels()
- CALL Setr (calc, Nentnn, Ntotnn, N, &
- Bound(:,N), Echan(:,N), &
- A_Isinsq , A_Isinph, A_Idphi, A_Icscs, &
- A_Iss, A_Icc , Zke(:,N), Zeta(:,N), &
- A_Idpdr, A_Idsdr, &
- A_Irmat, A_Iymat, A_Irootp, A_Linvr, A_Linvi, &
- A_Ipsmal, Krext, Lrmat, Minr, Maxr, Ipoten)
-!
- I_Re_Setr = 0
- DO I=1,Ntotnn
- IF (Jfexcl(I,Nnnn).LT.0) I_Re_Setr = 1
- END DO
- IF (I_Re_Setr.EQ.1) THEN
-! *** If any Jfexcl are < 0, that channel is excluded from
+ CALL Setr (calc, spinInfo, N, Lrmat, Minr, Ipoten)
+!
+! *** If any channel is completely excluded from
! *** the entire calculation (not just from final state)
- CALL Re_Setr (Nentnn, Ntotnn, A_Isinsq , A_Isinph , &
- A_Idphi , A_Icscs, A_Iss , A_Icc, A_Idpdr, A_Idsdr, &
- A_Irmat, A_Iymat, A_Irootp, A_Linvr, A_Linvi, &
- Jfexcl(:,Nnnn))
- END IF
+! set its information to zero
+ CALL Re_Setr (calc, spinInfo, N)
+
!
IF (Lrmat.EQ.1) THEN
! *** Calculate Xq & Xxxx matrices if trivial
- CALL Zeror (A_Ixxxxr, A_Ixxxxi, A_Ixqr, A_Ixqi, &
- A_Ipxrr, A_Ipxri, Ntotnn)
+ CALL Zeror (calc)
ELSE
! *** Invert Ymat; note that Xqr is "Dummy" here
- CALL Yinvrs (A_Iymat, A_Iyinv, A_Ixqr, Ntotnn)
+ CALL Yinvrs (calc, Ntotnn)
! *** Generate XQ & Xxxx matrices
- CALL Setxqx (Ntotnn, A_Iyinv, A_Irmat, A_Ixqr, A_Ixqi, &
- A_Irootp, A_Linvr, A_Linvi, A_Ixxxxr, A_Ixxxxi)
+ CALL Setxqx (calc, Ntotnn)
END IF
!
- Dgoj = spinInfo%getGFactor()
! *** generate cross section pieces
- CALL Sectio (Nentnn, Nextnn, N, Echan(:,N), &
- Jfexcl(:,N), Jfcros, Zke(:,N), Zeta(:,N), A_Ixxxxr, &
- A_Ixxxxi, A_Isinsq , A_Isinph, A_Itermf, Crss(:,N), &
- Crssx, A_Icscs, Dgoj, Ntotnn)
-!
- IF (Ks_Res.NE.2) THEN
- IF ( Lrmat.EQ.0 .AND. &
- ( needDeriv .OR. &
- (Npx.NE.0 .AND. Ifext .EQ.0) .OR. &
- Ifzzz.EQ.0 .OR. Ifradt.EQ.0 ) ) THEN
+ CALL Sectio (spinInfo, calc, N)
+
+ IF (calc%wantDerivs) THEN
+ IF ( Lrmat.EQ.0.and.needDerivPlus) THEN
!
! *** Generate Q = partial Derivative of Xxxx wrt R
- CALL Setqri (A_Iyinv, A_Ixqr, A_Ixqi, A_Irootp, &
- A_Linvr, A_Linvi, A_Iqr , A_Iqi , A_Ipsmal, &
- Ntotnn)
+ CALL Setqri (calc, Ntotnn)
!
! *** Generate T = partial of cross sections with respect to R
! *** T = [ partial (sigma) wrt X ] * Q
- CALL Settri (Nentnn, Nextnn, N, Echan(:,N), &
- Jfexcl(:,N), Zke(:,N), Zeta(:,N), Jfcros,A_Ixxxxr, &
- A_Ixxxxi, A_Isinsq , A_Isinph, A_Icscs, A_Iqr, &
- A_Iqi, A_Itr, A_Iti, A_Itx, Ntotnn)
+ CALL Settri (spinInfo, calc, N)
END IF
!
IF (Lrmat.EQ.0 .AND. needDeriv) THEN
! *** Find derivatives of cross sections wrt res pars
- CALL Derres (calc, Nentnn, Jfexcl(:,N), Jfcros, &
- Deriv(:,:,N), Derivx(:,:,:,:,N), &
- A_Itr , A_Iti , A_Itx, I_Inotu, A_Iddddd, Dgoj, &
- Ntotnn, Minr, Maxr)
+ CALL Derres (spinInfo, calc, N, iparStart)
END IF
!
- IF (Lrmat.EQ.0 .AND. Ifcap) THEN
-! *** Find derivatives of cs wrt universal capture width
- CALL Dercap (calc, Nentnn, Jfexcl(:,N), Jfcros, &
- Deriv(:,:,N), Derivx(:,:,:,:,N), &
- A_Itr , A_Iti , A_Itx , I_Inotu, A_Iddddd, Dgoj, &
- Ntotnn, Minr, Maxr)
- END IF
!
-!
- IF (Ifzzz.EQ.0) THEN
+ IF (calc%Ifzzz) THEN
! *** Find derivatives of cross sections wrt Tzero & Elzero
! *** (via energy-denominator portion of R-matrix)
- CALL Dereee (calc, Nentnn, Jfexcl(:,N), Jfcros, &
- Derivx(:,:,:,:,N), A_Itr, A_Iti, A_Itx, &
- Prer(:,N), Prei(:,N), A_Iddtlz, Ntotnn)
+ CALL Dereee (spinInfo, calc, N)
END IF
!
- IF (Npx.NE.0 .AND. Ifext.EQ.0) THEN
+ IF (calc%Ifext) THEN
+
! *** Find deriv of cross sections with respect to R-ext pars
- CALL Derext (calc, Jfexcl(:,N), Jfcros, &
- Deriv(:,:,N), Derivx(:,:,:,:,N), A_Itr, A_Itx, &
- Dgoj, Ntotnn, Nentnn, Krext)
+ CALL Derext (spinInfo, calc, N)
END IF
!
- IF (Lrmat.EQ.0 .AND. (Ifzzz.EQ.0 .OR. Ifrad.EQ.0)) THEN
+ IF (Lrmat.EQ.0 .AND. (calc%Ifzzz .OR. calc%Ifrad )) THEN
! *** Find derivatives of Xxxx wrt rho
- CALL Setpxr (A_Irootp, A_Ixxxxr, A_Ixxxxi, &
- A_Idpdr, A_Idsdr, A_Ipxrr, A_Ipxri, Ntotnn)
+ CALL Setpxr (calc, Ntotnn)
END IF
!
- Nnext = Nextnn
- IF (Nnext.EQ.0) Nnext = 1
- IF (Ifzzz.EQ.0 .OR. Ifrad.EQ.0) THEN
+ IF (calc%Ifzzz .OR. calc%Ifrad) THEN
! *** Find derivatives of Crss & Crssx wrt rho
- CALL Derrho (spinInfo, Jfcros, &
- Zke(:,n), A_Isinsq, A_Isinph, A_Icscs, A_Idphi, &
- A_Ixxxxr, A_Ixxxxi, A_Ipxrr, A_Ipxri, A_Idsf, &
- A_Idst, A_Idstt, A_Idsfx, A_Idstx, Nnext, &
- Lrmat)
+ CALL Derrho (spinInfo, calc, N, Lrmat)
END IF
!
- IF (Ifrad.EQ.0) THEN
+ IF (calc%Ifrad) THEN
! *** Find Deriv of Crss & Crssx wrt radii
- CALL Derrad (Echan(:,N), &
- Jfexcl(:,N), Jfcros, Zke(:,N), &
- Deriv(:,:,N), Derivx(:,:,:,:,N), &
- A_Idsf, A_Idst, A_Idstt, A_Idsfx, A_Idstx, &
- Dgoj, Nnext, Lrmat, N)
+ CALL Derrad (spinInfo, calc, N, Lrmat)
END IF
!
- IF (Lrmat.EQ.0 .AND. Ifrad.EQ.0) THEN
+ IF (Lrmat.EQ.0 .AND. calc%Ifrad) THEN
! *** Find rest of Deriv of Crss & Crssx wrt radii (the
! *** part due to non-varied particle widths)
- CALL Derwid (Jfexcl(:,N), Jfcros, &
- A_Ipgar, A_Ipgai, Deriv(:,:,N), &
- Derivx(:,:,:,:,N), A_Itr, A_Iti, A_Itx, &
- A_Iddddd, Dgoj, Ntotnn, Nentnn, Nfprrr)
+ CALL Derwid (spinInfo, calc, N)
END IF
!
- IF (Ifzzz.EQ.0) THEN
+ IF (calc%Ifzzz) THEN
! *** Find deriv of Crss & Crssx wrt Tzero & Elzero (via rho
! via Phi)
- CALL Dertze_Phi (Nentnn, Jfcros, Zke(:,N),A_Iddtlz, &
- Derivx(:,:,:,:,N), A_Idsf, A_Idsfx, A_Idstx, N)
+ CALL Dertze_Phi (spinInfo, calc, N)
END IF
!
- IF (Lrmat.EQ.0 .AND. Ifzzz.EQ.0) THEN
+ IF (Lrmat.EQ.0 .AND. calc%Ifzzz) THEN
! *** Find deriv of Crss & Crssx wrt Tzero & Elzero (via rho
! via P & S)
- CALL Dertze (Nentnn, Nextnn, Jfexcl(:,N), Jfcros, &
- Zke(:,N), A_Iddtlz, Derivx(:,:,:,:,N), A_Idst, &
- A_Idstt, A_Idstx, Nnext, Ntotnn, N)
+ CALL Dertze (spinInfo, calc, N)
END IF
!
- IF (Ifzzz.EQ.0) THEN
+ IF (calc%Ifzzz) THEN
! *** Find rest of Deriv Crss wrt Tzero * Elzero (Crss only,
! *** not Crssx)
- CALL Derzzz (Crss(:,n), Deriv(:,:,N), A_Iddtlz, Dgoj)
+ CALL Derzzz (spinInfo, calc, N)
END IF
!
- IF (Ifiso.EQ.0) THEN
+ IF (calc%Ifiso) THEN
! *** Find derivative of Crss wrt isotopic abundance
- IflAbund = spinInfo%getAbundanceFitFlag()
- CALL Deriso (IflAbund, Crss(:,N),Deriv(:,:,N),VarAbn)
+ CALL Deriso (spinInfo, calc, N)
END IF
!
@@ -306,17 +187,24 @@ contains
IF (Kadddc.NE.0) THEN
DO Iiidrc=1,Nucdrc
IF (Ndrcpt(Iiidrc).EQ.N) THEN
- IF (Xdrcpt(Iiidrc).NE.Zero) THEN
+ IF (Xdrcpt(Iiidrc).NE.0.0d0) THEN
DO Ijk=1,Nummsc ! only consider direct capture
if (Nammsc(IJK).NE.'DRCAP') cycle
IF (Jjkmsc(Ijk).EQ.0) THEN
GO TO 10
- ELSE IF (Jjkmsc(Ijk).EQ.Iiidrc) THEN
- Crss(2:Ncrsss,N) = Crss(2:Ncrsss,N) + &
- Xdrcpt(Iiidrc)*Parmsc(Ijk)
- IF (Ks_Res.NE.2 .AND. Jflmsc(Ijk).GT.0) THEN
+ ELSE IF (Jjkmsc(Ijk).EQ.Iiidrc) THEN
+ val = Xdrcpt(Iiidrc)*Parmsc(Ijk)
+ do j = 2, calc%Ntotc+1
+ calc%crossInternal(j, N, 0) = calc%crossInternal(j, N, 0) + val
+ end do
+ IF (Jflmsc(Ijk).GT.0) THEN
Ipar = Jflmsc(Ijk)
- Deriv(2:Ncrsss,Ipar,N) = Xdrcpt(Iiidrc)
+ val = Xdrcpt(Iiidrc)
+ if (val.ne.0.0d0) then
+ do j = 2, calc%Ntotc+1
+ calc%crossInternal(j, N, Ipar) = calc%crossInternal(j, N, Ipar) + val
+ end do
+ end if
GO TO 10
END IF
END IF
@@ -329,7 +217,7 @@ contains
END IF
10 CONTINUE
!
- Kstart = Kstart + Npr
+ iparStart = iparStart + calc%inumSize
END DO
!
RETURN
@@ -338,102 +226,4 @@ contains
!
! ______________________________________________________________________
!
- SUBROUTINE Which_Derivs ()
- use fixedi_m
- use ifwrit_m
- use EndfData_common_m
- use ifsubs_common
- use SammySpinGroupInfo_M
- implicit none
- integer::n, ifgam
- type(SammySpinGroupInfo)::spinInfo
- type(SammyIsoInfo)::isoInfo
- integer::ig,ich,ii,is
-!
-! *** Purpose -- Set flags = 0 if (maybe) calculate derivatives
-! *** = 1 if do not calculate derivatives
-!
-! Need combined capture width derivatives if any gamma width is a
-! combined gamma width
-!
- Ifzzz = 1
- IF (Itzero.GT.0) THEN
- IF (Ksolve.EQ.2 .AND. &
- covData%isPupedParameter(Itzero)) THEN
- Ifzzz = 0
- ELSE IF (Ksolve.NE.2) THEN
- Ifzzz = 0
- END IF
- END IF
- IF (Ifzzz.EQ.1) THEN
- IF (Ilzero.GT.0) THEN
- IF (Ksolve.EQ.2 .AND. &
- covData%isPupedParameter(Ilzero)) THEN
- Ifzzz = 0
- ELSE IF (Ksolve.NE.2) THEN
- Ifzzz = 0
- END IF
- END IF
- END IF
-!
- IF (Ksolve.EQ.2 .AND. Nfpext.NE.Nvpext) THEN
- Ifext = 0
- ELSE IF (Ksolve.NE.2 .AND. Nfpext.NE.0) THEN
- Ifext = 0
- ELSE
- Ifext = 1
- END IF
-!
- Ifrad = 1
- Ifradt = 1
- DO ig=1,resparData%getNumSpinGroups()
- call resParData%getSpinGroupInfo(spinInfo, ig)
- DO Ich=1,spinInfo%getNumChannels()
- ii = radFitFlags%getTrueFitFlag(Ig, Ich)
- if (ii.gt.0) then
- if( Ksolve.NE.2) then
- Ifrad = 0
- Ifradt = 0
- else
- if (covData%isPupedParameter(ii)) then
- Ifrad = 0
- Ifradt = 0
- end if
- end if
- END IF
- ii = radFitFlags%getEffFitFlag(Ig, Ich)
- if (ii.gt.0) then
- if( Ksolve.NE.2) then
- Ifrad = 0
- else
- if (covData%isPupedParameter(ii)) then
- Ifrad = 0
- end if
- end if
- END if
- if (Ifrad.eq.0.and.Ifradt.eq.0) exit
- END DO
- if (Ifrad.eq.0.and.Ifradt.eq.0) exit
- END DO
-!
- Ifiso = 1
- if (Ncrssx.NE.0) then
- do is = 1, resParData%getNumIso()
- call resParData%getIsoInfo(isoInfo, Is)
- ii = isoInfo%getFitOption()
- if (ii.gt.0) then
- if (Ksolve.ne.2) then
- Ifiso = 0
- else
- if(covData%isPupedParameter(ii))then
- Ifiso = 0
- end if
- end if
- end if
- if (Ifiso.eq.0) exit
- end do
- end if
-!
- RETURN
- END
end module mxct06_m
diff --git a/sammy/src/xct/mxct07.f90 b/sammy/src/xct/mxct07.f90
index c7e80bdf8..1e23b5932 100644
--- a/sammy/src/xct/mxct07.f90
+++ b/sammy/src/xct/mxct07.f90
@@ -1,15 +1,12 @@
!
module xct7_m
use XctCrossCalc_M
+ IMPLICIT None
contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Setr (calc, Nent, Ntot, Igr, Bound, Echan, &
- Sinsqr, Sin2ph, Dphi, Cscs, Sinphi, &
- Cosphi, Zke, Zeta, Dpdr, Dsdr, Rmat, &
- Ymat, Rootp, Elinvr, Elinvi, Psmall, Krext, Lrmat, Min, Max, &
- Ipoten)
+ SUBROUTINE Setr (calc, spinInfo, Igr, Lrmat, Min, Ipoten)
!
! *** PURPOSE -- Generate Linv = 1/(S-B+IP)
! *** Rootp = sqrt(P)
@@ -17,30 +14,17 @@ module xct7_m
! *** Ymat = Linv - Rmat
! *** Also return Lrmat = 1 if no R-matrix contribution
!
- use sammy_CoulombSelector_I
use sammy_LogarithmicDerivativeCWF_M
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use broad_common_m
- use varyr_common_m
- use EndfData_common_m
use SammyResonanceInfo_M
+ use SammySpinGroupInfo_M
use RMatResonanceParam_M
-
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
+ type(SammySpinGroupInfo)::spinInfo
class(XctCrossCalc)::calc
- DIMENSION Bound(*), Echan(*), &
- Sinsqr(*), Sin2ph(*), Dphi(*), Cscs(2,*), Zke(*), &
- Zeta(*), Dpdr(*), &
- Dsdr(*), Rmat(2,*), Ymat(2,*), Rootp(*), Elinvr(*), &
- Elinvi(*), Psmall(*)
- DIMENSION Sinphi(*), Cosphi(*)
+ integer::igr, Ipoten, Lrmat, Min
LOGICAL ABOVE_THRESHOLD
type(SammyResonanceInfo)::resInfo
type(RMatResonance)::resonance
- type(SammySpinGroupInfo)::spinInfo
type(SammyChannelInfo)::channelInfo
type(RMatChannelParams)::channel
type(SammyParticlePairInfo)::pairInfo
@@ -52,16 +36,13 @@ module xct7_m
type(RExternalFunction)::rext
real(kind=8)::Parext(7)
double precision, parameter :: Big = 1.0E30
-!
-! DIMENSION Bound(Ntotc),
-! * Echan(Ntotc),
-! * Zke(Ntotc), Zeta(Ntotc),
-! * Dpdr(Ntotc), Dsdr(Ntotc), Rmat(2,Ntriag),
-! * Ymat(2,Ntriag), Rootp(Ntotc), Elinvr(Ntotc), Elinvi(Ntotc),
-! * Psmall(Ntotc)
-!
- DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/, &
- Tiny /1.d-8/, Teeny /1.d-20/
+
+ real(kind=8),parameter:: Zero = 0.0d0, One = 1.0d0, Two = 2.0d0, &
+ Tiny =1.d-8, Teeny = 1.d-20
+ integer::Nent, Ntot, I, Ichan, Iffy, Ires, Ishift, J, Ji, K, Kk, Kkx
+ integer::Kl, Kx, L, Lsp, Ii, Nrext
+ real(kind=8)::Aloge, beta, channelWidthC, channelWidthCPrime, Dp, Ds, Eta
+ real(kind=8)::Hi, Hr, P, Q, Rho, Rhof, S, Su
!
! NNNTOT not used anywhere
!
@@ -71,14 +52,18 @@ module xct7_m
! *** Initialize Rmat = R-Matrix
!
Aloge = Zero
+ Su = dAbs(calc%ener)
KL = 0
+ Nent = spinInfo%getNumEntryChannels()
+ Ntot = spinInfo%getNumChannels()
DO K=1,Ntot
- hasRext = resParData%hasRexInfo(Nnnn, K)
- Parext = 0.0d0
- IF (hasRext) then
- call resparData%getRextInfoByGroup(rextInfo, Nnnn, K)
- call resparData%getRext(rext, rextInfo)
- DO J = 1, rextInfo%getNrext()
+ hasRext = calc%resData%hasRexInfo(Igr, K)
+ Parext = 0.0d0
+ IF (hasRext) then
+ call calc%resData%getRextInfoByGroup(rextInfo, Igr, K)
+ Nrext = rextInfo%getNrext()
+ call calc%resData%getRext(rext, rextInfo)
+ DO J = 1, Nrext
Parext(J) = rext%getSammyValue(J)
end do
Aloge &
@@ -86,14 +71,14 @@ module xct7_m
end if
DO L=1,K
KL = KL + 1
- Rmat(1,KL) = Zero
- Rmat(2,KL) = Zero
+ calc%Rmat(1,KL) = Zero
+ calc%Rmat(2,KL) = Zero
IF (L.EQ.K .AND. hasRext) &
THEN
- Rmat(1,KL) = Parext(3) &
+ calc%Rmat(1,KL) = Parext(3) &
+ Parext(4)*Su &
- Parext(5)*Aloge
- IF (Nrext.EQ.7) Rmat(1,KL) = Rmat(1,KL) &
+ IF (Nrext.EQ.7) calc%Rmat(1,KL) = calc%Rmat(1,KL) &
+ Parext(7)*Su**2 - Parext(6)* &
( Parext(2) - Parext(1) ) &
- Parext(6)*Aloge*Su
@@ -101,22 +86,22 @@ module xct7_m
END DO
END DO
!
- call resParData%getSpinGroupInfo(spinInfo, igr)
+ call calc%resData%getSpinGroupInfo(spinInfo, igr)
- IF (Max.GE.Min .AND. Min.GT.0) THEN
- DO Ires=Min,Max
- call resParData%getResonanceInfo(resInfo, Ires)
- call resParData%getRedResonance(resonance, resInfo)
+ DO Ires=Min,calc%resData%getNumResonances()
+ call calc%resData%getResonanceInfo(resInfo, Ires)
+ if( resInfo%getSpinGroupIndex().ne.igr) exit
+ call calc%resData%getRedResonance(resonance, resInfo)
KL = 0
DO K=1,Ntot
ichan = spinInfo%getWidthForChannel(k)
channelWidthC = resonance%getWidth(ichan)
call spinInfo%getChannelInfo(channelInfo, K)
- call resParData%getChannel(channel, channelInfo)
- call resParData%getParticlePairInfo( &
+ call calc%resData%getChannel(channel, channelInfo)
+ call calc%resData%getParticlePairInfo( &
pairInfo, &
channelInfo%getParticlePairIndex())
- call resParData%getParticlePair(pair, pairInfo)
+ call calc%resData%getParticlePair(pair, pairInfo)
if (pair%getCalcShift()) then
Ishift = 1
else
@@ -131,32 +116,31 @@ module xct7_m
! Check on Beta is unnecessary, as we would just add zero - who cares
! Use K to track whether we add closed channel contribution based on value of Ishift
IF( Ishift == 0 ) THEN ! B=S
- IF ( Su.GT.Echan(K) .AND. Su.GT.Echan(L) ) THEN
- Rmat(1,KL) = Rmat(1,KL)+calc%Alphar(Ires)*Beta
+ IF ( Su.GT.calc%Echan(K, Igr) .AND. Su.GT.calc%Echan(L, Igr) ) THEN
+ calc%Rmat(1,KL) = calc%Rmat(1,KL)+calc%Alphar(Ires)*Beta
IF (calc%needAlphai(Ires)) THEN
- Rmat(2,KL) = Rmat(2,KL) + &
+ calc%Rmat(2,KL) = calc%Rmat(2,KL) + &
calc%Alphai(Ires)*Beta
END IF
END IF
ELSE ! B =/= S
- Rmat(1,KL) = Rmat(1,KL) + calc%Alphar(Ires)*Beta
+ calc%Rmat(1,KL) = calc%Rmat(1,KL) + calc%Alphar(Ires)*Beta
IF (calc%needAlphai(Ires)) THEN
- Rmat(2,KL) = Rmat(2,KL) + &
+ calc%Rmat(2,KL) = calc%Rmat(2,KL) + &
calc%Alphai(Ires)*Beta
END IF
END IF
END DO
END DO
END DO
- END IF
!
! *** Check if Rmat is Zero; if so, set Lrmat=1
KL = 0
DO K=1,Ntot
DO L=1,K
KL = KL + 1
- IF (Rmat(1,KL).NE.Zero) GO TO 20
- IF (Rmat(2,KL).NE.Zero) GO TO 20
+ IF (calc%Rmat(1,KL).NE.Zero) GO TO 20
+ IF (calc%Rmat(2,KL).NE.Zero) GO TO 20
END DO
END DO
Lrmat = 1
@@ -174,44 +158,46 @@ module xct7_m
DO K=1,Ntot
DO L=1,K
KL = KL + 1
- Ymat(1,KL) = - Rmat(1,KL)
- Ymat(2,KL) = - Rmat(2,KL)
+ calc%Ymat(1,KL) = - calc%Rmat(1,KL)
+ calc%Ymat(2,KL) = - calc%Rmat(2,KL)
END DO
END DO
!
- CALL Zero_Array (Psmall, Ntot)
+ calc%Psmall = Zero
+ if (calc%Ifzzz .OR. calc%Ifrad) then
+ calc%Dpdr = Zero
+ calc%Dsdr = Zero
+ end if
!
II = 0
DO I=1,Ntot
call spinInfo%getChannelInfo(channelInfo, I)
- call resParData%getChannel(channel, channelInfo)
- call resParData%getParticlePairInfo( &
+ call calc%resData%getChannel(channel, channelInfo)
+ call calc%resData%getParticlePairInfo( &
pairInfo, &
channelInfo%getParticlePairIndex())
- call resParData%getParticlePair(pair, pairInfo)
+ call calc%resData%getParticlePair(pair, pairInfo)
II = II + I
- Rootp (I) = Zero ! new default to cancel out closed channels
- Elinvr(I) = Zero
- Elinvi(I) = Zero ! new default to cancel out closed channels
- Dpdr(I) = Zero
- Dsdr(I) = Zero
+ calc%Rootp (I) = Zero ! new default to cancel out closed channels
+ calc%Elinvr(I) = Zero
+ calc%Elinvi(I) = Zero ! new default to cancel out closed channels
! IFFY is used to report when L is not invertible, i.e. L = S - B + iP = 0
Iffy = 0
! are we above the threshold for this channel?
ABOVE_THRESHOLD = .FALSE.
- if( (Su - Echan(I) ) .GT. Zero ) ABOVE_THRESHOLD = .TRUE.
+ if( (Su - calc%Echan(I, Igr) ) .GT. Zero ) ABOVE_THRESHOLD = .TRUE.
Lsp = channel%getL()
Q = Zero ! effective incoming energy
IF ( ABOVE_THRESHOLD ) THEN ! effective incoming energy is above channel threshold
- Q = dSQRT( Su - Echan(I) )
+ Q = dSQRT( Su - calc%Echan(I, Igr) )
ELSE ! effective incoming energy is below channel threshold
- Q = dSQRT( dABS( Su - Echan(I) ) )
+ Q = dSQRT( dABS( Su - calc%Echan(I, Igr) ) )
ENDIF
- Rho = channel%getApt()*Zke( I ) * Q ! "true" rho (effective incident neutron energy with "true" channel radius)
- Rhof = channel%getApe()*Zke( I ) * Q ! "effective" rho (effective incident neutron energy with "effective" channel radius)
+ Rho = channel%getApt()*calc%Zke(I, Igr) * Q ! "true" rho (effective incident neutron energy with "true" channel radius)
+ Rhof = channel%getApe()*calc%Zke(I, Igr) * Q ! "effective" rho (effective incident neutron energy with "effective" channel radius)
Eta = Zero
IF( Q .EQ. Zero ) THEN ! bomb out to prevent division by zero
@@ -220,7 +206,7 @@ module xct7_m
F10.5, ' effective energy was exactly zero:', F10.5)
RETURN
ENDIF
- IF( Zeta( I ) /= Zero ) Eta = Zeta( I ) / Q ! effective Eta
+ IF( calc%Zeta(I, Igr) /= Zero ) Eta = calc%Zeta(I, Igr) / Q ! effective Eta
! set CWF solver parameters
call cwf_solver%setRealPartRho( Rho )
@@ -273,9 +259,9 @@ module xct7_m
Hi = Zero
IF( Ishift /= 0 ) THEN
! we set the denominator first, then divide by it later
- Hr = ( S - Bound( I ) )**2 + P**2
+ Hr = ( S - calc%Bound(I, Igr) )**2 + P**2
Hi = -P / Hr
- Hr = ( S - Bound( I ) ) / Hr
+ Hr = ( S - calc%Bound(I, Igr ) ) / Hr
ELSE
! TODO: Maybe introduce cutoff on P? P < SMALL or something
! otherwise - should be impossible to get exactly P = 0.0 with Ishift = 0
@@ -287,9 +273,9 @@ module xct7_m
ENDIF
! compute phase shift and derivative if necessary
- Dphi( I ) = Zero
- Sinphi( I ) = Zero
- Cosphi( I ) = One
+ calc%Dphi( I ) = Zero
+ calc%Sinphi( I ) = Zero
+ calc%Cosphi( I ) = One
IF( ABOVE_THRESHOLD ) THEN
IF( Rho /= Rhof ) THEN
! TODO: Bug in old SAMMY implementation, uses wrong Rho for charged particles phase shifts...
@@ -298,23 +284,23 @@ module xct7_m
call cwf_solver%setRealPartRho( Rhof )
ENDIF
ENDIF
- Dphi( I ) = cwf_solver%getPhaseShiftDerivative()
- Sinphi( I ) = cwf_solver%getSinPhaseShift()
- Cosphi( I ) = cwf_solver%getCosPhaseShift()
+ calc%Dphi( I ) = cwf_solver%getPhaseShiftDerivative()
+ calc%Sinphi( I ) = cwf_solver%getSinPhaseShift()
+ calc%Cosphi( I ) = cwf_solver%getCosPhaseShift()
ENDIF
- Sinsqr(I) = Sinphi( I )**2 ! sin^2( phase shift )
- Sin2ph(I) = Two * Sinphi( I ) * Cosphi( I ) ! sin( 2 * phase shift )
+ calc%Sinsqr(I) = calc%Sinphi( I )**2 ! sin^2( phase shift )
+ calc%Sin2ph(I) = Two * calc%Sinphi( I ) * calc%Cosphi( I ) ! sin( 2 * phase shift )
- IF (Ifdif.NE.0) THEN
+ IF (calc%needAngular) THEN
Kk = (I*(I-1))/2
IF (I.GT.1) THEN
DO Kx=1,I-1
Kkx = Kk + Kx
- Cscs(1,Kkx) = Cosphi(Kx)*Cosphi(I) - &
- Sinphi(Kx)*Sinphi(I)
- Cscs(2,Kkx) = Cosphi(Kx)*Sinphi(I) + &
- Sinphi(Kx)*Cosphi(I)
+ calc%Cscs(1,Kkx) = calc%Cosphi(Kx)*calc%Cosphi(I) - &
+ calc%Sinphi(Kx)*calc%Sinphi(I)
+ calc%Cscs(2,Kkx) = calc%Cosphi(Kx)*calc%Sinphi(I) + &
+ calc%Sinphi(Kx)*calc%Cosphi(I)
END DO
ENDIF
ENDIF
@@ -345,53 +331,57 @@ module xct7_m
! ii) P was less than "Tiny"
! By removing that giant block, we are assuming that cases 1, 2.a, 2.b.i, and 2.b.ii never happen
- Rootp(I) = dSQRT( P )
- Dpdr(I) = Dp
- Dsdr(I) = Ds
+ calc%Rootp(I) = dSQRT( P )
+ if (calc%Ifzzz .OR. calc%Ifrad) then
+ calc%Dpdr(I) = Dp
+ calc%Dsdr(I) = Ds
+ end if
IF (Iffy.EQ.0 .AND. .NOT. (Ishift.EQ.0 .AND. &
- (One-P*Rmat(2,Ii).EQ.One .OR. P.LT.Tiny))) THEN
- Elinvr(I) = Hr
- Elinvi(I) = Hi
- Ymat(1,Ii) = Hr + Ymat(1,Ii)
- Ymat(2,Ii) = Hi + Ymat(2,Ii)
+ (One-P*calc%Rmat(2,Ii).EQ.One .OR. P.LT.Tiny))) THEN
+ calc%Elinvr(I) = Hr
+ calc%Elinvi(I) = Hi
+ calc%Ymat(1,Ii) = Hr + calc%Ymat(1,Ii)
+ calc%Ymat(2,Ii) = Hi + calc%Ymat(2,Ii)
ELSE
! *** Here penetrability is very small but non-Zero
! *** However, if too small to compute, set Psmall = -1.0
- IF (Rootp(I).LT.Teeny) THEN
- Psmall(I) = -One
+ IF (calc%Rootp(I).LT.Teeny) THEN
+ calc%Psmall(I) = -One
ELSE
- Psmall(I) = Rootp(I)
+ calc%Psmall(I) = calc%Rootp(I)
END IF
- Ymat(1,Ii) = P*Ymat(1,Ii)
- Ymat(2,Ii) = P*Ymat(2,Ii) - One
- Rmat(1,Ii) = P*Rmat(1,Ii)
- Rmat(2,Ii) = P*Rmat(2,Ii)
+ calc%Ymat(1,Ii) = P*calc%Ymat(1,Ii)
+ calc%Ymat(2,Ii) = P*calc%Ymat(2,Ii) - One
+ calc%Rmat(1,Ii) = P*calc%Rmat(1,Ii)
+ calc%Rmat(2,Ii) = P*calc%Rmat(2,Ii)
IF (Ntot.GT.1) THEN
IF (I.GT.1) THEN
DO J=1,I-1
Ji = (I*(I-1))/2 + J
- Ymat(1,Ji) = Rootp(I)*Ymat(1,Ji)
- Ymat(2,Ji) = Rootp(I)*Ymat(2,Ji)
- Rmat(1,Ji) = Rootp(I)*Rmat(1,Ji)
- Rmat(2,Ji) = Rootp(I)*Rmat(2,Ji)
+ calc%Ymat(1,Ji) = calc%Rootp(I)*calc%Ymat(1,Ji)
+ calc%Ymat(2,Ji) = calc%Rootp(I)*calc%Ymat(2,Ji)
+ calc%Rmat(1,Ji) = calc%Rootp(I)*calc%Rmat(1,Ji)
+ calc%Rmat(2,Ji) = calc%Rootp(I)*calc%Rmat(2,Ji)
END DO
END IF
IF (I.LT.Ntot) THEN
DO J=I+1,Ntot
Ji = (J*(J-1))/2 + I
- Ymat(1,Ji) = Rootp(I)*Ymat(1,Ji)
- Ymat(2,Ji) = Rootp(I)*Ymat(2,Ji)
- Rmat(1,Ji) = Rootp(I)*Rmat(1,Ji)
- Rmat(2,Ji) = Rootp(I)*Rmat(2,Ji)
+ calc%Ymat(1,Ji) = calc%Rootp(I)*calc%Ymat(1,Ji)
+ calc%Ymat(2,Ji) = calc%Rootp(I)*calc%Ymat(2,Ji)
+ calc%Rmat(1,Ji) = calc%Rootp(I)*calc%Rmat(1,Ji)
+ calc%Rmat(2,Ji) = calc%Rootp(I)*calc%Rmat(2,Ji)
END DO
END IF
END IF
- Rootp(I) = One
- Elinvr(I) = Zero
- Elinvi(I) = -One
- Dpdr(I) = Zero
- Dsdr(I) = Zero
+ calc%Rootp(I) = One
+ calc%Elinvr(I) = Zero
+ calc%Elinvi(I) = -One
+ if (calc%Ifzzz .OR. calc%Ifrad) then
+ calc%Dpdr(I) = Zero
+ calc%Dsdr(I) = Zero
+ end if
END IF
END DO
@@ -401,8 +391,8 @@ module xct7_m
KL = 0
DO K=1,Ntot
KL = KL + K
- IF (Ymat(1,KL).EQ.Zero .AND. Ymat(2,KL).EQ.Zero) THEN
- Ymat(1,KL) = One
+ IF (calc%Ymat(1,KL).EQ.Zero .AND. calc%Ymat(2,KL).EQ.Zero) THEN
+ calc%Ymat(1,KL) = One
END IF
END DO
END IF
@@ -416,60 +406,65 @@ module xct7_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Re_Setr (Nent, Ntot, Sinsqr, Sin2ph, Dphi, Cscs, &
- Sinphi, Cosphi, Dpdr, Dsdr, Rmat, Ymat, Rootp, Elinvr, Elinvi, &
- If_Excl)
+ SUBROUTINE Re_Setr (calc, spinInfo, Igr)
!
! *** Purpose -- Reset all necessary values to zero if some channels
! *** are excluded
!
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use broad_common_m
- use varyr_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ use SammySpinGroupInfo_M
+
!
- DIMENSION Sinsqr(*), Sin2ph(*), Dphi(*), Cscs(2,*), Dpdr(*), &
- Dsdr(*), Rmat(2,*), Ymat(2,*), Rootp(*), Elinvr(*), &
- Elinvi(*), Sinphi(*), Cosphi(*), If_Excl(*)
+ type(SammySpinGroupInfo)::spinInfo
+ class(XctCrossCalc)::calc
+ integer::igr
+ type(SammyChannelInfo)::channelInfo
+ integer::I, K, KL, L, Ntot
!
!
- DATA Zero /0.0d0/, One /1.0d0/
+ real(kind=8),parameter::Zero=0.0d0, One=1.0d0
+ logical::hasExclude
!
!
+ hasExclude = .false.
+ ntot = spinInfo%getNumChannels()
DO I=1,Ntot
- IF (If_Excl(I).LT.0) THEN
- Sinphi(I) = Zero
- Cosphi(I) = Zero
- Sinsqr(I) = Zero
- Sin2ph(I) = Zero
- Rootp (I) = Zero
- Elinvr(I) = Zero
- Elinvi(I) = Zero
- Dphi (I) = Zero
- Dpdr (I) = Zero
- Dsdr (I) = Zero
+ call spinInfo%getChannelInfo(channelInfo, I)
+ if (channelInfo%getExcludeCompletely()) then
+ hasExclude = .true.
+ calc%Sinphi(I) = Zero
+ calc%Cosphi(I) = Zero
+ calc%Sinsqr(I) = Zero
+ calc%Sin2ph(I) = Zero
+ calc%Rootp (I) = Zero
+ calc%Elinvr(I) = Zero
+ calc%Elinvi(I) = Zero
+ calc%Dphi(I) = Zero
+ if (calc%Ifzzz .OR. calc%Ifrad) then
+ calc%Dpdr (I) = Zero
+ calc%Dsdr (I) = Zero
+ end if
END IF
END DO
+ if (.not.hasExclude) return
!
KL = 0
DO K=1,Ntot
- DO L=1,K
+ call spinInfo%getChannelInfo(channelInfo, K)
+ hasExclude = channelInfo%getExcludeCompletely()
+ DO L=1,K
KL = KL + 1
- IF (If_Excl(K).LT.0 .OR. If_Excl(L).LT.0) THEN
- IF (Ifdif.NE.0) THEN
- Cscs(1,KL) = Zero
- Cscs(2,KL) = Zero
+ call spinInfo%getChannelInfo(channelInfo, l)
+ IF (hasExclude .OR.channelInfo%getExcludeCompletely()) THEN
+ IF (calc%needAngular) THEN
+ calc%Cscs(:,KL) = Zero
END IF
- Rmat(1,KL) = Zero
- Rmat(2,KL) = Zero
+ calc%Rmat(:,KL) = Zero
IF (K.EQ.L) THEN
- Ymat(1,KL) = One
+ calc%Ymat(1,KL) = One
ELSE
- Ymat(1,KL) = Zero
+ calc%Ymat(1,KL) = Zero
END IF
- Ymat(2,KL) = Zero
+ calc%Ymat(2,KL) = Zero
END IF
END DO
END DO
diff --git a/sammy/src/xct/mxct08.f90 b/sammy/src/xct/mxct08.f90
index c3bc87aaa..acce85913 100755
--- a/sammy/src/xct/mxct08.f90
+++ b/sammy/src/xct/mxct08.f90
@@ -1,56 +1,54 @@
+module mxct08_m
+use XctCrossCalc_M
+IMPLICIT none
+
+
+private Yfour
+contains
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Zeror (Xxxxr, Xxxxi, Xqr, Xqi, Pxrhor, Pxrhoi, Ntot)
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Xxxxr(*), Xxxxi(*), Xqr(Ntot,*), Xqi(Ntot,*), &
- Pxrhor(*), Pxrhoi(*)
- DATA Zero /0.0d0/
- N = Ntot
- JK = 0
- DO J=1,N
- DO K=1,J
- JK = JK + 1
- Xxxxr (JK) = Zero
- Xxxxi (JK) = Zero
- Pxrhor(JK) = Zero
- Pxrhoi(JK) = Zero
- END DO
- END DO
- DO J=1,N
- DO K=1,N
- Xqr(K,J) = Zero
- Xqi(K,J) = Zero
- END DO
- END DO
+ SUBROUTINE Zeror (calc)
+ class(XctCrossCalc)::calc
+
+ calc%Xxxxi = 0.0d0
+ calc%Xxxxr = 0.0d0
+ calc%Xqr = 0.0d0
+ calc%Xqi = 0.0d0
+
+ IF (calc%Ifzzz .OR. calc%Ifrad) THEN
+ calc%Pxrhor = 0.0d0
+ calc%Pxrhoi = 0.0d0
+ end if
+
RETURN
END
!
! --------------------------------------------------------------
!
- SUBROUTINE Yinvrs (Ymat, Yinv, Dummy, Ntot)
+ SUBROUTINE Yinvrs (calc, Ntot)
!
! *** PURPOSE -- Invert Ymat to give Yinv
!
- DOUBLE PRECISION Ymat, Yinv, Dummy
- DIMENSION Ymat(2,*), Yinv(2,*), Dummy(*)
+ integer::ntot
+ class(XctCrossCalc)::calc
!
IF (Ntot.EQ.1) THEN
! *** ONE CHANNEL -- (INVERSE OF Ymat) = Yinv
- CALL Onech (Ymat, Yinv)
+ CALL Onech (calc%Ymat, calc%Yinv)
!
ELSE IF (Ntot.EQ.2) THEN
! *** TWO CHANNELS -- (INVERSE OF Ymat) = Yinv
- CALL Twoch (Ymat, Yinv)
+ CALL Twoch (calc%Ymat, calc%Yinv)
!
ELSE IF (Ntot.EQ.3) THEN
! *** THREE CHANNELS -- (INVERSE OF Ymat) = Yinv
- CALL Three (Ymat, Yinv)
+ CALL Three (calc%Ymat, calc%Yinv)
!
ELSE
! *** INVERT Ymat TO GIVE Yinv FOR MORE THAN Three CHANNELS
- CALL Yfour (Ymat, Yinv, Dummy, Ntot)
+ CALL Yfour (calc%Ymat, calc%Yinv, calc%Xqr, Ntot)
!
END IF
RETURN
@@ -60,32 +58,29 @@
! --------------------------------------------------------------
!
SUBROUTINE Yfour (Ymat, Yinv, Dummy, Ntot)
-!
-! *** PURPOSE -- calculate Ymat**-1, for any number of channels.
-!
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Ymat(2,*), Yinv(2,*), Dummy(2,*), III(100)
- DATA Zero /0.0d0/, One /1.0d0/
- DATA Maxaa /100/
-!
+ use Xspfa_Xspsl_m
+ real(kind=8)::Ymat(:,:), Yinv(:,:), Dummy(:,:)
+ integer::III(100)
+ integer::Ntot
+ real(kind=8),parameter::Zero = 0.0d0, One=1.0d0
+ integer,parameter::Maxaa=100
+ integer::Kj, J, K, Info
+
IF (Ntot.GT.Maxaa) STOP '[STOP in Yfour in xct/mxct08.f]'
-!
+
CALL Xspfa (Ymat, Ntot, Iii, Info)
IF (Info.NE.0) WRITE (6,99998) Info
99998 FORMAT (' Problem in Xspfa with Info=', I5)
Kj = 0
DO K=1,Ntot
- DO J=1,Ntot
- Dummy(1,J) = Zero
- Dummy(2,J) = Zero
- END DO
+ Dummy(1:2,:) = Zero
Dummy(1,K) = One
- CALL Xspsl (Ymat, Ntot, Iii, Dummy)
+ CALL Xspsl (Ymat, Ntot, Iii, Dummy(1:2,:))
DO J=1,K
Kj = Kj + 1
Yinv(1,KJ) = Dummy(1,J)
Yinv(2,KJ) = Dummy(2,J)
END DO
END DO
- RETURN
END
+end module mxct08_m
diff --git a/sammy/src/xct/mxct09.f90 b/sammy/src/xct/mxct09.f90
index b070dc007..9111626bd 100644
--- a/sammy/src/xct/mxct09.f90
+++ b/sammy/src/xct/mxct09.f90
@@ -1,9 +1,12 @@
+module mxct09_m
+use XctCrossCalc_M
+IMPLICIT None
+contains
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Setxqx (Ntot, Yinv, Rmat, Xqr, Xqi, Rootp, Elinvr, &
- Elinvi, Xxxxr, Xxxxi)
+ SUBROUTINE Setxqx (calc, Ntot)
!
! *** Purpose -- Form XQ & XXXX matrices, where
! *** XQ = Yinv * Rmat and
@@ -17,20 +20,15 @@
!
! *** ie W = I + 2i XXXX
!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
- DIMENSION Yinv(2,*), Rmat(2,*), Xqr(Ntot,*), Xqi(Ntot,*), &
- Rootp(*), Elinvr(*), Elinvi(*), Xxxxr(*), Xxxxi(*)
-! DIMENSION Yinv(2,Nnnn), Rmat(2,Nnnn), Xqr(Ntot,Ntot),
-! * Xqi(Ntot,Ntot), Rootp(Ntotc), Elinvr(Ntot), Elinvi(Ntot),
-! * Xxxxr(Nnnn), Xxxxi(Nnnn)
- EXTERNAL Ijkl
+ class(XctCrossCalc)::calc
+ integer::ntot
+ integer::I, Ij, Jk, K, J
+ real(kind=8)::Pli, Plr
+
!
- CALL Zero_Array (Xqr, Ntot*Ntot)
- CALL Zero_Array (Xqi, Ntot*Ntot)
+ calc%Xqr = 0.0d0
+ calc%Xqi = 0.0d0
!
! *** Xqr(k,i) = (L**-1-R)**-1 * R ... note asymmetry
DO I=1,Ntot
@@ -38,10 +36,10 @@
Ij = Ijkl(J,I)
DO K=1,Ntot
Jk = Ijkl(K,J)
- Xqr(K,I) = Xqr(K,I) + Yinv(1,Ij)*Rmat(1,Jk) - &
- Yinv(2,Ij)*Rmat(2,Jk)
- Xqi(K,I) = Xqi(K,I) + Yinv(1,Ij)*Rmat(2,Jk) + &
- Yinv(2,Ij)*Rmat(1,Jk)
+ calc%Xqr(K,I) = calc%Xqr(K,I) + calc%Yinv(1,Ij)*calc%Rmat(1,Jk) - &
+ calc%Yinv(2,Ij)*calc%Rmat(2,Jk)
+ calc%Xqi(K,I) = calc%Xqi(K,I) + calc%Yinv(1,Ij)*calc%Rmat(2,Jk) + &
+ calc%Yinv(2,Ij)*calc%Rmat(1,Jk)
END DO
END DO
END DO
@@ -49,12 +47,12 @@
! *** Xxxx = sqrt(P)/L * xq * sqrt(P) ... symmetric
IJ = 0
DO I=1,Ntot
- Plr = Rootp(I)*Elinvr(I)
- Pli = Rootp(I)*Elinvi(I)
+ Plr = calc%Rootp(I)*calc%Elinvr(I)
+ Pli = calc%Rootp(I)*calc%Elinvi(I)
DO J=1,I
Ij = Ij + 1
- Xxxxr(Ij) = Rootp(J)* (Xqr(J,I)*Plr-Xqi(J,I)*Pli)
- Xxxxi(Ij) = Rootp(J)* (Xqi(J,I)*Plr+Xqr(J,I)*Pli)
+ calc%Xxxxr(Ij) = calc%Rootp(J)* (calc%Xqr(J,I)*Plr-calc%Xqi(J,I)*Pli)
+ calc%Xxxxi(Ij) = calc%Rootp(J)* (calc%Xqi(J,I)*Plr+calc%Xqr(J,I)*Pli)
END DO
END DO
RETURN
@@ -63,128 +61,133 @@
!
! --------------------------------------------------------------
!
- SUBROUTINE Sectio (Nent, Next, igr, Echan, If_Excl, Ifcros, Zke, &
- Zeta, Xxxxr, Xxxxi, Sinsqr, Sin2ph, Termf, Crss, Crssx, Cscs, &
- Dgoj, Ntotnn)
+ SUBROUTINE Sectio (spinInfo, calc, igr)
!
! *** Purpose -- Generate pieces of cross sections (except for "4 pi / E")
!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- use EndfData_common_m
use SammyResonanceInfo_M
use RMatResonanceParam_M
- use mxct26_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ use mxct26_m
!
+ class(XctCrossCalc)::calc
type(SammySpinGroupInfo)::spinInfo
type(SammyChannelInfo)::channelInfo
type(RMatChannelParams)::channel
- DIMENSION Echan(*), If_Excl(*), Ifcros(*), Zke(*), &
- Zeta(*), Xxxxr(*), Xxxxi(*),Sinsqr(*), Sin2ph(*), Termf(*), &
- Crss(Ncrsss), Crssx(2,Ntotc,Ntotc,*), Cscs(2,*)
- DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/
-!
-!
-!
- IF (Ifcros(1).EQ.1) THEN
+ real(kind=8),parameter:: Zero = 0.0d0, One = 1.0d0, Two = 2.0d0
+ integer::Nent, Next, igr, Ntotnn
+ real(kind=8)::Dgoj
+ real(kind=8)::val, Su
+ real(kind=8)::Ai, Ar, Bi, Br, Ci, Cr, Di, Dr
+ real(kind=8)::Terma, Termn, Zz
+ logical::Ifs
+ integer::I, Ichan, Ichanx, Ii, Ij, J, Jj, Lspin, Lspinx
+!
+!
+!
+ Su = dAbs(calc%ener)
+ Nent = spinInfo%getNumEntryChannels()
+ Next = spinInfo%getNumExitChannels()
+ Ntotnn = spinInfo%getNumChannels()
+ Dgoj = spinInfo%getGFactor()
+ IF (calc%Ifcros(1)) THEN
! *** elastic Crss(1) = g*0.25* sum(entrance chs c,c')
! *** times |(1-U(c,c'))| **2 / Zz
! *** = g* [ sin(phi)**2 * (1-2Xxxxi)
! *** - sin(2phi)*Xxxxr
! *** + (Xxxxr**2 + Xxxxi**2) ] / Zz
- Crss(1) = Zero
+ val = Zero
Ii = 0
Ij = 0
DO I=1,Nent
- Zz = Zke(I)**2
+ Zz = calc%Zke(I, Igr)**2
Ii = Ii + I
- Termn = Sinsqr(I)*( One - Two * Xxxxi(Ii) ) &
- - Sin2ph(I)*Xxxxr(Ii)
+ Termn = calc%Sinsqr(I)*( One - Two *calc%Xxxxi(Ii) ) &
+ - calc%Sin2ph(I)*calc%Xxxxr(Ii)
Termn = Termn / Zz
DO J=1,I
Ij = Ij + 1
- Ar = ( Xxxxr(Ij)**2 + Xxxxi(Ij)**2 )/Zz
+ Ar = ( calc%Xxxxr(Ij)**2 + calc%Xxxxi(Ij)**2 )/Zz
IF (I.NE.J) Ar = Ar + Ar
Termn = Termn + Ar
END DO
- Crss(1) = Termn + Crss(1)
+ val = Termn + val
END DO
- Crss(1) = Crss(1)*Dgoj
+ val = val * Dgoj + calc%crossInternal(1, igr, 0)
+ calc%crossInternal(1, igr, 0) = val
END IF
!
- IF (Ifcros(2).EQ.1) THEN
+ IF (calc%Ifcros(2)) THEN
! *** absorption = g*0.25 * sum(inc c)
! *** [ 1 - sum(inc c') |U(c,c')| **2 ] / Zz
! *** = - g* (Xxxxr**2 + Xxxxi**2) / Zz
- Crss(2) = Zero
+ val = Zero
Ii = 0
Ij = 0
DO I=1,Nent
Ii = Ii + I
- Zz = Zke(I)**2
- Terma = Xxxxi(Ii)*(One-Xxxxi(Ii)) - Xxxxr(Ii)**2
+ Zz = calc%Zke(I, Igr)**2
+ Terma = calc%Xxxxi(Ii)*(One-calc%Xxxxi(Ii)) - calc%Xxxxr(Ii)**2
DO J=1,I
Ij = Ij + 1
IF (J.NE.I) THEN
- Ar = - Xxxxr(Ij)**2 - Xxxxi(Ij)**2
+ Ar = - calc%Xxxxr(Ij)**2 - calc%Xxxxi(Ij)**2
Ar = Ar + Ar
Terma = Terma + Ar
END IF
END DO
Terma = Terma / Zz
- Crss(2) = Terma + Crss(2)
+ val = Terma + val
END DO
- Crss(2) = Crss(2)*Dgoj
+ val = val * Dgoj + calc%crossInternal(2, igr, 0)
+ calc%crossInternal(2, igr, 0) = val
END IF
!
IF (Next.GT.0 .and. Ntotnn.GT.Nent) THEN
! *** reaction ch c'= g*0.25 * sum(inc c) |U(c,c')|**2 / Zz
! *** = g* (Xxxxr**2 + Xxxxi**2) / Zz
+ calc%termf = Zero
DO Jj=1,Next
- Termf(Jj) = Zero
- END DO
- DO Jj=1,Next
- IF (Jj+Nent.LE.Ntotnn .AND. Ifcros(Jj+2).NE.0) THEN
- IF ( (Kaptur.EQ.0 .AND. If_Excl(Jj+Nent).EQ.0) .OR. &
- (Kaptur.EQ.1 .AND. If_Excl(Jj+Nent).EQ.1) ) THEN
+ IF (Jj+Nent.LE.Ntotnn .AND. calc%Ifcros(Jj+2)) THEN
+ call spinInfo%getChannelInfo(channelInfo, Jj+Nent)
+ ifs = channelInfo%getIncludeInCalc()
+ IF ( (.not.calc%addElimKapt .AND. Ifs) .OR. &
+ ( calc%addElimKapt .AND. .not.Ifs) ) THEN
J = Jj + Nent
DO I=1,Nent
- Zz = Zke(I)**2
+ Zz = calc%Zke(I, Igr)**2
Ij = (J*(J-1))/2 + I
!q Ij = Ijkl(I,J) but I < J always
- Termf(Jj) = Termf(Jj) + &
- (Xxxxr(Ij)**2+Xxxxi(Ij)**2)/Zz
+ calc%Termf(Jj) = calc%Termf(Jj) + &
+ (calc%Xxxxr(Ij)**2+calc%Xxxxi(Ij)**2)/Zz
END DO
END IF
- Crss(2+Jj) = Termf(Jj)*Dgoj
+ val = calc%Termf(Jj)*Dgoj + calc%crossInternal(2+Jj, igr, 0)
+ calc%crossInternal(2+Jj, igr, 0) = val
END IF
END DO
END IF
!
!
- IF (Ifdif.NE.0) THEN
+ IF (calc%needAngular) THEN
!
-! *** Angular Distribution Crssx(.,i,ix,igroup) = (1-U)/2
- call resParData%getSpinGroupInfo(spinInfo, igr)
+! *** Angular Distribution Crssx(.,i,ix,igroup) = (1-U)/2
DO Ichan=1,Ntotnn
call spinInfo%getChannelInfo(channelInfo, Ichan)
- call resParData%getChannel(channel, channelInfo)
+ call calc%resData%getChannel(channel, channelInfo)
Lspin = channel%getL()
- Ifs = If_Stay (Ichan, Ifdif, Nent, If_Excl(Ichan), Kaptur)
- IF (Ifs.EQ.0) THEN
+
+ IF (calc%useChannel(Ichan,2)) THEN
!
- IF (Zeta(Ichan).NE.Zero .AND. Su.GT.Echan(Ichan)) THEN
+ IF (calc%Zeta(Ichan, Igr).NE.Zero .AND. Su.GT.calc%Echan(Ichan,Igr)) THEN
CALL Get_Coul_Phase (Cr, Ci, Lspin, &
- Echan(Ichan), Zeta(Ichan), Su)
+ calc%Echan(Ichan, Igr), calc%Zeta(Ichan, Igr), Su)
ELSE
Cr = One
Ci = Zero
END IF
DO Ichanx=1,Nent
call spinInfo%getChannelInfo(channelInfo, Ichanx)
- call resParData%getChannel(channel, channelInfo)
+ call calc%resData%getChannel(channel, channelInfo)
Lspinx = channel%getL()
IF (Ichanx.LE.Ichan) THEN
II = (Ichan*(Ichan-1))/2 + Ichanx
@@ -193,26 +196,26 @@
END IF
! *** real and imaginary parts of (1-U)/2
IF (Ichanx.EQ.Ichan) THEN
- Ar = Sinsqr(Ichan)*(One-Two*Xxxxi(II)) &
- - Sin2ph(Ichan)*Xxxxr(II) + Xxxxi(II)
- Ai = Sin2ph(Ichan)*(0.5d0-Xxxxi(II)) &
- - (One-Two*Sinsqr(Ichan)) * Xxxxr(II)
+ Ar = calc%Sinsqr(Ichan)*(One-Two*calc%Xxxxi(II)) &
+ - calc%Sin2ph(Ichan)*calc%Xxxxr(II) + calc%Xxxxi(II)
+ Ai = calc%Sin2ph(Ichan)*(0.5d0-calc%Xxxxi(II)) &
+ - (One-Two*calc%Sinsqr(Ichan)) * calc%Xxxxr(II)
ELSE
- Ar = Cscs(1,II)*Xxxxi(II) - Cscs(2,II)*Xxxxr(II)
- Ai =-Cscs(1,II)*Xxxxr(II) - Cscs(2,II)*Xxxxi(II)
+ Ar = calc%Cscs(1,II)*calc%Xxxxi(II) - calc%Cscs(2,II)*calc%Xxxxr(II)
+ Ai =-calc%Cscs(1,II)*calc%Xxxxr(II) - calc%Cscs(2,II)*calc%Xxxxi(II)
END IF
- If (Zeta(Ichan ).NE.Zero .OR. &
- Zeta(Ichanx).NE.Zero) THEN
+ If (calc%Zeta(Ichan, Igr).NE.Zero .OR. &
+ calc%Zeta(Ichanx,Igr).NE.Zero) THEN
Br = Ar*Cr - Ai*Ci
Bi = Ar*Ci + Ai*Cr
IF ((Lspinx.NE.Lspin .OR. &
- Zeta(Ichanx).NE.Zeta(Ichan)) .AND. &
+ calc%Zeta(Ichanx,Igr).NE.calc%Zeta(Ichan,Igr)) .AND. &
Ichan.NE.Ichanx ) THEN
- IF (Zeta(Ichanx).NE.Zero .AND. &
- Su.GT.Echan(Ichanx)) THEN
+ IF (calc%Zeta(Ichanx,Igr).NE.Zero .AND. &
+ Su.GT.calc%Echan(Ichanx, Igr)) THEN
CALL Get_Coul_Phase (Dr, Di, &
- Lspinx, Echan(Ichanx), &
- Zeta(Ichanx), Su)
+ Lspinx, calc%Echan(Ichanx, Igr), &
+ calc%Zeta(Ichanx,Igr), Su)
ELSE
Dr = One
Di = Zero
@@ -224,8 +227,8 @@
Ar = Br*Dr - Bi*Di
Ai = Br*Di + Bi*Dr
END IF
- Crssx(1,Ichanx ,Ichan,Nnnn ) = Ar
- Crssx(2,Ichanx ,Ichan,Nnnn ) = Ai
+ calc%angInternal(1,Ichanx ,Ichan,Igr, 0) = Ar
+ calc%angInternal(2,Ichanx ,Ichan,Igr, 0) = Ai
! entrance,exit ,group
END DO
END IF
@@ -240,6 +243,7 @@
! --------------------------------------------------------------
!
INTEGER FUNCTION Ijkl (M,N)
+ integer::M,N
IF (M.LE.N) THEN
Ijkl = (N*(N-1))/2 + M
ELSE
@@ -247,31 +251,4 @@
END IF
RETURN
END
-!
-!
-! --------------------------------------------------------------
-!
- INTEGER FUNCTION If_Stay (Ichan, Ifdif, Nent, If_Excl, Kaptur)
-! *** If_Stay = 0 if want this channel, If_Stay = 1 if do not
- If_Stay = 0
- IF (Ifdif.EQ.1 .AND. Ichan.GT.Nent) THEN
-! *** Ifdif=1 means elastic
- If_Stay = 1
- ELSE IF (Ifdif.EQ.2) THEN
-! *** Ifdif=2 means reaction of some kind
- IF (Ichan.LE.Nent) THEN
- If_Stay = 1
-! *** Do not want elastic
- ELSE IF (Kaptur.EQ.0 .AND. If_Excl.EQ.1) THEN
- If_Stay = 1
-! *** Do not want excluded channel in final state
- ELSE IF (Kaptur.EQ.1 .AND. If_Excl.EQ.0) THEN
- If_Stay = 1
-! *** Will subtract only excluded channels from absorption
- ELSE IF (If_Excl.EQ.-1) THEN
- If_Stay = -1
-! *** Do not want excluded channel anywhere in the calculation
- END IF
- END IF
- RETURN
- END
+end module mxct09_m
diff --git a/sammy/src/xct/mxct10.f90 b/sammy/src/xct/mxct10.f90
index 77e12f92b..9f2180d6a 100644
--- a/sammy/src/xct/mxct10.f90
+++ b/sammy/src/xct/mxct10.f90
@@ -1,53 +1,50 @@
+module mxct10_m
+use XctCrossCalc_M
+contains
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Setqri (Yinv, Xqr, Xqi, Rootp, Elinvr, Elinvi, Qr, Qi, &
- Psmall, Ntot)
+ SUBROUTINE Setqri (calc, Ntot)
!
! *** Purpose -- Generate QR,QI =
! *** SQRT(P)/(S-B+IP) * Yinv*Yinv * SQRT(P)/(S-B+IP)
! ***
! *** That is, Qr(KL,Ij) is (real part of) partial of XXXX(Kl) wrt R(Ij)
!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ use mxct09_m
+ IMPLICIT None
!
!
- DIMENSION Yinv(2,*), Qr(Nn,*), Qi(NN,*), Psmall(*), &
- Xqr(Ntot,*), Xqi(Ntot,*), Rootp(*), Elinvr(*), Elinvi(*)
+ class(XctCrossCalc)::calc
+ integer::ntot
+ integer::I, Ij, J, K, Kl, L, IK
+ real(kind=8)::Plii, Plri
!
-! DIMENSION Yinv(2,nn), Qr(Nn,Nn), Qi(Nn,Nn),
-! * Xqr(Ntot,Ntot), Xqi(Ntot,Ntot), Rootp(Ntot),
-! * Elinvr(Ntot), Elinvi(Ntot), Psmall(Ntot)
-!
- EXTERNAL Ijkl
- DATA Zero /0.0d0/
+ real(kind=8), parameter::Zero = 0.0d0
!
!
! *** redefine meaning of Xqr & Xqi
! *** Xq = Rootp*Yinv
DO I=1,Ntot
- Plri = Rootp(I)*Elinvr(I)
- Plii = Rootp(I)*Elinvi(I)
+ Plri = calc%Rootp(I)*calc%Elinvr(I)
+ Plii = calc%Rootp(I)*calc%Elinvi(I)
DO K=1,Ntot
IK = IJKL(I,K)
- Xqr(K,I) = Plri*Yinv(1,IK) - Plii*Yinv(2,IK)
- Xqi(K,I) = Plri*Yinv(2,IK) + Plii*Yinv(1,IK)
- IF (Psmall(K).GT.Zero) THEN
- Xqr(K,I) = Xqr(K,I)*Psmall(K)
- Xqi(K,I) = Xqi(K,I)*Psmall(K)
- ELSE IF (Psmall(K).LT.Zero) THEN
- Xqr(K,I) = Zero
- Xqi(K,I) = Zero
+ calc%Xqr(K,I) = Plri*calc%Yinv(1,IK) - Plii*calc%Yinv(2,IK)
+ calc%Xqi(K,I) = Plri*calc%Yinv(2,IK) + Plii*calc%Yinv(1,IK)
+ IF (calc%Psmall(K).GT.Zero) THEN
+ calc%Xqr(K,I) = calc%Xqr(K,I)*calc%Psmall(K)
+ calc%Xqi(K,I) = calc%Xqi(K,I)*calc%Psmall(K)
+ ELSE IF (calc%Psmall(K).LT.Zero) THEN
+ calc%Xqr(K,I) = Zero
+ calc%Xqi(K,I) = Zero
END IF
END DO
END DO
!
- CALL Zero_Array (Qr, Nn*Nn)
- CALL Zero_Array (Qi, Nn*Nn)
+ calc%Qr = Zero
+ calc%Qi = Zero
!
Ij = 0
DO I=1,Ntot
@@ -57,15 +54,15 @@
DO K=1,Ntot
DO L=1,K
KL = KL + 1
- Qr(KL,Ij) = Xqr(I,K)*Xqr(J,L) - &
- Xqi(I,K)*Xqi(J,L)
- Qi(KL,Ij) = Xqr(I,K)*Xqi(J,L) + &
- Xqi(I,K)*Xqr(J,L)
+ calc%Qr(KL,Ij) = calc%Xqr(I,K)*calc%Xqr(J,L) - &
+ calc% Xqi(I,K)*calc%Xqi(J,L)
+ calc%Qi(KL,Ij) = calc%Xqr(I,K)*calc%Xqi(J,L) + &
+ calc%Xqi(I,K)*calc%Xqr(J,L)
IF (I.NE.J) THEN
- Qr(KL,Ij) = Qr(KL,Ij) + Xqr(J,K)*Xqr(I,L) - &
- Xqi(J,K)*Xqi(I,L)
- Qi(KL,Ij) = Qi(KL,Ij) + Xqr(J,K)*Xqi(I,L) + &
- Xqi(J,K)*Xqr(I,L)
+ calc%Qr(KL,Ij) = calc%Qr(KL,Ij) + calc%Xqr(J,K)*calc%Xqr(I,L) - &
+ calc%Xqi(J,K)*calc%Xqi(I,L)
+ calc%Qi(KL,Ij) = calc%Qi(KL,Ij) + calc%Xqr(J,K)*calc%Xqi(I,L) + &
+ calc%Xqi(J,K)*calc%Xqr(I,L)
END IF
END DO
END DO
@@ -78,108 +75,111 @@
!
! --------------------------------------------------------------
!
- SUBROUTINE Settri (Nent, Next, igr, Echan, If_Excl, Zke, Zeta, &
- Ifcros, Xxxxr, Xxxxi, Sinsqr, Sin2ph, Cscs, Qr, Qi, Tr, Ti, Tx, &
- Ntot)
+ SUBROUTINE Settri (spinInfo,calc, igr)
!
! *** Purpose -- Generate Tr & Ti, which are 0.5 * [the real and
! *** imaginary parts of the partial of Crss with respect to R]
!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- use EndfData_common_m
use SammyResonanceInfo_M
use RMatResonanceParam_M
use mxct26_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ use mxct09_m
+ IMPLICIT None
!
+ class(XctCrossCalc)::calc
type(SammySpinGroupInfo)::spinInfo
+ integer::igr
type(SammyChannelInfo)::channelInfo
- type(RMatChannelParams)::channel
- DIMENSION Echan(*), If_Excl(*), Zke(*), Zeta(*), &
- Ifcros(*), Xxxxr(*), Xxxxi(*), Sinsqr(*), Sin2ph(*), Cscs(2,*), &
- Qr(NN,*), Qi(NN,*), Tr(Ncrsss,*), Ti(Ncrsss,*), Tx(2,Ntriag,*)
+ type(RMatChannelParams)::channel
!
- DATA Zero /0.0d0/, Half /0.5d0/, One /1.0d0/, Two /2.0d0/
+ real(kind=8),parameter::Zero = 0.0d0, Half = 0.5d0, One = 1.0d0, Two = 2.0d0
+ integer::Nent, Next, Ntot
+ logical::Ifs
+ real(kind=8)::Ai, Ar, Bi, Br, Ci, Cr, Di, Dr, Zz, Su
+ integer::I, I_Ifcros, Ix, Iy, Ij, J, K, Kk, Kl, L, Lspin, LspinL, M
+
+ Nent = spinInfo%getNumEntryChannels()
+ Next = spinInfo%getNumExitChannels()
+ Ntot = spinInfo%getNumChannels()
+ Su = dAbs(calc%ener)
!
- IF (Ncrssx.NE.0) THEN
+ IF (any(calc%Ifcros)) THEN
!
- CALL Zero_Array (TR, Ncrsss*Ntriag)
- CALL Zero_Array (TI, Ncrsss*Ntriag)
+ calc%Tr = 0.0d0
+ calc%Ti = 0.0d0
!
! *** GENERATE Tr AND Ti, WHERE
! *** Tr(M,Ij) = REAL PART OF PARTIAL (Mth CROSS SECTION) WITH
! *** RESPECT TO R(Ij), EXCEPT FOR c=4pi/E
!
!
- IF (Ifcros(1).NE.0) THEN
+ IF (calc%Ifcros(1)) THEN
! *** first, integrated elastic, diagonal in channel #'s
KL = 0
DO K=1,Nent
- Zz = Zke(K)**2
+ Zz = calc%Zke(K, Igr)**2
KL = KL + K
Ij = 0
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- IF (Qi(KL,Ij).NE.Zero .OR. QR(KL,Ij).NE.Zero) THEN
- Ar = Qr(KL,Ij)*(-Sin2ph(K)*Half) + &
- Qi(KL,Ij)*(-Sinsqr(K))
- Ai = Qi(KL,Ij)*(-Sin2ph(K)*Half) - &
- Qr(KL,Ij)*(-Sinsqr(K))
- Tr(1,Ij) = Tr(1,Ij) + Ar/Zz
- Ti(1,Ij) = Ti(1,Ij) + Ai/Zz
+ IF (calc%Qi(KL,Ij).NE.Zero .OR. calc%QR(KL,Ij).NE.Zero) THEN
+ Ar = calc%Qr(KL,Ij)*(-calc%Sin2ph(K)*Half) + &
+ calc%Qi(KL,Ij)*(-calc%Sinsqr(K))
+ Ai = calc%Qi(KL,Ij)*(-calc%Sin2ph(K)*Half) - &
+ calc%Qr(KL,Ij)*(-calc%Sinsqr(K))
+ calc%Tr(1,Ij) = calc%Tr(1,Ij) + Ar/Zz
+ calc%Ti(1,Ij) = calc%Ti(1,Ij) + Ai/Zz
END IF
END DO
END DO
END DO
END IF
!
- IF (Ifcros(2).NE.0) THEN
+ IF (calc%Ifcros(2)) THEN
! *** next, absorption only, diagonal in channel numbers
KL = 0
DO K=1,Nent
- Zz = Zke(K)**2 * Two
+ Zz = calc%Zke(K, Igr)**2 * Two
KL = KL + K
Ij = 0
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- IF (Qi(KL,Ij).NE.Zero) Tr(2,Ij) = Tr(2,Ij) + &
- Qi(KL,Ij)/Zz
- IF (Qr(KL,Ij).NE.Zero) Ti(2,Ij) = Ti(2,Ij) - &
- Qr(KL,Ij)/Zz
+ IF (calc%Qi(KL,Ij).NE.Zero) calc%Tr(2,Ij) = calc%Tr(2,Ij) + &
+ calc%Qi(KL,Ij)/Zz
+ IF (calc%Qr(KL,Ij).NE.Zero) calc%Ti(2,Ij) = calc%Ti(2,Ij) - &
+ calc%Qr(KL,Ij)/Zz
END DO
END DO
END DO
END IF
!
- IF (Ifcros(1).EQ.1 .OR. Ifcros(2).EQ.1) THEN
+ IF (calc%Ifcros(1) .OR. calc%Ifcros(2)) THEN
! *** next, not-necessarily diagonal pieces of elastic & capture
KL = 0
DO K=1,Nent
- Zz = Zke(K)**2
+ Zz = calc%Zke(K, Igr)**2
DO L=1,K
KL = KL + 1
Ij = 0
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- IF (Qi(KL,Ij).NE.Zero.OR.Qr(KL,Ij).NE.Zero) THEN
- Ar = Qr(KL,Ij)*Xxxxr(Kl) + Qi(KL,Ij)*Xxxxi(KL)
- Ai = Qi(KL,Ij)*Xxxxr(Kl) - Qr(KL,Ij)*Xxxxi(KL)
+ IF (calc%Qi(KL,Ij).NE.Zero.OR.calc%Qr(KL,Ij).NE.Zero) THEN
+ Ar = calc%Qr(KL,Ij)*calc%Xxxxr(Kl) + calc%Qi(KL,Ij)*calc%Xxxxi(KL)
+ Ai = calc%Qi(KL,Ij)*calc%Xxxxr(Kl) - calc%Qr(KL,Ij)*calc%Xxxxi(KL)
IF (K.NE.L) THEN
Ar = Ar*Two
Ai = Ai*Two
END IF
- IF (Ifcros(1).EQ.1) THEN
- Tr(1,Ij) = Tr(1,Ij) + Ar/Zz
- Ti(1,Ij) = Ti(1,Ij) + Ai/Zz
+ IF (calc%Ifcros(1)) THEN
+ calc%Tr(1,Ij) = calc%Tr(1,Ij) + Ar/Zz
+ calc%Ti(1,Ij) = calc%Ti(1,Ij) + Ai/Zz
END IF
- IF (Ifcros(2).EQ.1) THEN
- Tr(2,Ij) = Tr(2,Ij) - Ar/Zz
- Ti(2,Ij) = Ti(2,Ij) - Ai/Zz
+ IF (calc%Ifcros(2)) THEN
+ calc%Tr(2,Ij) = calc%Tr(2,Ij) - Ar/Zz
+ calc%Ti(2,Ij) = calc%Ti(2,Ij) - Ai/Zz
END IF
END IF
END DO
@@ -188,11 +188,11 @@
END DO
END IF
!
- IF (Ncrsss.GE.3) THEN
+ IF (calc%ntotc.GE.2) THEN
! *** next, reactions
I_Ifcros = 0
DO KK=1,Next
- IF (Ifcros(KK+2).NE.0) I_Ifcros = 1
+ IF (calc%Ifcros(KK+2)) I_Ifcros = 1
END DO
IF (I_Ifcros.EQ.1) THEN
KL = 0
@@ -200,21 +200,21 @@
DO L=1,K
KL = KL + 1
IF (L.LE.Nent .AND. K.GT.Nent) THEN
- Zz = Zke(L)**2
+ Zz = calc%Zke(L, Igr)**2
M = K - Nent + 2
- IF (Ifcros(M).GT.0) THEN
+ IF (calc%Ifcros(M)) THEN
IJ = 0
DO I=1,Ntot
DO J=1,I
IJ = IJ + 1
- IF (Qi(KL,Ij).NE.Zero .OR. &
- Qr(KL,Ij).NE.Zero ) THEN
- Tr(M,Ij) = Tr(M,Ij) + &
- ( Qr(KL,Ij)*Xxxxr(Kl) + &
- Qi(KL,Ij)*Xxxxi(Kl) )/Zz
- Ti(M,Ij) = Ti(M,Ij) + &
- ( Qi(KL,Ij)*Xxxxr(Kl) - &
- Qr(KL,Ij)*Xxxxi(Kl) )/Zz
+ IF (calc%Qi(KL,Ij).NE.Zero .OR. &
+ calc%Qr(KL,Ij).NE.Zero ) THEN
+ calc%Tr(M,Ij) = calc%Tr(M,Ij) + &
+ ( calc%Qr(KL,Ij)*calc%Xxxxr(Kl) + &
+ calc%Qi(KL,Ij)*calc%Xxxxi(Kl) )/Zz
+ calc%Ti(M,Ij) = calc%Ti(M,Ij) + &
+ ( calc%Qi(KL,Ij)*calc%Xxxxr(Kl) - &
+ calc%Qr(KL,Ij)*calc%Xxxxi(Kl) )/Zz
END IF
END DO
END DO
@@ -230,17 +230,17 @@
!
!
!
- IF (Ifdif.NE.0) THEN
+ IF (calc%needAngular) THEN
!
! *** For angular distributions
! *** prtl (1-U)(kl) wrt R(ij) = prtl(1-U)(kl) wrt X(kl) * prtl X wrt R
! *** Tx(1,ij,kl) = prtl Re(1-U) wrt ReR = -prtl Im (1-U) wrt ImR
! *** Tx(2,ij,kl) = prtl Re(1-U) wrt ImR = prtl Re (1-U) wrt ReR
!
- CALL Zero_Array (Tx, 2*Ntriag*Ntriag)
+ calc%Tx = 0.0d0
!
! *** first, do diagonal (in K & L) ... only for elastic
- IF (Ifdif.EQ.1) THEN
+ IF (calc%reactType.ne.11) THEN
KL = 0
DO K=1,Nent
KL = KL + K
@@ -248,14 +248,14 @@
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- IF (QI(KL,Ij).NE.Zero .OR. QR(KL,Ij).NE.Zero) THEN
+ IF (calc%QI(KL,Ij).NE.Zero .OR. calc%QR(KL,Ij).NE.Zero) THEN
! *** Qr = Qr*Dr - Qi*Di, Ai = Qi*Dr + Qr*Di
- Ar = Qr(KL,Ij)*(-Sin2ph(K)) - &
- Qi(KL,Ij)*(Two*Sinsqr(K)-One)
- Ai = Qi(KL,Ij)*(-Sin2ph(K)) + &
- Qr(KL,Ij)*(Two*Sinsqr(K)-One)
- Tx(1,Ij,KL) = Ar
- Tx(2,Ij,KL) = Ai
+ Ar = calc%Qr(KL,Ij)*(-calc%Sin2ph(K)) - &
+ calc%Qi(KL,Ij)*(Two*calc%Sinsqr(K)-One)
+ Ai = calc%Qi(KL,Ij)*(-calc%Sin2ph(K)) + &
+ calc%Qr(KL,Ij)*(Two*calc%Sinsqr(K)-One)
+ calc%Tx(1,Ij,KL) = Ar
+ calc%Tx(2,Ij,KL) = Ai
END IF
END DO
END DO
@@ -266,24 +266,24 @@
KL = 0
DO L=1,Ntot
DO K=1,L
- Ifs = If_Stay (L, Ifdif, Nent, If_Excl(L), Kaptur)
+ Ifs = calc%useChannel(L,2)
KL = KL + 1
- IF (Ifs.EQ.0 .AND. K.LE.Nent) THEN
+ IF (Ifs.AND. K.LE.Nent) THEN
IF (K.NE.L) THEN
IJ = 0
DO I=1,Ntot
IJ = (I*(I-1))/2
DO J=1,I
IJ = IJ + 1
- IF (Qi(KL,Ij).NE.Zero .OR. &
- Qr(KL,Ij).NE.Zero) THEN
+ IF (calc%Qi(KL,Ij).NE.Zero .OR. &
+ calc%Qr(KL,Ij).NE.Zero) THEN
! *** Ar = Qr*Dr - Qi*Di, Ai = Qi*Dr + Qr*Di
- Ar = -Qr(KL,Ij)*Cscs(2,KL) + &
- Qi(KL,Ij)*Cscs(1,KL)
- Ai = -Qi(KL,Ij)*Cscs(2,KL) - &
- Qr(KL,Ij)*Cscs(1,KL)
- Tx(1,Ij,KL) = Ar
- Tx(2,Ij,KL) = Ai
+ Ar = -calc%Qr(KL,Ij)*calc%Cscs(2,KL) + &
+ calc%Qi(KL,Ij)*calc%Cscs(1,KL)
+ Ai = -calc%Qi(KL,Ij)*calc%Cscs(2,KL) - &
+ calc%Qr(KL,Ij)*calc%Cscs(1,KL)
+ calc%Tx(1,Ij,KL) = Ar
+ calc%Tx(2,Ij,KL) = Ai
END IF
END DO
END DO
@@ -294,16 +294,15 @@
!
! *** Now multiply by Coulomb phase shift if needed
!
- call resParData%getSpinGroupInfo(spinInfo, igr)
DO K=1,Ntot
call spinInfo%getChannelInfo(channelInfo, K)
- call resParData%getChannel(channel, channelInfo)
+ call calc%resData%getChannel(channel, channelInfo)
Lspin = channel%getL()
- IF (If_Stay (K,Ifdif,Nent,If_Excl(K),Kaptur) .EQ.0) THEN
- IF (Zeta(K).NE.Zero .AND. Su.GT.Echan(K)) THEN
- CALL Get_Coul_Phase (Cr, Ci, Lspin, Echan(K), &
- Zeta(K), Su)
+ IF (calc%useChannel(K,2)) THEN
+ IF (calc%Zeta(K, igr).NE.Zero .AND. Su.GT.calc%Echan(K, Igr)) THEN
+ CALL Get_Coul_Phase (Cr, Ci, Lspin, calc%Echan(K, Igr), &
+ calc%Zeta(K, Igr), Su)
Ix = 1
ELSE
Cr = One
@@ -314,7 +313,7 @@
KL = (K*(K-1))/2
DO L=1,K
call spinInfo%getChannelInfo(channelInfo, L)
- call resParData%getChannel(channel, channelInfo)
+ call calc%resData%getChannel(channel, channelInfo)
LspinL = channel%getL()
KL = KL + 1
IF (K.EQ.L) THEN
@@ -322,9 +321,9 @@
Di = Ci
Iy = Ix
ELSE
- IF (Zeta(L).NE.Zero .AND. Su.GT.Echan(L)) THEN
- CALL Get_Coul_Phase (Dr, Di, LspinL, Echan(L), &
- Zeta(L), Su)
+ IF (calc%Zeta(L, Igr).NE.Zero .AND. Su.GT.calc%Echan(L, Igr)) THEN
+ CALL Get_Coul_Phase (Dr, Di, LspinL, calc%Echan(L, Igr), &
+ calc%Zeta(L, Igr), Su)
Iy = 1
ELSE
Dr = One
@@ -338,8 +337,8 @@
DO I=1,Ntot
DO J=1,I
IJ = IJ + 1
- Ar = Tx(1,IJ,KL)
- Ai = Tx(2,IJ,KL)
+ Ar = calc%Tx(1,IJ,KL)
+ Ai = calc%Tx(2,IJ,KL)
IF (Ix.EQ.0) THEN
Br = Ar
Bi = Ai
@@ -354,8 +353,8 @@
Ar = Br*Dr - Bi*Di
Ai = Br*Di + Bi*Dr
END IF
- Tx(1,IJ,KL) = Ar
- Tx(2,IJ,KL) = Ai
+ calc%Tx(1,IJ,KL) = Ar
+ calc%Tx(2,IJ,KL) = Ai
END DO
END DO
END IF
@@ -367,3 +366,4 @@
END IF
RETURN
END
+end module mxct10_m
diff --git a/sammy/src/xct/mxct11.f90 b/sammy/src/xct/mxct11.f90
index 2f9de07ea..507a3ad6f 100644
--- a/sammy/src/xct/mxct11.f90
+++ b/sammy/src/xct/mxct11.f90
@@ -1,331 +1,221 @@
module mxct11_m
use XctCrossCalc_M
contains
+ logical function wantChannelInCalc(calc, spinInfo, ichan, nent) result(want)
+ type(SammySpinGroupInfo):: spinInfo
+ class(XctCrossCalc)::calc
+ type(SammyChannelInfo)::channelInfo
+ integer::ichan, nent, K
+ logical::inc
+
+ want = .false.
+ if (ichan.le.2) then
+ want = .true.
+ return
+ end if
+ k = Ichan-2+Nent
+ inc = .true.
+ if (k.le.spinInfo%getNumChannels()) then
+ call spinInfo%getChannelInfo(channelInfo, k)
+ inc = channelInfo%getIncludeInCalc()
+ end if
+ if (inc) then
+ if (.not.calc%addElimKapt) want = .true.
+ else
+ if (calc%addElimKapt) want = .true.
+ end if
+ end function wantChannelInCalc
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Derres (calc, Nent,If_Excl, Ifcros, Deriv, &
- Derivx, Tr, Ti, Tx, Notu, Ddddd, Dgoj, Ntot, Minres, Maxres)
+ SUBROUTINE Derres (spinInfo , calc, Igr, iparStart)
!
! *** 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)
- integer::Notu(:)
+ use SammySpinGroupInfo_M
+ use mxct09_m
+ IMPLICIT none
!
+ type(SammySpinGroupInfo):: spinInfo
class(XctCrossCalc)::calc
- 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)
+ integer::iparStart
+ integer::idPos, Igr, Nent, Ntot
+ real(kind=8)::Dgoj, val, A1, A2
+ integer::I, Ichanx, Ij, J, K, Kl, M, Mm, Ichan, Ix
!
- DATA Zero /0.0d0/
+ real(kind=8):: Zero = 0.0d0
!
+ nent = spinInfo%getNumEntryChannels()
+ ntot = spinInfo%getNumChannels()
+ Dgoj = spinInfo%getGFactor()
+
+
+ IF (any(calc%Ifcros)) THEN
+ DO Mm=1,calc%inumSize
+ M = iparStart + Mm
+ idPos = calc%Inum(Mm,1)
+ if (.not.calc%covariance%contributes(idPos)) cycle
!
- 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
+ calc%Ddddd = Zero
+ DO I=1,calc%ntotc
DO J=1,I
IJ = IJ + 1
- IF (calc%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
+ IF (calc%Pi(Ij,M).NE.Zero.or.calc%Pr(Ij,M).NE.Zero) THEN
+ DO K=1,calc%Ntotc + 1
+ IF (calc%useChannel(K,1)) THEN ! check for ifcross has been added to useChannel
+! *** Kaptur=1 (now calc%addElimKapt == true) and If_Excl=1 (not channelInfo%getIncludeInCalc() == false) means subtract this excluded channel from
! *** absorption to give the eliminated gamma channel contribution
- Ddddd(K) = Ddddd(K) - calc%Pi(Ij,M)*Ti(K,Ij)
- END IF
- END IF
- END DO
- END IF
- IF (calc%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) + calc%Pr(Ij,M)*Tr(K,Ij)
- END IF
+ calc%Ddddd(K) = calc%Ddddd(K) - calc%Pi(Ij,M)*calc%Ti(K,Ij)
+ calc%Ddddd(K) = calc%Ddddd(K) + calc%Pr(Ij,M)*calc%Tr(K,Ij)
+
END IF
END DO
- END IF
+ 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
+ DO K=1,calc%Ntotc + 1
+ IF (calc%Ddddd(K).ne.Zero) THEN
+ val = Dgoj*calc%Ddddd(K) + calc%crossInternal(K, Igr, idPos)
+ calc%crossInternal(K, Igr, idPos) = val
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 (calc%needAngular) THEN
+ DO Mm=1,calc%inumSize
+ M = iparStart + Mm
+ idPos = calc%Inum(Mm,1)
+ if (.not.calc%covariance%contributes(idPos)) cycle
+
+ DO IJ=1,calc%ntriag
IF (calc%Pi(Ij,M).NE.Zero .OR. calc%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 Ichan=1,Ntot
+ IF (calc%useChannel(Ichan,2)) 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) + &
- calc%Pr(Ij,M)*Tx(1,Ij,KL) - &
- calc%Pi(Ij,M)*Tx(2,Ij,KL)
- Derivx(2,Ichanx,Ichan,idPos) = &
- Derivx(2,Ichanx,Ichan,idPos) + &
- calc%Pr(Ij,M)*Tx(2,Ij,KL) + &
- calc%Pi(Ij,M)*Tx(1,Ij,KL)
+
+ Do Ix = 1, 2
+ val = calc%angInternal(Ix,Ichanx,Ichan, Igr, idPos)
+ select case(ix)
+ case(1)
+ A1 = calc%Pr(Ij,M)*calc%Tx(1,Ij,KL)
+ A2 = -calc%Pi(Ij,M)*calc%Tx(2,Ij,KL)
+ case(2)
+ A1 = calc%Pr(Ij,M)*calc%Tx(2,Ij,KL)
+ A2 = calc%Pi(Ij,M)*calc%Tx(1,Ij,KL)
+ end select
+ val = val + A1 + A2
+ calc%angInternal(Ix,Ichanx,Ichan, Igr, idPos) = val
+ end do
+
END DO
END IF
END DO
END IF
END DO
- END IF
- END DO
- END IF
- RETURN
- END SUBROUTINE Derres
-!
-!
-! --------------------------------------------------------------
-!
- SUBROUTINE Dercap (calc, Nent, If_Excl, Ifcros, 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)
-!
- class(XctCrossCalc)::calc
- type(SammyResonanceInfo)::resInfo
- 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 (calc%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) - calc%Pi(Ij,M)*Ti(K,Ij)
- END IF
- END IF
- END DO
- END IF
- IF (calc%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) + calc%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 (calc%Pi(Ij,M).NE.Zero .OR. calc%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) + &
- calc%Pr(Ij,M)*Tx(1,Ij,KL) - &
- calc%Pi(Ij,M)*Tx(2,Ij,KL)
- Derivx(2,Ichanx,Ichan,Ifl) = &
- Derivx(2,Ichanx,Ichan,Ifl) + &
- calc%Pr(Ij,M)*Tx(2,Ij,KL) + &
- calc%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
+ END SUBROUTINE Derres
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Dereee (calc, Nent, If_Excl, Ifcros, Derivx, Tr, Ti, &
- Tx, Prer, Prei, Ddddtl, Ntot)
+ SUBROUTINE Dereee (spinInfo, calc, Igr)
!
! *** 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)
+ use varyr_common_m, only : Etz, Elz
+ use mxct09_m
+ use SammySpinGroupInfo_M
+ IMPLICIT None
!
+ type(SammySpinGroupInfo):: spinInfo
class(XctCrossCalc)::calc
- 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
+ logical::Ifs
+ integer::Igr
!
-! 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/
+ real(kind=8),parameter::Zero =0.0d0
+ integer::I, Ichan, Ichanx, Ij, Itz, Ilz, J, K, KL, Nent, Ntot, Ix
+ real(kind=8)::Zz, A1, A2, val
!
- Itz = Itzero
- Ilz = IlZero
- IF (Ncrssx.NE.0) THEN
+ Itz = calc%Itzero
+ Ilz = calc%IlZero
+ ntot = spinInfo%getNumChannels()
+ nent = spinInfo%getNumEntryChannels()
+
+ IF (any(calc%Ifcros)) 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
+! *** Z = partial E wrt sqrt(E) = 2*sqrt(E)
! *** 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
+ Zz = calc%enerSq*4.0D0
+ calc%Ddddtl = Zero
Ij = 0
- DO I=1,Ntot
+ 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
+ IF (calc%Prei(Ij, Igr).NE.Zero.or.calc%Prer(Ij, Igr).NE.Zero) THEN
+ DO K=1,calc%Ntotc+1
+ IF (calc%Ifcros(K)) THEN
+ IF (wantChannelInCalc(calc, spinInfo, k, nent)) THEN
+ calc%Ddddtl(K) = calc%Ddddtl(K) - calc%Prei(Ij, Igr)*calc%Ti(K,Ij)*Zz
+ calc%Ddddtl(K) = calc%Ddddtl(K) + calc%Prer(Ij, Igr)*calc%Tr(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 IF
END DO
END DO
END IF
!
!
- IF (Ifdif.NE.0) THEN
+ IF (calc%needAngular) 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 Ij=1,calc%ntriag
+ IF (calc%PreI(Ij, Igr).NE.Zero .OR. calc%PreR(Ij, Igr).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
+ Ifs = calc%useChannel(Ichan,2)
+ IF (Ifs .AND. Ichanx.LE.Nent) THEN
+ Do Ix = 1, 2
+ select case(Ix)
+ case(1)
+ A1 = calc%Prer(Ij, Igr)*calc%Tx(1,Ij,KL)
+ A2 = -calc%Prei(Ij, Igr)*calc%Tx(2,Ij,KL)
+ case(2)
+ A1 = calc%Prer(Ij, Igr)*calc%Tx(2,Ij,KL)
+ A2 = calc%Prei(Ij, Igr)*calc%Tx(1,Ij,KL)
+ end select
+ IF (Itz.GT.0) THEN
+ val = calc%angInternal(Ix,Ichanx,Ichan, Igr, Itz)
+ val = val + A1 + A2*Etz
+ calc%angInternal(Ix,Ichanx,Ichan, Igr, Itz) = val
+ end if
+ IF (iLz.GT.0) THEN
+ val = calc%angInternal(Ix,Ichanx,Ichan, Igr, iLz)
+ val = val + A1 + A2*Elz
+ calc%angInternal(Ix,Ichanx,Ichan, Igr, iLz) = val
+ end if
+ end do
END IF
END DO
END DO
diff --git a/sammy/src/xct/mxct12.f90 b/sammy/src/xct/mxct12.f90
index 0a01d87b0..f17343bc6 100644
--- a/sammy/src/xct/mxct12.f90
+++ b/sammy/src/xct/mxct12.f90
@@ -1,43 +1,47 @@
module mxct12_m
use XctCrossCalc_M
+implicit none
+private multiplyDerivx
contains
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Derext (calc, If_Excl, Ifcros, Deriv, Derivx, &
- Tr, Tx, Dgoj, Ntot, Nent, Krext)
+ SUBROUTINE Derext (spinInfo, calc, Igr)
!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
use SammyRExternalInfo_M
use RMatResonanceParam_M
- use EndfData_common_m, only : resParData
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ use mxct09_m
!
- class(XctCrossCalc)::calc
- DIMENSION If_Excl(*), Ifcros(*), &
- Deriv(Ncrsss,*), &
- Derivx(2,Ntotc,Ntotc,*), Tr(Ncrsss,*), Tx(2,Ntriag,*)
+ class(XctCrossCalc)::calc
+ type(SammySpinGroupInfo)::spinInfo
+
type(SammyRExternalInfo)::rextInfo
real(kind=8)::Parext(7)
type(RExternalFunction)::rext
-! DIMENSION If_Excl(*), Ifcros(Ncrsss),
-! * Deriv(Ncrsss,Ndasig+ndbsig),
-! * Derivx(2,Ntotc,Ntotc,nap), Tr(Ncrsss,Nn), Tx(2,Ntriag,Ntriag)
-!
- DATA Two /2.0d0/
+ integer::Igr, Jstart, Nrext
+ logical::rextVaried
+
+ real(kind=8),parameter:: Two = 2.0d0
+ real(kind=8)::A, Dgoj, val, Su
+ integer::I, Ichan, J, Kl, M, Nchan, Nchanx, Nent, Ntot, Ij
!
!
- IF (Ncrsss.NE.0) THEN
+
+ Ntot = spinInfo%getNumChannels()
+ Nent = spinInfo%getNumEntryChannels()
+ Dgoj = spinInfo%getGFactor()
+ Su = dAbs(calc%ener)
+ rextVaried = .false.
+ IF (any(calc%Ifcros)) THEN
Ij = 0
DO I=1,Ntot
Ij = Ij + I
Parext = 0.0d0
- IF (resparData%hasRexInfo(Nnnn, I)) THEN
- call resparData%getRextInfoByGroup(rextInfo, Nnnn, I)
- call resParData%getRext(rext, rextInfo)
+ IF (calc%resData%hasRexInfo(Igr, I)) THEN
+ call calc%resData%getRextInfoByGroup(rextInfo, Igr, I)
+ nrext = rextInfo%getNrext()
+ call calc%resData%getRext(rext, rextInfo)
DO J = 1, rextInfo%getNrext()
Parext(J) = rext%getSammyValue(J)
end do
@@ -45,86 +49,102 @@ contains
! *** ergo need to multiply by 2 here
A = Two*Dgoj
IF (rextInfo%getIflSammyIndex(1).NE.0) THEN
- Jstart = Jstart + 1
- DO M=1,Ncrsss
- IF (Ifcros(M).NE.0 .AND. (M.LE.2 .OR. &
- If_Excl(M-2+Nent).EQ.Kaptur) ) THEN
- IF (Nrext.EQ.5) Deriv(M,Jstart) = &
- -Tr(M,Ij)*A*(Parext(5))/ &
+ rextVaried = .true.
+ Jstart = rextInfo%getIflSammyIndex(1)
+ DO M=1,calc%ntotc+1
+ IF (calc%useChannel(M,1)) THEN
+ val = 0.0d0
+ IF (Nrext.EQ.5) then
+ val = -calc%Tr(M,Ij)*A*(Parext(5))/ &
(Su-Parext(1))
- IF (Nrext.EQ.7) Deriv(M,Jstart) = - Tr(M,Ij)*A* &
- (Parext(5)+ &
- Parext(6)*Parext(1)) &
- / (Su-Parext(1))
+ else if (Nrext.EQ.7) then
+ val = - calc%Tr(M,Ij)*A* (Parext(5)+ Parext(6)*Parext(1))/ &
+ (Su-Parext(1))
+ end if
+ val = val + calc%crossInternal(M, Igr, Jstart)
+ calc%crossInternal(M, Igr, Jstart) = val
END IF
END DO
END IF
IF (rextInfo%getIflSammyIndex(2).NE.0) THEN
- Jstart = Jstart + 1
- DO M=1,Ncrsss
- IF (Ifcros(M).NE.0 .AND. (M.LE.2 .OR. &
- If_Excl(M-2+Nent).EQ.Kaptur) ) THEN
- IF (Nrext.EQ.5) Deriv(M,Jstart) = &
- - Tr(M,Ij)*A*(Parext(5))/ &
+ rextVaried = .true.
+ Jstart = rextInfo%getIflSammyIndex(2)
+ DO M=1,calc%ntotc+1
+ IF (calc%useChannel(M,1) ) THEN
+ val = 0.0d0
+ IF (Nrext.EQ.5) then
+ val = - calc%Tr(M,Ij)*A*(Parext(5))/ &
(Parext(2)-Su)
- IF (Nrext.EQ.7) Deriv(M,Jstart) = - Tr(M,Ij)*A* &
- (Parext(5)+ &
- Parext(6)*Parext(2)) &
- / (Parext(2)-Su)
+ else if (Nrext.EQ.7) then
+ val = - calc%Tr(M,Ij)*A* (Parext(5)+ Parext(6)*Parext(2))/ &
+ (Parext(2)-Su)
+ end if
+ val = val + calc%crossInternal(M, Igr, Jstart)
+ calc%crossInternal(M, Igr, Jstart) = val
END IF
END DO
END IF
IF (rextInfo%getIflSammyIndex(3).NE.0) THEN
- Jstart = Jstart + 1
- DO M=1,Ncrsss
- IF (Ifcros(M).NE.0 .AND. (M.LE.2 .OR. &
- If_Excl(M-2+Nent).EQ.Kaptur) ) THEN
- Deriv(M,Jstart) = Tr(M,Ij)*A
+ rextVaried = .true.
+ Jstart = rextInfo%getIflSammyIndex(3)
+ DO M=1,calc%ntotc+1
+ IF (calc%useChannel(M,1)) THEN
+ val = calc%Tr(M,Ij)*A
+ val = val + calc%crossInternal(M, Igr, Jstart)
+ calc%crossInternal(M, Igr, Jstart) = val
END IF
END DO
END IF
IF (rextInfo%getIflSammyIndex(4).NE.0) THEN
- Jstart = Jstart + 1
- DO M=1,Ncrsss
- IF (Ifcros(M).NE.0 .AND. (M.LE.2 .OR. &
- If_Excl(M-2+Nent).EQ.Kaptur) ) THEN
- Deriv(M,Jstart) = Tr(M,Ij)*A*Su
+ rextVaried = .true.
+ Jstart = rextInfo%getIflSammyIndex(4)
+ DO M=1,calc%ntotc+1
+ IF (calc%useChannel(M,1)) THEN
+ val = calc%Tr(M,Ij)*A*Su
+ val = val + calc%crossInternal(M, Igr, Jstart)
+ calc%crossInternal(M, Igr, Jstart) = val
END IF
END DO
END IF
IF (rextInfo%getIflSammyIndex(5).NE.0) THEN
- Jstart = Jstart + 1
- DO M=1,Ncrsss
- IF (Ifcros(M).NE.0 .AND. (M.LE.2 .OR. &
- If_Excl(M-2+Nent).EQ.Kaptur) ) THEN
- Deriv(M,Jstart) = -2.0D0*Tr(M,Ij)* &
+ rextVaried = .true.
+ Jstart = rextInfo%getIflSammyIndex(5)
+ DO M=1,calc%ntotc+1
+ IF (calc%useChannel(M,1) ) THEN
+ val = -2.0D0*calc%Tr(M,Ij)* &
A*dSQRT(Parext(5))* &
dLOG( (Parext(2)-Su)/ &
(Su-Parext(1)) )
! *** Remember that the u-parameter is the
! *** square root of Parext(5)
+ val = val + calc%crossInternal(M, Igr, Jstart)
+ calc%crossInternal(M, Igr, Jstart) = val
END IF
END DO
END IF
IF (rextInfo%getNrext().GT.5) THEN
IF (rextInfo%getIflSammyIndex(6).NE.0) THEN
- Jstart = Jstart + 1
- DO M=1,Ncrsss
- IF (Ifcros(M).NE.0 .AND. (M.LE.2 .OR. &
- If_Excl(M-2+Nent).EQ.Kaptur) ) THEN
- Deriv(M,Jstart) = - Tr(M,Ij)*A* &
+ rextVaried = .true.
+ Jstart = rextInfo%getIflSammyIndex(6)
+ DO M=1,calc%ntotc+1
+ IF (calc%useChannel(M,1) ) THEN
+ val = - calc%Tr(M,Ij)*A* &
( (Parext(2)-Parext(1)) + &
Su*dLOG( (Parext(2)-Su)/ &
(Su-Parext(1)) ) )
+ val = val + calc%crossInternal(M, Igr, Jstart)
+ calc%crossInternal(M, Igr, Jstart) = val
END IF
END DO
END IF
IF (rextInfo%getIflSammyIndex(7).NE.0) THEN
- Jstart = Jstart + 1
- DO M=1,Ncrsss
- IF (Ifcros(M).NE.0 .AND. (M.LE.2 .OR. &
- If_Excl(M-2+Nent).EQ.Kaptur) ) THEN
- Deriv(M,Jstart) = Tr(M,Ij)*A*Su**2
+ rextVaried = .true.
+ Jstart = rextInfo%getIflSammyIndex(7)
+ DO M=1,calc%ntotc+1
+ IF (calc%useChannel(M,1)) THEN
+ val = calc%Tr(M,Ij)*A*Su**2
+ val = val + calc%crossInternal(M, Igr, Jstart)
+ calc%crossInternal(M, Igr, Jstart) = val
END IF
END DO
END IF
@@ -135,31 +155,28 @@ contains
!
!
!
- IF (Ifdif.NE.0) THEN
- Jstartx = Jstart
+ IF (calc%needAngular.and.rextVaried) THEN
Ij = 0
DO Ichan=1,Ntot
- Ij = Ij + Ichan
- Jstart = Jstartx
+ Ij = Ij + Ichan
DO Nchan=1,Ntot
Parext = 0.0d0
- IF (If_Stay (Nchan, Ifdif, Nent, If_Excl(Nchan), Kaptur) &
- .EQ.0) THEN
+ IF (calc%useChannel(Nchan,2)) THEN
DO Nchanx=1,Nent
IF (Nchanx.LE.Nchan) THEN
Kl = (Nchan*(Nchan-1))/2 + Nchanx
ELSE
Kl = (Nchanx*(Nchanx-1))/2 + Nchan
END IF
- IF (resparData%hasRexInfo(Nnnn, Ichan)) THEN
- call resparData%getRextInfoByGroup(rextInfo, &
- Nnnn, Ichan)
- call resParData%getRext(rext, rextInfo)
+ IF (calc%resData%hasRexInfo(Igr, Ichan)) THEN
+ call calc%resData%getRextInfoByGroup(rextInfo, &
+ Igr, Ichan)
+ call calc%resData%getRext(rext, rextInfo)
DO J = 1, rextInfo%getNrext()
Parext(J) = rext%getSammyValue(J)
end do
IF (rextInfo%getIflSammyIndex(1).NE.0) THEN
- Jstart = Jstart + 1
+ Jstart = rextInfo%getIflSammyIndex(1)
IF (Nrext.EQ.5) THEN
A = -Parext(5)/ &
(Su-Parext(1))
@@ -169,13 +186,10 @@ contains
Parext(1)) &
/(Su-Parext(1))
END IF
- Derivx(1,Nchanx,Nchan,Jstart) = Tx(1,Ij,KL)*A &
- + Derivx(1,Nchanx,Nchan,Jstart)
- Derivx(2,Nchanx,Nchan,Jstart) = Tx(2,Ij,KL)*A &
- + Derivx(2,Nchanx,Nchan,Jstart)
+ call multiplyDerivx(calc, Igr, Nchanx,Nchan,Ij, Kl, Jstart, A)
END IF
IF (rextInfo%getIflSammyIndex(2).NE.0) THEN
- Jstart = Jstart + 1
+ Jstart = rextInfo%getIflSammyIndex(2)
IF (Nrext.EQ.5) THEN
A = - Parext(5)/ &
(Parext(2)-Su)
@@ -185,60 +199,36 @@ contains
Parext(2)) &
/ (Parext(2)-Su)
END IF
- Derivx(1,Nchanx,Nchan,Jstart) = Tx(1,Ij,KL)*A &
- + Derivx(1,Nchanx,Nchan,Jstart)
- Derivx(2,Nchanx,Nchan,Jstart) = Tx(2,Ij,KL)*A &
- + Derivx(2,Nchanx,Nchan,Jstart)
+ call multiplyDerivx(calc, Igr, Nchanx,Nchan,Ij, Kl, Jstart, A)
END IF
IF (rextInfo%getIflSammyIndex(3).NE.0) THEN
- Jstart = Jstart + 1
- Derivx(1,Nchanx,Nchan,Jstart) = Tx(1,Ij,KL) + &
- Derivx(1,Nchanx,Nchan,Jstart)
- Derivx(2,Nchanx,Nchan,Jstart) = Tx(2,Ij,KL) + &
- Derivx(2,Nchanx,Nchan,Jstart)
+ Jstart = rextInfo%getIflSammyIndex(3)
+ call multiplyDerivx(calc, Igr, Nchanx,Nchan,Ij, Kl, Jstart, 1.0d0)
END IF
IF (rextInfo%getIflSammyIndex(4).NE.0) THEN
- Jstart = Jstart + 1
- Derivx(1,Nchanx,Nchan,Jstart) = &
- Tx(1,Ij,KL)*Su + &
- Derivx(1,Nchanx,Nchan,Jstart)
- Derivx(2,Nchanx,Nchan,Jstart) = &
- Tx(2,Ij,KL)*Su + &
- Derivx(2,Nchanx,Nchan,Jstart)
+ Jstart = rextInfo%getIflSammyIndex(4)
+ call multiplyDerivx(calc, Igr, Nchanx,Nchan,Ij, Kl, Jstart, Su)
END IF
IF (rextInfo%getIflSammyIndex(5).NE.0) THEN
- Jstart = Jstart + 1
+ Jstart = rextInfo%getIflSammyIndex(5)
A = - Two*DSQRT(Parext(5))* &
dLOG((Parext(2)-Su)/ &
(Su-Parext(1)))
- Derivx(1,Nchanx,Nchan,Jstart) = Tx(1,Ij,KL)*A &
- + Derivx(1,Nchanx,Nchan,Jstart)
- Derivx(2,Nchanx,Nchan,Jstart) = Tx(2,Ij,KL)*A &
- + Derivx(2,Nchanx,Nchan,Jstart)
+ call multiplyDerivx(calc, Igr, Nchanx,Nchan,Ij, Kl, Jstart, A)
END IF
IF (rextInfo%getNrext().GT.5) THEN
IF (rextInfo%getIflSammyIndex(6).NE.0) THEN
- Jstart = Jstart + 1
+ Jstart = rextInfo%getIflSammyIndex(6)
A = - ((Parext(2)- &
Parext(1)) - &
Su*dLOG((Parext(2)-Su)/ &
(Su-Parext(1))) )
- Derivx(1,Nchanx,Nchan,Jstart) = &
- Tx(1,Ij,KL)*A &
- + Derivx(1,Nchanx,Nchan,Jstart)
- Derivx(2,Nchanx,Nchan,Jstart) = &
- Tx(2,Ij,KL)*A &
- + Derivx(2,Nchanx,Nchan,Jstart)
+ call multiplyDerivx(calc, Igr, Nchanx,Nchan,Ij, Kl, Jstart, A)
END IF
IF (rextInfo%getIflSammyIndex(7).NE.0) THEN
- Jstart = Jstart + 1
+ Jstart = rextInfo%getIflSammyIndex(7)
A = Su**2
- Derivx(1,Nchanx,Nchan,Jstart) = &
- Tx(1,Ij,KL)*A &
- + Derivx(1,Nchanx,Nchan,Jstart)
- Derivx(2,Nchanx,Nchan,Jstart) = &
- Tx(2,Ij,KL)*A &
- + Derivx(2,Nchanx,Nchan,Jstart)
+ call multiplyDerivx(calc, Igr, Nchanx,Nchan,Ij, Kl, Jstart, A)
END IF
END IF
END IF
@@ -250,4 +240,18 @@ contains
!
RETURN
END
+
+ subroutine multiplyDerivx(calc, Igr, Nchanx,Nchan,Ij, Kl, Jstart, A)
+ class(XctCrossCalc)::calc
+ integer::igr
+ integer:: Nchanx,Nchan,Ij, Kl, Jstart
+ real(kind=8)::A
+ integer::ix
+
+ do ix = 1, 2
+ calc%angInternal(Ix,Nchanx,Nchan, Igr, Jstart) = &
+ calc%Tx(Ix,Ij,KL)*A &
+ + calc%angInternal(Ix,Nchanx,Nchan, Igr, Jstart)
+ end do
+ end subroutine multiplyDerivx
end module mxct12_m
diff --git a/sammy/src/xct/mxct13.f90 b/sammy/src/xct/mxct13.f90
index 5bc5a6254..cc9f09c8d 100644
--- a/sammy/src/xct/mxct13.f90
+++ b/sammy/src/xct/mxct13.f90
@@ -1,56 +1,56 @@
+module mxct13_m
+use XctCrossCalc_M
+contains
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Setpxr (Rootp, Xxxxr, Xxxxi, Dpdr, Dsdr, Pxrhor, &
- Pxrhoi, Ntot)
+ SUBROUTINE Setpxr (calc, Ntot)
!
! *** purpose -- generate Pxrho_ = partial(Xxxx_) wrt (Rho)
!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ use mxct09_m
+ IMPLICIT none
!
!
- DIMENSION Rootp(*), Xxxxr(*), Xxxxi(*), Dpdr(*), Dsdr(*), &
- Pxrhor(Nn,*), Pxrhoi(Nn,*)
-! DIMENSION Rootp(Ntot), Xxxxr(Nn), Xxxxi(Nn), Dpdr(Ntot), Dsdr(Ntot),
-! * Pxrhor(Nn,Ntotc), Pxrhoi(Nn,Ntotc)
+ class(XctCrossCalc)::calc
+ integer::ntot
+ real(kind=8)::Ai, Ar, Bi, Br, Dpopi, Dpopj
+ integer::I, Ij, Ik, J, Kj, K
!
- EXTERNAL Ijkl
- DATA Zero /0.0d0/, Half /0.5d0/
+ real(kind=8),parameter:: Zero = 0.0d0, Half = 0.5d0
!
- CALL Zero_Array (Pxrhor, Nn*Ntotc)
- CALL Zero_Array (Pxrhoi, Nn*Ntotc)
!
+ calc%Pxrhor = 0.0d0
+ calc%Pxrhoi = 0.0d0
+
Ij = 0
DO I=1,Ntot
- Dpopi = Dpdr(I)*Half/Rootp(I)**2
+ Dpopi = calc%Dpdr(I)*Half/calc%Rootp(I)**2
! *** = [ partial ( sqrt(P)) wrt rho ] / sqrt(P)
DO J=1,I
Ij = Ij + 1
IF (Dpopi.NE.Zero) THEN
- Pxrhor(Ij,I) = Pxrhor(Ij,I) + Xxxxr(Ij)*Dpopi
- Pxrhoi(Ij,I) = Pxrhoi(Ij,I) + Xxxxi(Ij)*Dpopi
+ calc%Pxrhor(Ij,I) = calc%Pxrhor(Ij,I) + calc%Xxxxr(Ij)*Dpopi
+ calc%Pxrhoi(Ij,I) = calc%Pxrhoi(Ij,I) + calc%Xxxxi(Ij)*Dpopi
END IF
- IF (Dpdr(J).NE.Zero) THEN
- Dpopj = Dpdr(J)*Half/Rootp(J)**2
- Pxrhor(Ij,J) = Pxrhor(Ij,J) + Xxxxr(Ij)*Dpopj
- Pxrhoi(Ij,J) = Pxrhoi(Ij,J) + Xxxxi(Ij)*Dpopj
+ IF (calc%Dpdr(J).NE.Zero) THEN
+ Dpopj = calc%Dpdr(J)*Half/calc%Rootp(J)**2
+ calc%Pxrhor(Ij,J) = calc%Pxrhor(Ij,J) + calc%Xxxxr(Ij)*Dpopj
+ calc%Pxrhoi(Ij,J) = calc%Pxrhoi(Ij,J) + calc%Xxxxi(Ij)*Dpopj
END IF
DO K=1,Ntot
- IF (Dsdr(K).NE.Zero .OR. Dpdr(K).NE.Zero) THEN
+ IF (calc%Dsdr(K).NE.Zero .OR. calc%Dpdr(K).NE.Zero) THEN
Ik = Ijkl(I,K)
Kj = Ijkl(K,J)
- Ar = Xxxxr(Ik)/Rootp(K)
- Ai = Xxxxi(Ik)/Rootp(K)
- Br = Ar*Dsdr(K) - Ai*Dpdr(K)
- Bi = Ai*Dsdr(K) + Ar*Dpdr(K)
- Ar = Xxxxr(Kj)/Rootp(K)
- Ai = Xxxxi(Kj)/Rootp(K)
- Pxrhor(Ij,k) = Pxrhor(Ij,k) + Ar*Br - Ai*Bi
- Pxrhoi(Ij,k) = Pxrhoi(Ij,k) + Ar*Bi + Ai*Br
+ Ar = calc%Xxxxr(Ik)/calc%Rootp(K)
+ Ai = calc%Xxxxi(Ik)/calc%Rootp(K)
+ Br = Ar*calc%Dsdr(K) - Ai*calc%Dpdr(K)
+ Bi = Ai*calc%Dsdr(K) + Ar*calc%Dpdr(K)
+ Ar = calc%Xxxxr(Kj)/calc%Rootp(K)
+ Ai = calc%Xxxxi(Kj)/calc%Rootp(K)
+ calc%Pxrhor(Ij,k) = calc%Pxrhor(Ij,k) + Ar*Br - Ai*Bi
+ calc%Pxrhoi(Ij,k) = calc%Pxrhoi(Ij,k) + Ar*Bi + Ai*Br
END IF
END DO
END DO
@@ -58,3 +58,4 @@
!
RETURN
END
+end module mxct13_m
diff --git a/sammy/src/xct/mxct14.f90 b/sammy/src/xct/mxct14.f90
index f8c7a877b..160805a28 100644
--- a/sammy/src/xct/mxct14.f90
+++ b/sammy/src/xct/mxct14.f90
@@ -1,11 +1,6 @@
module Derrho_m
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- use SammySpinGroupInfo_M
- use SammyChannelInfo_M
- use EndfData_common_m, only : radFitFlags
- IMPLICIT NONE
+use XctCrossCalc_M
+IMPLICIT NONE
contains
@@ -13,9 +8,7 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Derrho (spinInfo, Ifcros, Zke, Sinsqr, &
- Sin2ph, Cscs, Dphi, Xxxxr, Xxxxi, Pxrhor, Pxrhoi, Dsf, Dst, &
- Dstt, Dsfx, Dstx, Nnext, Lrmat)
+ SUBROUTINE Derrho (spinInfo, calc, Igr, Lrmat)
!
! *** generate derivatives of Crss & Crssx wrt rho
! *** Dsf ( I) = Deriv of Crss(1 ) wrt rho via phi(I)
@@ -24,54 +17,46 @@ contains
!
!
!
+ use mxct09_m
+ use SammySpinGroupInfo_M
+ use SammyChannelInfo_M
+ class(XctCrossCalc)::calc
type(SammySpinGroupInfo)::spinInfo
- type(SammyChannelInfo)::channelInfo
- real(kind=8):: Zke(*), Sinsqr(*), Sin2ph(*), &
- Cscs(2,*), Dphi(*), Xxxxr(*), Xxxxi(*), Pxrhor(nn,*), &
- Pxrhoi(Nn,*), Dsf(*), Dst(2,*), Dstt(Nnext,*), Dstx(2,Ntotc,*), &
- Dsfx(2,Ntotc,*)
- INTEGER::Ifcros(*)
+ type(SammyChannelInfo)::channelInfo
- integer:: nnext, lrmat
+ integer:: lrmat
real(kind=8)::half, one, two, four, zero
real(kind=8):: a, Aa, suma, sumb, Zz
integer::i, ichan, ifc, ii, ij, m, jchan, j, Jj, mchan
- integer::chanExcl, igr
- logical::iflApe, iflApt
-! DIMENSION Ifcros(Ncrsss), Zke(Ntot), Sinsqr(Ntot),
-! * Sin2ph(Ntot), Cscs(2,Ntriag), Dphi(Ntot), Xxxxr(Nn), Xxxxi(Nn),
-! * Pxrhor(Nn,Ntot), Pxrhoi(Nn,Ntot), Dsf(Ntot), Dst(2,Ntot),
- ! * Dstt(Next,Nent), Dstx(2,Ntotc,Ntotc), Dsfx(2,Ntotc,Ntotc)
- integer::Ijkl
- EXTERNAL Ijkl
+ integer::igr
+ logical::iflApe, iflApt, elastic
+
DATA Half /0.5d0/, One /1.0d0/, Two /2.0d0/, Four /4.0d0/
DATA Zero /0.0d0/
-
iflApe = .false.
iflApt = .false.
- igr = spinInfo%getSpinGroupIndex()
DO I=1, spinInfo%getNumChannels()
- if (radFitFlags%getTrueFitFlag(igr, I).ne.0) iflApt = .true.
- if (radFitFlags%getEffFitFlag(igr, I).ne.0) iflApe = .true.
+ if (calc%radiusData%getTrueFitFlag(igr, I).ne.0) iflApt = .true.
+ if (calc%radiusData%getEffFitFlag(igr, I).ne.0) iflApe = .true.
end Do
!
!
- IF (Ncrssx.EQ.1) THEN
+ IF (any(calc%Ifcros)) THEN
! *** (Ncrssx=1 if some of Crss need to be calculated; otherwise
! *** Ncrssx=0)
!
- IF (iflApe.OR. Ktzero.GT.0) THEN
- IF (Ifcros(1).NE.0) THEN
+ IF (iflApe.OR. calc%Ifzzz) THEN
+ IF (calc%Ifcros(1)) THEN
! *** [partial of elastic cross section wrt phi] *
! *** [partial of phi wrt rho]
Ii = 0
DO I=1,spinInfo%getNumEntryChannels()
Ii = Ii + I
- Dsf(I) = ( Sin2ph(I)*(One-Two*Xxxxi(Ii)) &
- - Four*(Half-Sinsqr(I))*Xxxxr(Ii) ) * &
- Dphi(I) /Zke(I)**2
+ calc%Dsf(I) = ( calc%Sin2ph(I)*(One-Two*calc%Xxxxi(Ii)) &
+ - Four*(Half-calc%Sinsqr(I))*calc%Xxxxr(Ii) ) * &
+ calc%Dphi(I) /calc%Zke(I, Igr)**2
END DO
! *** Note that the "f" in Dsf is for "effective" rho... ie
! *** effective radius
@@ -79,8 +64,8 @@ contains
END IF
!
IF (Lrmat.EQ.0) THEN
- IF (iflApt.OR. Ktzero.GT.0) THEN
- IF (Ifcros(1).NE.0 .OR. Ifcros(2).NE.0) THEN
+ IF (iflApt.OR. calc%Ifzzz) THEN
+ IF (calc%Ifcros(1).OR. calc%Ifcros(2)) THEN
! *** [partial derivatives of elastic and absorption cross
! *** sections wrt Xxxx] * [partial of Xxxx wrt rho_m]
DO M=1,spinInfo%getNumChannels()
@@ -88,21 +73,21 @@ contains
Ij = 0
DO I=1,spinInfo%getNumEntryChannels()
Ii = Ii + I
- Zz = Zke(I)**2
- Sumb = - Two*Sinsqr(I)*Pxrhoi(Ii,M) - &
- Sin2ph(I)*Pxrhor(Ii,M)
+ Zz = calc%Zke(I, Igr)**2
+ Sumb = - Two*calc%Sinsqr(I)*calc%Pxrhoi(Ii,M) - &
+ calc%Sin2ph(I)*calc%Pxrhor(Ii,M)
Sumb = Sumb / Zz
- Suma = Pxrhoi(Ii,M) / Zz
+ Suma = calc%Pxrhoi(Ii,M) / Zz
DO J=1,I
Ij = Ij + 1
- A = Two* ( Xxxxr(Ij)*Pxrhor(Ij,M) + &
- Xxxxi(Ij)*Pxrhoi(Ij,M) )
+ A = Two* ( calc%Xxxxr(Ij)*calc%Pxrhor(Ij,M) + &
+ calc%Xxxxi(Ij)*calc%Pxrhoi(Ij,M) )
IF (I.NE.J) A = A + A
Sumb = Sumb + A/Zz
Suma = Suma - A/Zz
END DO
- IF (Ifcros(1).NE.0) Dst(1,M) = Sumb
- IF (Ifcros(2).NE.0) Dst(2,M) = Suma
+ IF (calc%Ifcros(1)) calc%Dst(1,M) = Sumb
+ IF (calc%Ifcros(2)) calc%Dst(2,M) = Suma
END DO
END DO
END IF
@@ -114,35 +99,31 @@ contains
! *** scattering) wrt Xxxx] * [partial Xxxx wrt rho_m]
Ifc = 0
DO Jj=1,spinInfo%getNumExitChannels()
- IF (Ifcros(Jj+2).NE.0) Ifc = 1
+ IF (calc%Ifcros(Jj+2)) Ifc = 1
END DO
IF (Ifc.NE.0) THEN
- DO M=1,spinInfo%getNumChannels()
- DO Jj=1,spinInfo%getNumExitChannels()
- Dstt(Jj,M) = Zero
- END DO
+ calc%Dstt = Zero
+ DO M=1,spinInfo%getNumChannels()
DO I=1,spinInfo%getNumEntryChannels()
- Zz = Zke(i)**2
+ Zz = calc%Zke(i, Igr)**2
DO Jj=1,spinInfo%getNumExitChannels()
if((Jj+spinInfo%getNumEntryChannels()).gt.spinInfo%getNumChannels()) cycle
- if ( Ifcros(Jj+2).eq.0) cycle
+ if ( .not.calc%Ifcros(Jj+2)) cycle
call spinInfo%getChannelInfo(channelInfo, Jj+spinInfo%getNumEntryChannels())
- if ( channelInfo%getExcludeCompletely()) then
- chanExcl = -1
- else if (channelInfo%getIncludeInCalc()) then
- chanExcl = 0
+ if ( channelInfo%getExcludeCompletely()) cycle
+ if ( channelInfo%getIncludeInCalc()) then
+ if (calc%addElimKapt) cycle
else
- chanExcl = 1
+ if (.not.calc%addElimKapt) cycle
end if
- if (chanExcl.ne.Kaptur) cycle
-
+
J = Jj + spinInfo%getNumEntryChannels()
Ij = Ijkl(I,J)
- A = Two * (Xxxxr(Ij)*Pxrhor(Ij,M)+ &
- Xxxxi(Ij)*Pxrhoi(Ij,M))
- Dstt(Jj,M) = A/Zz + Dstt(Jj,M)
+ A = Two * (calc%Xxxxr(Ij)*calc%Pxrhor(Ij,M)+ &
+ calc%Xxxxi(Ij)*calc%Pxrhoi(Ij,M))
+ calc%Dstt(Jj,M) = A/Zz + calc%Dstt(Jj,M)
END DO
END DO
END DO
@@ -154,55 +135,48 @@ contains
END IF
!
!
- IF (Ifdif.NE.0) THEN
+ IF (calc%needAngular) THEN
+ elastic = calc%reactType.ne.11
!
- IF (iflApe.OR. Ktzero.GT.0) THEN
+ IF (iflApe.OR. calc%Ifzzz) THEN
! *** [partial of pieces of angular distribution wrt phi]
! *** * [partial phi wrt rho]
- CALL Zero_Array (Dstx, 2*Ntotc**2)
- CALL Zero_Array (Dsfx, 2*Ntotc**2)
+ calc%Dstx = 0.0d0
+ calc%Dsfx = 0.0d0
!
- IF (Ifdif.EQ.1) THEN
+ IF (elastic) THEN
! *** First, diagonal pieces
II = 0
DO Ichan=1,spinInfo%getNumEntryChannels()
- Zz = Zke(Ichan)**2
+ Zz = calc%Zke(Ichan, Igr)**2
II = II + Ichan
- A = ( Sin2ph(Ichan)*(One-Two*Xxxxi(II)) - Four* &
- (Half-Sinsqr(Ichan))*Xxxxr(II) ) * Dphi(Ichan)
- Aa = ( (One-Two*Sinsqr(Ichan))*(One-Two*Xxxxi(II)) &
- - Two*Sin2ph(Ichan)*Xxxxr(II) ) * Dphi(Ichan)
- Dsfx(1,Ichan,Ichan) = A/Zz
- Dsfx(2,Ichan,Ichan) = Aa/Zz
+ A = ( calc%Sin2ph(Ichan)*(One-Two*calc%Xxxxi(II)) - Four* &
+ (Half-calc%Sinsqr(Ichan))*calc%Xxxxr(II) ) * calc%Dphi(Ichan)
+ Aa = ( (One-Two*calc%Sinsqr(Ichan))*(One-Two*calc%Xxxxi(II)) &
+ - Two*calc%Sin2ph(Ichan)*calc%Xxxxr(II) ) * calc%Dphi(Ichan)
+ calc%Dsfx(1,Ichan,Ichan) = A/Zz
+ calc%Dsfx(2,Ichan,Ichan) = Aa/Zz
END DO
END IF
! *** off-diagonal pieces
Ij = 0
DO Ichan=1,spinInfo%getNumChannels()
- Zz = Zke(Ichan)**2
+ Zz = calc%Zke(Ichan, Igr)**2
DO Jchan=1,Ichan
Ij = Ij + 1
IF (Jchan.LE.spinInfo%getNumEntryChannels() .AND. Jchan.NE.Ichan) THEN
call spinInfo%getChannelInfo(channelInfo, Ichan)
- if ( channelInfo%getExcludeCompletely()) then
- chanExcl = -1
- else if (channelInfo%getIncludeInCalc()) then
- chanExcl = 0
- else
- chanExcl = 1
- end if
-
- IF ( (Ifdif.EQ.1 .AND. Ichan.LE.spinInfo%getNumEntryChannels()) .OR. &
- (Ifdif.EQ.2 .AND. Ichan.GT.spinInfo%getNumEntryChannels() .AND. &
- chanExcl.EQ.Kaptur) ) THEN
- A = ( -Cscs(2,Ij)*Xxxxi(Ij) &
- - Cscs(1,Ij)*Xxxxr(Ij) ) * Dphi(Ichan)
- AA = ( Cscs(2,Ij)*Xxxxr(Ij) &
- - Cscs(1,Ij)*Xxxxi(Ij) ) * Dphi(Ichan)
- Dsfx(1,Jchan,Ichan) = A /Zz +Dsfx(1,Jchan,Ichan)
- Dsfx(2,Jchan,Ichan) = Aa/Zz +Dsfx(2,Jchan,Ichan)
+ if ( channelInfo%getExcludeCompletely()) cycle
+
+ IF ( calc%useChannel(Ichan ,2) ) THEN
+ A = ( -calc%Cscs(2,Ij)*calc%Xxxxi(Ij) &
+ - calc%Cscs(1,Ij)*calc%Xxxxr(Ij) ) * calc%Dphi(Ichan)
+ AA = ( calc%Cscs(2,Ij)*calc%Xxxxr(Ij) &
+ - calc%Cscs(1,Ij)*calc%Xxxxi(Ij) ) * calc%Dphi(Ichan)
+ calc%Dsfx(1,Jchan,Ichan) = A /Zz +calc%Dsfx(1,Jchan,Ichan)
+ calc%Dsfx(2,Jchan,Ichan) = Aa/Zz +calc%Dsfx(2,Jchan,Ichan)
!c Zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz these are probably not right... cuz wrt
!c Zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz which variable?
END IF
@@ -211,46 +185,38 @@ contains
END DO
END IF
!
- IF (iflApt.OR. Ktzero.GT.0) THEN
+ IF (iflApt.OR. calc%Ifzzz) THEN
! *** [partial derivatives of diff cross section wrt XXXX] *
!c *** [partial XXX wrt rho]
DO Mchan=1,spinInfo%getNumChannels()
Ii = 0
Ij = 0
DO Ichan=1,spinInfo%getNumChannels()
- Zz = Zke(Ichan)**2
+ Zz = calc%Zke(Ichan, Igr)**2
Ii = Ii + Ichan
- IF (Ifdif.EQ.1 .AND. Ichan.LE.spinInfo%getNumEntryChannels()) THEN
- A = - Two*Sinsqr(Ichan)*Pxrhoi(Ii,Mchan) - &
- Sin2ph(Ichan)*Pxrhor(Ii,Mchan)
- AA = (Two*Sinsqr(Ichan)-One)*Pxrhor(Ii,Mchan) + &
- Sin2ph(Ichan)*Pxrhoi(Ii,Mchan)
- Dstx(1,Ichan,Ichan) = Dstx(1,Ichan,Ichan) + A /Zz
- Dstx(2,Ichan,Ichan) = Dstx(2,Ichan,Ichan) + Aa/Zz
+ IF (elastic .AND. Ichan.LE.spinInfo%getNumEntryChannels()) THEN
+ A = - Two*calc%Sinsqr(Ichan)*calc%Pxrhoi(Ii,Mchan) - &
+ calc%Sin2ph(Ichan)*calc%Pxrhor(Ii,Mchan)
+ AA = (Two*calc%Sinsqr(Ichan)-One)*calc%Pxrhor(Ii,Mchan) + &
+ calc%Sin2ph(Ichan)*calc%Pxrhoi(Ii,Mchan)
+ calc%Dstx(1,Ichan,Ichan) = calc%Dstx(1,Ichan,Ichan) + A /Zz
+ calc%Dstx(2,Ichan,Ichan) = calc%Dstx(2,Ichan,Ichan) + Aa/Zz
END IF
DO Jchan=1,Ichan
Ij = Ij + 1
call spinInfo%getChannelInfo(channelInfo, Ichan)
- if ( channelInfo%getExcludeCompletely()) then
- chanExcl = -1
- else if (channelInfo%getIncludeInCalc()) then
- chanExcl = 0
- else
- chanExcl = 1
- end if
+ if ( channelInfo%getExcludeCompletely()) cycle
IF (Jchan.NE.Ichan .AND. Jchan.LE.spinInfo%getNumEntryChannels()) THEN
- IF ( (Ifdif.EQ.1 .AND. Ichan.LE.spinInfo%getNumEntryChannels()) .OR. &
- (Ifdif.EQ.2 .AND. Ichan.GT.spinInfo%getNumEntryChannels() .AND. &
- chanExcl.EQ.Kaptur) ) THEN
- A = Cscs(1,Ij)*Pxrhoi(Ij,Mchan) - &
- Cscs(2,Ij)*Pxrhor(Ij,Mchan)
- AA=-Cscs(1,Ij)*Pxrhor(Ij,Mchan) - &
- Cscs(2,Ij)*Pxrhoi(Ij,Mchan)
- Dstx(1,Jchan,Ichan) = Dstx(1,Jchan,Ichan) + &
+ IF ( calc%useChannel(Ichan, 2)) THEN
+ A = calc%Cscs(1,Ij)*calc%Pxrhoi(Ij,Mchan) - &
+ calc%Cscs(2,Ij)*calc%Pxrhor(Ij,Mchan)
+ AA=-calc%Cscs(1,Ij)*calc%Pxrhor(Ij,Mchan) - &
+ calc%Cscs(2,Ij)*calc%Pxrhoi(Ij,Mchan)
+ calc%Dstx(1,Jchan,Ichan) = calc%Dstx(1,Jchan,Ichan) + &
A/Zz
- Dstx(2,Jchan,Ichan) = Dstx(2,Jchan,Ichan) + &
+ calc%Dstx(2,Jchan,Ichan) = calc%Dstx(2,Jchan,Ichan) + &
Aa/Zz
!czzzzzzzzzzzzzzzzzzzzzzzzzzzzzz these are not right yet!
END IF
diff --git a/sammy/src/xct/mxct15.f90 b/sammy/src/xct/mxct15.f90
index 9a5e627fe..da4d6c4bb 100644
--- a/sammy/src/xct/mxct15.f90
+++ b/sammy/src/xct/mxct15.f90
@@ -1,73 +1,69 @@
+module mxc15_m
+use XctCrossCalc_M
+implicit none
+contains
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Derrad (Echan, If_Excl, Ifcros, Zke, &
- Deriv, Derivx, Dsf, Dst, Dstt, Dsfx, &
- Dstx, Dgoj, Nnext, Lrmat, igr)
+ SUBROUTINE Derrad (spinInfo, calc, Igr, Lrmat)
!
! *** generate derivatives of cross section wrt radius
!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- use EndfData_common_m, only : resparData, radFitFlags
use SammySpinGroupInfo_M
use SammyChannelInfo_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
!
logical::iflApe, iflApt
+ class(XctCrossCalc)::calc
type(SammySpinGroupInfo)::spinInfo
- DIMENSION Echan(*), If_Excl(*), Ifcros(*), Zke(*), &
- Deriv(Ncrsss,*), Derivx(2,Ntotc,Ntotc,*), Dsf(*), &
- Dst(2,*), Dstt(Nnext,*), Dsfx(2,Ntotc,*), Dstx(2,Ntotc,*)
- DATA Zero /0.0d0/
+ integer::Lrmat, Igr
+ real(kind=8),parameter:: Zero=0.0d0
+ real(kind=8)::Dgoj, val, Su
+ integer::I,Ichan, Ifc, Ifzk, Ifzkj, Jchan, Jj, K, Nent, Next, Ntot, Ix
+ real(kind=8)::Z, Zz, Zzj
+ logical::elastic
!
!
- call resParData%getSpinGroupInfo(spinInfo,igr)
Nent = spinInfo%getNumEntryChannels()
Next = spinInfo%getNumExitChannels()
Ntot = spinInfo%getNumChannels()
- DO I=1, spinInfo%getNumChannels()
- if (radFitFlags%getTrueFitFlag(Igr, I).ne.0) then
- iflApt = .true.
- end if
- if (radFitFlags%getEffFitFlag(Igr, I).ne.0) then
- iflApe = .true.
- end if
- END DO
- IF (Ncrssx.NE.0) THEN
-!
- IF (iflApe.AND. Ifcros(1).NE.0) THEN
+ Dgoj = spinInfo%getGFactor()
+ Su = dAbs(calc%ener)
+
+ IF (any(calc%Ifcros)) THEN
+!
+ IF (calc%Ifcros(1)) THEN
! *** derivatives of elastic cross section wrt effective radius
! *** [d sigma-el/d phi] * [d phi/d effective radius]
DO Ichan=1,Nent
- Ifzk = radFitFlags%getEffFitFlag(Igr, Ichan)
+ Ifzk = calc%radiusData%getEffFitFlag(Igr, Ichan)
IF (Ifzk.GT.0) THEN
- IF (Su.GT.Echan(Ichan)) THEN
- Zz = Dgoj * dSQRT(Su-Echan(Ichan))*Zke(Ichan)
+ IF (Su.GT.calc%Echan(Ichan,Igr)) THEN
+ Zz = Dgoj * dSQRT(Su-calc%Echan(Ichan,Igr))*calc%Zke(Ichan,Igr)
! *** Note that Dgoj * {partial rho wrt a, for channel
! *** Ichan} = Dgoj * sqrt(E)*Zke = Zz*Zke
- Deriv(1,Ifzk) = Deriv(1,Ifzk) + Dsf(Ichan)*Zz
+ val = calc%Dsf(Ichan)*Zz + calc%crossInternal(1, Igr, Ifzk)
+ calc%crossInternal(1, Igr, Ifzk) = val
END IF
END IF
END DO
END IF
!
- IF (Lrmat.EQ.0 .AND.iflApt) THEN
+ IF (Lrmat.EQ.0) THEN
!
- IF (Ifcros(1).NE.0 .OR. Ifcros(2).NE.0) THEN
+ IF (calc%Ifcros(1).OR. calc%Ifcros(2)) THEN
! *** derivatives of elastic & absorption wrt true radius
DO k=1,2
- IF (Ifcros(k).NE.0) THEN
+ IF (calc%Ifcros(k)) THEN
DO Ichan=1,Ntot
- Ifzk = radFitFlags%getTrueFitFlag(Igr,Ichan)
- IF (Ifzk.GT.0 .AND.Su.GT.Echan(Ichan)) THEN
- Zz = Dgoj * dSQRT(Su-Echan(Ichan))*Zke(Ichan)
- Deriv(k,Ifzk) = Deriv(k,Ifzk) + &
- Dst(k,Ichan)*zz
+ Ifzk = calc%radiusData%getTrueFitFlag(Igr,Ichan)
+ IF (Ifzk.GT.0 .AND.Su.GT.calc%Echan(Ichan,Igr)) THEN
+ Zz = Dgoj * dSQRT(Su-calc%Echan(Ichan,Igr))*calc%Zke(Ichan,Igr)
+ val = calc%Dst(k,Ichan)*zz + calc%crossInternal(k, Igr, Ifzk)
+ calc%crossInternal(k, Igr, Ifzk) = val
END IF
END DO
END IF
@@ -80,32 +76,30 @@
! *** (true) radius
Ifc = 0
DO Jj=1,Next
- IF (Ifcros(Jj+2).NE.0) Ifc = 1
+ IF (calc%Ifcros(Jj+2)) Ifc = 1
END DO
IF (Ifc.EQ.1) THEN
DO Ichan=1,Nent
- Ifzk = radFitFlags%getTrueFitFlag(Igr,Ichan)
- IF (Su.LE.Echan(Ichan)) THEN
+ Ifzk = calc%radiusData%getTrueFitFlag(Igr,Ichan)
+ IF (Su.LE.calc%Echan(Ichan,Igr)) THEN
Zz = Zero
ELSE
- Zz = Dgoj*Zke(Ichan)*dSQRT(Su-Echan(Ichan))
+ Zz = Dgoj*calc%Zke(Ichan,Igr)*dSQRT(Su-calc%Echan(Ichan,Igr))
END IF
DO Jj=1,Next
- IF (Jj+Nent.LE.Ntot .AND. Ifcros(Jj+2).NE.0 &
- .AND. If_Excl(Jj+Nent).EQ.Kaptur) THEN
+ IF (Jj+Nent.LE.Ntot .AND. calc%useChannel(JJ+2, 1)) THEN
Jchan = Jj + Nent
- IF (radFitFlags%getTrueFitFlag(Igr,Ichan) &
- .GT.0 &
- .AND. Zz.NE.Zero) &
- Deriv(Jj+2,Ifzk) = Deriv(Jj+2,Ifzk) + &
- Dstt(Jj,Ichan)*Zz
- Ifzkj = radFitFlags%getTrueFitFlag(Igr,Jchan)
+ IF (Ifzk .GT.0 .AND. Zz.NE.Zero) then
+ val = calc%Dstt(Jj,Ichan)*Zz + calc%crossInternal(Jj+2, Igr, Ifzk)
+ calc%crossInternal(Jj+2, Igr, Ifzk) = val
+ end if
+ Ifzkj = calc%radiusData%getTrueFitFlag(Igr,Jchan)
IF (Ifzkj.GT.0) THEN
- IF (Su.GT.Echan(Jchan)) THEN
- Zzj = Dgoj*Zke(Jchan)* &
- Dsqrt(Su-Echan(Jchan))
- Deriv(Jj+2,Ifzkj) = Deriv(Jj+2,Ifzkj) + &
- Dstt(Jj,Jchan)*Zzj
+ IF (Su.GT.calc%Echan(Jchan,Igr)) THEN
+ Zzj = Dgoj*calc%Zke(Jchan,Igr)* &
+ Dsqrt(Su-calc%Echan(Jchan,Igr))
+ val = calc%Dstt(Jj,Jchan)*Zzj + calc%crossInternal(Jj+2, Igr, Ifzkj)
+ calc%crossInternal(Jj+2, Igr, Ifzkj) = val
END IF
END IF
END IF
@@ -115,56 +109,61 @@
END IF
!
END IF
- END IF
+ end if
!
!
- IF (Ifdif.NE.0) THEN
+ IF (calc%needAngular) THEN
+ elastic = calc%reactType.ne.11
+
+ DO I=1, spinInfo%getNumChannels()
+ if (calc%radiusData%getTrueFitFlag(Igr, I).ne.0) then
+ iflApt = .true.
+ end if
+ if (calc%radiusData%getEffFitFlag(Igr, I).ne.0) then
+ iflApe = .true.
+ end if
+ END DO
!
IF (iflApe) THEN
! *** derivatives of pieces of differential elastic scatt wrt
! *** effective radius; First, diagonal pieces
- IF (Ifdif.EQ.1) THEN
+ IF (elastic) THEN
DO Ichan=1,Nent
- Ifzk = radFitFlags%getEffFitFlag(Igr, Ichan)
+ Ifzk = calc%radiusData%getEffFitFlag(Igr, Ichan)
IF (Ifzk.GT.0) THEN
- Zz = Zke(Ichan)*Squ
- Derivx(1,Ichan,Ichan,Ifzk) = &
- Derivx(1,Ichan,Ichan,Ifzk) + &
- Zz*Dsfx(1,Ichan,Ichan)
- Derivx(2,Ichan,Ichan,Ifzk) = &
- Derivx(2,Ichan,Ichan,Ifzk) + &
- Zz*Dsfx(2,Ichan,Ichan)
+ Zz = calc%Zke(Ichan,Igr)*calc%enerSq
+ do ix = 1, 2
+ val = calc%angInternal(Ix,Ichan,Ichan, Igr, Ifzk)
+ val = val + Zz*calc%Dsfx(Ix,Ichan,Ichan)
+ calc%angInternal(Ix,Ichan,Ichan, Igr, Ifzk) = val
+ end do
END IF
END DO
END IF
- IF ( (Ifdif.EQ.1 .AND. Nent.GT.1) .OR. Ifdif.EQ.2) THEN
+ IF ( (elastic .AND. Nent.GT.1) .OR. .not.elastic) THEN
! *** derivatives of pieces of differential cross section wrt
! *** effective radius; Now, off-diagonal pieces
DO Ichan=1,Ntot
DO Jchan=1,Nent
IF (Jchan.LT.Ichan) THEN
- IF ( (Ifdif.EQ.1 .AND. Ichan.LE.Nent) .OR. &
- (Ifdif.EQ.2 .AND. Ichan.GT.Nent .AND. &
- If_Excl(Ichan).EQ.Kaptur) ) THEN
- Ifzk = radFitFlags%getEffFitFlag(Igr, Ichan)
+ IF ( calc%useChannel(Ichan, 2)) THEN
+ Ifzk = calc%radiusData%getEffFitFlag(Igr, Ichan)
IF (Ifzk.GT.0) THEN
- Zz = Zke(Ichan)*Squ
- Derivx(1,Jchan,Ichan,Ifzk) = &
- Derivx(1,Jchan,Ichan,Ifzk) + &
- Zz*Dsfx(1,Jchan,Ichan)
- Derivx(2,Jchan,Ichan,Ifzk) = &
- Derivx(2,Jchan,Ichan,Ifzk) + &
- Zz*Dsfx(2,Jchan,Ichan)
+ Zz = calc%Zke(Ichan,Igr)*calc%enerSq
+ do ix = 1, 2
+ val = calc%angInternal(ix,Jchan,Ichan, Igr, Ifzk)
+ val = val + Zz*calc%Dsfx(Ix,Jchan,Ichan)
+ calc%angInternal(ix,Jchan,Ichan, Igr, Ifzk) = val
+ end do
END IF
- Ifzk = radFitFlags%getEffFitFlag(Igr, Jchan)
+ Ifzk = calc%radiusData%getEffFitFlag(Igr, Jchan)
IF (Ifzk.GT.0) THEN
- Zz = Zke(Jchan)*Squ
- Derivx(1,Jchan,Ichan,Ifzk) = &
- Derivx(1,Jchan,Ichan,Ifzk) + &
- Zz*Dsfx(1,Jchan,Ichan)
- Derivx(2,Jchan,Ichan,Ifzk) = &
- Derivx(2,Jchan,Ichan,Ifzk) + &
- Zz*Dsfx(2,Jchan,Ichan)
+ Zz = calc%Zke(Jchan,Igr)*calc%enerSq
+ do ix = 1, 2
+ val = calc%angInternal(ix,Jchan,Ichan, Igr, Ifzk)
+ val = val + Zz*calc%Dsfx(ix,Jchan,Ichan)
+ calc%angInternal(ix,Jchan,Ichan, Igr, Ifzk) = val
+ end do
END IF
END IF
END IF
@@ -176,42 +175,37 @@
IF (iflApt) THEN
! *** derivatives of pieces of angular distribution wrt true radius
DO Ichan=1,Ntot
- Ifzk = radFitFlags%getTrueFitFlag(Igr,Ichan)
+ Ifzk = calc%radiusData%getTrueFitFlag(Igr,Ichan)
Zz = Zero
IF (Ifzk.GT.0) THEN
- Zz = Zke(Ichan)*Squ
- IF (Ifdif.EQ.1 .AND. Ichan.LE.Nent) THEN
- Derivx(1,Ichan,Ichan,Ifzk) = &
- Derivx(1,Ichan,Ichan,Ifzk) + &
- Zz*Dstx(1,Ichan,Ichan)
- Derivx(2,Ichan,Ichan,Ifzk) = &
- Derivx(2,Ichan,Ichan,Ifzk) + &
- Zz*Dstx(2,Ichan,Ichan)
+ Zz = calc%Zke(Ichan,Igr)*calc%enerSq
+ IF (elastic .AND. Ichan.LE.Nent) THEN
+ do ix = 1, 2
+ val = calc%angInternal(ix,Ichan,Ichan, Igr, Ifzk)
+ val = val + Zz*calc%Dstx(Ix,Ichan,Ichan)
+ calc%angInternal(ix,Ichan,Ichan, Igr, Ifzk) = val
+ end do
END IF
END IF
DO Jchan=1,Nent
IF (Jchan.NE.Ichan) THEN
- IF ( (Ifdif.EQ.1 .AND. Ichan.LE.Nent) .OR. &
- (Ifdif.EQ.2 .AND. Ichan.GT.Nent .AND. &
- If_Excl(Ichan).EQ.Kaptur) ) THEN
- IF (radFitFlags%getTrueFitFlag(Igr,Ichan) &
+ IF ( calc%useChannel(Ichan, 2)) THEN
+ IF (calc%radiusData%getTrueFitFlag(Igr,Ichan) &
.GT.0) THEN
- Derivx(1,Jchan,Ichan,Ifzk) = &
- Derivx(1,Jchan,Ichan,Ifzk) + &
- Zz*Dstx(1,Jchan,Ichan)
- Derivx(2,Jchan,Ichan,Ifzk) = &
- Derivx(2,Jchan,Ichan,Ifzk) + &
- Zz*Dstx(2,Jchan,Ichan)
+ do ix = 1, 2
+ val = calc%angInternal(ix,Jchan,Ichan,Igr, Ifzk)
+ val = val + Zz*calc%Dstx(ix,Jchan,Ichan)
+ calc%angInternal(ix,Jchan,Ichan,Igr, Ifzk) = val
+ end do
END IF
- Ifzkj=radFitFlags%getTrueFitFlag(Igr,Jchan)
+ Ifzkj=calc%radiusData%getTrueFitFlag(Igr,Jchan)
IF (Ifzkj.GT.0) THEN
- Z = Zke(Jchan)*Squ
- Derivx(1,Jchan,Ichan,Ifzkj) = &
- Derivx(1,Jchan,Ichan,Ifzkj) + &
- Z*Dstx(1,Jchan,Ichan)
- Derivx(2,Jchan,Ichan,Ifzkj) = &
- Derivx(2,Jchan,Ichan,Ifzkj) + &
- Z*Dstx(2,Jchan,Ichan)
+ Z = calc%Zke(Jchan,Igr)*calc%enerSq
+ do ix = 1, 2
+ val = calc%angInternal(ix,Jchan,Ichan, Igr, Ifzkj)
+ val = val + Z*calc%Dstx(ix,Jchan,Ichan)
+ calc%angInternal(ix,Jchan,Ichan, Igr, Ifzkj) = val
+ end do
END IF
END IF
END IF
@@ -222,3 +216,4 @@
!
RETURN
END
+end module
diff --git a/sammy/src/xct/mxct16.f90 b/sammy/src/xct/mxct16.f90
index 2a909c630..08e8e8fdf 100644
--- a/sammy/src/xct/mxct16.f90
+++ b/sammy/src/xct/mxct16.f90
@@ -1,124 +1,129 @@
+module mxct16_m
+use XctCrossCalc_M
+implicit none
+contains
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Derwid (If_Excl, Ifcros, Pgar, Pgai, Deriv, &
- Derivx, Tr, Ti, Tx, Ddddd, Dgoj, Ntot, Nent, Nfprrr)
+ SUBROUTINE Derwid (spinInfo, calc, Igr)
!
! *** generate Deriv = that portion of (partial Crss(k) wrt radius) that
! *** comes from the unvaried widths
!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- use EndfData_common_m, only : radFitFlags
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ use mxct09_m
!
- DIMENSION If_Excl(*), Ifcros(*), Pgar(Ntriag,Nfprrr,*), &
- Pgai(Ntriag,Nfprrr,*), Deriv(Ncrsss,*), Derivx(2,Ntotc,Ntotc,*), &
- Tr(Ncrsss,*), Ti(Ncrsss,*), Tx(2,Ntriag,*), Ddddd(*)
- integer::iflagMatch
+ class(XctCrossCalc)::calc
+ type(SammySpinGroupInfo)::spinInfo
+ integer::Nent, Igr
+ real(kind=8)::Dgoj, val, A1, A2
+ logical::hasRad
!
- DATA Zero /0.0d0/
+ real(kind=8),parameter::Zero=0.0d0
+ integer::Ij, Iz, J, K, KL, M, Nchan, Nchanx, Numrrr, I, Ir, Ix
!
!
- iflagMatch = radFitFlags%matchFitFlag()
- Numrrr = radFitFlags%getNumRadInfo()
- IF (Numrrr.EQ.0) Numrrr = Nfprrr
- IF (Ncrssx.GT.0) THEN
+
+ hasRad = .false.
+ if( allocated(calc%iradIndex)) then
+ hasRad = any(calc%iradIndex.ne.0)
+ end if
+ if (.not.hasRad) return ! no radius adjustments
+
+ Numrrr = size(calc%iradIndex)
+ Dgoj = spinInfo%getGFactor()
+ Nent = spinInfo%getNumEntryChannels()
+
+
+ IF (any(calc%Ifcros)) THEN
DO Ir=1,Numrrr
- IF (radFitFlags%getNumRadInfo().GT.0) THEN
- Ix = radFitFlags%getTrueFitFlagByIndex(Ir)
- ELSE
- Ix = iflagMatch
- END IF
- IF (Ix.GT.0) THEN
- Ix = Ix - Nfpres - Nfpext
- DO K=1,Ncrsss
- Ddddd(K) = Zero
- END DO
+ M = calc%iradIndex(Ir)
+ if (M.eq.0) exit ! calc%iradIndex=0, means we found all unique true radii
+
+ calc%Ddddd = Zero
+
Iz = 0
Ij = 0
- DO I=1,Ntot
+ DO I=1,calc%ntotc
DO J=1,I
Ij = Ij + 1
- IF (Pgai(Ij,Ix,Nnnn).NE.Zero) THEN
- DO K=1,Ncrsss
- IF (Ifcros(K).NE.0) Ddddd(K) = Ddddd(K) - &
- Pgai(Ij,Ix,Nnnn)*Ti(K,Ij)
+ IF (calc%Pgai(Ij,Ir,Igr).NE.Zero) THEN
+ DO K=1,calc%ntotc+1
+ IF (calc%Ifcros(K)) then
+ calc%Ddddd(K) = calc%Ddddd(K) - calc%Pgai(Ij,Ir,Igr)*calc%Ti(K,Ij)
+ end if
Iz = Iz + 1
END DO
END IF
- IF (Pgar(Ij,Ix,Nnnn).NE.Zero) THEN
- DO K=1,Ncrsss
- IF (Ifcros(K).NE.0) Ddddd(K) = Ddddd(K) + &
- Pgar(Ij,Ix,Nnnn)*Tr(K,Ij)
+ IF (calc%Pgar(Ij,Ir,Igr).NE.Zero) THEN
+ DO K=1,calc%ntotc+1
+ IF (calc%Ifcros(K)) then
+ calc%Ddddd(K) = calc%Ddddd(K) + calc%Pgar(Ij,Ir,Igr)*calc%Tr(K,Ij)
+ end if
Iz = Iz + 1
END DO
END IF
END DO
END DO
- IF (Iz.NE.0) THEN
- IF (radFitFlags%getNumRadInfo().GT.0) THEN
- M = radFitFlags%getTrueFitFlagByIndex(Ir)
- ELSE
- M = iflagMatch
- END IF
+ IF (Iz.NE.0) THEN
DO K=1,2
- IF (Ifcros(K).NE.0) Deriv(K,M) = Dgoj*Ddddd(K) &
- + Deriv(K,M)
+ IF (calc%Ifcros(K)) then
+ val = Dgoj*calc%Ddddd(K) + calc%crossInternal(K, Igr, M)
+ calc%crossInternal(K, Igr, M) = val
+ end if
+ END DO
+ DO K=3,calc%ntotc+1
+ IF (calc%useChannel(K,1)) THEN
+ val = Dgoj*calc%Ddddd(K) + calc%crossInternal(K, Igr, M)
+ calc%crossInternal(K, Igr, M) = val
+ END IF
END DO
- IF (Ncrsss.GT.2) THEN
- DO K=3,Ncrsss
- IF (Ifcros(K).NE.0 .AND. &
- If_Excl(K-2+Nent).EQ.Kaptur) THEN
- Deriv(K,M) = Dgoj*Ddddd(K) + Deriv(K,M)
- END IF
- END DO
- END IF
END IF
- END IF
+
END DO
END IF
!
!
! *** now for differential elastic cross sections
- IF (Ifdif.NE.0) THEN
+ IF (calc%needAngular) THEN
DO Ir=1,Numrrr
- Ix = radFitFlags%getTrueFitFlagByIndex(Ir)
- IF (Ix.GT.0) THEN
- Ix = Ix - Nfpres - Nfpext
- M = radFitFlags%getTrueFitFlagByIndex(Ir)
+ M = calc%iradIndex(Ir)
+ if (M.eq.0) exit ! calc%iradIndex=0, means we found all unique true radii
+
Ij = 0
- DO Ij=1,NN
- IF (Pgai(Ij,Ix,Nnnn).NE.Zero .OR. &
- Pgar(Ij,Ix,Nnnn).NE.Zero ) THEN
- DO Nchan=1,Ntot
- Ifs = If_Stay (Nchan, Ifdif, Nent, &
- If_Excl(Nchan), Kaptur)
- IF (Ifs.EQ.0) THEN
+ DO Ij=1,calc%ntriag
+ IF (calc%Pgai(Ij,Ir,Igr).NE.Zero .OR. &
+ calc%Pgar(Ij,Ir,Igr).NE.Zero ) THEN
+ DO Nchan=1,calc%ntotc
+ IF (calc%useChannel(Nchan,2)) THEN
DO Nchanx=1,Nent
IF (Nchanx.LE.Nchan) THEN
KL = (Nchan*(Nchan-1))/2 + Nchanx
ELSE
KL = (Nchanx*(Nchanx-1))/2 + Nchan
END IF
- Derivx(1,Nchanx,Nchan,M) = &
- Derivx(1,Nchanx,Nchan,M) + &
- Pgar(Ij,Ix,Nnnn)*Tx(1,Ij,KL) - &
- Pgai(Ij,Ix,Nnnn)*Tx(2,Ij,KL)
- Derivx(2,Nchanx,Nchan,M) = &
- Derivx(2,Nchanx,Nchan,M) + &
- Pgar(Ij,Ix,Nnnn)*Tx(2,Ij,KL) + &
- Pgai(Ij,Ix,Nnnn)*Tx(1,Ij,KL)
+ do ix = 1, 2
+ val = calc%angInternal(Ix,Nchanx,Nchan, Igr, M)
+ select case(i)
+ case(1)
+ A1 = calc%Pgar(Ij,Ir,Igr)*calc%Tx(1,Ij,KL)
+ A2 = -calc%Pgai(Ij,Ir,Igr)*calc%Tx(2,Ij,KL)
+ case(2)
+ A1 = calc%Pgar(Ij,Ir,Igr)*calc%Tx(2,Ij,KL)
+ A2 = calc%Pgai(Ij,Ir,Igr)*calc%Tx(1,Ij,KL)
+ end select
+ val = val + A1 + A2
+ calc%angInternal(Ix,Nchanx,Nchan, Igr, M) = val
+ end do
END DO
END IF
END DO
END IF
END DO
- END IF
+
END DO
END IF
!
RETURN
END
+end module mxct16_m
diff --git a/sammy/src/xct/mxct17.f90 b/sammy/src/xct/mxct17.f90
index e4348a2e1..ebb271d4d 100644
--- a/sammy/src/xct/mxct17.f90
+++ b/sammy/src/xct/mxct17.f90
@@ -1,68 +1,71 @@
+module mxct17_m
+use XctCrossCalc_M
+IMPLICIT None
+contains
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Dertze_Phi (Nent, Ifcros, Zke, Ddddtl, Derivx, &
- Dsf, Dsfx, Dstx, igr)
+ SUBROUTINE Dertze_Phi (spinInfo, calc, Igr)
!
! *** Purpose -- Generate derivatives of cross section wrt sqrt(E) via Rho
! *** Note that [partial Rho wrt sqrt(E)] = effective radius (Zke is k without sqrt(E) term)
!
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use varyr_common_m
- use EndfData_common_m
+ use varyr_common_m, only : Elz, Etz
use SammyResonanceInfo_M
use RMatResonanceParam_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
!
+ class(XctCrossCalc)::calc
type(SammySpinGroupInfo)::spinInfo
type(SammyChannelInfo)::channelInfo
type(RMatChannelParams)::channelI, channelJ
- DIMENSION Ifcros(*), Zke(*), Ddddtl(*), Derivx(2,Ntotc,Ntotc,*), &
- Dsf(*), Dsfx(2,Ntotc,*), Dstx(2,Ntotc,*)
+ integer::igr
+ integer::Itz, Ilz, Jchan, nent, Ichan, Ix
+ real(kind=8)::Zz, A, R1, R2, val
!
!
- IF (Itzero.LE.0 .AND. ILzero.LE.0) RETURN
- Itz = Itzero
- ILz = ILzero
- call resParData%getSpinGroupInfo(spinInfo, igr)
- IF (Ncrssx.NE.0) THEN
+ IF (calc%Itzero.LE.0 .AND. calc%ILzero.LE.0) RETURN
+ Itz = calc%Itzero
+ ILz = calc%ILzero
+ nent = spinInfo%getNumEntryChannels()
+
+ IF ((calc%ntotc+1).NE.0) THEN
!
- IF (Ifcros(1).NE.0) THEN
+ IF (calc%Ifcros(1)) THEN
! *** Derivative of elastic cross section wrt sqrt(E) via phi
DO Ichan=1,Nent
call spinInfo%getChannelInfo(channelInfo, Ichan)
- call resParData%getChannel(channelI, channelInfo)
- A = Dsf(Ichan)*channelI%getApe()*Zke(Ichan)
- Ddddtl(1) = Ddddtl(1) + A
+ call calc%resData%getChannel(channelI, channelInfo)
+ A = calc%Dsf(Ichan)*channelI%getApe()*calc%Zke(Ichan, Igr)
+ calc%Ddddtl(1) = calc%Ddddtl(1) + A
END DO
END IF
END IF
!
!
- IF (Ifdif.NE.0) THEN
+ IF (calc%needAngular) THEN
!
! *** derivatives of pieces of angular distribution wrt Tzero &
! *** Elzero diagonal pieces, via phi
DO Ichan=1,Nent
call spinInfo%getChannelInfo(channelInfo, Ichan)
- call resParData%getChannel(channelI, channelInfo)
- IF (Itz.GT.0) THEN
- Zz = Etz*channelI%getApe()*Zke(Ichan)
- Derivx(1,Ichan,Ichan,Itz) = Derivx(1,Ichan,Ichan,Itz) + &
- Zz*Dsfx(1,Ichan,Ichan)
- Derivx(2,Ichan,Ichan,Itz) = Derivx(2,Ichan,Ichan,Itz) + &
- Zz*Dsfx(2,Ichan,Ichan)
+ call calc%resData%getChannel(channelI, channelInfo)
+ IF (Itz.GT.0) THEN
+ Zz = Etz*channelI%getApe()*calc%Zke(Ichan, Igr)
+ do ix = 1, 2
+ val = calc%angInternal(Ix,Ichan,Ichan, Igr, Itz)
+ val = val + Zz*calc%Dsfx(Ix,Ichan,Ichan)
+ calc%angInternal(Ix,Ichan,Ichan, Igr, Itz) = val
+ end do
END IF
IF (ILz.GT.0) THEN
- Zz = ELz*channelI%getApe()*Zke(Ichan)
- Derivx(1,Ichan,Ichan,ILz) = Derivx(1,Ichan,Ichan,ILz) + &
- Zz*Dsfx(1,Ichan,Ichan)
- Derivx(2,Ichan,Ichan,ILz) = Derivx(2,Ichan,Ichan,ILz) + &
- Zz*Dsfx(2,Ichan,Ichan)
+ Zz = ELz*channelI%getApe()*calc%Zke(Ichan, Igr)
+ do ix = 1, 2
+ val = calc%angInternal(Ix,Ichan,Ichan, Igr, ILz)
+ val = val + Zz*calc%Dsfx(Ix,Ichan,Ichan)
+ calc%angInternal(Ix,Ichan,Ichan, Igr, ILz) = val
+ end do
END IF
END DO
!
@@ -72,43 +75,27 @@
!x DO Ichan=1,Ntot???????????
DO Ichan=1,Nent
call spinInfo%getChannelInfo(channelInfo, Ichan)
- call resParData%getChannel(channelI, channelInfo)
+ call calc%resData%getChannel(channelI, channelInfo)
DO Jchan=1,Nent
call spinInfo%getChannelInfo(channelInfo, Jchan)
- call resParData%getChannel(channelJ, channelInfo)
+ call calc%resData%getChannel(channelJ, channelInfo)
IF (Jchan.NE.Ichan) THEN
- IF (Itz.GT.0) THEN
- Zz = Etz*channelI%getApe()*Zke(Ichan)
- Derivx(1,Jchan,Ichan,Itz) = &
- Derivx(1,Jchan,Ichan,Itz) + &
- Zz*Dstx(1,Jchan,Ichan)
- Derivx(2,Jchan,Ichan,Itz) = &
- Derivx(2,Jchan,Ichan,Itz) + &
- Zz*Dstx(2,Jchan,Ichan)
- Zz = Etz*channelJ%getApe()*Zke(Jchan)
- Derivx(1,Jchan,Ichan,Itz) = &
- Derivx(1,Jchan,Ichan,Itz) + &
- Zz*Dstx(1,Jchan,Ichan)
- Derivx(2,Jchan,Ichan,Itz) = &
- Derivx(2,Jchan,Ichan,Itz) + &
- Zz*Dstx(2,Jchan,Ichan)
- END IF
- IF (ILz.GT.0) THEN
- Zz = ELz*channelI%getApe()*Zke(Ichan)
- Derivx(1,Jchan,Ichan,ILz) = &
- Derivx(1,Jchan,Ichan,ILz) + &
- Zz*Dstx(1,Jchan,Ichan)
- Derivx(2,Jchan,Ichan,ILz) = &
- Derivx(2,Jchan,Ichan,ILz) + &
- Zz*Dstx(2,Jchan,Ichan)
- Zz = ELz*channelJ%getApe()*Zke(Jchan)
- Derivx(1,Jchan,Ichan,ILz) = &
- Derivx(1,Jchan,Ichan,ILz) + &
- Zz*Dstx(1,Jchan,Ichan)
- Derivx(2,Jchan,Ichan,ILz) = &
- Derivx(2,Jchan,Ichan,ILz) + &
- Zz*Dstx(2,Jchan,Ichan)
- END IF
+ R1 = channelI%getApe()*calc%Zke(Ichan, Igr)
+ R2 = channelJ%getApe()*calc%Zke(Jchan, Igr)
+ do ix = 1, 2
+ IF (Itz.GT.0) THEN
+ val = calc%angInternal(Ix,Jchan,Ichan,Igr, Itz)
+ val = val + Etz*R1 * calc%Dstx(Ix,Jchan,Ichan)
+ val = val + Etz*R2 * calc%Dstx(Ix,Jchan,Ichan)
+ calc%angInternal(Ix,Jchan,Ichan, Igr, Itz) = val
+ end if
+ IF (ILz.GT.0) THEN
+ val = calc%angInternal(Ix,Jchan,Ichan, Igr, ILz)
+ val = val + Elz*R1*calc%Dstx(Ix,Jchan,Ichan)
+ val = val + Elz*R2*calc%Dstx(Ix,Jchan,Ichan)
+ calc%angInternal(Ix,Jchan,Ichan, Igr, ILz) = val
+ end if
+ end do
END IF
END DO
END DO
@@ -122,46 +109,46 @@
!
! --------------------------------------------------------------
!
- SUBROUTINE Dertze (Nent, Next, If_Excl, Ifcros, Zke, &
- Ddddtl, Derivx, Dst, Dstt, Dstx, Nnext, Ntotnn, igr)
+ SUBROUTINE Dertze (spinInfo, calc, Igr)
!
! *** Purpose -- Generate derivatives of cross section wrt sqrt(E) via Rho
! *** Note that [partial Rho wrt sqrt(E)] = true radius (Zke is k without sqrt(E) term)
!
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use varyr_common_m
- use EndfData_common_m
+ use varyr_common_m, only : Elz, Etz
use SammyResonanceInfo_M
use RMatResonanceParam_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ use SammySpinGroupInfo_M
!
!
+ class(XctCrossCalc)::calc
type(SammySpinGroupInfo)::spinInfo
- type(SammyChannelInfo)::channelInfo
+ type(SammyChannelInfo)::channelInfo
type(RMatChannelParams)::channelI, channelJ
- DIMENSION If_Excl(*), Ifcros(*), Zke(*), Ddddtl(*), &
- Derivx(2,Ntotc,Ntotc,*), Dst(2,*), Dstt(Nnext,*), &
- Dstx(2,Ntotc,*)
-!
-!
- IF (Itzero.LE.0 .AND. ILzero.LE.0) RETURN
- Itz = Itzero
- ILz = ILzero
- call resParData%getSpinGroupInfo(spinInfo, igr)
- IF (Ncrssx.NE.0) THEN
-!
- IF (Ifcros(1).NE.0 .OR. Ifcros(2).NE.0) THEN
+ integer::igr
+ integer::Itz, ILz, nent, next, Ntotnn
+ integer::Ichan, Jchan, Jj, Ifc, ix
+ real(kind=8)::Xx, Zz, R1, R2, val
+!
+!
+ IF (calc%Itzero.LE.0 .AND. calc%ILzero.LE.0) RETURN
+ Itz = calc%Itzero
+ ILz = calc%ILzero
+ nent = spinInfo%getNumEntryChannels()
+ Next = spinInfo%getNumExitChannels()
+ Ntotnn = spinInfo%getNumChannels()
+
+ IF (any(calc%Ifcros)) THEN
+!
+ IF (calc%Ifcros(1) .OR. calc%Ifcros(2)) THEN
! *** derivatives of elastic and capture cross section wrt Tzero &
! *** Elzero, via S (shift) & P (penetrability)
DO Ichan=1,Nent
call spinInfo%getChannelInfo(channelInfo, Ichan)
- call resParData%getChannel(channelI, channelInfo)
- Ddddtl(1) = Ddddtl(1) + &
- channelI%getApt()*Zke(Ichan)*Dst(1,Ichan)
- Ddddtl(2) = Ddddtl(2) + &
- channelI%getApt()*Zke(Ichan)*Dst(2,Ichan)
+ call calc%resData%getChannel(channelI, channelInfo)
+ calc%Ddddtl(1) = calc%Ddddtl(1) + &
+ channelI%getApt()*calc%Zke(Ichan,Igr)*calc%Dst(1,Ichan)
+ calc%Ddddtl(2) = calc%Ddddtl(2) + &
+ channelI%getApt()*calc%Zke(Ichan,Igr)*calc%Dst(2,Ichan)
END DO
END IF
!
@@ -170,17 +157,17 @@
! *** wrt Tzero & Elzero via S & P
Ifc = 0
DO Jj=1,Next
- IF (Ifcros(Jj+2).NE.0) Ifc = 1
+ IF (calc%Ifcros(Jj+2)) Ifc = 1
END DO
IF (Ifc.NE.0) THEN
DO Ichan=1,Nent
call spinInfo%getChannelInfo(channelInfo, Ichan)
- call resParData%getChannel(channelI, channelInfo)
- Xx = channelI%getApt()*Zke(Ichan)
+ call calc%resData%getChannel(channelI, channelInfo)
+ Xx = channelI%getApt()*calc%Zke(Ichan, Igr)
DO Jj=1,Next
- IF (Jj+Nent.LE.Ntotnn .AND. Ifcros(Jj+2).NE.0) THEN
- IF (If_Excl(Jj+Nent).EQ.Kaptur) THEN
- Ddddtl(Jj+2) = Ddddtl(Jj+2) + Xx*Dstt(Jj,Ichan)
+ IF ((Jj+Nent).LE.Ntotnn .AND. calc%Ifcros(Jj+2)) THEN
+ IF (calc%useChannel(JJ+2,1)) THEN
+ calc%Ddddtl(Jj+2) = calc%Ddddtl(Jj+2) + Xx*calc%Dstt(Jj,Ichan)
END IF
END IF
END DO
@@ -190,60 +177,51 @@
END IF
!
!
- IF (Ifdif.NE.0) THEN
+ IF (calc%needAngular) THEN
!
! *** derivatives of pieces of angular distribution wrt Tzero &
! *** Elzero via S & P
!x DO Ichan=1,Nent???????
DO Ichan=1,Ntotnn
call spinInfo%getChannelInfo(channelInfo, Ichan)
- call resParData%getChannel(channelI, channelInfo)
+ call calc%resData%getChannel(channelI, channelInfo)
IF (Ichan.LE.Nent) THEN
- IF (Itz.GT.0) THEN
- Zz = Etz*channelI%getApt()*Zke(Ichan)
- Derivx(1,Ichan,Ichan,Itz) = Derivx(1,Ichan,Ichan,Itz)+ &
- Zz*Dstx(1,Ichan,Ichan)
- Derivx(2,Ichan,Ichan,Itz) = Derivx(2,Ichan,Ichan,Itz)+ &
- Zz*Dstx(2,Ichan,Ichan)
- END IF
- IF (ILz.GT.0) THEN
- Zz = Elz*channelI%getApt()*Zke(Ichan)
- Derivx(1,Ichan,Ichan,ILz) = Derivx(1,Ichan,Ichan,ILz)+ &
- Zz*Dstx(1,Ichan,Ichan)
- Derivx(2,Ichan,Ichan,ILz) = Derivx(2,Ichan,Ichan,ILz)+ &
- Zz*Dstx(2,Ichan,Ichan)
- END IF
+ Zz = channelI%getApt()*calc%Zke(Ichan, igr)
+ do ix = 1, 2
+ if (Itz.gt.0) then
+ val = calc%angInternal(Ix,Ichan,Ichan, Igr, Itz)
+ val = val + Zz * Etz * calc%Dstx(Ix,Ichan,Ichan)
+ calc%angInternal(Ix,Ichan,Ichan, Igr, Itz) = val
+ end if
+ if (Ilz.gt.0) then
+ val = calc%angInternal(Ix,Ichan,Ichan, Igr, Ilz)
+ val = val + Zz * Elz * calc%Dstx(Ix,Ichan,Ichan)
+ calc%angInternal(Ix,Ichan,Ichan, Igr, Ilz) = val
+ end if
+ end do
END IF
!X DO Jchan=1,Ichan
DO Jchan=1,Nent
call spinInfo%getChannelInfo(channelInfo, Jchan)
- call resParData%getChannel(channelJ, channelInfo)
+ call calc%resData%getChannel(channelJ, channelInfo)
IF (Jchan.NE.Ichan) THEN
- IF (Itz.GT.0) THEN
- Zz = Etz*channelI%getApt()*Zke(Ichan)
- Derivx(1,Jchan,Ichan,Itz) = Derivx(1,Jchan,Ichan,Itz)+ &
- Zz*Dstx(1,Jchan,Ichan)
- Derivx(2,Jchan,Ichan,Itz) = Derivx(2,Jchan,Ichan,Itz)+ &
- Zz*Dstx(2,Jchan,Ichan)
- Zz = Etz*channelJ%getApt()*Zke(Jchan)
- Derivx(1,Jchan,Ichan,Itz) = Derivx(1,Jchan,Ichan,Itz)+ &
- Zz*Dstx(1,Jchan,Ichan)
- Derivx(2,Jchan,Ichan,Itz) = Derivx(2,Jchan,Ichan,Itz)+ &
- Zz*Dstx(2,Jchan,Ichan)
-! ??? double-counting here?
- END IF
- IF (ILz.GT.0) THEN
- Zz = ELz*channelI%getApt()*Zke(Ichan)
- Derivx(1,Jchan,Ichan,ILz) = Derivx(1,Jchan,Ichan,ILz)+ &
- Zz*Dstx(1,Jchan,Ichan)
- Derivx(2,Jchan,Ichan,ILz) = Derivx(2,Jchan,Ichan,ILz)+ &
- Zz*Dstx(2,Jchan,Ichan)
- Zz = ELz*channelJ%getApt()*Zke(Jchan)
- Derivx(1,Jchan,Ichan,ILz) = Derivx(1,Jchan,Ichan,ILz)+ &
- Zz*Dstx(1,Jchan,Ichan)
- Derivx(2,Jchan,Ichan,ILz) = Derivx(2,Jchan,Ichan,ILz)+ &
- Zz*Dstx(2,Jchan,Ichan)
- END IF
+ R1 = channelI%getApt()*calc%Zke(Ichan, igr)
+ R2 = channelJ%getApt()*calc%Zke(Jchan, igr)
+ do ix = 1, 2
+ IF (Itz.GT.0) THEN
+ val = calc%angInternal(Ix,Jchan,Ichan, Igr, Itz)
+ val = val + Etz * R1 * calc%Dstx(ix,Jchan,Ichan)
+ val = val + Etz * R2 * calc%Dstx(ix,Jchan,Ichan)
+ calc%angInternal(Ix,Jchan,Ichan,Igr, Itz) = val
+ ! ??? double-counting here?
+ end if
+ IF (Ilz.GT.0) THEN
+ val = calc%angInternal(Ix,Jchan,Ichan,Igr, Ilz)
+ val = val + Elz * R1 * calc%Dstx(ix,Jchan,Ichan)
+ val = val + Elz * R2 * calc%Dstx(ix,Jchan,Ichan)
+ calc%angInternal(Ix,Jchan,Ichan, Igr, Ilz) = val
+ end if
+ end do
END IF
END DO
END DO
@@ -255,32 +233,33 @@
!
! --------------------------------------------------------------
!
- SUBROUTINE Derzzz (Crss, Deriv, Ddddtl, Dgoj)
+ SUBROUTINE Derzzz (spinInfo, calc, Igr)
!
! *** Purpose -- calculate the piece of (Derivative of sigma wrt Tzero
! *** & Elzero) * (E/4pi) that comes directly from the 1/E term (1/k**2)
! *** in the formula for cross section
!
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use varyr_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-!
- DIMENSION Crss(*), Deriv(Ncrsss,*), 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_
-! DIMENSION Crss(Ncrsss), Deriv(Ncrsss,Napres)
- DATA Two/2.0d0/
-!
- 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
- IF (Ilz.GT.0) Deriv(I,Ilz) = A*Elz
+ use varyr_common_m, only : Elz, Etz
+ use SammySpinGroupInfo_M
+!
+ class(XctCrossCalc)::calc
+ type(SammySpinGroupInfo)::spinInfo
+ integer::Igr, I
+ real(kind=8)::val, A, Dgoj
+ real(kind=8),parameter:: Two= 2.0d0
+!
+ Dgoj = spinInfo%getGFactor()
+ DO I=1,calc%Ntotc + 1
+ val = calc%crossInternal(I, Igr, 0)
+ A = calc%Ddddtl(I)*Dgoj - val*Two/calc%enerSq
+ IF (calc%Itzero.GT.0) then
+ val = A*Etz + calc%crossInternal(I,Igr, calc%Itzero)
+ calc%crossInternal(I,Igr, calc%Itzero ) = val
+ end if
+ IF (calc%Ilzero.GT.0) then
+ val = A*Elz + calc%crossInternal(I,Igr, calc%Ilzero)
+ calc%crossInternal(I,Igr, calc%Ilzero) = val
+ end if
END DO
!
RETURN
@@ -289,25 +268,29 @@
!
! --------------------------------------------------------------
!
- SUBROUTINE Deriso (Ifzke, Crss, Deriv, AbnVal)
+ SUBROUTINE Deriso (spinInfo, calc, Igr)
!
! *** Purpose -- find derivative of Crss wrt isotopic abundance
!
- use fixedi_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-!
- DIMENSION Crss(*), Deriv(Ncrsss,*)
- ! 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_
-! DIMENSION Crss(Ncrsss), Deriv(Ncrsss,Napres), Ifzke
+ use SammySpinGroupInfo_M
+ IMPLICIT None
!
- IF (Ifzke.LE.0) RETURN
- Ifzk = Ifzke
- DO I=1,Ncrsss
- Deriv(I,Ifzk) = Crss(I)/AbnVal
+ class(XctCrossCalc)::calc
+ type(SammySpinGroupInfo)::spinInfo
+ integer::Igr, iflIso, I
+ real(kind=8)::val, AbnVal
+
+!
+ iflIso = spinInfo%getAbundanceFitFlag()
+ if (iflIso.le.0) RETURN
+
+ AbnVal = spinInfo%getAbundance()
+ DO I=1, calc%Ntotc + 1
+ val = calc%crossInternal(I, Igr, 0)
+ val = val/AbnVal + calc%crossInternal(I, Igr, iflIso)
+ calc%crossInternal(I,Igr, iflIso) = val
END DO
!
RETURN
- END
+ END SUBROUTINE
+end module mxct17_m
diff --git a/sammy/src/xct/mxct18.f90 b/sammy/src/xct/mxct18.f90
index b8f933a19..af30e1cd1 100644
--- a/sammy/src/xct/mxct18.f90
+++ b/sammy/src/xct/mxct18.f90
@@ -1,68 +1,41 @@
module mxct18_m
use XctCrossCalc_M
+!Todo: Remove global parameters
contains
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Zwhich (calc, Sigxxx, Dasigx, Dbsigx, Sigsin, Dasigs, &
- Dbsigs, Theory, Su, Eb, Lllmmm, Kslow)
+ SUBROUTINE Zwhich (calc)
!
! *** Purpose -- Set the particular cross sections needed for this run
!
- use oops_common_m
- use fixedi_m
- use ifwrit_m
- use exploc_common_m
- use templc_common_m
+ use ifwrit_m, only : Kssmsc, Kaverg
+ use exploc_common_m, only : A_Isiabn , &
+ A_Iprdet , I_Ifldet , I_Iigrde , I_Iflmsc , &
+ A_Icmlab , I_Isoqva
use mxct20_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ use mxct19_m
+ IMPLICIT None
class(XctCrossCalc)::calc
- real(kind=8),pointer,dimension(:)::A_Ietax
!
- DIMENSION Sigxxx(Nnnsig,*), Dasigx(Nnnsig,*), &
- Dbsigx(Nnnsig,Ndbxxx,*), Sigsin(*), Dasigs(*), Dbsigs(Ndbxxx,*)
- DATA Zero /0.0d0/
+ real(kind=8),parameter::Zero = 0.0d0
!
- M = Nnniso
- IF (Iq_Val.GT.M) M = Iq_Val
- CALL Zero_Array (Sigxxx, Nnnsig*M)
- IF (Ndasig.GT.0) CALL Zero_Array (Dasigx, Nnnsig*Ndasig)
- IF (Ndbsig.GT.0) CALL Zero_Array (Dbsigx, Nnnsig*Ndbsig*M)
- IF (Ksindi.GT.0) THEN
- CALL Zero_Array (Sigsin, M)
- IF (Ndasig.GT.0) CALL Zero_Array (Dasigs, Ndasig)
- IF (Ndbsig.GT.0) CALL Zero_Array (Dbsigs, Ndbsig*M)
- END IF
-!
- IF (Su.EQ.Zero) RETURN
+ IF (calc%ener.EQ.Zero) RETURN
!
- IF ((Kcros.EQ. 9 .OR. (Kcros.LT.7 .AND. (Kssmsc.EQ.0 .OR. &
+ IF ((calc%reactType.EQ. 9 .OR. (calc%reactType.LT.7 .AND. (Kssmsc.EQ.0 .OR. &
Kssmsc.EQ.-1))) .AND. Kaverg.NE.2) THEN
!
-! *** Here for no scattering of any kind, only one type of cross section
- isize = size(A_Iprmsc)
- A_Ietax => A_Iprmsc(Kjetan:isize)
- if (size(A_Ietax).lt.mjetan) then
- STOP '[STOP in Zwhich in mxct18.f A_Iprmsc is too small ]'
- end if
- CALL Prtclr ( I_Ixciso , &
- I_Iflmsc , A_Ietax , &
- A_Ietaee , Theory, Sigxxx, Dasigx, Dbsigx, &
- A_Icrss , A_Ideriv , A_Itermf, I_Iisopa , Su, Eb)
+! *** Here for no scattering of any kind, only one type of cross section
+ CALL Prtclr (calc)
!
ELSE
! *** Here where there is scattering, self-shielding, angular
! *** distributions, or something involving more than one
! *** type of cross section
CALL Diffel ( calc, A_Isiabn , &
- I_Ifexcl , &
A_Iprdet , I_Ifldet , I_Iigrde , I_Iflmsc , &
- Sigxxx, Dasigx, Dbsigx, Sigsin, Dasigs, Dbsigs, &
- I_Iisopa , A_Icccll, A_Idddll, &
- A_Icrss , A_Ideriv , A_Icrssx , A_Idervx , A_Itermf, &
- A_Iterfx, A_Iechan , A_Icmlab , I_Isoqva , Lllmmm, &
- Su, Eb, Kslow)
+ A_Icmlab , I_Isoqva)
!
END IF
RETURN
diff --git a/sammy/src/xct/mxct19.f90 b/sammy/src/xct/mxct19.f90
index bc43961c5..b8d3fd70a 100644
--- a/sammy/src/xct/mxct19.f90
+++ b/sammy/src/xct/mxct19.f90
@@ -1,244 +1,209 @@
+module mxct19_m
+use XctCrossCalc_M
+IMPLICIT None
+contains
!
!
! ______________________________________________________________________
!
- SUBROUTINE Prtclr (Ixciso, Iflmsc, &
- Etanux, Etaeee, Theory, Sigxxx, Dasigx, Dbsigx, &
- Crss, Deriv, Termf, Isopar, Su, Eb)
+ SUBROUTINE Prtclr (calc)
!
! *** Purpose -- Set Sigxxx(...) = the particular cross sections needed
! *** for this run.
-! *** Also, set the derivatives to Dasigx(Nnnsig,iIipar)
-! *** and Dbsigx(Nnnsig,iIipar,Nnniso).
+! *** Also, set the derivatives
!
! *** Note -- changes made here may also need to be made in sub-routine
! *** INDIVI in mrec3.f
!
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use constn_common_m
- use EndfData_common_m
+ use constn_common_m, only : Fourpi
use SammySpinGroupInfo_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-!
- DIMENSION Ixciso(*), Iflmsc(*), &
- Etanux(*), Etaeee(*), &
- Sigxxx(Nnnsig,*), Dasigx(Nnnsig,*), Dbsigx(Nnnsig,Ndbxxx,*), &
- Isopar(*), Crss(Ncrsss,*), Deriv(Ncrsss,Nnpar,*), &
- Termf(*)
-! DIMENSION
-! * Ixciso(Numiso), Iflmsc(Nummsc), Etanux(Mjetan),
-! * Etaeee(Mjetan), Sigxxx(Nnnsig,Nnniso),
-! * Dasigx(Nnnsig,Ndasig), Dbsigx(Nnnsig,Ndbsig,Nnniso),
-! * Isopar(Nfpall), Crss(Ncrsss,Ngroup), Deriv(Ncrsss,Nnpar,Ngroup)
-!
- DIMENSION A2aaaa(2,2), D2aaaa(2,2)
+!
+ type(XctCrossCalc)::calc
+ real(kind=8)::Su
+ integer::I, Iipar, Iso, K1, K2, N, Nd, Nnn
+ integer::isoN
+ real(kind=8)::Etan, A1, A2, A3, Answer, C, D, Eta
+ real(kind=8)::F, A2d, A2x, Ab, Dtermf, Termff, Terma, val
+
+ real(kind=8)::A2aaaa(2,2), D2aaaa(2,2)
type(SammySpinGroupInfo)::spinInfo
- DATA A2aa31/2.92d0/, A2aa32/0.0d0/, A2aa41/2.48d0/, A2aa42/1.17d0/
+ real(kind=8),parameter:: A2aa31 = 2.92d0, A2aa32= 0.0d0, A2aa41=2.48d0, A2aa42=1.17d0
! *** change per request from Mike Moore, Nov 12, 1996
!
- DATA Zero /0.0d0/
+ real(kind=8),parameter:: Zero=0.0d0
+ logical::haveAny
!
!
- IF (Kcros.EQ.7 .OR. Kcros.EQ.11 .OR. Kcros.EQ.8 .OR. Kcros.LT.0) &
+ IF (calc%reactType.EQ.7 .OR. &
+ calc%reactType.EQ.11 .OR. &
+ calc%reactType.EQ.8 .OR. &
+ calc%reactType.LT.0) then
STOP '[STOP in Prtclr in xct/mxct19.f]'
+ end if
!
Answer = Zero
- Terma = Zero
- Termff = Zero
C = Zero
F = Zero
Eta = Zero
+
+ Su = dAbs(calc%ener)
!
- IF (Kfake.EQ.1) Theory = Zero
- DO 60 Iso=1,Nnniso
- IF (Nnniso.EQ.Numiso .AND. Ixciso(Iso).EQ.1) GO TO 60
- IF (Kcros.NE.6 .AND. Kcros.NE.9 .AND. Su.EQ.Zero) THEN
+ DO 60 Iso=1,calc%numIso
+ IF (calc%reactType.NE.6 .AND. &
+ calc%reactType.NE.9 .AND. &
+ calc%ener.EQ.Zero) THEN
Answer = Zero
GO TO 15
END IF
!
! *** first, set the cross sections:
- Termn = Zero
- Terma = Zero
+ calc%Termf = Zero
Termff = Zero
- IF (Ncrsss.GT.2) THEN
- DO I=3,Ncrsss
- Termf(I-2) = Zero
- END DO
- END IF
!
- DO 10 N=1,resParData%getNumSpinGroups()
- IF (Kcros.EQ.9) THEN
- A2aaaa(N,1) = Crss(3,N)
- A2aaaa(N,2) = Crss(4,N)
+ DO 10 N=1,calc%resData%getNumSpinGroups()
+ IF (calc%reactType.EQ.9) THEN
+ A2aaaa(N,1) = calc%crossInternal(3, N, 0)
+ A2aaaa(N,2) = calc%crossInternal(4, N, 0)
ELSE
- call resParData%getSpinGroupInfo(spinInfo, N)
- isoN = spinInfo%getIsotopeIndex()
- IF (IsoN.EQ.Iso .OR. Nnniso.NE.Numiso) THEN
+ call calc%resData%getSpinGroupInfo(spinInfo, N)
+ isoN = 1
+ if (calc%separateIso) isoN = spinInfo%getIsotopeIndex()
+ IF (isoN.eq.iso) THEN
! *** If we're keeping the Isotopes separate, and this spin
! *** group does not belong to this Isotope, then do not
! *** include this spin group this time thru
Ab = spinInfo%getAbundance()
- Termn = Crss(1,N)*Ab + Termn
- Terma = Crss(2,N)*Ab + Terma
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Termf(I) = Termf(I) + Crss(I+2,N)*Ab
- END DO
- END IF
+ do i = 1, calc%ntotc + 1
+ calc%Termf(I) = calc%Termf(I) + calc%crossInternal(I, N, 0)*Ab
+ end do
END IF
END IF
10 CONTINUE
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Termff = Termff + Termf(I)
- END DO
- END IF
+ DO I=3, calc%ntotc + 1
+ Termff = Termff + calc%Termf(I)
+ END DO
!
! *** total cross section
- IF (Kcros.EQ.1) Answer = Termn + Terma
+ IF (calc%reactType.EQ.1) Answer = calc%Termf(1) + calc%Termf(2)
!
! *** elastic scattering cross section
- IF (Kcros.EQ.2) Answer = Termn
+ IF (calc%reactType.EQ.2) Answer = calc%Termf(1)
!
! *** inelastic scattering cross section, or fission, or reaction
- IF (Kcros.EQ.3 .AND. Kaptur.EQ.0) Answer = Termff
- IF (Kcros.EQ.3 .AND. Kaptur.EQ.1) Answer = Terma - Termff
+! or cross section at position 1, if we calculate eta
+ IF (calc%reactType.EQ.3.or.calc%reactType.EQ.6) then
+ if (.not.calc%addElimKapt) then
+ Answer = Termff
+ else
+ Answer = calc%Termf(2) - Termff
+ end if
+ end if
!
! *** capture cross section
- IF (Kcros.EQ.4) Answer = Terma - Termff
+ IF (calc%reactType.EQ.4) Answer = calc%Termf(2) - Termff
!
! *** absorption cross section
- IF (Kcros.EQ.5) Answer = Terma
!
-! *** eta
- IF (Kcros.EQ.6) THEN
- IF (Mjetan.GT.1) THEN
- Etan = A_Interp (Su, Etanux, Etaeee, Mjetan, A1, A2, K1, &
- K2)
- ELSE
- Etan = Etanuu
- A1 = 1.0d0
- K1 = 1
- K2 = 0
- END IF
- IF (Kefcap.EQ.0) THEN
- A3 = Termff/Terma
- Answer = A3*Etan
- ELSE
- C = (Terma-Termff)*Effcap
- F = Termff*Efffis
- A3 = F/(F+C)
- Answer = A3*Etan
- Eta = Answer
- END IF
- END IF
+ IF (calc%reactType.EQ.5) Answer = calc%Termf(2)
+
+ ! eta: position 1: fission, position 2: absorption
+ if (calc%reactType.EQ.6) then
+ call calc%crossData%addDataNs(calc%row, 2, 0, Iso, calc%Termf(2))
+ end if
+!
!
! *** A2
- IF (Kcros.EQ.9) THEN
+ IF (calc%reactType.EQ.9) THEN
A2 = A2aa31*A2aaaa(1,1) + A2aa32*A2aaaa(1,2) + &
A2aa41*A2aaaa(2,1) + A2aa42*A2aaaa(2,2)
A2x = A2aaaa(1,1)+A2aaaa(1,2)+A2aaaa(2,1)+A2aaaa(2,2)
Answer = A2/A2x
END IF
!
- IF (Kcros.NE.6 .AND. Kcros.NE.9) Answer = Answer*Fourpi/Su
+ IF (calc%reactType.NE.6 .AND. calc%reactType.NE.9) Answer = Answer*Fourpi/Su
!
- IF (Eb.LT.Zero) Answer = - Answer
+ IF (calc%ener.LT.Zero.and.calc%reactType.Ne.6) Answer = - Answer
!
15 CONTINUE
- Sigxxx(1,Iso) = Answer
- IF (Kfake.EQ.1) Theory = Answer + Theory
+ call calc%crossData%addDataNs(calc%row, 1, 0, Iso, Answer)
+
+ Terma = calc%termf(2) ! save absorption cross section
!
!
! *** Now, set the derivatives (if needed)
- IF ( (Ndasig.GT.0 .OR. Ndbsig.GT.0) .AND. &
- (Kcros.EQ.6 .OR. Kcros.EQ.9 .OR. Su.NE.Zero) ) THEN
-!
- DO Iipar=1,Ndasig+Ndbsig
- Iiparn = Iipar - Ndasig
- Dtermn = Zero
- Dterma = Zero
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Termf(I) = Zero
- END DO
- END IF
- DO N=1,resParData%getNumSpinGroups()
- J_Deriv = 0
- DO I=1,Ncrsss
- IF (Deriv(I,Iipar,N).NE.Zero) J_Deriv = 1
- END DO
- IF (J_Deriv.EQ.1) THEN
- IF (Kcros.EQ.9) THEN
- D2aaaa(N,1) = Deriv(3,Iipar,N)
- D2aaaa(N,2) = Deriv(4,Iipar,N)
+
+ IF ( calc%covariance%getNumTotalParam().gt.0 .AND. &
+ (calc%reactType.EQ.6 .OR. calc%reactType.EQ.9 .OR. calc%ener.NE.Zero) ) THEN
+!
+ DO Iipar=1,calc%covariance%getNumTotalParam()
+ if (.not.calc%covariance%contributes(Iipar)) continue
+ calc%termf = Zero
+ DO N=1,calc%resData%getNumSpinGroups()
+ haveAny = .false.
+ do i = 1, calc%ntotc+1
+ if (calc%crossInternal(i, N, Iipar).ne.0.0d0) then
+ haveAny = .true.
+ exit
+ end if
+ end do
+ if (.not.haveAny) cycle
+ IF (calc%reactType.EQ.9) THEN
+ D2aaaa(N,1) = calc%crossInternal(3, N, Iipar)
+ D2aaaa(N,2) = calc%crossInternal(4, N, Iipar)
ELSE
- call resParData%getSpinGroupInfo(spinInfo,N)
- isoN = spinInfo%getIsotopeIndex()
- IF (IsoN.EQ.Iso .OR. Nnniso.NE.Numiso) THEN
+ call calc%resData%getSpinGroupInfo(spinInfo,N)
+ isoN = 1
+ if (calc%separateIso) isoN = spinInfo%getIsotopeIndex()
+ IF (IsoN.EQ.Iso) THEN
! *** If we're keeping the Isotopes separate, and this
! *** spin group does not belong to this Isotope,
! *** then do not include this spin group this time
- Dtermn = Deriv(1,Iipar,N)* &
- spinInfo%getAbundance() + &
- Dtermn
- Dterma = Deriv(2,Iipar,N)* &
+ do i = 1, calc%ntotc+1
+ calc%termf(I) = calc%crossInternal(i, N, Iipar) * &
spinInfo%getAbundance() + &
- Dterma
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Termf(I) = Termf(I) + &
- Deriv(I+2,Iipar,N)* &
- spinInfo%getAbundance()
- END DO
- END IF
+ calc%termf(I)
+ end do
END IF
END IF
- END IF
END DO
Dtermf = Zero
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Dtermf = Dtermf + Termf(I)
- END DO
- END IF
+ DO I=3, calc%ntotc + 1
+ Dtermf = Dtermf + calc%Termf(I)
+ END DO
!
- IF (Dterma.NE.Zero .OR. Dtermn.NE.Zero .OR. &
- Dtermf.NE.Zero .OR. Kcros.EQ.9 ) THEN
+ IF (calc%termf(2).NE.Zero .OR. calc%termf(1).NE.Zero .OR. &
+ Dtermf.NE.Zero .OR. calc%reactType.EQ.9 ) THEN
!
! *** total cross section
- IF (Kcros.EQ.1) Answer = Dtermn + Dterma
+ IF (calc%reactType.EQ.1) Answer = calc%termf(1) + calc%termf(2)
!
! *** elastic scattering cross section
- IF (Kcros.EQ.2) Answer = Dtermn
+ IF (calc%reactType.EQ.2) Answer = calc%termf(1)
!
! *** inelastic scattering or reaction or fission
- IF (Kcros.EQ.3 .AND. Kaptur.EQ.0) Answer=Dtermf
- IF (Kcros.EQ.3 .AND. Kaptur.EQ.3) Answer=Dterma-Dtermf
+! or cross section at position 1, if we calculate eta
+ IF (calc%reactType.EQ.3.or.calc%reactType.EQ.6) then
+ if (.not.calc%addElimKapt) then
+ Answer=Dtermf
+ else
+ Answer=calc%termf(2)-Dtermf
+ end if
+ end if
!
! *** capture cross section
- IF (Kcros.EQ.4) Answer = Dterma - Dtermf
+ IF (calc%reactType.EQ.4) Answer = calc%termf(2) - Dtermf
!
! *** absorption cross section
- IF (Kcros.EQ.5) Answer = Dterma
+ IF (calc%reactType.EQ.5) Answer = calc%termf(2)
+
+ ! eta: position 1: fission, position 2: absorption
+ if (calc%reactType.EQ.6) then
+ call calc%crossData%addDataNs(calc%row, 2, Iipar, Iso, calc%termf(2))
+ end if
!
-! *** eta
- IF (Kcros.EQ.6) THEN
- IF (Kefcap.EQ.0) THEN
- Answer=Etan*(Dtermf-Dterma*Termff/Terma)/Terma
- ELSE
- D = Terma*Effcap + Termff*(Efffis-Effcap)
- Answer = Etan/D * ( Dtermf*Efffis - &
- Termff*Efffis/D* (Dterma*Effcap + &
- Dtermf*(Efffis-Effcap)) )
- END IF
- END IF
!
! *** A2
- IF (Kcros.EQ.9) THEN
+ IF (calc%reactType.EQ.9) THEN
A2 = A2aa31*D2aaaa(1,1) + A2aa32*D2aaaa(1,2) + &
A2aa41*D2aaaa(2,1) + A2aa42*D2aaaa(2,2)
A2x = A2aaaa(1,1) + A2aaaa(1,2) + A2aaaa(2,1) + &
@@ -248,80 +213,19 @@
Answer = (A2-A2d/A2x)/A2x
END IF
!
+
IF (Answer.NE.Zero) THEN
- IF (Kcros.NE.6 .AND. Kcros.NE.9) Answer = &
- Answer*Fourpi/Su
- IF (Eb.LT.Zero) Answer = - Answer
- IF (Iipar.LE.Ndasig) THEN
- IF (Dasigx(1,Iipar).EQ.Zero) THEN
- Dasigx(1,Iipar) = Answer
- Isopar(Iipar) = Iso
- ELSE
- WRITE (6,12345) Iipar, Dasigx(1,Iipar)
-12345 FORMAT ('Dasigx(1,', I3, ')=', 1PG14.6)
- STOP '[STOP in Prtclr in mxct19.f # 2]'
- END IF
- ELSE
- IF (Dbsigx(1,Iiparn,Iso).EQ.Zero) THEN
- Dbsigx(1,Iiparn,Iso) = Answer
- ELSE
- WRITE (6,12346) Iipar, Iso, &
- Dbsigx(1,Iiparn,Iso)
-12346 FORMAT ('Dbsigx(1,',I3,',',I3,')=', 1PG14.6)
- STOP '[STOP in Prtclr in mxct19.f # 3]'
- END IF
- END IF
- ELSE
- IF (Iipar.LE.Ndasig) THEN
- Isopar(Iipar) = Iso
- END IF
+ IF (calc%reactType.NE.6.and.calc%reactType.NE.9) then
+ Answer = Answer*Fourpi/Su
+ end if
+ IF (calc%ener.LT.Zero.and.calc%reactType.ne.6) Answer = - Answer
+ calc%crossSelfWhy(Iipar) = .true.
+ call calc%crossData%addDataNs(calc%row, 1, Iipar, Iso, Answer)
END IF
END IF
END DO
-!
- IF (Kcros.EQ.6) THEN
- IF (Kefcap.NE.0) THEN
- IF (Iflmsc(Kefcap).GT.0) THEN
- 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
- Dbsigx(1,Nd,Iso) = - Eta*(Terma-Termff)/D
- ELSE
- STOP '[STOP in Prtclr in mxct19.f # 5]'
- END IF
- END IF
- IF (Iflmsc(Keffis).GT.0) THEN
- 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
- Dbsigx(1,Nd,Iso) = Eta*C/(D*Efffis)
- ELSE
- STOP '[STOP in Prtclr in mxct19.f # 7]'
- END IF
- END IF
- END IF
- IF (Iflmsc(K1+Kjetan-1).GT.0) THEN
- 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
- ELSE
- STOP '[STOP in Prtclr in mxct19.f # 8.1]'
- END IF
- END IF
- IF (K2.GT.0 .AND. Iflmsc(K2+Kjetan-1).GT.0) THEN
- 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
- ELSE
- STOP '[STOP in Prtclr in mxct19.f # 9.1]'
- END IF
- END IF
- END IF
-!
+
+
END IF
60 CONTINUE
! *** here we're done with choosing proper cross sections et al
@@ -331,40 +235,6 @@
!
! ______________________________________________________________________
!
- Double Precision Function A_Interp (Su, Etanux, Etaeee, Mjetan, &
- A1, A2, Keta1, Keta2)
-!
-! *** Purpose -- Find A_Interp = value of Etanux (nu) at energy Su
-! *** for this run.
-!
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Etanux(*), Etaeee(*)
- IF (Su.LT.Etaeee(1)) THEN
- A_Interp = Etanux(1)
- Keta1 = 1
- Keta2 = 0
- A1 = 1.0d0
- A2 = 0.0d0
- RETURN
- END IF
- DO K=2,Mjetan
- IF (Su.LT.Etaeee(K)) GO TO 10
- END DO
- A_Interp = Etanux(Mjetan)
- Keta1 = Mjetan
- Keta2 = 0
- A1 = 1.0d0
- A2 = 0.0d0
- RETURN
- 10 CONTINUE
- E1 = Etaeee(K-1)
- E2 = Etaeee(K )
- De = E2 - E1
- A1 = (E2-Su)/De
- A2 = (Su-E1)/De
- A = A1*Etanux(K) + A2*Etanux(K-1)
- A_Interp = A
- Keta1 = K - 1
- Keta2 = K
- RETURN
- END
+ ! note: A_Interp moved to ZeroKCrossCorrections_M
+ ! as Eta is calculated there
+end module mxct19_m
diff --git a/sammy/src/xct/mxct20.f90 b/sammy/src/xct/mxct20.f90
index eae5434c2..f85fd5407 100644
--- a/sammy/src/xct/mxct20.f90
+++ b/sammy/src/xct/mxct20.f90
@@ -1,120 +1,140 @@
module mxct20_m
use XctCrossCalc_M
+!Todo: Remove global parameters
contains
!
!
! ______________________________________________________________________
!
- SUBROUTINE Diffel (calc, Siabnd, Jfexcl, &
+ SUBROUTINE Diffel (calc, Siabnd, &
Pardet, Ifldet, Igrdet, Iflmsc, &
- Sigxxx, Dasigx, Dbsigx, Sigsin, Dasigs, Dbsigs, &
- Isopar, Ccclll, Dddlll, Crss , Deriv , Crssx , &
- Derivx, Termf , Termfx, Echan , Cmlab , Iso_Qv, Lllmmm, Su, Eb, &
- Kslow)
+ Cmlab , Iso_Qv)
!
-! *** Purpose -- Set Ccclll(L,Iso or Iq) = coefficient of Legendre
+! *** Purpose -- Set coefficient of Legendre
! *** polynomial P-sub-(L-1) for Isotope Iso [or Q-value Iq]
! *** Also set other cross sections as needed
-! *** Also, set the derivatives to Dddlll(L,.,Iso or Iq)
+! *** Also, set the derivatives
!
- use fixedi_m
- use ifwrit_m
- use lbro_common_m
+ use ifwrit_m, only : Ksindi
use mxct32_m
use mxct31_m
use mxct22_m
use mxct21_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ use mxct23_m
+ IMPLICIT None
!
class(XctCrossCalc)::calc
- DIMENSION Siabnd(*), Jfexcl(Ntotc,*), &
- Pardet(*), Ifldet(*), Igrdet(*), Iflmsc(*), &
- Sigxxx(Nnnsig,*), Dasigx(Nnnsig,*), Dbsigx(Nnnsig,Ndbxxx,*), &
- Sigsin(*), Dasigs(*), Dbsigs(Ndbxxx,*), Isopar(*), &
- Termf(*), Termfx(*), Echan(*), Cmlab(3,*), Iso_Qv(*)
-! Sigxxx(Lllmax+1or2,Nnniso), Dasigx(ditto,Ndasig),
-! Dbsigx(ditto,Ndbsig,Nnniso),
-! Sigsin(Nnniso), Dasigs(Ndasig), Dbsigs(Ndbsig,Nnniso)
+ real(kind=8)::Siabnd(*), Pardet(*)
+ real(kind=8),allocatable::Cmlab(:,:)
+ integer::Ifldet(*), Igrdet(*), Iflmsc(*)
+ integer,allocatable::Iso_Qv(:)
!
- DIMENSION Ccclll(Lllmmm,*), Dddlll(Lllmmm,*)
-! Ccclll(Lllmax,Numiso or Iq_Val), Dddlll(Lllmax,Ndasig)
+ logical(C_BOOL)::accu
+ integer::Iso, L, Iipar
+ real(kind=8)::Eb, val
!
- DIMENSION Crss(Ncrsss,*), Deriv(Ncrsss,Nnpar,*)
- DIMENSION Crssx(2,Ntotc,Ntotc,*), Derivx(2,Ntotc,Ntotc,Nnpar,*)
!
!
!
- IF (Ifdif.NE.0) THEN
+ Eb = calc%ener
+ IF (calc%needAngular) THEN
!
! ****** first, set the Legendre coefficients:
- IF (Kslow.EQ.0) THEN
- CALL Setleg ( calc, Sigxxx, Ccclll, &
- Crssx, Echan, Cmlab, Iso_Qv, Lllmmm, Eb)
+ IF (calc%Kslow.EQ.0) THEN
+ CALL Setleg ( calc, Cmlab, Iso_Qv)
ELSE
- CALL Setleg_Slow (calc, Sigxxx, Ccclll, &
- Crssx, Echan, Cmlab, Iso_Qv, Lllmmm, Eb)
+ CALL Setleg_Slow (calc, Cmlab, Iso_Qv)
END IF
-!
- NNN = 0
- IF (.NOT.Yangle .AND. Kfinit.EQ.0 .AND. Kssmsc.EQ.0) GO TO 20
- IF (Nnnsig.LE.Lllmax .AND. Kfinit.GT.0) THEN
- WRITE (6,10000) Nnnsig, Lllmax
-10000 FORMAT (' Nnnsig =', I4, ' LlLmax =', I4)
- STOP '[STOP in Diffel in mxct20.f # 1]'
- END IF
-!
END IF
!
!
- IF (Ncrssx.NE.0) THEN
+ IF (any(calc%Ifcros)) THen
!
! ****** set the cross sections (non-angle-differential):
! ****** beginning with self-indication transmission
- IF (Ksindi.GT.0 .AND. Kcros.EQ.8) CALL Setsel (calc, Siabnd, &
- Sigsin, Crss, Su, Eb)
+ IF (Ksindi.GT.0 .AND. calc%reactType.EQ.8) then
+ CALL Setsel (calc, Siabnd)
+ end if
!
!
! ****** now do other terms
- CALL Setoth (calc, Pardet, Igrdet, &
- Sigxxx, Crss, Termf, Termfx, Su, Eb)
+ CALL Setoth (calc, Pardet, Igrdet)
END IF
!
20 CONTINUE
!
!
! *** Now, set the derivatives (if needed)
- IF (Ndasig+Ndbsig.LE.0) RETURN
-!
- IF (Ifdif.NE.0) THEN
-! ****** first, derivatives of Legendre coefficients
- IF (Ndasig.GT.0) THEN
- IF (Kslow.EQ.0) THEN
- CALL Derleg ( calc, &
- Sigxxx, Dasigx, Ccclll, Dddlll, Crssx, &
- Derivx, Isopar, Echan, Cmlab, Iso_Qv, Lllmmm, Eb)
+ IF (calc%covariance%getNumTotalParam().LE.0) then
+ IF (calc%needAngular) THEN ! correct angular cross section for 1/Eb
+ accu = .false.
+ call calc%crossData%setAccumulate(accu)
+ DO Iso=1,calc%numIso
+ DO L=1,calc%Lllmax
+ val = calc%crossData%getDataNs(calc%row, L, 0, Iso)
+ if (val.eq.0.0d0) cycle
+ val = val/Eb
+ call calc%crossData%addDataNs(calc%row, L, 0, Iso, val)
+ END DO
+ END DO
+ accu = .true.
+ call calc%crossData%setAccumulate(accu)
+ end if
+ return
+ end if
+!
+ IF (calc%needAngular) THEN
+! ****** first, derivatives of Legendre coefficients
+ IF (calc%hasParams) THEN
+ IF (calc%Kslow.EQ.0) THEN
+ CALL Derleg(calc, Cmlab, Iso_Qv)
ELSE
- CALL Derleg_Slow ( calc, &
- Sigxxx, Dasigx, Ccclll, Dddlll, &
- Crssx, Derivx, Isopar, Echan, Cmlab, Iso_Qv, Lllmmm, &
- Eb)
+ CALL Derleg_Slow(calc, Cmlab, Iso_Qv)
END IF
END IF
- IF (.NOT.Yangle .AND. Kfinit.EQ.0 .AND. Kssmsc.EQ.0) RETURN
+
+ ! correct angular cross section and derivative for 1/Eb
+ accu = .false.
+ call calc%crossData%setAccumulate(accu)
+ DO Iso=1,calc%numIso
+ DO L=1,calc%Lllmax
+ val = calc%crossData%getDataNs(calc%row, L, 0, Iso)
+ if (val.eq.0.0d0) cycle
+ val = val/Eb
+ call calc%crossData%addDataNs(calc%row, L, 0, Iso, val)
+ END DO
+ END DO
+
+ if( calc%hasParams) then
+ accu = .true.
+ call calc%crossData%setNotSetReturnsZero(accu)
+ DO Iipar=1,calc%covariance%getNumTotalParam()
+ DO L=1,calc%Lllmax
+ val = calc%crossData%getSharedValNs(calc%row, L, Iipar)
+ if (val.eq.0.0d0) cycle
+ val = val/Eb
+ call calc%crossData%setSharedValNs(calc%row, L, Iipar, val)
+ END DO
+ END DO
+ accu = .false.
+ call calc%crossData%setNotSetReturnsZero(accu)
+ end if
+
+ accu = .true.
+ call calc%crossData%setAccumulate(accu)
+
END IF
!
- IF (Yangle .AND. Kfinit.LE.0) RETURN
-!
- IF (Ncrssx.NE.0) THEN
+ IF (any(calc%Ifcros)) THEN
!
! ****** Now, the derivatives of the angle-integrated cross sections
! ****** beginning with self-indication transmission
- IF (Ksindi.GT.0 .AND. Kcros.EQ.8) call Dersel (Siabnd, &
- Iflmsc, Dasigs, Dbsigs, Crss, Deriv, Isopar, Su, Eb)
+ IF (Ksindi.GT.0 .AND. calc%reactType.EQ.8) then
+ call Dersel (calc, Siabnd, Iflmsc)
+ end if
!
! ****** Now derivatives of the other cross sections
- CALL Deroth (Pardet, Ifldet, &
- Igrdet, Iflmsc, Dasigx, Dbsigx, &
- Crss, Deriv, Isopar, Termf, Termfx, Su, Eb)
+ CALL Deroth (calc, Pardet, Ifldet, Igrdet, Iflmsc)
!
END IF
40 CONTINUE
diff --git a/sammy/src/xct/mxct21.f90 b/sammy/src/xct/mxct21.f90
index 10cfa6512..0db8e1fc6 100644
--- a/sammy/src/xct/mxct21.f90
+++ b/sammy/src/xct/mxct21.f90
@@ -4,6 +4,8 @@ IMPLICIT NONE
private Jxnnn, Jxmmm
+! Todo: Don't use global parameters Iq_Iso, Iq_Val
+
contains
integer function Jxnnn (Nb,Na,N, Ntotc, Ngroup)
integer Nb,Na,N, Ntotc, Ngroup
@@ -19,27 +21,22 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Setleg (calc, Sigxxx, Ccclll, &
- Crssx, Echan, Cmlab, Iso_Qv, Lllmmm, Eb)
+ SUBROUTINE Setleg (calc, Cmlab, Iso_Qv)
!
-! *** Purpose -- set Ccclll(L,Iso) = coefficient of Legendre polynomial
+! *** Purpose -- set coefficient of Legendre polynomial
! *** P-sub-(L-1) for Isotope Iso
!
- use fixedi_m, only : Nnnsig, Kkxlmn, Ntotc, Iq_Iso, Iq_Val, Lllmax, Nnniso, Numiso
+ use fixedi_m, only : Iq_Iso, Iq_Val
use SammySpinGroupInfo_M
use mdat9_m
!
type(XctCrossCalc)::calc
- real(kind=8):: &
- Sigxxx(Nnnsig,*), Ccclll(Lllmmm,*), &
- Crssx(2,Ntotc,Ntotc,*), Echan(Ntotc,*), Cmlab(3,*)
- integer:: Iso_Qv(*)
+ real(kind=8),allocatable:: Cmlab(:,:)
+ integer,allocatable:: Iso_Qv(:)
type(SammySpinGroupInfo)::spinMgr, spinNgr
real(kind=8),parameter::Zero = 0.0d0
- integer::Lllmmm
- real(kind=8)::Eb
- real(kind=8)::Ai, Ar, Br, C2
+ real(kind=8)::Ai, Ar, Br, C2, val
integer::Iq, Iso, isoMgr, isoNgr, Jx, Jxm, Jxn, Klmn, Kountr
integer::L, Mchan, Mchanx, Mgr, Nchan, Nchanx, Ngr
integer::ngroup
@@ -47,8 +44,7 @@ contains
!
ngroup = calc%resData%getNumSpinGroups()
- CALL Zero_Array (Ccclll, Iq_Iso*Lllmax)
- CALL Findpr (Kkxlmn, Klmn)
+ CALL Findpr (calc%C_G_Kxlmn, Klmn)
!
DO Iq=1,Iq_Iso
IF (Iq_Val.NE.0) THEN
@@ -60,112 +56,104 @@ contains
END IF
DO Ngr=1,calc%resData%getNumSpinGroups()
call calc%resData%getSpinGroupInfo(spinNgr, Ngr)
- IF (spinNgr%getIncludeInCalc()) THEN
- isoNgr = spinNgr%getIsotopeIndex()
- IF (IsoNgr.EQ.Iso .OR. Nnniso.NE.Numiso) THEN
-! *** If we're keeping isotopes separate, and this is the
-! *** wrong isotope, then don't do this one now
- DO Nchan=1,spinNgr%getNumChannels()
- IF ((Iq_Val.NE.0 .AND. Echan(Nchan,Ngr).EQ.C2) .OR. &
- Iq_Val.EQ.0) THEN
- DO Nchanx=1,spinNgr%getNumEntryChannels()
- Ar = Crssx(1,Nchanx,Nchan,Ngr)
- Ai = Crssx(2,Nchanx,Nchan,Ngr)
-! *** Ar & Ai are zero when Nchan is not an
-! *** included channel for the particular
-! *** reaction under consideration
- IF (Ar.NE.Zero .OR. Ai.NE.Zero) THEN
-! --------------------------------------------------------------------
- Jxn = Jxnnn (Nchanx,Nchan,Ngr, Ntotc, Ngroup)
- DO Mgr=1,calc%resData%getNumSpinGroups()
- call calc%resData%getSpinGroupInfo(spinMgr, Mgr)
- IF (spinMgr%getIncludeInCalc()) THEN
- isoMgr = spinMgr%getIsotopeIndex()
- IF (IsoMgr.EQ.Iso .OR. Nnniso.NE.Numiso) THEN
-! *** If we're keeping isotopes separate, and this
-! *** is the wrong isotope, then don't do this one
- DO Mchan=1,spinMgr%getNumChannels()
- IF (Iq_Val.EQ.0 .OR. (Iq_Val.NE.0 .AND. &
- Echan(Mchan,Mgr).EQ.C2)) THEN
+ IF (.not.spinNgr%getIncludeInCalc()) cycle
+ isoNgr = 1
+ if (calc%separateIso) isoNgr = spinNgr%getIsotopeIndex()
+ IF (IsoNgr.ne.Iso) cycle
+ ! *** If we're keeping isotopes separate, and this is the
+ ! *** wrong isotope, then don't do this one now
+ DO Nchan=1,spinNgr%getNumChannels()
+ IF (.not. ((Iq_Val.NE.0 .AND. calc%Echan(Nchan,Ngr).EQ.C2) .OR. &
+ Iq_Val.EQ.0)) cycle
+ DO Nchanx=1,spinNgr%getNumEntryChannels()
+ Ar = calc%angInternal(1,Nchanx,Nchan,Ngr, 0)
+ Ai = calc%angInternal(2,Nchanx,Nchan,Ngr, 0)
+ ! *** Ar & Ai are zero when Nchan is not an
+ ! *** included channel for the particular
+ ! *** reaction under consideration
+ IF (Ar.eq.Zero .and. Ai.eq.Zero) cycle
+ ! --------------------------------------------------------------------
+ Jxn = Jxnnn (Nchanx,Nchan,Ngr, calc%Ntotc, Ngroup)
+ DO Mgr=1,calc%resData%getNumSpinGroups()
+ call calc%resData%getSpinGroupInfo(spinMgr, Mgr)
+ IF (.not.spinMgr%getIncludeInCalc()) cycle
+ isoMgr = 1
+ if (calc%separateIso) isoMgr = spinMgr%getIsotopeIndex()
+ IF (IsoMgr.ne.Iso) cycle
+ ! *** If we're keeping isotopes separate, and this
+ ! *** is the wrong isotope, then don't do this one
+ DO Mchan=1,spinMgr%getNumChannels()
+ IF (.not.(Iq_Val.EQ.0 .OR. (Iq_Val.NE.0 .AND. &
+ calc%Echan(Mchan,Mgr).EQ.C2))) cycle
DO Mchanx=1,spinMgr%getNumEntryChannels()
- Br = Ar*Crssx(1,Mchanx,Mchan,Mgr) + &
- Ai*Crssx(2,Mchanx,Mchan,Mgr)
- IF (Br.NE.Zero) THEN
- Jxm = Jxmmm (Mchanx,Mchan,Mgr,Jxn, Ntotc, Lllmax)
- DO L=1,Lllmax
- Jx = Jxm + L
- CALL Find_Kountr_Jx (calc%Ixlmn(:,1), Kkxlmn, &
- Jx, Kountr, Klmn)
- IF (Kountr.GT.0) THEN
- IF (calc%Xlmn(Kountr).NE.Zero) &
- Ccclll(L,Iq) = Ccclll(L,Iq) + &
- Br*calc%Xlmn(Kountr)
- END IF
- END DO
- END IF
- END DO
- END IF
- END DO
- END IF
- END IF
- END DO
-! --------------------------------------------------------------------
- END IF
- END DO
- END IF
- END DO
- END IF
- END IF
- END DO
- END DO
-!
-! *** note that Xlmn includes Abndnc; ergo so do Ccclll etc
- DO Iso=1,Iq_Iso
- DO L=1,Lllmmm
- Sigxxx(L,Iso) = Ccclll(L,Iso)/Eb
- END DO
- END DO
+ Br = Ar*calc%angInternal(1,Mchanx,Mchan,Mgr, 0) + &
+ Ai*calc%angInternal(2,Mchanx,Mchan,Mgr, 0)
+ IF (Br.eq.Zero) cycle
+ Jxm = Jxmmm (Mchanx,Mchan,Mgr,Jxn, calc%Ntotc, calc%Lllmax)
+ DO L=1,calc%Lllmax
+ Jx = Jxm + L
+ CALL Find_Kountr_Jx (calc%Ixlmn(:,1), calc%C_G_Kxlmn, &
+ Jx, Kountr, Klmn)
+ IF (Kountr.GT.0) THEN
+ IF (calc%Xlmn(Kountr).NE.Zero) then
+ val = Br*calc%Xlmn(Kountr)
+ ! note that Xlmn includes Abndnc; ergo so do calc%crossData% etc
+ ! not corrected for 1/energy yet
+ if (val.ne.0.0d0) then
+ call calc%crossData%addDataNs(calc%row, L, 0, Iq, val)
+ end if
+ end if
+ END IF
+ END DO ! loop over legender order
+ END DO ! inner loop over entry channels (Mgr)
+ END DO ! inner loop over channels (Mgr)
+ END DO ! inner loop over spin groups (Mgr)
+ END DO ! end loop over entry channels (Ngr)
+ END DO ! end loop over channels (Ngr)
+ END DO ! end loop over spin groups (Ngr)
+ END DO ! end loop over calc%numIso
+
RETURN
- END
+ END subroutine
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Setsel (calc, Siabnd, Sigsin, Crss, Su, Eb)
+ SUBROUTINE Setsel (calc, Siabnd)
!
! *** Purpose -- set self-indication transmission if needed
!
- use fixedi_m, only : Ncrsss, Numiso, Numpmc
use constn_common_m, only : Fourpi
use SammySpinGroupInfo_M
- use paramagnetic_cross_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
class(XctCrossCalc)::calc
real(kind=8)::Siabnd(*)
- real(kind=8)::Sigsin(*)
- real(kind=8)::Crss(Ncrsss,*)
- real(kind=8)::Su, Eb
type(SammySpinGroupInfo)::spinInfo
+ real(kind=8)::val
real(kind=8), parameter::Zero=0.0d0
integer::Iso, isoN, N, Nnnnis
!
!
- Nnnnis = Numiso
+ Nnnnis = calc%resData%getNumIso()
IF (Nnnnis.EQ.0) Nnnnis = 1
DO Iso=1,Nnnnis
Sitota = Zero
DO N=1,calc%resData%getNumSpinGroups()
call calc%resData%getSpinGroupInfo(spinInfo, N)
IF (spinInfo%getIncludeInCalc()) THEN
- isoN = spinInfo%getIsotopeIndex()
- IF (Numiso.GT.0 .AND. IsoN.EQ.Iso) THEN
+ isoN = 1
+ if (calc%separateIso) isoN = spinInfo%getIsotopeIndex()
+ IF (IsoN.EQ.Iso) THEN
Ab = Siabnd(N)
- Sitota = Sitota + Ab*(Crss(1,N)+Crss(2,N))
+ val = calc%crossInternal(1, N, 0) + &
+ calc%crossInternal(2, N, 0)
+ Sitota = Sitota + Ab*val
END IF
END IF
END DO
- Sigsin(Iso) = Sigsin(Iso) + Sitota*Fourpi/Eb
+ val = Sitota*Fourpi/calc%ener
+ call calc%crossDataSelf%addDataNs(calc%row, 1, 0, iso, val)
END DO
RETURN
END
@@ -173,116 +161,107 @@ contains
!
! ______________________________________________________________________
!
- SUBROUTINE Setoth ( calc, Pardet, &
- Igrdet, Sigxxx, Crss, Termf, Termfx, Su, Eb)
+ SUBROUTINE Setoth ( calc, Pardet, Igrdet)
!
! *** Purpose -- Set "other" cross sections as needed
!
- use fixedi_m, only : Nnnsig, Ncrsss, Lllmax, Nnniso, Numdet, Numiso, Numpmc
- use ifwrit_m, only : Kaverg, Kssmsc, Nfissl, Ntgrlq, Kcros, Kfinit
- use lbro_common_m, only : Yangle
+ use fixedi_m, only : Numdet
+ use ifwrit_m, only : Nfissl
use constn_common_m, only : Fourpi
use SammySpinGroupInfo_M
use paramagnetic_cross_m
!
class(XctCrossCalc)::calc
- real(kind=8):: Pardet(*), &
- Sigxxx(Nnnsig,*), Crss(Ncrsss,*), Termf(*), Termfx(*)
+ real(kind=8):: Pardet(*)
integer:: Igrdet(*)
type(SammySpinGroupInfo)::spinInfo
real(kind=8),parameter::Zero = 0.0d0
- real(kind=8)::Su, Eb, Val
- real(kind=8)::abnSpin, Terma, Termax, Termff, Termn, Termxx
- integer::I, Iso, Isox, N, Nnn, isoN
+ real(kind=8)::Eb, Total, cross
+ real(kind=8)::abnSpin, Termff, Termxx
+ integer::I, Iso, Isox, N, Nnn, isoN, Nnnsig
!
!
- Nnn = Lllmax + 1
- DO Iso=1,Nnniso
+ Nnn = calc%Lllmax + 1
+ Eb = calc%ener
+ Nnnsig = calc%crossData%getNnnsig()
+ DO Iso=1,calc%numIso
!
- Termn = Zero
- Terma = Zero
- Termax = Zero
Termff = Zero
Termxx = Zero
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Termf(I) = Zero
- Termfx(I) = Zero
- END DO
- END IF
+ calc%termf = Zero
+ calc%termfx = Zero
DO N=1,calc%resData%getNumSpinGroups()
call calc%resData%getSpinGroupInfo(spinInfo, N)
IF (spinInfo%getIncludeInCalc()) THEN
- isoN= spinInfo%getIsotopeIndex()
+ isoN = 1
+ if (calc%separateIso) isoN= spinInfo%getIsotopeIndex()
abnSpin = spinInfo%getAbundance()
- IF (IsoN.EQ.Iso .OR. Nnniso.NE.Numiso) THEN
+ IF (IsoN.EQ.Iso) THEN
! *** If we're keeping spin groups separate, and this is the
! *** wrong spin group, then don't do this One now
- Termn = Crss(1,N)*AbnSpin + Termn
- Terma = Crss(2,N)*AbnSpin + Terma
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Termf(I) = Crss(I+2,N)*AbnSpin + Termf(I)
- END DO
- END IF
+ DO I=1,calc%ntotc+1
+ calc%termf(I) = calc%crossInternal(I, N, 0)*AbnSpin + calc%Termf(I)
+ end do
IF (Numdet.GT.0) THEN
- Termax = Termax + &
- Crss(2,N)*AbnSpin*Pardet(Igrdet(N))
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Termfx(I) = Termfx(I) + &
- Crss(3,N)*AbnSpin*Pardet(Igrdet(N))
- END DO
- END IF
+ do I = 2, calc%ntotc+1
+ calc%termfx(I)= calc%termfx(I) + &
+ calc%crossInternal(I, N, 0)*AbnSpin*Pardet(Igrdet(N))
+ end do
END IF
END IF
END IF
END DO
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Termff = Termff + Termf(I)
- Termxx = Termxx + Termfx(I)
- END DO
- END IF
+ do I = 3, calc%ntotc+1
+ Termff = Termff + calc%termf(I)
+ Termxx = Termxx + calc%termfx(I)
+ end do
!
!
- IF ((Ntgrlq.NE.0 .OR. Kssmsc.NE.0 .OR. Yangle .OR. Kaverg.EQ.2) &
- .AND. (.NOT.Yangle .OR. Kfinit.GT.0) )THEN
!
! *** total cross section
- Sigxxx(Nnn,Iso) = (Termn+Terma)*Fourpi/Eb
+ Total = (calc%termf(1)+calc%termf(2))*Fourpi/Eb
+ cross = Total
Isox = Iso
!
! *** elastic scattering cross section
- IF (Kcros.EQ.2) Sigxxx(Nnnsig,Iso) = Termn*Fourpi/Eb
+ IF (calc%reactType.EQ.2) then
+ cross = calc%termf(1)*Fourpi/Eb
+ end if
!
! *** inelastic scattering cross section, or fission
- IF (Kcros.EQ.3) THEN
+ IF (calc%reactType.EQ.3) THEN
IF (Numdet.EQ.0) THEN
- Sigxxx(Nnnsig,Iso) = Termff*Fourpi/Eb
+ cross = Termff*Fourpi/Eb
ELSE
- Sigxxx(Nnnsig,Iso) = Termxx*Fourpi/Eb
- END IF
+ cross = Termxx*Fourpi/Eb
+ END IF
END IF
!
! *** capture cross section
- IF (Kcros.EQ.4 .OR. Kcros.EQ.8) THEN
+ IF (calc%reactType.EQ.4 .OR. calc%reactType.EQ.8) THEN
IF (Numdet.EQ.0) THEN
- Sigxxx(Nnnsig,Iso) = (Terma-Termff)*Fourpi/Eb
+ cross = (calc%termf(2)-Termff)*Fourpi/Eb
ELSE
- Sigxxx(Nnnsig,Iso) = (Termax-Termxx)*Fourpi/Eb
- END IF
+ cross = (calc%termfx(2)-Termxx)*Fourpi/Eb
+ END IF
END IF
!
-! *** fission cross section for integral quantities
- IF (Kcros.EQ.10 .AND. Nfissl.EQ.1) Sigxxx(Nnn,Iso) = &
- Termff*Fourpi/Eb
+! *** fission cross section for integral quantities
+ IF (calc%reactType.EQ.10 .AND. Nfissl.EQ.1) then
+ total = Termff*Fourpi/Eb
+ end if
!
! *** absorption cross section (maybe for integral quantities)
- IF (Kcros.EQ.5 .OR. Kcros.EQ.10) Sigxxx(Nnnsig,Iso) = &
- Terma*Fourpi/Eb
+ IF (calc%reactType.EQ.5 .OR. calc%reactType.EQ.10) then
+ cross = calc%termf(2)*Fourpi/Eb
+ end if
+
+ if (Nnn.ne.Nnnsig) then
+ call calc%crossData%addDataNs(calc%row, Nnn, 0, Iso, total)
+ end if
+
+ call calc%crossData%addDataNs(calc%row, Nnnsig, 0, Iso, cross)
!
- END IF
END DO
RETURN
END
diff --git a/sammy/src/xct/mxct22.f90 b/sammy/src/xct/mxct22.f90
index 481181436..5320df1bd 100644
--- a/sammy/src/xct/mxct22.f90
+++ b/sammy/src/xct/mxct22.f90
@@ -1,178 +1,168 @@
module mxct22_m
-use XctCrossCalc_M
-implicit none
+ use XctCrossCalc_M
+ implicit none
-private Jxnnn, Jxmmm
+ private Jxnnn, Jxmmm
+
+! Todo: Don't use global parameters Iq_Iso, Iq_Val
contains
- integer function Jxnnn (Nb,Na,N, Ntotc, Ngroup)
- integer Nb,Na,N, Ntotc, Ngroup
+ integer function Jxnnn (Nb,Na,N, Ntotc, Ngroup)
+ integer Nb,Na,N, Ntotc, Ngroup
+
+ Jxnnn = (((N-1)*Ntotc+Na-1)*Ntotc+Nb-1)*Ngroup - 1
+ end function Jxnnn
+ integer function Jxmmm (Mb,Ma,M,J, Ntotc, Lllmax)
+ integer Mb,Ma,M,J, Ntotc, Lllmax
+
+ Jxmmm = (((J+M)*Ntotc+Ma-1)*Ntotc+Mb-1)*Lllmax
+ end function Jxmmm
+
+ ! Note :
+ ! Derleg and Derleg_slow are almost identical
+ ! except for the calls to Jxnnn, Jxmm and
+ ! Find_Kountr_Jx and Find_Kountr_Jx_Slow
+ ! all related to find data in calc%Xlmn
+
- Jxnnn = (((N-1)*Ntotc+Na-1)*Ntotc+Nb-1)*Ngroup - 1
- end function
- integer function Jxmmm (Mb,Ma,M,J, Ntotc, Lllmax)
- integer Mb,Ma,M,J, Ntotc, Lllmax
+ !
+ !
+ ! ______________________________________________________________________
+ !
+ SUBROUTINE Derleg (calc, Cmlab, Iso_Qv)
+ !
+ ! *** Purpose -- Set Derivative of coefficient of
+ ! *** Legendre polynomial P-sub-(L-1) for Isotope Iso
+ ! ***
+ ! *** Note -- Enter this routine only if we want derivatives
+ !
+ use fixedi_m, only : Iq_Iso, Iq_Val
+ use SammySpinGroupInfo_M
+ use SammyIsoInfo_M
+ use mdat9_m
+ use mxct21_m
+ !
+ class(XctCrossCalc)::calc
+ real(kind=8),allocatable:: Cmlab(:,:)
+ integer,allocatable:: Iso_Qv(:)
+ type(SammySpinGroupInfo)::spinMgr, spinNgr
+ type(SammyIsoInfo)::isoInfo
+ real(kind=8),parameter:: Zero = 0.0d0
+ real(kind=8)::val
+ real(kind=8)::Ai, Ar, Bi, Br, C2, Dai, Dar, Dbi, Dbr, Dr
+ integer::Ifl, Iipar, Iq, Iso, IsoMgr, isoNgr, Jx, Jxm, Jxn
+ integer::Klmn, Kountr, Mchan, Mchanx, Mgr, Nchan, Nchanx
+ integer::Ngr, L
+ integer::ngroup
+ !
+ ngroup = calc%resData%getNumSpinGroups()
+ CALL Findpr (calc%C_G_Kxlmn, Klmn)
+ !
+ DO Iq=1,Iq_Iso
+ IF (Iq_Val.NE.0) THEN
+ Iso = Iso_Qv(Iq)
+ C2 = Cmlab(2,Iq)
+ ELSE
+ Iso = Iq
+ C2 = Zero
+ END IF
+ DO Ngr=1,calc%resData%getNumSpinGroups()
+ call calc%resData%getSpinGroupInfo( spinNgr, Ngr)
+ IF (.not.spinNgr%getIncludeInCalc()) cycle
+ isoNgr = 1
+ if (calc%separateIso) isoNgr = spinNgr%getIsotopeIndex()
+ IF (isoNgr.ne.Iso) cycle
+ ! *** If we're keeping spin groups separate, and this is the
+ ! *** wrong spin group, then don't do this one now
+ DO Nchan=1,spinNgr%getNumChannels()
+ IF (.not.((Iq_Val.NE.0 .AND. calc%Echan(Nchan,Ngr).EQ.C2) .OR. &
+ Iq_Val.EQ.0)) cycle
+ DO Nchanx=1,spinNgr%getNumEntryChannels()
+ Ar = calc%angInternal(1,Nchanx,Nchan,Ngr, 0)
+ Ai = calc%angInternal(2,Nchanx,Nchan,Ngr, 0)
+ IF (Ar.eq.Zero .and. Ai.eq.Zero) cycle
+ Jxn = Jxnnn (Nchanx,Nchan,Ngr, calc%Ntotc, Ngroup)
+ DO Mgr=1,calc%resData%getNumSpinGroups()
+ call calc%resData%getSpinGroupInfo( spinMgr, Mgr)
+ IF (.not.spinMgr%getIncludeInCalc()) cycle
+ isoMgr = 1
+ if (calc%separateIso) isoMgr = spinMgr%getIsotopeIndex()
+ IF (IsoMgr.ne.Iso) cycle
+ ! *** If we're keeping spin groups separate, and this is the wrong
+ ! *** spin group, then don't do this one
+ DO Mchan=1,spinMgr%getNumChannels()
+ IF (.not.(Iq_Val.EQ.0 .OR. (Iq_Val.NE.0 .AND. &
+ calc%Echan(Mchan,Mgr).EQ.C2))) cycle
+ DO Mchanx=1,spinMgr%getNumEntryChannels()
+ Br = calc%angInternal(1,Mchanx,Mchan,Mgr, 0)
+ Bi = calc%angInternal(2,Mchanx,Mchan,Mgr, 0)
+ Jxm = Jxmmm (Mchanx,Mchan,Mgr,Jxn, calc%Ntotc, calc%Lllmax)
+ DO Iipar=1,calc%covariance%getNumTotalParam()
+ Dar = calc%angInternal(1,Nchanx,Nchan,Ngr, Iipar)
+ Dai = calc%angInternal(2,Nchanx,Nchan,Ngr, Iipar)
+ IF (Dar.NE.Zero .OR. Dai.NE.Zero) THEN
+ calc%crossSelfWhy(Iipar) = .true.
+ Dr = Br*Dar + Bi*Dai
+ ELSE
+ Dr = Zero
+ END IF
+ Dbr = calc%angInternal(1,Mchanx,Mchan,Mgr, Iipar)
+ Dbi = calc%angInternal(2,Mchanx,Mchan,Mgr, Iipar)
+ IF (Dbr.NE.Zero .OR. Dbi.NE.Zero) THEN
+ calc%crossSelfWhy(Iipar) = .true.
+ Dr = Ar*Dbr + Ai*Dbi + Dr
+ END IF
+ IF (Dr.eq.Zero) cycle
+ DO L=1,calc%Lllmax
+ Jx = Jxm + L
+ CALL Find_Kountr_Jx (calc%Ixlmn(:,1), calc%C_G_Kxlmn, Jx, &
+ Kountr, Klmn)
+ IF (Kountr.GT.0) THEN
+ IF (calc%Xlmn(Kountr).NE.Zero) THEN
+ val = Dr*calc%Xlmn(Kountr)
+ if (val.ne.0.0d0) then
+ call calc%crossData%setSharedValNs(calc%row, L, Iipar, val)
+ end if
+ END IF
+ END IF
+ END DO ! loop over legender order
+ END DO ! loop over parameters
+ END DO ! inner loop over entry channels (Mgr)
+ END DO ! inner loop over channels (Mgr)
+ END DO ! inner loop over spin groups (Mgr)
+ END DO ! end loop over entry channels (Ngr)
+ END DO ! end loop over channels (Ngr)
+ END DO ! end loop over spin groups (Ngr)
+ END DO ! end loop over calc%numIso
- Jxmmm = (((J+M)*Ntotc+Ma-1)*Ntotc+Mb-1)*Lllmax
- end function
+ !
+ ! *** find derivative of Crss wrt isotopic Abundance
+ ! Always calculate
+ ! ##################### maybe NOT CORRECT YET FOR Iq_Val>0
+ !
+ ! DAW todo: This still does not seem correct for
+ ! if number of real isotopes > 1
+ DO Iq=1, calc%numIso
+ IF (Iq_Val.NE.0) THEN
+ Iso = Iso_Qv(Iq)
+ ELSE
+ Iso = Iq
+ END IF
+ call calc%resData%getIsoInfo(isoInfo, Iso)
+ Ifl = isoInfo%getFitOption()
+ IF (Ifl.GT.0) THEN
+ calc%crossSelfWhy(Ifl) = .true.
+ DO L=1,calc%Lllmax
+ val = calc%crossData%getDataNs(calc%row, L, 0, Iq)
+ if (val.eq.0.0d0) cycle
+ val = val/calc%resData%getAbundanceByIsotope(Iso)
+ call calc%crossData%setSharedValNs(calc%row, L, Ifl, val)
+ END DO
+ END IF
+ END DO
-!
-!
-! ______________________________________________________________________
-!
- SUBROUTINE Derleg (calc, &
- Sigxxx, Dasigx, Ccclll, Dddlll, Crssx, &
- Derivx, Isopar, Echan, Cmlab, Iso_Qv, Lllmmm, Eb)
-!
-! *** Purpose -- Set Dddlll(L,.,Iso) = Derivative of coefficient of
-! *** Legendre polynomial P-sub-(L-1) for Isotope Iso
-! ***
-! *** Note -- Enter this routine only if Ndasig > 0
-!
- use fixedi_m, only : Nnnsig, Kkxlmn, Ntotc, Iq_Iso, Iq_Val, Lllmax, Ndasig, &
- Nfpiso, Nnniso, Numiso
- use ifwrit_m, only : Nnpar
- use SammySpinGroupInfo_M
- use SammyIsoInfo_M
- use mdat9_m
- use mxct21_m
-!
- class(XctCrossCalc)::calc
- integer::Lllmmm
- real(kind=8)::Eb
- real(kind=8):: &
- Sigxxx(Nnnsig,*), &
- Dasigx(Nnnsig,*), Ccclll(Lllmmm,*), Dddlll(Lllmmm,*), &
- Crssx(2,Ntotc,Ntotc,*), &
- Derivx(2,Ntotc,Ntotc,Nnpar,*), &
- Echan(Ntotc,*), Cmlab(3,*)
- integer:: Isopar(*), Iso_Qv(*)
- type(SammySpinGroupInfo)::spinMgr, spinNgr
- type(SammyIsoInfo)::isoInfo
- real(kind=8),parameter:: Zero = 0.0d0
- real(kind=8)::val
- real(kind=8)::Ai, Ar, Bi, Br, C2, Dai, Dar, Dbi, Dbr, Dr
- integer::Ifl, Iipar, Iq, Iso, IsoMgr, isoNgr, Jx, Jxm, Jxn
- integer::Klmn, Kountr, Mchan, Mchanx, Mgr, Nchan, Nchanx
- integer::Ngr, L
- integer::ngroup
-!
- ngroup = calc%resData%getNumSpinGroups()
- CALL Zero_Array (Dddlll, Lllmmm*Ndasig)
- CALL Findpr (Kkxlmn, Klmn)
-!
- DO Iq=1,Iq_Iso
- IF (Iq_Val.NE.0) THEN
- Iso = Iso_Qv(Iq)
- C2 = Cmlab(2,Iq)
- ELSE
- Iso = Iq
- C2 = Zero
- END IF
- DO Ngr=1,calc%resData%getNumSpinGroups()
- call calc%resData%getSpinGroupInfo( spinNgr, Ngr)
- IF (spinNgr%getIncludeInCalc()) THEN
- isoNgr = spinNgr%getIsotopeIndex()
- IF (Numiso.LE.0 .OR. isoNgr.EQ.Iso .OR. &
- Nnniso.NE.Numiso) THEN
-! *** If we're keeping spin groups separate, and this is the
-! *** wrong spin group, then don't do this one now
- DO Nchan=1,spinNgr%getNumChannels()
- IF ((Iq_Val.NE.0 .AND. Echan(Nchan,Ngr).EQ.C2) .OR. &
- Iq_Val.EQ.0) THEN
- DO Nchanx=1,spinNgr%getNumEntryChannels()
- Ar = Crssx(1,Nchanx,Nchan,Ngr)
- Ai = Crssx(2,Nchanx,Nchan,Ngr)
- IF (Ar.NE.Zero .OR. Ai.NE.Zero) THEN
-! ----------------------------------------------------------
- Jxn = Jxnnn (Nchanx,Nchan,Ngr, Ntotc, Ngroup)
- DO Mgr=1,calc%resData%getNumSpinGroups()
- call calc%resData%getSpinGroupInfo( spinMgr, Mgr)
- IF (spinMgr%getIncludeInCalc()) THEN
- isoMgr = spinMgr%getIsotopeIndex()
- IF (Numiso.LE.0 .OR. IsoMgr.EQ.Iso .OR. &
- Nnniso.NE.Numiso) THEN
-! *** If we're keeping spin groups separate, and this is the wrong
-! *** spin group, then don't do this one
- DO Mchan=1,spinMgr%getNumChannels()
- IF (Iq_Val.EQ.0 .OR. (Iq_Val.NE.0 .AND. &
- Echan(Mchan,Mgr).EQ.C2)) THEN
- DO Mchanx=1,spinMgr%getNumEntryChannels()
- Br = Crssx(1,Mchanx,Mchan,Mgr)
- Bi = Crssx(2,Mchanx,Mchan,Mgr)
- Jxm = Jxmmm (Mchanx,Mchan,Mgr,Jxn, Ntotc, Lllmax)
-! ----------------------------------------------------------
- DO Iipar=1,Ndasig
- Dar = Derivx(1,Nchanx,Nchan,Iipar,Ngr)
- Dai = Derivx(2,Nchanx,Nchan,Iipar,Ngr)
- IF (Dar.NE.Zero .OR. Dai.NE.Zero) THEN
- IF (Isopar(Iipar).EQ.0) Isopar(Iipar) = Iso
- Dr = Br*Dar + Bi*Dai
- ELSE
- Dr = Zero
- END IF
- Dbr = Derivx(1,Mchanx,Mchan,Iipar,Mgr)
- Dbi = Derivx(2,Mchanx,Mchan,Iipar,Mgr)
- IF (Dbr.NE.Zero .OR. Dbi.NE.Zero) THEN
- IF (Isopar(Iipar).EQ.0) Isopar(Iipar) = Iso
- Dr = Ar*Dbr + Ai*Dbi + Dr
- END IF
- IF (Dr.NE.Zero) THEN
- DO L=1,Lllmax
- Jx = Jxm + L
- CALL Find_Kountr_Jx (calc%Ixlmn(:,1), Kkxlmn, Jx, &
- Kountr, Klmn)
- IF (Kountr.GT.0) THEN
- IF (calc%Xlmn(Kountr).NE.Zero) THEN
- Dddlll(L,Iipar) = &
- Dddlll(L,Iipar) + Dr*calc%Xlmn(Kountr)
- END IF
- END IF
- END DO
- END IF
- END DO
-! ----------------------------------------------------------
- END DO
- END IF
- END DO
- END IF
- END IF
- END DO
-! ----------------------------------------------------------
- END IF
- END DO
- END IF
- END DO
- END IF
- END IF
- END DO
- END DO
-!
-! *** find derivative of Crss wrt isotopic Abundance
-! ##################### maybe NOT CORRECT YET FOR Iq_Val>0
- IF (Nfpiso.GT.0) THEN
- DO Iso=1,Numiso
- call calc%resData%getIsoInfo(isoInfo, Iso)
- Ifl = isoInfo%getFitOption()
- IF (Ifl.GT.0) THEN
- Ifl = Ifl
- Isopar(Ifl) = Iso
- DO L=1,Lllmax
- Dddlll(L,Ifl) = Ccclll(L,Iso)/ &
- calc%resData%getAbundanceByIsotope(Iso)
- END DO
- END IF
- END DO
- END IF
-!
- IF (Ndasig.GT.0) THEN
- DO Iipar=1,Ndasig
- DO L=1,Lllmax
- Dasigx(L,Iipar) = Dddlll(L,Iipar)/Eb
- END DO
- END DO
- END IF
- RETURN
- END
+ !
+ RETURN
+ END subroutine Derleg
end module mxct22_m
diff --git a/sammy/src/xct/mxct23.f90 b/sammy/src/xct/mxct23.f90
index 6dfca2191..c7c1480b5 100644
--- a/sammy/src/xct/mxct23.f90
+++ b/sammy/src/xct/mxct23.f90
@@ -1,48 +1,51 @@
+module mxct23_m
+use XctCrossCalc_M
+implicit none
+! Note: To do: don't use the global parameter Ksindi, Numdet or Nfissl
+contains
!
!
! ______________________________________________________________________
!
- SUBROUTINE Dersel (Siabnd,Iflmsc, &
- Dasigs, Dbsigs, Crss, Deriv, Isopar, &
- Su, Eb)
+ SUBROUTINE Dersel (calc, Siabnd,Iflmsc)
!
! *** purpose -- set derivatives of transmission sample total cross
! *** section for self-indication experiments
!
- use fixedi_m
- use ifwrit_m
- use lbro_common_m
- use constn_common_m
- use EndfData_common_m
+ use ifwrit_m, only : Ksindi
+ use constn_common_m, only : Fourpi
use SammySpinGroupInfo_M
use SammyIsoInfo_M
- use paramagnetic_cross_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
- DIMENSION Siabnd(*), &
- Iflmsc(*), Dasigs(*), &
- Dbsigs(Ndbxxx,*), Crss(Ncrsss,*), Deriv(Ncrsss,Nnpar,*), &
- Isopar(*)
+ type(XctCrossCalc)::calc
+ real(kind=8):: Siabnd(*)
+ integer:: Iflmsc(*)
type(SammySpinGroupInfo)::spinInfo
type(SammyIsoInfo)::isoInfo
- DATA Zero /0.0d0/
+ real(kind=8)::val
+ real(kind=8),parameter::Zero=0.0d0
+ integer::Iipar, Iipars, Ik, Iso, IsoN, Lk, N, isoOur
!
- IF (Numiso.NE.0) THEN
+ IF (calc%resData%getNumIso().ne.0) THEN
!
! *** beginning with self-indication transmission
Ik = Ksindi - 1
- DO Iso=1,Numiso
+ DO Iso=1,calc%numIso
Ik = Ik + 1
Iipars = Iflmsc(ik)
IF (Iipars.GT.0) THEN
- Ipars = Iipars - Ndasig
- DO N=1,Ngroup
- call resParData%getSpinGroupInfo(spinInfo, N)
+ DO N=1,calc%resData%getNumSpinGroups()
+ call calc%resData%getSpinGroupInfo(spinInfo, N)
IF (spinInfo%getIncludeInCalc()) THEN
- isoN = spinInfo%getIsotopeIndex()
+ isoN = 1
+ if (calc%separateIso) isoN = spinInfo%getIsotopeIndex()
IF (isoN.EQ.Iso) THEN
- Dbsigs(Ipars,Iso) = Dbsigs(Ipars,Iso) + &
- Crss(1,n) + Crss(2,n)
+ val = calc%crossInternal(1, N, 0) + &
+ calc%crossInternal(2, N, 0)
+ val = val * Fourpi/calc%ener
+ if (val.ne.0.0d0) then
+ call calc%crossDataSelf%addDataNs(calc%row, 1, Iipars, iso, val)
+ end if
! *** This is Derivative wrt Abundance
END IF
END IF
@@ -53,55 +56,33 @@
!
! *** si2 now do derivatives wrt resonance parameters et al
Ik = Ksindi - 1
- DO Iso=1,Nnniso
+ DO Iso=1,calc%numIso
Ik = Ik + 1
- Iipars = Iflmsc(ik)
- Ipars = 0
- IF (Iipars.GT.0) Ipars = Iipars - Ndasig
- call resParData%getIsoInfo(isoInfo, Iso)
+ Iipars = Iflmsc(ik)
+ call calc%resData%getIsoInfo(isoInfo, Iso)
Lk = isoInfo%getFitOption()
- DO N=1,Ngroup
- call resParData%getSpinGroupInfo(spinInfo, N)
+ DO N=1,calc%resData%getNumSpinGroups()
+ call calc%resData%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.NE.Iipar) THEN
+ IF (isoN.EQ.Iso) THEN
+ DO Iipar=1,calc%covariance%getNumTotalParam()
+ IF (Lk.NE.Iipar) THEN ! if abundance is not varied (lk <= 0), it can't be equal to Iipar
! *** If this parameter is an abundance for the capture
! *** sample, then derivatives here are zero
- Dasigs(Iipar) = Dasigs(Iipar) + &
- Siabnd(n) * ( Deriv(1,Iipar,N)+Deriv(2,Iipar,N) )
- END IF
- END DO
- END IF
- IF (Ndbsig.GT.0) THEN
- DO Iipar=1,Ndbsig
- IF (Ipars.NE.Iipar) THEN
-! *** IF (this is self-indication Abndnc) it's already done
- IF (Lk.LE.0 .OR. Lk.NE.Iipar) THEN
-! *** If this parameter is an abundance for the capture
-! *** sample, then derivatives here are zero
- Dbsigs(Iipar,Iso) = Dbsigs(Iipar,Iso) + &
- Siabnd(N) * ( Deriv(1,Iipar+Ndasig,N) + &
- Deriv(2,Iipar+Ndasig,N) )
- END IF
+ val = calc%crossInternal(1, N, Iipar) + &
+ calc%crossInternal(2, N, Iipar)
+ val = Siabnd(n) * val
+ if (calc%crossSelfWhy(Iipar)) then
+ ! reproduce a SAMMY bug for self-indication experiments. To Do fix the bug insteadq
+ val = val * Fourpi/calc%ener
+ end if
+ if (val.ne.0.0d0) then
+ call calc%crossDataSelf%addDataNs(calc%row, 1, Iipar, iso, val)
+ end if
END IF
END DO
END IF
END DO
- IF (Ndasig.GT.0) THEN
- DO Iipar=1,Ndasig
- IF (Isopar(Iipar).EQ.Iso) THEN
- IF (Dasigs(Iipar).NE.Zero) Dasigs(Iipar) = &
- Dasigs(Iipar)*Fourpi/Eb
- END IF
- END DO
- END IF
- IF (Ndbsig.GT.0) THEN
- DO Iipar=1,Ndbsig
- IF (Dbsigs(Iipar,Iso).NE.Zero) Dbsigs(Iipar,Iso) = &
- Dbsigs(Iipar,Iso)*Fourpi/Eb
- END DO
- END IF
END DO
!
RETURN
@@ -110,63 +91,54 @@
!
! ______________________________________________________________________
!
- SUBROUTINE Deroth ( Pardet, Ifldet, &
- Igrdet, Iflmsc, Dasigx, Dbsigx, Crss, &
- Deriv, Isopar, Termf, Termfx, Su, Eb)
+ SUBROUTINE Deroth ( calc, Pardet, Ifldet, Igrdet, Iflmsc)
!
! *** Purpose -- Set derivatives of "other" cross sections
! (non-angular-dependent)
!
- use fixedi_m
- use ifwrit_m
- use lbro_common_m
- use constn_common_m
- use EndfData_common_m
+ use fixedi_m, only : Numdet
+ use ifwrit_m, only : Ksindi, Nfissl
+ use constn_common_m, only : Fourpi
use SammySpinGroupInfo_M
- use paramagnetic_cross_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
- DIMENSION Iflmsc(*), Pardet(*), Ifldet(*), &
- Igrdet(*), Dasigx(Nnnsig,*), Dbsigx(Nnnsig,Nnpar,*), &
- Crss(Ncrsss,*), Deriv(Ncrsss,Nnpar,*), Isopar(*), Termf(*), &
- Termfx(*)
+ type(XctCrossCalc)::calc
+ real(kind=8):: Pardet(*)
+ integer:: Iflmsc(*), Ifldet(*), Igrdet(*)
type(SammySpinGroupInfo)::spinInfo
- DATA Zero /0.0d0/
-!
-!
- Nnnnis = Numiso
- IF (Nnnnis.EQ.0) Nnnnis = 1
- Nnn = Lllmax + 1
- DO 90 Iso=1,Nnniso
- Ix = 0
- DO 80 Iipar=1,Nnpar
-!
- IF (Ksindi.GT.0 .AND. Kcros.EQ.8) THEN
+ real(kind=8)::Eb
+ real(kind=8)::Ab, Dterfx, Dtermf, Total, cross
+ integer::I,Ifl, Igrd, Iipar, Iiparn, Iso, isoN, Isox
+ integer::Ix, Lk, Lkk, N, Nnn, Nnnnis, Nnnsig
+ real(kind=8),parameter::Zero=0.0d0
+!
+!
+ Nnnnis = calc%resData%getNumIso()
+ Nnn = calc%Lllmax + 1
+ Nnnsig = calc%crossData%getNnnsig()
+ Eb = calc%ener
+ DO Iso=1,calc%numIso
+ Ix = 0
+ DO Iipar=1,calc%covariance%getNumTotalParam()
+!
+ IF (Ksindi.GT.0 .AND. calc%reactType.EQ.8) THEN
Lkk = Ksindi - 1
DO Isox=1,Nnnnis
Lkk = Lkk + 1
Lk = Iflmsc(lkk)
- IF (Lk.GT.0 .AND. Lk.EQ.Iipar) GO TO 80
+ IF (Lk.GT.0 .AND. Lk.EQ.Iipar) cycle
END DO
END IF
!
- Dtermn = Zero
- Dterma = Zero
- Dterax = Zero
+ calc%Termf = Zero
+ calc%Termfx = Zero
Dtermf = Zero
- Dterfx = Zero
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Termf(I) = Zero
- Termfx(I) = Zero
- END DO
- END IF
- DO N=1,Ngroup
- call resParData%getSpinGroupInfo(spinInfo, N)
- IF (spinInfo%getIncludeInCalc()) THEN
- isoN = spinInfo%getIsotopeIndex()
- IF (Numiso.LE.0 .OR. isoN.EQ.Iso .OR. &
- Nnniso.NE.Numiso) THEN
+ Dterfx = Zero
+ DO N=1,calc%resData%getNumSpinGroups()
+ call calc%resData%getSpinGroupInfo(spinInfo, N)
+ IF (spinInfo%getIncludeInCalc()) THEN
+ isoN = 1
+ if( calc%separateIso) isoN = spinInfo%getIsotopeIndex()
+ IF (isoN.EQ.Iso) THEN
! *** If we're keeping spin groups separate, and this is
! *** the wrong spin group, then don't do this one now
Ab = spinInfo%getAbundance()
@@ -174,138 +146,91 @@
Igrd = Igrdet(N)
Ifl = Ifldet(Igrd)
IF (Ifl.EQ.Iipar) THEN
- Dterax = Dterax + Crss(2,N)*ab
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Termfx(I) = Termfx(I) + Crss(I+2,N)*Ab
- END DO
- END IF
+ Do I = 2, calc%ntotc+1
+ calc%termfx(I) = calc%Termfx(I) + &
+ calc%crossInternal(I, N, 0)*Ab
+ end do
ELSE
- Dterax = Dterax + &
- Deriv(2,Iipar,N)*Ab*Pardet(Igrdet(N))
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Termfx(I) = Termfx(I) + Ab * &
- Deriv(I+2,Iipar,N)*Pardet(Igrdet(N))
- END DO
- END IF
+ Do I = 2, calc%ntotc+1
+ calc%termfx(I) = calc%termfx(I) + &
+ calc%crossInternal(I, N, Iipar)*Ab*Pardet(Igrdet(N))
+ end do
END IF
ELSE
- Dtermn = Deriv(1,Iipar,N)*Ab + Dtermn
- Dterma = Deriv(2,Iipar,N)*Ab + Dterma
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Termf(I) = Termf(I) +Deriv(I+2,Iipar,N)*Ab
- END DO
- END IF
+ do I = 1, calc%ntotc+1
+ calc%termf(I) = calc%termf(I) + &
+ calc%crossInternal(I, N, Iipar)*Ab
+ end do
END IF
END IF
END IF
END DO
- IF (Ncrsss.GE.3) THEN
- DO I=1,Ncrsss-2
- Dtermf = Dtermf + Termf(I)
- Dterfx = Dterfx + Termfx(I)
- END DO
- END IF
-!
- IF (Dtermn.NE.Zero .OR. Dterma.NE.Zero .OR. Dterax.NE.Zero &
- .OR. Dtermf.NE.Zero .OR. Dterfx.NE.Zero) THEN
- IF (Iipar.LE.Ndasig) THEN
- IF (Isopar(Iipar).EQ.0 .OR. Isopar(Iipar).EQ.Iso) THEN
- Isopar(Iipar) = Iso
- END IF
- END IF
+ Do I = 3, calc%ntotc+1
+ Dtermf = Dtermf + calc%termf(I)
+ Dterfx = Dterfx + calc%Termfx(I)
+ end do
+
+!
+ IF (calc%termf(1).NE.Zero .OR. calc%termf(2).NE.Zero .OR. calc%termfx(2).NE.Zero &
+ .OR. Dtermf.NE.Zero .OR. Dterfx.NE.Zero) THEN
+ calc%crossSelfWhy(Iipar) = .true.
ELSE
- GO TO 80
+ cycle
END IF
!
!
- Iiparn = Iipar - Ndasig
! *** total cross section
IF (Nnn.GT.0) THEN
- IF (Iipar.LE.Ndasig) THEN
- IF (Isopar(Iipar).EQ.Iso) THEN
- Dasigx(Nnn,Iipar) = (Dtermn+Dterma)*Fourpi/Eb
- END IF
- ELSE
- Dbsigx(Nnn,Iiparn,Iso) = (Dtermn+Dterma)*Fourpi/Eb
- END IF
+ Total = (calc%termf(1)+calc%termf(2))*Fourpi/Eb
+ cross = total
Ix = Ix + 1
END IF
!
! *** elastic scattering cross section
- IF (Kcros.EQ.2) THEN
- IF (Iipar.LE.Ndasig) THEN
- IF (Isopar(Iipar).EQ.Iso) &
- Dasigx(Nnnsig,Iipar) = Dtermn*Fourpi/Eb
- ELSE
- Dbsigx(Nnnsig,Iiparn,Iso) = Dtermn*Fourpi/Eb
- END IF
+ IF (calc%reactType.EQ.2) THEN
+ cross = calc%termf(1) *Fourpi/Eb
END IF
!
! *** inelastic scattering cross section, or fission
- IF (Kcros.EQ.3) THEN
- IF (Iipar.LE.Ndasig) THEN
- IF (Isopar(Iipar).EQ.Iso) THEN
- IF (Numdet.EQ.0) THEN
- Dasigx(Nnnsig,Iipar) = Dtermf*Fourpi/Eb
- ELSE
- Dasigx(Nnnsig,Iipar) = Dterfx*Fourpi/Eb
- END IF
- END IF
+ IF (calc%reactType.EQ.3) THEN
+ IF (Numdet.EQ.0) THEN
+ cross = Dtermf*Fourpi/Eb
ELSE
- IF (Numdet.EQ.0) THEN
- Dbsigx(Nnnsig,Iiparn,Iso) = Dtermf*Fourpi/Eb
- ELSE
- Dbsigx(Nnnsig,Iiparn,Iso) = Dterfx*Fourpi/Eb
- END IF
- END IF
+ cross = Dterfx*Fourpi/Eb
+ END IF
END IF
!
! *** capture cross section
- IF (Kcros.EQ.4 .OR. Kcros.EQ.8) THEN
- IF (Iipar.LE.Ndasig) THEN
- IF (Isopar(Iipar).EQ.Iso) THEN
- IF (Numdet.EQ.0) THEN
- Dasigx(Nnnsig,Iipar) = (Dterma-Dtermf)*Fourpi/Eb
- ELSE
- Dasigx(Nnnsig,Iipar) = (Dterax-Dterfx)*Fourpi/Eb
- END IF
- END IF
+ IF (calc%reactType.EQ.4 .OR. calc%reactType.EQ.8) THEN
+ IF (Numdet.EQ.0) THEN
+ cross = (calc%termf(2)-Dtermf)*Fourpi/Eb
ELSE
- IF (Numdet.EQ.0) THEN
- Dbsigx(Nnnsig,Iiparn,Iso)=(Dterma-Dtermf)*Fourpi/Eb
- ELSE
- Dbsigx(Nnnsig,Iiparn,Iso)=(Dterax-Dterfx)*Fourpi/Eb
- END IF
- END IF
+ cross = (calc%termfx(2)-Dterfx)*Fourpi/Eb
+ END IF
END IF
!
! *** fission cross section for integral quantities
- IF (Kcros.EQ.10 .AND. Nfissl.EQ.1) THEN
- IF (Iipar.LE.Ndasig) THEN
- IF (Isopar(Iipar).EQ.Iso) THEN
- Dasigx(Nnn,Iipar) = Dtermf*Fourpi/Eb
- END IF
- ELSE
- Dbsigx(Nnn,Iiparn,Iso) = Dtermf*Fourpi/Eb
- END IF
+ IF (calc%reactType.EQ.10 .AND. Nfissl.EQ.1) THEN
+ Total = Dtermf*Fourpi/Eb
END IF
!
! *** absorption cross section, maybe for integral quantities
- IF (Kcros.EQ.5 .OR. (Kcros.EQ.10 .AND. Nfissl.EQ.1) ) THEN
- IF (Iipar.LE.Ndasig) THEN
- IF (Isopar(Iipar).EQ.Iso) THEN
- Dasigx(Nnnsig,Iipar) = Dterma*Fourpi/Eb
- END IF
- ELSE
- Dbsigx(Nnnsig,Iiparn,Iso) = Dterma*Fourpi/Eb
- END IF
+ IF (calc%reactType.EQ.5 .OR. calc%reactType.EQ.10 ) THEN
+ cross = calc%termf(2)*Fourpi/Eb
END IF
-!
- 80 CONTINUE
- 90 CONTINUE
+
+ if (Nnn.ne.Nnnsig) then
+ if (total.ne.0.0d0) then
+ call calc%crossData%addDataNs(calc%row, Nnn, Iipar, Iso, total)
+ end if
+ end if
+ if (cross.ne.0.0d0) then
+ call calc%crossData%addDataNs(calc%row, Nnnsig, Iipar, Iso, cross)
+ end if
+!
+ end do ! end of loop over Iipar
+ end do ! end of loop over isotopes
!
RETURN
END
+end module mxct23_m
diff --git a/sammy/src/xct/mxct24.f90 b/sammy/src/xct/mxct24.f90
index 98fae5bbd..b6961a40c 100644
--- a/sammy/src/xct/mxct24.f90
+++ b/sammy/src/xct/mxct24.f90
@@ -9,10 +9,6 @@ contains
real(kind=8) function Addpmc (Parpmc, Isopmc, Numpmc, Isox, Ab, Eb) result(Answer)
!
! *** purpose -- Add paramgnetic cross section thereof
-!
- !use fixedi_m, only : Nnniso, Numiso, Numpmc
- !use EndfData_common_m, only : resParData
-
!
real(kind=8)::Parpmc(:,:)
integer::Isopmc(:)
diff --git a/sammy/src/xct/mxct26.f90 b/sammy/src/xct/mxct26.f90
index 55ce15f84..1dfc4e858 100644
--- a/sammy/src/xct/mxct26.f90
+++ b/sammy/src/xct/mxct26.f90
@@ -1,13 +1,14 @@
module mxct26_m
+IMPLICIT None
contains
+! Todo: remove dependence on global parameters
!
!
! --------------------------------------------------------------
!
- Subroutine Find_If_Coulomb (calc, IfCoul, Ifdif)
+ Subroutine Find_If_Coulomb (calc, IfCoul)
use CrossSectionCalculator_M
use SammySpinGroupInfo_M
- IMPLICIT none
class(CrossSectionCalculator)::calc
type(SammySpinGroupInfo)::spinInfo
@@ -17,7 +18,7 @@ contains
! *** On output, IfCoul = Maximum number of entrance channels which
! *** require Coulomb
IfCoul = 0
- IF (Ifdif.EQ.1) THEN
+ IF (calc%needAngular .and. calc%reactType.ne.11) THEN ! angular for elastic
Nn = 0
hasCoulomb = .false.
DO I=1,calc%resData%getNumSpinGroups()
@@ -34,24 +35,23 @@ contains
!
! ______________________________________________________________________
!
- SUBROUTINE Start_Coul (Zke, Ccoulx)
- use fixedi_m, only : Ntotc
- use EndfData_common_m
+ SUBROUTINE Start_Coul (Zke, Ccoulx, resData)
+ use SammyRMatrixParameters_M
use SammySpinGroupInfo_M
- IMPLICIT None
- real(kind=8)::Zke(Ntotc,*), Ccoulx(Ntotc,*)
+ real(kind=8)::Zke(:,:), Ccoulx(:,:)
+ type(SammyRMatrixParameters)::resData
type(SammySpinGroupInfo)::spinInfo
real(kind=8)::A
- integer::Igroup, Ich, Nenti, Ntoti
+ integer::Igroup, Ich, Nenti
real(kind=8),parameter::Hth=0.01d0
- DO Igroup=1,resParData%getNumSpinGroups()
- call resParData%getSpinGroupInfo(spinInfo, Igroup)
+ Ccoulx = 0.0d0
+ DO Igroup=1,resData%getNumSpinGroups()
+ call resData%getSpinGroupInfo(spinInfo, Igroup)
A = Hth* &
spinInfo%getAbundance()* &
spinInfo%getGFactor()
- Nenti = spinInfo%getNumEntryChannels()
- Ntoti = spinInfo%getNumChannels()
+ Nenti = spinInfo%getNumEntryChannels()
DO Ich=1,Nenti
Ccoulx(Ich,Igroup) = A/Zke(Ich,Igroup)**2
END DO
@@ -62,26 +62,26 @@ contains
!
! ______________________________________________________________________
!
- SUBROUTINE Store_Coul (Ccoul, Dcoul, Crssx, Derivx, Ccoulx, Jdat)
+ SUBROUTINE Store_Coul (Ccoul, Dcoul, angInternal, Ccoulx, Jdat)
use fixedi_m, only : Ntotc, Ngroup
use ifwrit_m, only : Nnpar
- use EndfData_common_m
- IMPLICIT NONE
+ use EndfData_common_m
+ real(kind=8),dimension(:,:,:,:,0:)::angInternal
integer::Jdat
- real(kind=8)::Ccoul(2,Ntotc,Ngroup,*), Crssx(2,Ntotc,Ntotc,*), &
- Dcoul(2,Ntotc,Nnpar,Ngroup,*), &
- Derivx(2,Ntotc,Ntotc,Nnpar,*), Ccoulx(Ntotc,*)
+ real(kind=8)::Ccoul(2,Ntotc,Ngroup,*), &
+ Dcoul(2,Ntotc,Nnpar,Ngroup,*)
+ real(kind=8)::Ccoulx(:,:)
integer::igroup, Nn, Ix, Iipar
DO Igroup=1,resParData%getNumSpinGroups()
DO Nn=1,Ntotc
DO Ix=1,2
Ccoul(Ix,Nn,Igroup,Jdat) = &
- Crssx(Ix,Nn,Nn,Igroup)*Ccoulx(Nn,Igroup)
+ angInternal(Ix,Nn,Nn,Igroup, 0)*Ccoulx(Nn,Igroup)
IF (Nnpar.GT.0) THEN
DO Iipar=1,Nnpar
Dcoul(Ix,Nn,Iipar,Igroup,Jdat) = &
- Derivx(Ix,Nn,Nn,Iipar,Igroup)*Ccoulx(Nn,Igroup)
+ angInternal(Ix,Nn,Nn,Igroup, Iipar)*Ccoulx(Nn,Igroup)
END DO
END IF
END DO
@@ -94,7 +94,6 @@ contains
! --------------------------------------------------------------
!
SUBROUTINE Get_Coul_Phase (Cr, Ci, Lspin, Echan, Zeta, Su)
- IMPLICIT NONE
real(kind=8)::Aa, Cr, Ci, Cc, Ccx, Ccy, Eta,Echan, Zeta, Su
integer::L, Ll, Lspin
real(kind=8)::Ss, Ssx, Ssy
diff --git a/sammy/src/xct/mxct27.f90 b/sammy/src/xct/mxct27.f90
index e9104c4b3..c23f9643d 100644
--- a/sammy/src/xct/mxct27.f90
+++ b/sammy/src/xct/mxct27.f90
@@ -3,8 +3,9 @@
! --------------------------------------------------------------
!
SUBROUTINE Zero_Array (A, N)
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION A(*)
+ IMPLICIT None
+ real(kind=8)::A(*)
+ integer::K,N
DO K=1,N
A(K) = 0.0d0
END DO
@@ -15,7 +16,9 @@
! --------------------------------------------------------------
!
SUBROUTINE Zero_Integer (Ia, N)
- DIMENSION Ia(*)
+ implicit none
+ integer::Ia(*)
+ integer::K,N
DO K=1,N
Ia(K) = 0
END DO
@@ -25,6 +28,7 @@
module mxct27_m
+ IMPLICIT NONE
contains
!
!
@@ -32,15 +36,18 @@ module mxct27_m
!
SUBROUTINE Write_Cross_Sections (derivs, &
Nnnsss, Kkkkkk, Kkkmin, If_W_Selfin, derivsSelf)
- use fixedi_m
- use ifwrit_m
- use cbro_common_m
+ use fixedi_m, only : Montec, Ndasig, Ndbsig, Nnniso, numcro
+ use ifwrit_m, only : Kksave, Kmsave, ktzero
+ use cbro_common_m, only : Filein, Filout
use SammyGridAccess_M
- use EndfData_common_m
+ use EndfData_common_m, only : expData
use DerivativeHandler_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+
type(SammyGridAccess)::grid
type(DerivativeHandler)::derivs, derivsSelf
+ integer::Nnnsss, Kkkkkk, Kkkmin, If_W_Selfin
+
+ integer::iipar, Iso, Iunit, J, K, Kk
!
optional derivsSelf
IF (Montec.EQ.1) THEN
diff --git a/sammy/src/xct/mxct28.f90 b/sammy/src/xct/mxct28.f90
index 6f8746ad1..09ad058c4 100755
--- a/sammy/src/xct/mxct28.f90
+++ b/sammy/src/xct/mxct28.f90
@@ -1,39 +1,22 @@
+module Zgauss_m
+implicit none
+contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Zgauss (A, Gb, Eb)
-!
-! *** PURPOSE -- FORM THE CROSS SECTION Crss for the case where
-! *** Gaussian (dummy) resonances are to be used
-! *** AND THE ( PARTIAL DERIVATIVES OF THE CROSS SECTION
-! *** WITH RESPECT TO THE VARIED PARAMETERS ) = Deriv
-!
- use fixedi_m
- use ifwrit_m
- use exploc_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION A(*), Gb(*)
-!
- CALL Gausss (Gb, Eb)
- RETURN
- END
-!
-!
-! --------------------------------------------------------------
-!
- SUBROUTINE Gausss (Gb, Eb)
- use fixedi_m
- use ifwrit_m
- use exploc_common_m
- use EndfData_common_m
+ SUBROUTINE Zgauss (resparData, Gb, Eb)
+ use SammyRMatrixParameters_M
use SammyResonanceInfo_M
use RMatResonanceParam_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Gb(*)
+
+ real(kind=8)::Gb, Eb
+ type(SammyRMatrixParameters)::resParData
type(SammyResonanceInfo)::resInfo
type(RMatResonance)::resonance
- DATA One /1.0d0/
- CALL Zero_Array (Gb, Nsgbou)
+ real(kind=8),parameter:: One = 1.0d0
+ integer::I, N
+ real(kind=8)::Gamtot, Eee
+ Gb = 0.0d0
DO I=1,resParData%getNumResonances()
call resParData%getResonanceInfo(resInfo, I)
call resParData%getResonance(resonance, resInfo)
@@ -43,9 +26,10 @@
Gamtot = Gamtot + resonance%getWidth(N)
END DO
Eee = 1000.0d0*(Eb-resonance%getEres())/Gamtot
- Gb(1) = Gb(1) + dEXP(-Eee**2)
+ Gb = Gb + dEXP(-Eee**2)
END IF
END DO
!
RETURN
END
+end module Zgauss_m
diff --git a/sammy/src/xct/mxct31.f90 b/sammy/src/xct/mxct31.f90
index 3e4c4c37d..0c70d0dbc 100644
--- a/sammy/src/xct/mxct31.f90
+++ b/sammy/src/xct/mxct31.f90
@@ -2,6 +2,9 @@ module mxct31_m
use XctCrossCalc_M
implicit none
public Setleg_Slow, Find_Kountr_Jx_Slow
+
+! Todo: Delete dependence on Iq_val, number of distinct Q values
+
contains
integer function Jxlmn(Mb,Ma,M, Ntotc)
@@ -13,41 +16,30 @@ end function
!
! --------------------------------------------------------------
!
- SUBROUTINE Setleg_Slow (calc, Sigxxx, &
- Ccclll, Crssx, Echan, Cmlab, Iso_Qv, Lllmmm, Eb)
+ SUBROUTINE Setleg_Slow (calc, Cmlab, Iso_Qv)
!
-! *** Purpose -- set Ccclll(L,Iso) = coefficient of Legendre polynomial
+! *** Purpose -- set coefficient of Legendre polynomial
! *** P-sub-(L-1) for Isotope Iso
!
- !use fixedi_m
- !use ifwrit_m
- !use lbro_common_m
- !use EndfData_common_m
- use fixedi_m, only : Nnnsig, Kkxlmn, Ntotc, Iq_Iso, Iq_Val, Lllmax, &
- Nnniso, Numiso
+ use fixedi_m, only : Iq_Val
use SammySpinGroupInfo_M
use mdat9_m
!
class(XctCrossCalc)::calc
- integer::Lllmmm
- real(kind=8)::Eb
- real(kind=8):: &
- Sigxxx(Nnnsig,*), Ccclll(Lllmmm,*), &
- Crssx(2,Ntotc,Ntotc,*), Echan(Ntotc,*), Cmlab(3,*)
- integer:: Iso_Qv(*)
+ real(kind=8),allocatable:: Cmlab(:,:)
+ integer,allocatable:: Iso_Qv(:)
type(SammySpinGroupInfo)::spinMgr, spinNgr
real(kind=8),parameter:: Zero = 0.0d0
- real(kind=8)::Ai, Ar, Br, C2
+ real(kind=8)::Ai, Ar, Br, C2, val
integer::Iq, Iso, isoMgr, isoNgr, Jxm, Jxn
integer::Klmn, Kountr, L, Mchan, Mchanx, Mgr, Ngr
integer::Nchan, Nchanx
!
!
- CALL Zero_Array (Ccclll, Iq_Iso*Lllmax)
- CALL Findpr (Kkxlmn, Klmn)
+ CALL Findpr (calc%C_G_Kxlmn, Klmn)
!
- DO Iq=1,Iq_Iso
+ DO Iq=1,calc%numiso
IF (Iq_Val.NE.0) THEN
Iso = Iso_Qv(Iq)
C2 = Cmlab(2,Iq)
@@ -57,72 +49,64 @@ end function
END IF
DO Ngr=1,calc%resData%getNumSpinGroups()
call calc%resData%getSpinGroupInfo(spinNgr, Ngr)
- IF (spinNgr%getIncludeInCalc()) THEN
- isoNgr = spinNgr%getIsotopeIndex()
- IF (IsoNgr.EQ.Iso .OR. Nnniso.NE.Numiso) THEN
-! *** If we're keeping isotopes separate, and this is the
-! *** wrong isotope, then don't do this one now
- DO Nchan=1,spinNgr%getNumChannels()
- IF ((Iq_Val.NE.0 .AND. Echan(Nchan,Ngr).EQ.C2) .OR. &
- Iq_Val.EQ.0) THEN
- DO Nchanx=1,spinNgr%getNumEntryChannels()
- Ar = Crssx(1,Nchanx,Nchan,Ngr)
- Ai = Crssx(2,Nchanx,Nchan,Ngr)
-! *** Ar & Ai are zero when Nchan is not an
-! *** included channel for the particular
-! *** reaction under consideration
- IF (Ar.NE.Zero .OR. Ai.NE.Zero) THEN
-! --------------------------------------------------------------------
- Jxn = Jxlmn (Nchanx,Nchan,Ngr, Ntotc)
- DO Mgr=1,calc%resData%getNumSpinGroups()
- call calc%resData%getSpinGroupInfo(spinMgr, Mgr)
- IF (spinMgr%getIncludeInCalc()) THEN
- isoMgr = spinMgr%getIsotopeIndex()
- IF (IsoMgr.EQ.Iso .OR. Nnniso.NE.Numiso) THEN
-! *** If we're keeping isotopes separate, and this
-! *** is the wrong isotope, then don't do this one
- DO Mchan=1,spinMgr%getNumChannels()
- IF (Iq_Val.EQ.0 .OR. (Iq_Val.NE.0 .AND. &
- Echan(Mchan,Mgr).EQ.C2)) THEN
+ IF (.not.spinNgr%getIncludeInCalc()) cycle
+ isoNgr = 1
+ if (calc%separateIso) isoNgr = spinNgr%getIsotopeIndex()
+ IF (IsoNgr.ne.Iso) cycle
+ ! *** If we're keeping isotopes separate, and this is the
+ ! *** wrong isotope, then don't do this one now
+ DO Nchan=1,spinNgr%getNumChannels()
+ IF (.not.((Iq_Val.NE.0 .AND. calc%Echan(Nchan,Ngr).EQ.C2) .OR. &
+ Iq_Val.EQ.0)) cycle
+ DO Nchanx=1,spinNgr%getNumEntryChannels()
+ Ar = calc%angInternal(1,Nchanx,Nchan,Ngr,0)
+ Ai = calc%angInternal(2,Nchanx,Nchan,Ngr,0)
+ ! *** Ar & Ai are zero when Nchan is not an
+ ! *** included channel for the particular
+ ! *** reaction under consideration
+ IF (Ar.eq.Zero .and. Ai.eq.Zero) cycle
+ ! --------------------------------------------------------------------
+ Jxn = Jxlmn (Nchanx,Nchan,Ngr, calc%Ntotc)
+ DO Mgr=1,calc%resData%getNumSpinGroups()
+ call calc%resData%getSpinGroupInfo(spinMgr, Mgr)
+ IF (.not.spinMgr%getIncludeInCalc()) cycle
+ isoMgr = 1
+ if (calc%separateIso) isoMgr = spinMgr%getIsotopeIndex()
+ IF (IsoMgr.ne.Iso) cycle
+ ! *** If we're keeping isotopes separate, and this
+ ! *** is the wrong isotope, then don't do this one
+ DO Mchan=1,spinMgr%getNumChannels()
+ IF (.not.(Iq_Val.EQ.0 .OR. (Iq_Val.NE.0 .AND. &
+ calc%Echan(Mchan,Mgr).EQ.C2))) cycle
DO Mchanx=1,spinMgr%getNumEntryChannels()
- Br = Ar*Crssx(1,Mchanx,Mchan,Mgr) + &
- Ai*Crssx(2,Mchanx,Mchan,Mgr)
- IF (Br.NE.Zero) THEN
- Jxm = Jxlmn (Mchanx,Mchan,Mgr, Ntotc)
- DO L=1,Lllmax
- CALL Find_Kountr_Jx_Slow (calc%Ixlmn, &
- Kkxlmn, L, Jxm, Jxn, Kountr, Klmn)
- IF (Kountr.GT.0) THEN
- IF (calc%Xlmn(Kountr).NE.Zero) &
- Ccclll(L,Iq) = Ccclll(L,Iq) + &
- Br*calc%Xlmn(Kountr)
- END IF
- END DO
- END IF
- END DO
- END IF
- END DO
- END IF
- END IF
- END DO
-! --------------------------------------------------------------------
- END IF
- END DO
- END IF
- END DO
- END IF
- END IF
- END DO
- END DO
-!
-! *** note that Xlmn includes Abundance; ergo so do Ccclll etc
- DO Iso=1,Iq_Iso
- DO L=1,Lllmmm
- Sigxxx(L,Iso) = Ccclll(L,Iso)/Eb
- END DO
- END DO
+ Br = Ar*calc%angInternal(1,Mchanx,Mchan,Mgr,0) + &
+ Ai*calc%angInternal(2,Mchanx,Mchan,Mgr,0)
+ IF (Br.eq.Zero) cycle
+ Jxm = Jxlmn (Mchanx,Mchan,Mgr, calc%Ntotc)
+ DO L=1,calc%Lllmax
+ CALL Find_Kountr_Jx_Slow (calc%Ixlmn, &
+ calc%C_G_Kxlmn, L, Jxm, Jxn, Kountr, Klmn)
+ IF (Kountr.GT.0) THEN
+ IF (calc%Xlmn(Kountr).NE.Zero) then
+ val = Br*calc%Xlmn(Kountr)
+ ! note that Xlmn includes Abndnc; ergo so do calc%crossData% etc
+ ! not corrected for 1/energy yet
+ if (val.ne.0.0d0) then
+ call calc%crossData%addDataNs(calc%row, L, 0, Iq, val)
+ end if
+ end if
+ end if
+ END DO ! loop over legender order
+ END DO ! inner loop over entry channels (Mgr)
+ END DO ! inner loop over channels (Mgr)
+ END DO ! inner loop over spin groups (Mgr)
+ END DO ! end loop over entry channels (Ngr)
+ END DO ! end loop over channels (Ngr)
+ END DO ! end loop over spin groups (Ngr)
+ END DO ! end loop over calc%numIso
+
RETURN
- END
+ END subroutine
!
!
! --------------------------------------------------------------
diff --git a/sammy/src/xct/mxct32.f90 b/sammy/src/xct/mxct32.f90
index 7b242eb72..0f23b213e 100644
--- a/sammy/src/xct/mxct32.f90
+++ b/sammy/src/xct/mxct32.f90
@@ -1,169 +1,156 @@
module mxct32_m
-use XctCrossCalc_M
-IMPLICIT none
+ use XctCrossCalc_M
+ IMPLICIT none
-public Derleg_Slow
+ public Derleg_Slow
+ ! Todo: Delete dependence on Iq_val, number of distinct Q values
contains
-integer function Jxlmn(Mb,Ma,M, Ntotc)
- integer::Mb,Ma,M, Ntotc
- Jxlmn = ((M-1)*Ntotc+Ma-1)*Ntotc + Mb
-end function
-!
-!
-! ______________________________________________________________________
-!
- SUBROUTINE Derleg_Slow ( calc, &
- Sigxxx, Dasigx, Ccclll, Dddlll, Crssx, &
- Derivx, Isopar, Echan, Cmlab, Iso_Qv, Lllmmm, Eb)
-!
-! *** Purpose -- Set Dddlll(L,.,Iso) = Derivative of coefficient of
-! *** Legendre polynomial P-sub-(L-1) for Isotope Iso
-! ***
-! *** Note -- Enter this routine only if Ndasig > 0 and Kslow=1
-!
- use fixedi_m, only : Nnnsig, Iq_Iso, Iq_val, &
- Lllmax, Ndasig, Nfpiso, Nnniso, Numiso, Ntotc, &
- Kkxlmn
- use ifwrit_m, only : Nnpar
- use SammySpinGroupInfo_M
- use SammyIsoInfo_M
- use mdat9_m
- use mxct31_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-!
- class(XctCrossCalc)::calc
- real(kind=8)::Eb
- integer::Lllmmm
- real(kind=8):: &
- Sigxxx(Nnnsig,*), &
- Dasigx(Nnnsig,*), Ccclll(Lllmmm,*), Dddlll(Lllmmm,*), &
- Crssx(2,Ntotc,Ntotc,*), &
- Derivx(2,Ntotc,Ntotc,Nnpar,*), &
- Echan(Ntotc,*), Cmlab(3,*)
- integer:: Isopar(*), Iso_Qv(*)
- type(SammySpinGroupInfo)::spinNgr, spinMgr
- type(SammyIsoInfo)::isoInfo
- real(kind=8),parameter :: Zero = 0.0d0
- real(kind=8)::val
- real(kind=8)::Ai, Ar, Bi, Br, C2, Dai, Dar, Dbi, Dbr, Dr
- integer::Ifl, Iipar, Iq, Iso, isoMgr, isoNgr, Jxm, Jxn, Klmn, Kountr
- integer::L,Mchan, Mchanx, Mgr, Nchan, Nchanx, Ngr
-!
- CALL Zero_Array (Dddlll, Lllmmm*Ndasig)
- CALL Findpr (Kkxlmn, Klmn)
-!
- DO Iq=1,Iq_Iso
- IF (Iq_Val.NE.0) THEN
- Iso = Iso_Qv(Iq)
- C2 = Cmlab(2,Iq)
- ELSE
- Iso = Iq
- C2 = Zero
- END IF
- DO Ngr=1,calc%resData%getNumSpinGroups()
- call calc%resData%getSpinGroupInfo(spinNgr, Ngr)
- IF (spinNgr%getIncludeInCalc()) THEN
- isoNgr = spinNgr%getIsotopeIndex()
- IF (Numiso.LE.0 .OR. IsoNgr.EQ.Iso .OR. &
- Nnniso.NE.Numiso) THEN
-! *** If we're keeping spin groups separate, and this is the
-! *** wrong spin group, then don't do this one now
- DO Nchan=1,spinNgr%getNumChannels()
- IF ((Iq_Val.NE.0 .AND. Echan(Nchan,Ngr).EQ.C2) .OR. &
- Iq_Val.EQ.0) THEN
- DO Nchanx=1,spinNgr%getNumEntryChannels()
- Ar = Crssx(1,Nchanx,Nchan,Ngr)
- Ai = Crssx(2,Nchanx,Nchan,Ngr)
- IF (Ar.NE.Zero .OR. Ai.NE.Zero) THEN
-! ----------------------------------------------------------
- Jxn = Jxlmn (Nchanx,Nchan,Ngr, Ntotc)
- DO Mgr=1,calc%resData%getNumSpinGroups()
- call calc%resData%getSpinGroupInfo(spinMgr, Mgr)
- IF (spinMgr%getIncludeInCalc()) THEN
- isoMgr = spinMgr%getIsotopeIndex()
- IF (Numiso.LE.0 .OR. IsoMgr.EQ.Iso .OR. &
- Nnniso.NE.Numiso) THEN
-! *** If we're keeping spin groups separate, and this is the wrong
-! *** spin group, then don't do this one
- DO Mchan=1,spinMgr%getNumChannels()
- IF (Iq_Val.EQ.0 .OR. (Iq_Val.NE.0 .AND. &
- Echan(Mchan,Mgr).EQ.C2)) THEN
- DO Mchanx=1,spinMgr%getNumEntryChannels()
- Br = Crssx(1,Mchanx,Mchan,Mgr)
- Bi = Crssx(2,Mchanx,Mchan,Mgr)
- Jxm = Jxlmn (Mchanx,Mchan,Mgr, Ntotc)
-! ----------------------------------------------------------
- DO Iipar=1,Ndasig
- Dar = Derivx(1,Nchanx,Nchan,Iipar,Ngr)
- Dai = Derivx(2,Nchanx,Nchan,Iipar,Ngr)
- IF (Dar.NE.Zero .OR. Dai.NE.Zero) THEN
- IF (Isopar(Iipar).EQ.0) Isopar(Iipar) = Iso
- Dr = Br*Dar + Bi*Dai
- ELSE
- Dr = Zero
- END IF
- Dbr = Derivx(1,Mchanx,Mchan,Iipar,Mgr)
- Dbi = Derivx(2,Mchanx,Mchan,Iipar,Mgr)
- IF (Dbr.NE.Zero .OR. Dbi.NE.Zero) THEN
- IF (Isopar(Iipar).EQ.0) Isopar(Iipar) = Iso
- Dr = Ar*Dbr + Ai*Dbi + Dr
- END IF
- IF (Dr.NE.Zero) THEN
- DO L=1,Lllmax
- CALL Find_Kountr_Jx_Slow (calc%Ixlmn, Kkxlmn, L, Jxm, Jxn, &
- Kountr, Klmn)
- IF (Kountr.GT.0) THEN
- IF (calc%Xlmn(Kountr).NE.Zero) THEN
- Dddlll(L,Iipar) = &
- Dddlll(L,Iipar) + Dr*calc%Xlmn(Kountr)
- END IF
- END IF
- END DO
- END IF
- END DO
-! ----------------------------------------------------------
- END DO
- END IF
- END DO
- END IF
- END IF
- END DO
-! ----------------------------------------------------------
- END IF
- END DO
- END IF
- END DO
- END IF
- END IF
- END DO
- END DO
-!
-! *** find derivative of Crss wrt isotopic Abundance
-! ##################### maybe NOT CORRECT YET FOR Iq_Val>0
- IF (Nfpiso.GT.0) THEN
- DO Iso=1,Numiso
- call calc%resData%getIsoInfo(isoInfo, Iso)
- Ifl = isoInfo%getFitOption()
- IF (Ifl.GT.0) THEN
- Ifl = Ifl
- Isopar(Ifl) = Iso
- DO L=1,Lllmax
- Dddlll(L,Ifl) = Ccclll(L,Iso)/ &
- calc%resData%getAbundanceByIsotope(Iso)
- END DO
- END IF
- END DO
- END IF
-!
- IF (Ndasig.GT.0) THEN
- DO Iipar=1,Ndasig
- DO L=1,Lllmax
- Dasigx(L,Iipar) = Dddlll(L,Iipar)/Eb
- END DO
- END DO
- END IF
- RETURN
- END
+ integer function Jxlmn(Mb,Ma,M, Ntotc)
+ integer::Mb,Ma,M, Ntotc
+ Jxlmn = ((M-1)*Ntotc+Ma-1)*Ntotc + Mb
+ end function Jxlmn
+ !
+ ! Note :
+ ! Derleg and Derleg_slow are almost identical
+ ! except for the calls to Jxnnn, Jxmm and
+ ! Find_Kountr_Jx and Find_Kountr_Jx_Slow
+ ! all related to find data in calc%Xlmn
+
+ !
+ ! ______________________________________________________________________
+ !
+ SUBROUTINE Derleg_Slow ( calc, Cmlab, Iso_Qv)
+ !
+ ! *** Purpose -- Set Derivative of coefficient of
+ ! *** Legendre polynomial P-sub-(L-1) for Isotope Iso
+ ! ***
+ ! *** Note -- Enter this routine only if we need derivatives and Kslow=1
+ !
+ use fixedi_m, only : Iq_val
+ use SammySpinGroupInfo_M
+ use SammyIsoInfo_M
+ use mdat9_m
+ use mxct31_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ !
+ class(XctCrossCalc)::calc
+ real(kind=8)::Eb
+ integer::Lllmmm
+ real(kind=8),allocatable::Cmlab(:,:)
+ integer,allocatable:: Iso_Qv(:)
+ type(SammySpinGroupInfo)::spinNgr, spinMgr
+ type(SammyIsoInfo)::isoInfo
+ real(kind=8),parameter :: Zero = 0.0d0
+ real(kind=8)::val
+ real(kind=8)::Ai, Ar, Bi, Br, C2, Dai, Dar, Dbi, Dbr, Dr
+ integer::Ifl, Iipar, Iq, Iso, isoMgr, isoNgr, Jxm, Jxn, Klmn, Kountr
+ integer::L,Mchan, Mchanx, Mgr, Nchan, Nchanx, Ngr
+ !
+ CALL Findpr (calc%C_G_Kxlmn, Klmn)
+ !
+ DO Iq=1,calc%numIso
+ IF (Iq_Val.NE.0) THEN
+ Iso = Iso_Qv(Iq)
+ C2 = Cmlab(2,Iq)
+ ELSE
+ Iso = Iq
+ C2 = Zero
+ END IF
+ DO Ngr=1,calc%resData%getNumSpinGroups()
+ call calc%resData%getSpinGroupInfo(spinNgr, Ngr)
+ IF (.not.spinNgr%getIncludeInCalc()) cycle
+ isoNgr = 1
+ if (calc%separateIso) isoNgr = spinNgr%getIsotopeIndex()
+ IF (IsoNgr.ne.Iso) cycle
+ ! *** If we're keeping spin groups separate, and this is the
+ ! *** wrong spin group, then don't do this one now
+ DO Nchan=1,spinNgr%getNumChannels()
+ IF (.not.((Iq_Val.NE.0 .AND. calc%Echan(Nchan,Ngr).EQ.C2) .OR. &
+ Iq_Val.EQ.0)) cycle
+ DO Nchanx=1,spinNgr%getNumEntryChannels()
+ Ar = calc%angInternal(1,Nchanx,Nchan,Ngr, 0)
+ Ai = calc%angInternal(2,Nchanx,Nchan,Ngr, 0)
+ IF (Ar.eq.Zero .and. Ai.eq.Zero) cycle
+ ! ----------------------------------------------------------
+ Jxn = Jxlmn (Nchanx,Nchan,Ngr, calc%Ntotc)
+ DO Mgr=1,calc%resData%getNumSpinGroups()
+ call calc%resData%getSpinGroupInfo(spinMgr, Mgr)
+ IF (.not.spinMgr%getIncludeInCalc()) cycle
+ isoMgr = 1
+ if (calc%separateIso) isoMgr = spinMgr%getIsotopeIndex()
+ IF (IsoMgr.ne.Iso) cycle
+ ! *** If we're keeping spin groups separate, and this is the wrong
+ ! *** spin group, then don't do this one
+ DO Mchan=1,spinMgr%getNumChannels()
+ IF (.not. (Iq_Val.EQ.0 .OR. (Iq_Val.NE.0 .AND. &
+ calc%Echan(Mchan,Mgr).EQ.C2))) cycle
+ DO Mchanx=1,spinMgr%getNumEntryChannels()
+ Br = calc%angInternal(1,Mchanx,Mchan,Mgr, 0)
+ Bi = calc%angInternal(2,Mchanx,Mchan,Mgr, 0)
+ Jxm = Jxlmn (Mchanx,Mchan,Mgr, calc%Ntotc)
+ DO Iipar=1,calc%covariance%getNumTotalParam()
+ Dar = calc%angInternal(1,Nchanx,Nchan,Ngr, Iipar)
+ Dai = calc%angInternal(2,Nchanx,Nchan,Ngr, Iipar)
+ IF (Dar.NE.Zero .OR. Dai.NE.Zero) THEN
+ calc%crossSelfWhy(Iipar) = .true.
+ Dr = Br*Dar + Bi*Dai
+ ELSE
+ Dr = Zero
+ END IF
+ Dbr = calc%angInternal(1,Mchanx,Mchan,Mgr, Iipar)
+ Dbi = calc%angInternal(2,Mchanx,Mchan,Mgr, Iipar)
+ IF (Dbr.NE.Zero .OR. Dbi.NE.Zero) THEN
+ calc%crossSelfWhy(Iipar) = .true.
+ Dr = Ar*Dbr + Ai*Dbi + Dr
+ END IF
+ IF (Dr.eq.Zero) cycle
+ DO L=1,calc%Lllmax
+ CALL Find_Kountr_Jx_Slow (calc%Ixlmn, calc%C_G_Kxlmn, L, Jxm, Jxn, &
+ Kountr, Klmn)
+ IF (Kountr.GT.0) THEN
+ IF (calc%Xlmn(Kountr).NE.Zero) THEN
+ val = Dr*calc%Xlmn(Kountr)
+ if (val.ne.0.0d0) then
+ call calc%crossData%setSharedValNs(calc%row, L, Iipar, val)
+ end if
+ END IF
+ END IF
+ END DO ! loop over legender order
+ END DO ! loop over parameters
+ END DO ! inner loop over entry channels (Mgr)
+ END DO ! inner loop over channels (Mgr)
+ END DO ! inner loop over spin groups (Mgr)
+ END DO ! end loop over entry channels (Ngr)
+ END DO ! end loop over channels (Ngr)
+ END DO ! end loop over spin groups (Ngr)
+ END DO ! end loop over calc%numIso
+ !
+ ! *** find derivative of Crss wrt isotopic Abundance
+ ! ##################### maybe NOT CORRECT YET FOR Iq_Val>0
+ !
+ ! DAW todo: This still does not seem correct for
+ ! if number of real isotopes > 1
+ DO Iq=1, calc%numIso
+ IF (Iq_Val.NE.0) THEN
+ Iso = Iso_Qv(Iq)
+ ELSE
+ Iso = Iq
+ END IF
+ call calc%resData%getIsoInfo(isoInfo, Iso)
+ Ifl = isoInfo%getFitOption()
+ IF (Ifl.GT.0) THEN
+ calc%crossSelfWhy(Ifl) = .true.
+ DO L=1,calc%Lllmax
+ val = calc%crossData%getDataNs(calc%row, L, 0, Iq)
+ if( val.eq.0.0d0) cycle
+ val = val/calc%resData%getAbundanceByIsotope(Iso)
+ call calc%crossData%setSharedValNs(calc%row, L, Ifl, val)
+ END DO
+ END IF
+ END DO
+ !
+ RETURN
+ END SUBROUTINE Derleg_Slow
end module mxct32_m
--
GitLab