diff --git a/sammy/src/ang/mang1.f b/sammy/src/ang/mang1.f
index b5e4ddb440d30d45845bc0414209acb238044000..b4aac1292b49248506546f05d8037d24a6146a4c 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 b41b922da0e0c2029fe358807d8e198786e47923..15bea3f250f29121745a466f2cabf0f2e0d84173 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 bc9aee8cdbc911561e8e788f8d85eb1c09ec23be..8644a624362f53ee88435cf7569383f0bdfbf2f8 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 2f191b75e4bf65b529a6ea1d8b6745e93faba6ff..fec21230bb0a7288958980b34160da76c8c491eb 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 0f2f3b058affe8ec50347ba5dcaec1765e8744f8..78555cd69caf7d03fa15d17aead408e73bd3f9b4 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 8554cff7c3af1d805423480c9068613e45d94570..0000000000000000000000000000000000000000
--- 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 bdc67ace1dc5c2b55b2df5424e4560ffead03a68..5f5ccce75c5e891f46d8ce78ea5a9b80286bb181 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 2d7aa1cc64d44e8c030116b57f1b8c88dbd03267..1d328af4970dca33131deae733db90d752f8468d 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 0435f407c0403947014b29de3bcf58b6f0d137cb..a4223d1e56bf8af2d256e9b75bc75197d0957053 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 9719f6c6c4cb763d8061ed324125a0876fd009aa..897d34d578f621aec220253ee203073914c4f363 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 dee459d3b774e66a4bce5d8e34c2ffc4e52a94ca..a17ef666667772b0ed16a989953d2f973627adb4 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 9d61d79ab316ef821972f42f571e0eba4841cce8..e549200d2483985117d2bfcaaf647ae3747cbadf 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 8c17e91c41290a56ea8bf144e8a900ab67f4a550..2ad610a744fcdcd95ad4cebb01d94b6498a98e3e 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 8495fd8e960e259b85ffbc40fc54d9ff187ee7fe..684e2190414564727e33fc8ba9d5f946d0c70d5b 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 77babde1cb9a35465c2773aa210dc77402e5f7f1..70c40b8477f6ba318c7b3b405ddefe4773b58df3 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 6ec1cfb789bcd2d7458761a52686f714ba7f2d02..b071b1fa80cbe3a0f11a997ccc073b80243dd6d5 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 915f5015c0552dfaea7ddc1fd8d89e51f7c02a31..5363ede9abc4f328de9ad0ca3cdf5eb55195307b 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 79a0b1a45bbeed113316756cff0c0aefb85438a1..93a99092bc398bc7bfc9e90a21dc9b073ed4f63b 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 2e27395e32cd7bb1dd17be44825865f927ed8583..b4851722e059a31d02b4c5f5b7c95370848f2292 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 1caac597f0a4a841b8117aebfc9f8bc1ad740fcd..588520980a9c5b5bc9b474262f4a9e41d572862c 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 6b19cf04d176026a61099914ffb4ce155ee89006..c01245e96315926b6a12b9a2fd0a21ed064a23d6 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 06282178cfa26cc528630b393cb9dc2be89f5f0e..3efca439ccb3411f21fa458fc4e54fe9b09c0b94 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 0819414fec5bb0f22552936cf705af030917319f..c5ee33828b60e8f3b381f595f929a750f73be163 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 6769fc53f188e2db9c7e4a55c5e9bbb418853aee..aeccd8aafb5ca6f3600529b748d2cb17ce13a74f 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 575c19ea88c4680d10918b5b509c39baecd5af12..ccd575a71fbc783418b0510502a0e81576a9c750 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 7a05f90cedd8ab7d0273f75bd777faf99c9a4d94..73befac0a396c46c4afa2c3b374f9b081e2872f1 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 294df9b361e29322aea60bb007c5b81e33ab4fa4..f6bdbdddaad43804c5b00fd77833cb7e6eba1307 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 c18f7aaabc884eb93d4fd1703ef94f9d1a40b6e7..8897a3acb6da10d26f14cd6750399e38eb21d920 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 c116e4e1692e08993d1aa110c75b5206322c1f92..cca0ec9a471529be62dc2898238ded70b59a91b7 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 8d94997bb2b9f822092790330b9f3bc990f49ceb..d40f1bff61dca375ed8cd10c793a46d93b87a648 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 821a53c773c3147d6859db9477d8354657479102..449ae7cc1b2c8bcd49eeced15427d2d5e9f2071a 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 4b90307f63569ab8902f67537d2fcf5da5eee871..4995bf7acc636aaea220537edebf918d398c256d 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 31fc9648c05a70606aab073f1c699613bfc8dab7..fb20831253a0d989373a66c2f259b6748ed32a43 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 e54e2a76b9635f5687daaf27b6c15212ede87a91..cbd650de4b5d83f3e5260a97eb17ff84f0296bb3 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 c7e80bdf88a88f5072ec525c1194661e0bf2e953..1e23b593256f2b7bd1da010df73bce390bc0645a 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 c3bc87aaa20d399482a919e8b63e29195dd53fc6..acce85913f2ea754687d75fea89b13b86fb0a401 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 b070dc007c10ed068de04c42bdfb574eb9ce8843..9111626bdd2903581163e8be3dfe8f085c199649 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 77e12f92bd57e090bd2f076138d49cace8820ae1..9f2180d6a7a7070f519ad418769bc237a87df346 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 2f9de07ea0a4bff12764aa871c5ec8771e6e9030..507a3ad6fa5ae1a4b6ee4d854286b0936f6c6ea5 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 0a01d87b0b187276cdb4af3b180f201230256f64..f17343bc6647c299ab904cbfb9c2daef31aab150 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 5bc5a62541a0904274e9f6a2cafc52994eb11785..cc9f09c8d5194e411310890206ea8e3a75dd1336 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 f8c7a877bcf8ba48f239ec42a9a652c9ae6890f8..160805a28922e7e2f268f6202570019c3d478111 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 9a5e627feafe77c3ca18344af9da720f600ebd2b..da4d6c4bbe03f611be4383bbc5b7147754576a2d 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 2a909c6309069744cbb3088c5687c9874f890843..08e8e8fdf60b09faa69f89e36a32cbaecd3f922a 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 e4348a2e1b021a1464b694c92243366d9949eb14..ebb271d4dda77448b417dad314916a04a1ac12e5 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 b8f933a19c89c7ba353f09be1cd373b14fcb152c..af30e1cd12d5ac28a075dddee57673bd90243f55 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 bc43961c5f6292ec793b3715766bccaaaa3316d6..b8d3fd70ade7ac04cb304c3dfce7231b3b2e2521 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 eae5434c24981ae2bb2a6cc02441f24e0e56afbb..f85fd5407767f8b1cdc2af0a3e8cd3fde3c7fab6 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 10cfa6512f8b06844a695ac22c58222545d10ab9..0db8e1fc6a7d9208afac91f63f989c376650366c 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 481181436e6289c7c22f8cc14747d8cc606c86c1..5320df1bdafd7c470de4745e1f7e7dacb02192c6 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 6dfca2191183bf45693714609865e674f8e9f8d6..c7c1480b5c2d9c9f61b28cc736a33aeb5f925182 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 98fae5bbdb0fd84f50548d34bce06d292396bc12..b6961a40caeb23c1f426d19d0d2f634d5cab3fe6 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 55ce15f847b5d8fcf3c4c8157a222cd519a70c36..1dfc4e858b5a4a8bcb62f34d3243107236620751 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 e9104c4b3a4ae79772123f135953a4473bb56787..c23f9643dd3ff45a3876627ae7a3d4580c47da00 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 6f8746ad10cab533d458157e7b11b777b96afc81..09ad058c4a4c15c5c1213dac9b8d3c5aec3c81ad 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 3e4c4c37dfe8f601b82e5545d03ece8ce14630c4..0c70d0dbc63e9376185009a32624a77325be947c 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 7b242eb72232e6881bbdb7cfdcb4bbdbda9b8476..0f23b213e968fb4acb729f11c454007dfa0fcc4b 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