diff --git a/sammy/src/blk/Templc_common.f90 b/sammy/src/blk/Templc_common.f90
index fec21230bb0a7288958980b34160da76c8c491eb..7f82fae23ace29e5b02b3567c4cb1dfa0881e00a 100644
--- a/sammy/src/blk/Templc_common.f90
+++ b/sammy/src/blk/Templc_common.f90
@@ -1,31 +1,13 @@
-! replaces contents of B47ZYX which contains common block 'Templc'
+
module templc_common_m
- use AllocateFunctions_m
-! *** b47
-! TODO: Decrypt comment below
-! *** For use in xct and rec
-!
+
IMPLICIT NONE
+ ! direct capture arrays
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
- ! cro and mlb
- real(kind=8),allocatable,dimension(:)::A_Ics
- real(kind=8),allocatable,dimension(:)::A_Isi
- real(kind=8),allocatable,dimension(:)::A_Iwr
- real(kind=8),allocatable,dimension(:)::A_Iwi
- real(kind=8),allocatable,dimension(:)::A_Irinv
- real(kind=8),allocatable,dimension(:)::A_Isphr
- real(kind=8),allocatable,dimension(:)::A_Isphi
- real(kind=8),allocatable,dimension(:)::A_Iphr
- real(kind=8),allocatable,dimension(:)::A_Iphi
- real(kind=8),allocatable,dimension(:)::A_Iz
- real(kind=8),allocatable,dimension(:)::A_Ipwrr
- real(kind=8),allocatable,dimension(:)::A_Ipwri
-
-
end module templc_common_m
diff --git a/sammy/src/blk/Varyr_common.f90 b/sammy/src/blk/Varyr_common.f90
index 78555cd69caf7d03fa15d17aead408e73bd3f9b4..e76e536452f5dc3b301160228e04e6aa998f3cf5 100644
--- a/sammy/src/blk/Varyr_common.f90
+++ b/sammy/src/blk/Varyr_common.f90
@@ -1,22 +1,10 @@
-! replaces contents of B44ZYX which contains common block 'Varyr'
+
module varyr_common_m
-! *** b44
+
IMPLICIT NONE
double precision, save :: Su
- double precision, save :: Sigma
- double precision, save :: Squ
- double precision, save :: VarAbn
- double precision, save :: Sig1
- double precision, save :: Sig2
+ double precision, save :: Squ
double precision, save :: Etz
double precision, save :: Elz
-
- logical::resDeriv
- integer, save :: Npx
- integer, save :: Nnnn
- integer, save :: Nn
- integer, save :: Keff
- integer, save :: Ktru
- integer, save :: Kiso
end module varyr_common_m
diff --git a/sammy/src/cro/CroCrossCalcImpl_M.f90 b/sammy/src/cro/CroCrossCalcImpl_M.f90
index 5f5ccce75c5e891f46d8ce78ea5a9b80286bb181..2f1b9934854215b0d0fde55eadbf48f6f891d34f 100644
--- a/sammy/src/cro/CroCrossCalcImpl_M.f90
+++ b/sammy/src/cro/CroCrossCalcImpl_M.f90
@@ -25,7 +25,6 @@ contains
subroutine CroCrossCalcImpl_calcCross(this, ener, Ipoten)
use mcro2a_m
- use varyr_common_m, only : Su, Squ
class(CroCrossCalcImpl) ::this
real(kind=8)::ener
integer::ipoten
@@ -40,9 +39,6 @@ contains
IF (this%ener.LT.0.0d0) this%ener = -this%ener
- Su = this%ener
- Squ = this%enerSq
-
call Zparsh (this, Ipoten)
if (ener.lt.0.0d0) then
@@ -68,14 +64,7 @@ contains
this%ener = ener
end subroutine
- subroutine CroCrossCalcImpl_setEnergyIndependent(this, reactType, Twomhb, kwcoul, Etac)
- use fixedi_m, only : Kiniso, Kkkiso, Niniso, Nnniso, Nnnsig, Nres, Nrext, Ntotc, Kshift, Ndasig, Ndbsig, Ngbout, Nfpres, Kpolar
- use ifwrit_m, only : Ks_Res, Ksolve
- use exploc_common_m, only : A_Ibound, A_Iechan, A_Ipolar, A_Izke
- use oopsch_common_m, only : Nowwww, Segmen
- use EndfData_common_m, only : covData, resParData, radFitFlags
- use templc_common_m
- use AllocateFunctions_m
+ subroutine CroCrossCalcImpl_setEnergyIndependent(this, reactType, Twomhb, kwcoul, Etac)
use xct1_m
use mcro8_m
@@ -83,95 +72,11 @@ contains
integer::kwcoul, reactType
real(kind=8)::Twomhb, Etac
- integer::n_ix1
- integer::Krext, Mxany, N, N2, N3, N4, N6, N8, NA, Nb, NN
- integer::ns
- !
call CrossSectionCalculator_setEnergyIndependent(this, reactType, Twomhb, kwcoul, Etac)
if (this%wantDerivs) then
call Babb (this,.false.)
end if
-
- ! all the reset, except for the call to fixx and babb will
- ! go away after we did the proper allocating in CroCrossCalc
- !
- ! in order to avoid circular dependencies in the code that will be deleted, some
- ! is just copied here so that it compiles
- !
-
- ns = this%crossData%getNnnsig()
- call allocate_real_data(this%A_Isigxx, ns)
- call allocate_real_data(this%A_Idasig, Ndasig * ns)
- call allocate_real_data(this%A_Idbsig, Ndbsig * ns)
-
-
-
- !
- ! *** find array sizes for xx
- Mxany = this%resData%getNumResonances()
- !
- ! *** find array sizes for added cross section from endf/b-vi
- ! No done in C++
-
-
- Na = 1
- Nb = 1
- IF (Kshift.NE.0) Na = Nres
- IF (Kshift.NE.0) Nb = Mxany*Mxany*this%resData%getNumSpinGroups()
- NN = (Ntotc*(Ntotc+1))/2
- IF (this%wantDerivs) THEN
- N2 = NN*Nfpres
- N3 = Ngbout
- N4 = Nfpres
- ELSE
- N2 = 1
- N3 = 1
- N4 = 1
- END IF
- N6 = 1
- N8 = 1
-
-
-
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- Krext = Nrext
- IF (Nrext.EQ.0) Krext = 1
- !
- ! *** two ***
- N = N2
-
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- ! *** three ***
- n_ix1 = NA
- ! - - - - - - - - - - - - - - - - - - - - - - - - - - - >
- !
- ! *** five ***
- !
- ! - - - - - - - - - - - - - - - - <
- ! *** six ***
- ! CALL Abpart
- ! - - - - - - - - - - - - - - - - >
- !
- ! *** seven ***
- N = Ntotc
- call allocate_real_data(A_Ics, N)
- call allocate_real_data(A_Isi, N)
- call allocate_real_data(A_Iz, N)
- N = Nn
- call allocate_real_data(A_Iwr, N)
- call allocate_real_data(A_Iwi, N)
- N = Nn*2
- call allocate_real_data(A_Irinv, N)
- N = Ntotc*Ntotc
- call allocate_real_data(A_Ipwrr, N)
- call allocate_real_data(A_Ipwri, 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)
end subroutine
end module CroCrossCalcImpl_M
diff --git a/sammy/src/cro/CroCrossCalc_M.f90 b/sammy/src/cro/CroCrossCalc_M.f90
index 1d328af4970dca33131deae733db90d752f8468d..919a834d0d100a2109da35e3518fb685953b892e 100644
--- a/sammy/src/cro/CroCrossCalc_M.f90
+++ b/sammy/src/cro/CroCrossCalc_M.f90
@@ -10,7 +10,13 @@ module CroCrossCalc_M
implicit none
type, extends(XctCrossCalc) :: CroCrossCalc
- real(kind=8),allocatable,dimension(:)::A_Isigxx, A_Idasig, A_Idbsig
+ real(kind=8),allocatable,dimension(:)::Pwrhor, Pwrhoi
+ real(kind=8),allocatable,dimension(:)::Wr, Wi
+ real(kind=8),allocatable,dimension(:)::Cs, Si
+ real(kind=8),allocatable,dimension(:)::Sphr, Sphi
+ real(kind=8),allocatable,dimension(:)::Phr, Phi
+ real(kind=8),allocatable,dimension(:)::Z
+ integer::Kkkfis ! can be set to indicate that only the cross section for one of the fission channels is desired
contains
procedure, pass(this) :: setUpDerivativeList => CroCrossCalc_setUpDerivativeList ! set up crossData, depending on number of isotopes
procedure, pass(this) :: initialize => CroCrossCalc_initialize
@@ -41,12 +47,37 @@ subroutine CroCrossCalc_initialize(this, pars, cov, rad, niso, needAngular, Itze
logical,intent(in)::needAngular, doShiftRes
call XctCrossCalc_initialize(this, pars, cov, rad, niso, needAngular, Itzero, Ilzero, doShiftRes)
+ call allocate_real_data(this%Pwrhor, this%ntriag)
+ call allocate_real_data(this%Pwrhoi, this%ntriag)
+ call allocate_real_data(this%Wr, this%ntriag)
+ call allocate_real_data(this%Wi, this%ntriag)
+ call allocate_real_data(this%Cs, this%ntotc)
+ call allocate_real_data(this%Si, this%ntotc)
+ call allocate_real_data(this%Sphr, this%ntotc)
+ call allocate_real_data(this%Sphi, this%ntotc)
+ call allocate_real_data(this%Phr, this%ntotc)
+ call allocate_real_data(this%Phi, this%ntotc)
+ call allocate_real_data(this%Z, this%ntotc)
+
+ this%Kkkfis = 0
end subroutine
subroutine CroCrossCalc_destroy(this)
class(CroCrossCalc) :: this
call XctCrossCalc_destroy(this)
+
+ deallocate(this%Pwrhor)
+ deallocate(this%Pwrhoi)
+ deallocate(this%Wr)
+ deallocate(this%Wi)
+ deallocate(this%Cs)
+ deallocate(this%Si)
+ deallocate(this%Sphr)
+ deallocate(this%Sphi)
+ deallocate(this%Phr)
+ deallocate(this%Phi)
+ deallocate(this%Z)
end subroutine
end module CroCrossCalc_M
diff --git a/sammy/src/cro/mcro0.f90 b/sammy/src/cro/mcro0.f90
index a4223d1e56bf8af2d256e9b75bc75197d0957053..5d789c6912f556fce80f8a94be7b8798a6e05a31 100644
--- a/sammy/src/cro/mcro0.f90
+++ b/sammy/src/cro/mcro0.f90
@@ -3,21 +3,15 @@
!
SUBROUTINE Samcro_0
!
- use fixedi_m, only : Iq_Iso, Jcros, Kiniso, Kkkiso, Niniso, Nnniso, Nnnsig, Npfil3, Nres, Nrext, Nrfil3, Ntotc
+ use fixedi_m, only : Kiniso, Kkkiso, Nnniso, Nnnsig, Niniso
use ifwrit_m, only : Ks_Res, Ksolve
- use exploc_common_m, only : A_Ibound, A_Iechan, A_Ipolar, A_Izke
use oopsch_common_m, only : Nowwww, Segmen
- use EndfData_common_m, only : covData, resParData, radFitFlags
- use templc_common_m
- use AllocateFunctions_m
- use rsl7_m, only : Set_Kws_Xct
- use mcro8_m
+ use rsl7_m, only : Set_Kws_Xct, Figure_Kws_Cro
use AuxGridHelper_M, only : setAuxGridOffset, &
setAuxGridRowMax
IMPLICIT None
- real(kind=8),allocatable,dimension(:)::A_Ix1
- integer::n_ix1
- integer::Krext, Mxany, N, N2, N3, N4, N6, N8, NA, Nb, NN
+ integer::I,Kone, Idimen
+ external Idimen
!
!
WRITE (6,99999)
@@ -26,185 +20,25 @@
Segmen(2) = 'R'
Segmen(3) = 'O'
Nowwww = 0
+
+ call setAuxGridOffset(1) ! reset starting point for auxillary grid
+ call setAuxGridRowMax(0)
!
- IF (covData%getPupedParam().GT.0) THEN
- WRITE (6,10100)
-10100 FORMAT ('SAMCRO coding does not include options for', /, &
- 'PUPs (Propagated-Uncertainty Parameters, Flag=3).', /, &
- 'Contact N.M.Larson at LarsonNM@ornl.gov if you', /, &
- 'desperately need this option.')
- END IF
-!
- CALL Initil
Ks_Res = Ksolve
- IF (Jcros.EQ.6) THEN
- Nnnsig = 2
-! This is for eta-data only
- ELSE
- Nnnsig = 1
- ENDIF
!
!
! *** organize for broadening
IF (Nnniso.NE.1) STOP '[STOP in Samcro_0 in cro/mcro0.f]'
-!
-! *** find array sizes for xx
- MxAny = resParData%getNumResonances()
-!
-! *** find array sizes for added cross section from endf/b-vi
-! Now done in C++
- Npfil3 = 1
- Nrfil3 = 1
-! *** GUESSTIMATE SIZE OF ARRAY NEEDED FOR SAMMY-Cross section
- call setAuxGridOffset(1) ! reset auxillary grid offset
- call setAuxGridRowMax(0)
- CALL Estcro (Na, Nb, N2, N3, N4, NN, N6, N8, Mxany)
-!
-! *** one ***
- CALL Set_Kws_Xct
- !call calcData%setUpList(resParData, radFitFlags, Iq_Iso)
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- Krext = Nrext
- IF (Nrext.EQ.0) Krext = 1
-!
-! *** two ***
- N = N2
-!
- !call allocate_real_data(A_Ixx, Nres)
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - <
-! *** three ***
- n_ix1 = NA
- if (Mxany.gt.NA) n_ix1 = Mxany
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - >
-!
-!
-!
-! *** four ***
-! - - - - - - - - - - - - - - - - - - - - - - <
-!
-! *** five ***
-!
-! - - - - - - - - - - - - - - - - <
-! *** six ***
-! CALL Abpart
-! - - - - - - - - - - - - - - - - >
-!
-! *** seven ***
- N = Ntotc
- !call allocate_real_data(A_Ics, N)
- !call allocate_real_data(A_Isi, N)
- !call allocate_real_data(A_Iz, N)
- N = Nn
- !call allocate_real_data(A_Iwr, N)
- !call allocate_real_data(A_Iwi, N)
- N = Nn*2
- !call allocate_real_data(A_Irinv, N)
- N = Ntotc*Ntotc
- !call allocate_real_data(A_Ipwrr, N)
- !call allocate_real_data(A_Ipwri, 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 = N6
-! CALL Parsh
-! - - - - - - - - - - - - - - - - - - - - - - >
-!
-!
-! *** eight ***
-! actual routine that does the reconstruction is called from
-! ZeroKCrossCorrections
-!
- !deallocate(A_Ics)
- !deallocate(A_Isi)
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
-!
-!
+ CALL Figure_Kws_Cro (Kone)
+ CALL Set_Kws_Xct
+
Nnnsig = 1
Kiniso = Kkkiso
Niniso = Nnniso
- RETURN
-!
- END
-!
-!
-! _____________________________________________________________
-!
- SUBROUTINE Estcro (Na, Nb, N2, N3, N4, NN, N6, N8, Mxany)
-!
-! *** GUESSTIMATE SIZE OF ARRAY NEEDED FOR SAMMY-Cross section
-!
- use fixedi_m, only : Jcros, Kshift, Nfpres, Ngbout, Ngroup, Npfil3, Nres, Ntotc, Nrfil3, numcro
- use ifwrit_m, only : Ksolve
- use rsl7_m
- IMPLICIT None
-
- integer::Na, Nb, N2, N3, N4, NN, N6, N8, Mxany
- integer::I, Idimen
- integer::K, K1, K2, K3, K4, K5, K6, K7, K8, Ka, Kone,numE
- external Idimen
-!
-!
-
- Na = 1
- Nb = 1
- IF (Kshift.NE.0) Na = Nres
- IF (Kshift.NE.0) Nb = Mxany*Mxany*Ngroup
- NN = (Ntotc*(Ntotc+1))/2
- IF (Ksolve.NE.2) THEN
- N2 = NN*Nfpres
- N3 = Ngbout
- N4 = Nfpres
- ELSE
- N2 = 1
- N3 = 1
- N4 = 1
- END IF
- N6 = 1
- N8 = 1
-!
-! *** one ***
- CALL Figure_Kws_Cro (Kone)
- K1 = Ngroup*2 + Kone
-!
-! *** two ***
- K2 = (4*N2+Nres)
-!
-! *** three ***
- K3 = (NA+2*NB)
-!
-! *** four ***
- K4 = N3
- IF (Jcros.EQ.6) K4 = K4 + N3
-!
-! *** five ***
- K5 = (3*Nres + N4)
-!
-! *** Andy ***
- Ka = 2*Npfil3 + 2*Nrfil3
-!
-! *** six ***
- K6 = (2*Nres + 2*N4)
-!
-! *** seven ***
- K7 = (4*Ntotc + 4*Nn + 4*Nn + 6*Ntotc*Ntotc + &
- 4*Ntotc + 2*Nn*Nn + N6)
-!
- K5 = K5 + MAX0 (K6,K7) + Ka
-!
-! *** eight ***
- K8 = N8
-!
- K4 = K4 + MAX0 (K5,K8)
- K2 = K2 + MAX0 (K3,K4)
- K = K1 + K2
-!
- K = Idimen (K, 1, 'K, 1')
- I = Idimen (K, -1, 'K, -1')
- I = Idimen (0, 0, '0, 0')
+ I = Idimen (0, 0, '0, 0') ! preserve output
RETURN
+!
END
diff --git a/sammy/src/cro/mcro2.f90 b/sammy/src/cro/mcro2.f90
index 897d34d578f621aec220253ee203073914c4f363..d0c4dd0fe7c5b5c0b7a779af342c04f82673e72c 100644
--- a/sammy/src/cro/mcro2.f90
+++ b/sammy/src/cro/mcro2.f90
@@ -9,19 +9,19 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Zeror_Cro (Wr, Wi, Pwrhor, Pwrhoi, Ntot)
+ SUBROUTINE Zeror_Cro (calc)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Wr(*), Wi(*), Pwrhor(*), Pwrhoi(*)
- N = Ntot
+ class(CroCrossCalc)::calc
+
+ calc%Pwrhor = 0.0d0
+ calc%Pwrhoi = 0.0d0
+ calc%Wr = 0.0d0
+ calc%Wi = 0.0d0
Jk = 0
- DO J=1,N
+ DO J=1,calc%ntotc
DO K=1,J
- Jk = Jk + 1
- Wr(Jk) = 0.0D0
- IF (J.EQ.K) Wr(Jk) = 1.0D0
- Wi(Jk) = 0.0D0
- Pwrhor(Jk) = 0.0D0
- Pwrhoi(Jk) = 0.0D0
+ Jk = Jk + 1
+ IF (J.EQ.K) calc%Wr(Jk) = 1.0D0
END DO
END DO
RETURN
@@ -30,45 +30,46 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Rinvrs (calc, Rinv, Sphr, Sphi,Ntot)
+ SUBROUTINE Rinvrs (calc, Ntot)
!
-! *** PURPOSE -- INVERT Rmat TO GIVE Rinv
+! *** PURPOSE -- INVERT Rmat TO GIVE Yinv
!
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ IMPLICIT None
class(CroCrossCalc)::calc
- DIMENSION Rinv(2,*), Sphr(*), Sphi(*)
+ integer::Ntot
+ integer::I, Ij, J
!
IF (Ntot.LE.3) THEN
!
IF (Ntot.EQ.1) THEN
-! *** ONE CHANNEL -- (inverse of Rmat) = Rinv
- CALL Onech (calc%Rmat, Rinv)
+! *** ONE CHANNEL -- (inverse of Rmat) = Yinv
+ CALL Onech (calc%Rmat, calc%Yinv)
!
ELSE IF (Ntot.EQ.2) THEN
-! *** TWO CHANNELS -- (inverse of Rmat) = Rinv
- CALL Twoch (calc%Rmat, Rinv)
+! *** TWO CHANNELS -- (inverse of Rmat) = Yinv
+ CALL Twoch (calc%Rmat, calc%Yinv)
!
ELSE IF (Ntot.EQ.3) THEN
-! *** THREE CHANNELS -- (inverse of Rmat) = Rinv
- CALL Three (calc%Rmat, Rinv)
+! *** THREE CHANNELS -- (inverse of Rmat) = Yinv
+ CALL Three (calc%Rmat, calc%Yinv)
!
END IF
Ij = 0
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- 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)
+ calc%Xqr(J,I) = calc%Yinv(1,Ij)*calc%Sphr(I) - calc%Yinv(2,Ij)*calc%Sphi(I)
+ calc%Xqi(J,I) = calc%Yinv(1,Ij)*calc%Sphi(I) + calc%Yinv(2,Ij)*calc%Sphr(I)
IF (I.NE.J) THEN
- 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)
+ calc%Xqr(I,J) = calc%Yinv(1,Ij)*calc%Sphr(J) - calc%Yinv(2,Ij)*calc%Sphi(J)
+ calc%Xqi(I,J) = calc%Yinv(1,Ij)*calc%Sphi(J) + calc%Yinv(2,Ij)*calc%Sphr(J)
END IF
END DO
END DO
!
ELSE
! *** INVERT Rmat TO GIVE Rinv FOR MORE THAN THREE CHANNELS
- CALL Four (calc%Rmat, Rinv, Sphr, Sphi, calc%Xqr, calc%Xqi, Ntot)
+ CALL Four (calc%Rmat, calc%Yinv, calc%Sphr, calc%Sphi, calc%Xqr, calc%Xqi, Ntot)
!
END IF
!
@@ -86,10 +87,14 @@ 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(:,:), Dummy(2,*), Iii(100), Sphr(*), Sphi(*), &
+ IMPLICIT None
+ real(kind=8)::Rmat(:,:), Dummy(2,*), Sphr(:), Sphi(:), &
Xqr(Ntot,*), Xqi(Ntot,*)
- DATA Maxaa /100/, Zero /0.0d0/
+ integer:: Iii(100)
+ integer::Ntot
+ real(kind=8),parameter::Zero = 0.0d0
+ integer,parameter::Maxaa=100
+ integer::Info, J, K
!
IF (Ntot.GT.Maxaa) STOP '[STOP in Four in cro/mcro2.f]'
!
@@ -115,9 +120,7 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Setr_Cro (calc, Ntot, Bound, Echan, &
- Min, igr, &
- Z, Sphr, Sphi, Phr, Phi, Zke, Lrmat)
+ SUBROUTINE Setr_Cro (calc, Min, igr, Lrmat)
!
! *** PURPOSE -- GENERATE Rmat = 1/(S-B+IP)
! *** - Sum Beta*Beta/((DEL E)**2-(Gamgam/2)**2)
@@ -125,17 +128,12 @@ contains
! *** AND Sphr,Sphi = SQrT(P)/(S-B+IP)
! *** AND Phr,Phi = P/(S-B+IP)
!
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use broad_common_m
- use varyr_common_m
- use EndfData_common_m
use RMatResonanceParam_M
use SammyResonanceInfo_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ IMPLICIT None
!
class(CroCrossCalc)::calc
+ integer::Ntot, Min, igr, Lrmat
type(SammyResonanceInfo)::resInfo
type(RMatResonance)::resonance
type(SammySpinGroupInfo)::spinInfo
@@ -146,36 +144,32 @@ contains
logical::hasRext
type(SammyRExternalInfo)::rextInfo
type(RExternalFunction)::rext
- real(kind=8)::Parext(7)
- DIMENSION &
- Bound(Ntotc,*), Echan(Ntotc,*), &
- Sphr(*), Sphi(*), Phr(*), Phi(*), Z(*), &
- Zke(*)
-!
-! DIMENSION Ishift(Ntotc,Ngroup), Lpent(Ntotc,Ngroup),
-! * Lspin(Ntotc,Ngroup), Bound(Ntotc,Ngroup),
-! * Echan(Ntotc,Ngroup),
-! * Rmat(2,NTriag),
-! * Sphr(Ntotc), Sphi(Ntotc), Phr(Ntotc), Phi(Ntotc),
-! * Z(Ntotc)
- DATA Zero /0.0d0/, One /1.0d0/
-!
- call resParData%getSpinGroupInfo(spinInfo, igr)
+ real(kind=8)::Parext(7), Su
+
+ real(kind=8),parameter::Zero=0.0d0, One = 1.0d0
+ real(kind=8)::Aloge, beta, channelWidthC, channelWidthCPrime, Dp, Ds
+ real(kind=8)::Hi, Hr, P, Ps, Rho
+ integer::i, ichan, iffy, Ii, Ishift, J, K, Kl, L, Nrext
+!
+ call calc%resData%getSpinGroupInfo(spinInfo, igr)
Ntot = spinInfo%getNumChannels()
- IF (Ntot.EQ.3 .AND. Su.GT.Zero .AND. Su.LT.Echan(3,igr)) Ntot = 2
- IF (Ntot.EQ.2 .AND. Su.GT.Zero .AND. Su.LT.Echan(2,igr)) Ntot = 1
+ Su = calc%ener
+ IF (Ntot.EQ.3 .AND. Su.GT.Zero .AND. Su.LT.calc%Echan(3,igr)) Ntot = 2
+ IF (Ntot.EQ.2 .AND. Su.GT.Zero .AND. Su.LT.calc%Echan(2,igr)) Ntot = 1
!
! *** INITIALIZE Rmat ( = NEGATIVE OF R-MATRIX)
!
Aloge = Zero
KL = 0
DO K=1,Ntot
- hasRext = resParData%hasRexInfo(igr, K)
+ hasRext = calc%resData%hasRexInfo(igr, K)
Parext = 0.0d0
+ Nrext = 0
IF (hasRext) then
- call resparData%getRextInfoByGroup(rextInfo, igr, K)
- call resparData%getRext(rext, rextInfo)
- DO J = 1, rextInfo%getNrext()
+ call calc%resData%getRextInfoByGroup(rextInfo, igr, K)
+ call calc%resData%getRext(rext, rextInfo)
+ Nrext = rextInfo%getNrext()
+ DO J = 1, Nrext
Parext(J) = rext%getSammyValue(J)
end do
Aloge &
@@ -195,11 +189,11 @@ contains
END IF
END DO
END DO
- DO I=Min,resParData%getNumResonances()
- call resParData%getResonanceInfo(resInfo, I)
+ DO I=Min,calc%resData%getNumResonances()
+ call calc%resData%getResonanceInfo(resInfo, I)
if (resInfo%getSpinGroupIndex().ne.igr) exit
- call resParData%getRedResonance(resonance, resInfo)
+ call calc%resData%getRedResonance(resonance, resInfo)
KL = 0
DO K=1,Ntot
ichan = spinInfo%getWidthForChannel(K)
@@ -242,22 +236,22 @@ contains
Ii = 0
DO I=1,Ntot
Ii = Ii + I
- Sphr(I) = Zero
- Sphi(I) = Zero
- Phr (I) = Zero
- Phi (I) = Zero
- Z (I) = Zero
+ calc%Sphr(I) = Zero
+ calc%Sphi(I) = Zero
+ calc%Phr (I) = Zero
+ calc%Phi (I) = Zero
+ calc%Z (I) = Zero
Iffy = 0
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)
!
- IF (Su.LE.Echan(I,igr)) THEN
+ IF (Su.LE.calc%Echan(I,igr)) THEN
WRITE (21,10000)
WRITE (6,10000)
10000 FORMAT (' Oops -- error in Sub. SETR in mcro2 -- see NML to f &
@@ -275,35 +269,35 @@ contains
Ishift = 0
end if
- Rho = channel%getApt()*Zke(I)*dSQRT(Su-Echan(I,igr))
- CALL Pgh (Rho, L, Bound(I,igr), Hr, Hi, P, Dp, Ds, &
+ Rho = channel%getApt()*calc%Zke(I,igr)*dSQRT(Su-calc%Echan(I,igr))
+ CALL Pgh (Rho, L, calc%Bound(I,igr), Hr, Hi, P, Dp, Ds, &
Ishift, Iffy)
! HR AND HI ARE REAL AND IMAG PARTS OF 1/(S-B+IP)
! *** except when S-B+iP=Zero, in which case iffy=1
IF (Iffy.EQ.0) THEN
Ps = dSQRT(P)
- Sphr(I) = Hr*Ps
- Sphi(I) = Hi*Ps
- Phr(I) = Hr*P
- Phi(I) = Hi*P
+ calc%Sphr(I) = Hr*Ps
+ calc%Sphi(I) = Hi*Ps
+ calc%Phr(I) = Hr*P
+ calc%Phi(I) = Hi*P
calc%Rmat(1,Ii) = Hr + calc%Rmat(1,II)
calc%Rmat(2,Ii) = Hi + calc%Rmat(2,II)
- Z(I) = Dp/P
+ calc%Z(I) = Dp/P
END IF
!
ELSE
! *** HERE penetrability is not calculated; or, it is Zero
- Sphr(I) = Zero
- Sphi(I) = -One
-! Phr(I) = Zero
- Phi(I) = -One
+ calc%Sphr(I) = Zero
+ calc%Sphi(I) = -One
+! calc%Phr(I) = Zero
+ calc%Phi(I) = -One
! calc%Rmat(1,II) = calc%Rmat(1,II)
calc%Rmat(2,II) = calc%Rmat(2,II) - One
IF (Iffy.NE.0) THEN
calc%Rmat(1,II) = Zero
calc%Rmat(2,II) = -One
END IF
-! Z(I) = Zero
+! calc%Z(I) = Zero
END IF
!
END DO
diff --git a/sammy/src/cro/mcro2a.f90 b/sammy/src/cro/mcro2a.f90
index a17ef666667772b0ed16a989953d2f973627adb4..7d4429276ee5c49c78c54b9ac464373090e7e30c 100644
--- a/sammy/src/cro/mcro2a.f90
+++ b/sammy/src/cro/mcro2a.f90
@@ -7,22 +7,15 @@ contains
! *** AND THE ( PARTIAL DERIVATIVES OF THE CROSS SECTION
! *** WITH RESPECT TO THE VARIED PARAMETERS ) = SJkL
!
- use over_common_m
- use oops_common_m
- use fixedi_m
- use ifwrit_m
- use exploc_common_m
- use templc_common_m
use CroCrossCalc_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ IMPLICIT None
class(CroCrossCalc)::calc
+ integer::Ipoten
!
!
CALL Abpart_Cro (calc)
!
- CALL Parsh ( calc, &
- A_Izke , &
- Ipoten)
+ CALL Parsh ( calc, Ipoten)
!
RETURN
END
@@ -34,13 +27,9 @@ contains
! *** PURPOSE -- GENERATE Upr AND Upi = ENERGY-DEPENDENT Pieces OF
! *** PR AND PI = PARTIAL OF R WRT U-PARAMETERS
!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
use SammyRMatrixParameters_M
use SammyResonanceInfo_M
use SammySpinGroupInfo_M
- use EndfData_common_m
use RMatResonanceParam_M
use CroCrossCalc_M
IMPLICIT None
@@ -52,7 +41,7 @@ contains
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
+ real(kind=8)::Upr, Upi, su
!
DATA Zero /0.0d0/, Two /2.0d0/
!
@@ -60,9 +49,10 @@ contains
! *** AND Alphai = Gamgam/2 / ( DITTO )
!
calc%needAlphai = .false.
- DO I=1,resParData%getNumResonances()
- call resParData%getResonanceInfo(resInfo, I)
- call resParData%getRedResonance(resonance, resInfo)
+ Su = dAbs(calc%ener)
+ DO I=1,calc%resData%getNumResonances()
+ call calc%resData%getResonanceInfo(resInfo, I)
+ call calc%resData%getRedResonance(resonance, resInfo)
calc%Xden(I) = Zero
calc%Alphar(I)= Zero
calc%Alphai(I)= Zero
@@ -72,10 +62,10 @@ contains
end if
IF (dABS(calc%Difen(I)).LT.100.0D0*calc%Difmax(I)) calc%needAlphai(I) = .true.
- call resParData%getResonanceInfo(resInfo, I)
+ call calc%resData%getResonanceInfo(resInfo, I)
igr = resInfo%getSpinGroupIndex()
IF (resInfo%getIncludeInCalc()) THEN
- call resParData%getSpinGroupInfo(spinInfo, igr)
+ call calc%resData%getSpinGroupInfo(spinInfo, igr)
igam = spinInfo%getGammaWidthIndex()
G2 = resonance%getWidth(igam)**2
G3 = G2**2
@@ -147,24 +137,13 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Parsh ( calc, &
- Zke, &
- Ipoten)
+ SUBROUTINE Parsh ( calc, Ipoten)
!
!
! *** PURPOSE -- FORM THE CROSS SECTION Sigma
! *** AND THE ( PARTIAL DERIVATIVES OF THE CROSS SECTION
! *** WITH RESPECT TO THE VARIED PARAMETERS ) = SJKL
!
- 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 EndfData_common_m
use SammySpinGroupInfo_M
use SammyRMatrixParameters_M
use SammyResonanceInfo_M
@@ -175,76 +154,60 @@ contains
use mcro2_m
use mcro4_m
use CroCrossCalc_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ IMPLICIT None
!
!
class(CroCrossCalc)::calc
- DIMENSION Zke(Ntotc,*)
+ integer::Ipoten
type(SammyResonanceInfo)::resInfo
type(SammySpinGroupInfo)::spinInfo
type(RMatResonance)::resonance
type(SammyRExternalInfo)::rextInfo
-!
-! DIMENSION
-! * Zke(Ntotc,Ngroup)
-!
+ real(kind=8)::Agoj, VarAbn
+ integer::I, iflAbund, Ipar, Iso, istart, J, Lrmat, min, N, nent, next
+ integer::Nn2, Nnf1, Ntot, Ntotnn
+
!
!
!
Nnf1 = 0
Nn2 = 0
- Jstart = Nfpres
! *** DO LOOP OVER GROUPS (IE SPIN-PARITY GROUPS) -
! *** GOES TO END OF SUBROUTINE
!
!
istart = 0
ipar = 0
- DO N=1,resParData%getNumSpinGroups()
- call resParData%getSpinGroupInfo(spinInfo, N)
+ DO N=1,calc%resData%getNumSpinGroups()
+ call calc%resData%getSpinGroupInfo(spinInfo, N)
iflAbund = spinInfo%getAbundanceFitFlag()
min = istart + 1
call calc%getParamPerSpinGroup(istart, N)
IF (spinInfo%getIncludeInCalc()) THEN
- IF (Numiso.GT.0) THEN
- Iso = spinInfo%getIsotopeIndex()
- VarAbn = resParData%getAbundanceByIsotope(Iso)
- ELSE
- VarAbn = spinInfo%getAbundance()
- Iso = 1
- END IF
+ Iso = spinInfo%getIsotopeIndex()
+ VarAbn = calc%getAbundance(N)
!
- Nnnn = N
- Npx = 0
- IF (Ksolve.NE.2) then
- do I = 1, spinInfo%getNumChannels()
- 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.gt.0) exit
- end do
- end if
Nnf1 = Nnf1 + Nn2
ntot = spinInfo%getNumChannels()
Nn2 = Ntot*(Ntot+1)
- NN = Nn2/2
+ !NN = Nn2/2
!
!
- IF (Kcros.LE.2) THEN
+ IF (calc%reactType.LE.2) THEN
! *** CALCULATE SIN AND COS OF POTENTIAL SCATTERING PHASE SHIFT,
! *** AND R-EXTERNAL PHASE SHIFT
- CALL Cossin (resparData, Zke(1,N), &
- A_Ics, A_Isi, calc%Dphi, Nnnn, Ipoten, &
- Squ, Su)
+ CALL Cossin(calc%resData, &
+ calc%Zke(1,N), &
+ calc%Cs, &
+ calc%Si, &
+ calc%Dphi, &
+ N, &
+ Ipoten, &
+ calc%enerSq, &
+ calc%ener)
END IF
!
!
@@ -253,61 +216,47 @@ contains
Ntotnn = spinInfo%getNumChannels()
Lrmat = 0
- CALL Setr_Cro (calc, Ntotnn, &
- A_Ibound , A_Iechan , Min, n, &
- A_Iz , A_Isphr , A_Isphi , A_Iphr , A_Iphi , &
- Zke(1,N), Lrmat)
+ CALL Setr_Cro (calc, Min, n, Lrmat)
!
IF (Lrmat.EQ.1) THEN
- CALL Zeror_Cro (A_Iwr , A_Iwi , A_Ipwrr , A_Ipwri , &
- Ntotnn)
+ CALL Zeror_Cro (calc)
ELSE
! *** INVERT R-MATRIX; generate Xqr & Xqi
- CALL Rinvrs (calc, A_Irinv , A_Isphr , A_Isphi , Ntotnn)
+ CALL Rinvrs (calc, Ntotnn)
! *** GENERATE WR AND WI MATRICES
- CALL Wrwi (calc, Ntotnn, A_Iwr , A_Iwi, &
- A_Isphr , A_Isphi , A_Iphr ,A_Iphi )
+ CALL Wrwi (calc, Ntotnn )
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_Ipwrr , A_Ipwri , &
- A_Iphr , A_Iphi , N )
+ IF (Lrmat.EQ.0 .AND. calc%wantDerivs) CALL Partls (calc, Ntotnn, N )
!
Agoj = VarAbn*spinInfo%getGFactor()
! *** TOTAL CROSS SECTIONS
nent = spinInfo%getNumEntryChannels()
next = spinInfo%getNumExitChannels()
- IF (Kcros.EQ.1) CALL Total (calc, spinInfo, &
- A_Ics, A_Isi, &
- A_Iwr , A_Iwi , A_Ipwrr , A_Ipwri , Lrmat, &
- N, Zke(1,N), &
+ IF (calc%reactType.EQ.1) CALL Total (calc, spinInfo, &
+ Lrmat, &
+ N, &
iflAbund, ipar)
!
! *** SCATTERING (ELASTIC) CROSS SECTION
- IF (Kcros.EQ.2) CALL Elastc (calc, spinInfo, &
- A_Ics, &
- A_Isi, A_Iwr , A_Iwi, A_Ipwrr , A_Ipwri , &
+ IF (calc%reactType.EQ.2) CALL Elastc (calc, spinInfo, &
Lrmat, &
- N, Zke(1,N), &
+ N, &
iflAbund, ipar)
!
! *** REACTION (FISSION, INELASTIC SCATTERING, ETC.) CROSS SECTIONS
- IF (Kcros.EQ.3 .OR. Kcros.EQ.5 .OR. Kcros.EQ.6) CALL Reactn &
+ IF (calc%reactType.EQ.3 .OR. calc%reactType.EQ.5 .OR. calc%reactType.EQ.6) CALL Reactn &
( calc, spinInfo, &
- A_Iwr, A_Iwi, A_Ipwrr , &
- A_Ipwri , &
Lrmat, N, &
- Zke(1,N), iflAbund, ipar)
+ iflAbund, ipar)
!
! *** CAPTURE CROSS SECTION
- IF (Kcros.EQ.4 .OR. Kcros.EQ.5 .OR. Kcros.EQ.6) CALL Captur &
+ IF (calc%reactType.EQ.4 .OR. calc%reactType.EQ.5 .OR. calc%reactType.EQ.6) CALL Captur &
( calc, spinInfo, &
- A_Iwr, A_Iwi, A_Ipwrr , &
- A_Ipwri , &
Lrmat, N, &
- Zke(1,N), iflAbund, ipar)
+ iflAbund, ipar)
!
END IF
ipar = ipar + calc%inumSize
diff --git a/sammy/src/cro/mcro4.f90 b/sammy/src/cro/mcro4.f90
index e549200d2483985117d2bfcaaf647ae3747cbadf..81a76dd7014eefc14cf172dd0786248721cb920c 100644
--- a/sammy/src/cro/mcro4.f90
+++ b/sammy/src/cro/mcro4.f90
@@ -5,8 +5,7 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Wrwi (calc, Ntot, Wr, Wi, Sphr, Sphi, &
- Phr, Phi)
+ SUBROUTINE Wrwi (calc, Ntot)
!
! *** PURPOSE -- use Xqr AND Xqi MATRICES, WHERE
! *** Xq(J,I) = XINVERSE * SQRT(P)/(S-B+IP)
@@ -18,15 +17,10 @@ contains
! *** which is
! *** -SQRT(P)/(S-B+IP) * XQ(Kl)
!
- use fixedi_m
- use ifwrit_m
IMPLICIT none
!
class(CroCrossCalc)::calc
integer ::ntot
- real(kind=8) :: Phr(*), Phi(*), Sphr(*), Sphi(*), Wr(*), Wi(*)
-! DIMENSION Rinv(2,NN), Phr(Ntotc), Phi(Ntotc),
-! * Sphr(Ntotc), Sphi(Ntotc), Wr(NN), Wi(NN)
real(kind=8), parameter :: One = 1.0d0, Two = 2.0d0
integer :: I, Ij, J
@@ -36,13 +30,13 @@ contains
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- 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)
+ calc%Xxxxi(Ij) = calc%Sphi(J)*calc%Xqr(J,I) + calc%Sphr(J)*calc%Xqi(J,I)
+ calc%Xxxxr(Ij) = calc%Sphr(J)*calc%Xqr(J,I) - calc%Sphi(J)*calc%Xqi(J,I)
+ calc%Wr(Ij) = -Two*calc%Xxxxi(Ij)
+ calc%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)
+ calc%Wr(Ij) = calc%Wr(Ij) + One + Two*calc%Phi(I)
+ calc%Wi(Ij) = calc%Wi(Ij) - Two*calc%Phr(I)
END IF
END DO
END DO
@@ -52,8 +46,7 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Partls (calc, Ntot, Z, Pwrhor, Pwrhoi, &
- Phr, Phi, igr)
+ SUBROUTINE Partls (calc, Ntot, igr)
!
! *** PURPOSE -- GENERATE Qr,Qi =
! *** SQRT(P)/(S-B+IP) * (Rinv*Rinv
@@ -65,18 +58,11 @@ contains
! *** W(Ij) WrT Rhoi, AND THE CORRESPONDING IMAGINARY PART
!
!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
IMPLICIT None
!
class(CroCrossCalc)::calc
integer :: ntot
- real(kind=8) :: Pwrhor(*), Pwrhoi(*), Phr(*), Phi(*), Z(*)
-!
-! DIMENSION
-! * Pwrhor(NN), Pwrhoi(NN),
-! * Phr(Ntot), Phi(Ntot), Z(Ntot)
+
!
real(kind=8), parameter :: Zero = 0.0d0, One = 1.0d0, Two = 2.0d0
@@ -85,7 +71,7 @@ contains
logical::iflApe, iflApt
- call needRadiusDeriv(Ksolve, igr, iflApe, iflApt)
+ call needRadiusDeriv(calc, igr, iflApe, iflApt)
!
IF (calc%wantDerivs) THEN
Kl = 0
@@ -112,47 +98,45 @@ contains
END IF
!
IF (.not.iflApt) RETURN
- DO Ij=1,NN
- Pwrhor(Ij) = Zero
- Pwrhoi(Ij) = Zero
- END DO
+ calc%Pwrhoi = Zero
+ calc%Pwrhor = Zero
!
Ij = 0
Ii = 0
DO I=1,Ntot
Ii = Ii + I
- 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) - calc%Xxxxr(Ii)
- AI = One + Two*Phi(I) - calc%Xxxxi(Ii)
- Pwrhor(Ii) = Pwrhor(Ii) + &
- Two*(calc%Xxxxr(Ii)*AR-calc%Xxxxi(Ii)*AI)*Z(I)
- Pwrhoi(Ii) = Pwrhoi(Ii) + &
- Two*(calc%Xxxxr(Ii)*AI+calc%Xxxxi(Ii)*AR)*Z(I)
+ calc%Pwrhor(Ii) = -Two*calc%Z(I)*(calc%Phr(I)*calc%Phr(I)-calc%Phi(I)* (calc%Phi(I)+One))
+ calc%Pwrhoi(Ii) = -Two*calc%Z(I)*( Two*calc%Phr(I)*calc%Phi(I) + calc%Phr(I) )
+ IF (calc%Z(I).NE.Zero) THEN
+ AR = Two*calc%Phr(I) - calc%Xxxxr(Ii)
+ AI = One + Two*calc%Phi(I) - calc%Xxxxi(Ii)
+ calc%Pwrhor(Ii) = calc%Pwrhor(Ii) + &
+ Two*(calc%Xxxxr(Ii)*AR-calc%Xxxxi(Ii)*AI)*calc%Z(I)
+ calc%Pwrhoi(Ii) = calc%Pwrhoi(Ii) + &
+ Two*(calc%Xxxxr(Ii)*AI+calc%Xxxxi(Ii)*AR)*calc%Z(I)
END IF
DO J=1,I
Ij = Ij + 1
IF (I.NE.J) THEN
- IF (Z(I).NE.Zero) THEN
- AR = Two*Phr(I)
- AI = One + Two*Phi(I)
- Pwrhor(Ij) = Pwrhor(Ij) + Z(I)* &
+ IF (calc%Z(I).NE.Zero) THEN
+ AR = Two*calc%Phr(I)
+ AI = One + Two*calc%Phi(I)
+ calc%Pwrhor(Ij) = calc%Pwrhor(Ij) + calc%Z(I)* &
(AR*calc%Xxxxr(Ij)-AI*calc%Xxxxi(Ij))
- Pwrhoi(Ij) = Pwrhoi(Ij) + Z(I)* &
+ calc%Pwrhoi(Ij) = calc%Pwrhoi(Ij) + calc%Z(I)* &
(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)* &
+ IF (calc%Z(J).NE.Zero) THEN
+ AR = Two*calc%Phr(J)
+ AI = One + Two*calc%Phi(J)
+ calc%Pwrhor(Ij) = calc%Pwrhor(Ij) + calc%Z(J)* &
(AR*calc%Xxxxr(Ij)-AI*calc%Xxxxi(Ij))
- Pwrhoi(Ij) = Pwrhoi(Ij) + Z(J)* &
+ calc%Pwrhoi(Ij) = calc%Pwrhoi(Ij) + calc%Z(J)* &
(AR*calc%Xxxxi(Ij)+AI*calc%Xxxxr(Ij))
END IF
END IF
DO M=1,Ntot
- IF (Z(M).NE.Zero .AND. (I.NE.J .OR. I.NE.M)) THEN
+ IF (calc%Z(M).NE.Zero .AND. (I.NE.J .OR. I.NE.M)) THEN
IF (I.GE.M) THEN
IM = (I*(I-1))/2 + M
ELSE
@@ -163,9 +147,9 @@ contains
ELSE
JM = (M*(M-1))/2 + J
END IF
- Pwrhor(Ij) = Pwrhor(Ij) - Two*Z(M)* &
+ calc%Pwrhor(Ij) = calc%Pwrhor(Ij) - Two*calc%Z(M)* &
(calc%Xxxxr(IM)*calc%Xxxxr(JM)-calc%Xxxxi(IM)*calc%Xxxxi(JM))
- Pwrhoi(Ij) = Pwrhoi(Ij) - Two*Z(M)* &
+ calc%Pwrhoi(Ij) = calc%Pwrhoi(Ij) - Two*calc%Z(M)* &
(calc%Xxxxr(IM)*calc%Xxxxi(JM)+calc%Xxxxi(IM)*calc%Xxxxr(JM))
END IF
END DO
@@ -175,11 +159,11 @@ contains
RETURN
END
- subroutine needRadiusDeriv(Ksolve, igr, iflApe, iflApt)
- use EndfData_common_m, only : resParData, radFitFlags
+ subroutine needRadiusDeriv(calc, igr, iflApe, iflApt)
use SammySpinGroupInfo_M
IMPLICIT none
- integer::Ksolve, igr
+ class(CroCrossCalc)::calc
+ integer::igr
integer::I
logical::iflApe, iflApt
type(SammySpinGroupInfo)::spinInfo
@@ -187,13 +171,13 @@ contains
iflApe = .false.
iflApt = .false.
- if (Ksolve.NE.2) then
- call resParData%getSpinGroupInfo(spinInfo,igr)
+ if (calc%wantDerivs) then
+ call calc%resData%getSpinGroupInfo(spinInfo,igr)
DO I=1, spinInfo%getNumChannels()
- if (radFitFlags%getTrueFitFlag(Igr, I).ne.0) then
+ if (calc%radiusData%getTrueFitFlag(Igr, I).ne.0) then
iflApt = .true.
end if
- if (radFitFlags%getEffFitFlag(Igr, I).ne.0) then
+ if (calc%radiusData%getEffFitFlag(Igr, I).ne.0) then
iflApe = .true.
end if
END DO
@@ -203,20 +187,14 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Total (calc, spinInfo, &
- Cs, Si, Wr, Wi, Pwrhor, Pwrhoi, &
- Lrmat, igr, Zke, If_Zke, ipar)
+ SUBROUTINE Total (calc, spinInfo, Lrmat, igr, If_Zke, ipar)
!
! *** PURPOSE -- GENERATE CROSS SECTION and
! *** PARTIAL DERIVATIVE OF TOTAL
! *** CROSS SECTION WrT U-PARAMETER
!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- use constn_common_m
- use SammySpinGroupInfo_M
- use EndfData_common_m, only : radFitFlags
+ use constn_common_m, only : Pi100
+ use SammySpinGroupInfo_M
IMPLICIT none
class(CroCrossCalc)::calc
@@ -225,42 +203,40 @@ contains
!
!
type(SammySpinGroupInfo)::spinInfo
- real(kind=8) :: &
- Cs(*), Si(*), &
- Wr(*), Wi(*), Pwrhor(*), Pwrhoi(*), Zke(*)
real(kind=8)::val
-!
-! DIMENSION
-! * 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
!
real(kind=8) :: A, B, Sum, Sumc
- integer :: I, Ij, J, K, Kl
+ integer :: I, Ij, J, K, Kl, Keff, Kiso, Ktru
logical::iflApe, iflApt
+ real(kind=8)::Su, Squ
Agoj = calc%getAbundance(igr)*spinInfo%getGFactor()
nent = spinInfo%getNumEntryChannels()
Ntot = spinInfo%getNumChannels()
Sum = Zero
Sumc = Zero
+ Su = dAbs(calc%ener)
+ Squ = calc%enerSq
B = Two*Agoj*Pi100/Squ
Ij = 0
+
+
dO I=1,Nent
Ij = Ij + I
- A = 1.0D0/Zke(I)**2
- Sum = Sum + ( Cs(I)*Wr(Ij) + Si(I)*Wi(Ij) ) * A
+ A = 1.0D0/calc%Zke(I, igr)**2
+ Sum = Sum + ( calc%Cs(I)*calc%Wr(Ij) + calc%Si(I)*calc%Wi(Ij) ) * A
Sumc = Sumc + A
- Ktru = radFitFlags%getTrueFitFlag(Igr, I)
+ Ktru = calc%radiusData%getTrueFitFlag(Igr, I)
IF (Ktru.GT.0.and.calc%wantDerivs) THEN
- val = - B* ( Cs(I)*Pwrhor(Ij) + Si(I)*Pwrhoi(Ij) )/Zke(I)
+ val = - B* ( calc%Cs(I)*calc%Pwrhor(Ij) + calc%Si(I)*calc%Pwrhoi(Ij) )/calc%Zke(I, igr)
call calc%crossData%setSharedValNs(calc%row, 1, Ktru, val)
END IF
- Keff = radFitFlags%getEffFitFlag(Igr, I)
+ Keff = calc%radiusData%getEffFitFlag(Igr, I)
IF (Keff.GT.0.and.calc%wantDerivs) THEN
- val = - Two*B* ( Cs(I)*Wi(Ij)-Si(I)*Wr(Ij) )*calc%Dphi(I)/Zke(I)
+ val = - Two*B* ( calc%Cs(I)*calc%Wi(Ij)-calc%Si(I)*calc%Wr(Ij) )*calc%Dphi(I)/calc%Zke(I, igr)
call calc%crossData%setSharedValNs(calc%row, 1, Keff, val)
END IF
END DO
@@ -268,14 +244,13 @@ contains
call calc%crossData%setSharedValNs(calc%row, 1, 0, A)
Kiso = If_Zke
IF (Kiso.GT.0.and.calc%wantDerivs) THEN
- val = A/VarAbn
+ val = A/calc%getAbundance(Igr)
call calc%crossData%setSharedValNs(calc%row, 1, Kiso, val)
END IF
!
!
!
IF (Lrmat.EQ.1) RETURN
- IF (Ksolve.EQ.2) RETURN
IF (.not.calc%wantDerivs) RETURN
if (.not.allocated(calc%tr)) return
!
@@ -293,10 +268,10 @@ contains
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- 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)
+ calc%Ti(1,Ij) = calc%Ti(1, Ij) + calc%Qr(Ij,Kl)*calc%Cs(K) + &
+ calc%Qi(Ij,Kl)*calc%Si(K)
+ calc%Tr(1,Ij) = calc%Tr(1,Ij) + calc%Qi(Ij,Kl)*calc%Cs(K) - &
+ calc%Qr(Ij,Kl)*calc%Si(K)
END DO
END DO
END DO
@@ -311,43 +286,30 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Elastc (calc, spinInfo, &
- Cs, Si, Wr, Wi, Pwrhor, Pwrhoi, &
- Lrmat, igr, Zke, If_Zke, ipar)
+ SUBROUTINE Elastc (calc, spinInfo, Lrmat, igr, If_Zke, ipar)
!
! *** PURPOSE -- GENERATE CROSS SECTION
! *** AND PARTIAL DERIVATIVE OF SCATTERING
! *** CROSS SECTION WrT U-PARAMETER
!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- use constn_common_m
+ use constn_common_m, only : Pi100
use SammySpinGroupInfo_M
- use EndfData_common_m, only : radFitFlags
IMPLICIT NONE
!
class(CroCrossCalc)::calc
type(SammySpinGroupInfo)::spinInfo
real(kind=8) :: agoj
- integer :: Nent, Ntot, Lrmat, igr, If_Zke, ipar
+ integer :: Nent, Ntot, Lrmat, igr, If_Zke, ipar, Keff, Kiso, Ktru
- real(kind=8) :: &
- Cs(*), Si(*), &
- Wr(*), Wi(*), Pwrhor(*), Pwrhoi(*), Zke(*)
real(kind=8) :: val
logical(C_BOOL)::accu
-
-!
-! DIMENSION
-! * 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
!
real(kind=8) :: A, B, Bb, C, Csk, Sik,Sum, Sum1, Sumc
integer :: I, Ii, Ij, J, K, Kl, L
logical::iflAp
+ real(kind=8)::Su, Squ
Sum = Zero
Sum1 = Zero
@@ -356,30 +318,32 @@ contains
nent = spinInfo%getNumEntryChannels()
Ntot = spinInfo%getNumChannels()
+ Su = dAbs(calc%ener)
+ Squ = calc%enerSq
Ij = 0
C = Two*Agoj*Pi100/Squ
Ii = 0
DO I=1,Nent
- B = One/Zke(I)**2
+ B = One/calc%Zke(I, igr)**2
Sumc = Sumc + B
Ii = Ii + I
iflAp = .false.
if (calc%wantDerivs) then
- Ktru = radFitFlags%getTrueFitFlag(Igr, I)
- Keff = radFitFlags%getEffFitFlag(Igr, I)
+ Ktru = calc%radiusData%getTrueFitFlag(Igr, I)
+ Keff = calc%radiusData%getEffFitFlag(Igr, I)
iflAp = Ktru.ne.0.or.Keff.ne.0
end if
if (iflAp) then
- Bb = C/Zke(I)
+ Bb = C/calc%Zke(I, igr)
IF (Ktru.GT.0) THEN
- val = - ( Cs(I)*Pwrhor(Ii)+Si(I)*Pwrhoi(Ii) )*B
+ val = - ( calc%Cs(I)*calc%Pwrhor(Ii)+calc%Si(I)*calc%Pwrhoi(Ii) )*B
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) )*calc%Dphi(I)*B
+ val = Two*( calc%Cs(I)*calc%Wi(Ii)-calc%Si(I)*calc%Wr(Ii) )*calc%Dphi(I)*B
call calc%crossData%setSharedValNs(calc%row, 1, Keff, val)
END IF
else
@@ -388,13 +352,13 @@ contains
DO J=1,I
Ij = Ij + 1
- A = Wr(Ij)**2 + Wi(Ij)**2
+ A = calc%Wr(Ij)**2 + calc%Wi(Ij)**2
IF (I.NE.J) A = A + A
Sum1 = Sum1 + A*B
IF (I.EQ.J) THEN
- Sum = Sum + ( Cs(I)*Wr(Ij) + Si(I)*Wi(Ij) )*B
+ Sum = Sum + ( calc%Cs(I)*calc%Wr(Ij) + calc%Si(I)*calc%Wi(Ij) )*B
IF (Ktru.GT.0) THEN
- A = Wr(Ij)*Pwrhor(Ij) + Wi(Ij)*Pwrhoi(Ij)
+ A = calc%Wr(Ij)*calc%Pwrhor(Ij) + calc%Wi(Ij)*calc%Pwrhoi(Ij)
IF (I.NE.J) A = A + A
val = A*Bb
call calc%crossData%setSharedValNs(calc%row, 1, Ktru, val)
@@ -407,14 +371,13 @@ contains
!
Kiso = If_Zke
IF (Kiso.GT.0.and.calc%wantDerivs) THEN
- val = B/VarAbn
+ val = B/calc%getAbundance(Igr)
call calc%crossData%setSharedValNs(calc%row, 1, Kiso, val)
END IF
!
!
!
IF (Lrmat.EQ.1) RETURN
- IF (Ksolve.EQ.2) RETURN
IF (.not.calc%wantDerivs) RETURN
if (.not.allocated(calc%tr)) return
!
@@ -423,16 +386,16 @@ contains
!
Kl = 0
DO K=1,Nent
- Csk = Cs(K)
- Sik = Si(K)
+ Csk = calc%Cs(K)
+ Sik = calc%Si(K)
DO L=1,K
Kl = Kl + 1
IF (L.EQ.K) THEN
- A = Csk - Wr(Kl)
- B = Sik - Wi(Kl)
+ A = Csk - calc%Wr(Kl)
+ B = Sik - calc%Wi(Kl)
ELSE
- A = -Two*Wr(Kl)
- B = -Two*Wi(Kl)
+ A = -Two*calc%Wr(Kl)
+ B = -Two*calc%Wi(Kl)
END IF
Ij = 0
DO I=1,Ntot
@@ -455,47 +418,38 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Reactn (calc, spinInfo, &
- Wr, Wi, Pwrhor, Pwrhoi, Lrmat, &
- igr, Zke, If_Zke, ipar)
+ SUBROUTINE Reactn (calc, spinInfo, Lrmat, igr, If_Zke, ipar)
!
! *** PURPOSE -- GENERATE CROSS SECTION
! *** AND PARTIAL DERIVATIVE OF REACTION
! *** CROSS SECTION WrT U-PARAMETER
-!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- use constn_common_m
+!
+ use constn_common_m, only : Pi100
use SammySpinGroupInfo_M
- use EndfData_common_m, only : radFitFlags
use SammySpinGroupInfo_M
IMPLICIT none
!
class(CroCrossCalc)::calc
type(SammySpinGroupInfo)::spinInfo
real(kind=8) :: Agoj
- integer :: Nent, Next, Ntot, Lrmat, igr, ipar
+ integer :: Nent, Next, Ntot, Lrmat, igr, ipar, Kiso, Ktru
integer :: If_Zke
- real(kind=8) :: &
- Wr(*), Wi(*), Pwrhor(*), &
- Pwrhoi(*), Zke(*)
real(kind=8) :: val
!
-! DIMENSION
-! * Wr(NN), Wi(NN),
-! * Pwrhor(NN), Pwrhoi(NN)
!
- real(kind=8) :: Zero = 0.0d0, One = 1.0d0, Two = 2.0d00
+ real(kind=8),parameter :: Zero = 0.0d0, One = 1.0d0, Two = 2.0d00
real(kind=8) :: A, B, C, F1sum, F2sum, Sum
integer :: I, Ij, J, Jj, K, Kl, L, Ll
logical::iflApe, iflApt
+ real(kind=8)::Su, Squ, Sig1, Sig2
!
F1sum = Zero
F2sum = Zero
- call needRadiusDeriv(Ksolve, igr, iflApe, iflApt)
+ Su = dAbs(calc%ener)
+ Squ = calc%enerSq
+ call needRadiusDeriv(calc, igr, iflApe, iflApt)
Agoj = calc%getAbundance(igr)*spinInfo%getGFactor()
nent = spinInfo%getNumEntryChannels()
next = spinInfo%getNumExitChannels()
@@ -508,20 +462,20 @@ contains
F1sum = Zero
F2sum = Zero
DO Jj=1,Next
- IF (Kkkfis.EQ.0 .OR. Kkkfis.EQ.Jj) THEN
+ IF (calc%Kkkfis.EQ.0 .OR. calc%Kkkfis.EQ.Jj) THEN
J = Nent + Jj
IF (J.LE.Ntot) THEN
DO I=1,Nent
- B = One/Zke(I)**2
+ B = One/calc%Zke(I,igr)**2
Ij = (J*(J-1))/2 + I
IF (Jj.EQ.1) F1sum = F1sum + &
- (Wr(Ij)**2+Wi(Ij)**2)*B
+ (calc%Wr(Ij)**2+calc%Wi(Ij)**2)*B
IF (Jj.EQ.2) F2sum = F2sum + &
- (Wr(Ij)**2+Wi(Ij)**2)*B
- Ktru = radFitFlags%getTrueFitFlag(Igr, I)
+ (calc%Wr(Ij)**2+calc%Wi(Ij)**2)*B
+ Ktru = calc%radiusData%getTrueFitFlag(Igr, I)
IF (Ktru.GT.0) THEN
- B = ( Wr(Ij)*Pwrhor(Ij) + &
- Wi(Ij)*Pwrhoi(Ij) )*C/Zke(I)
+ B = ( calc%Wr(Ij)*calc%Pwrhor(Ij) + &
+ calc%Wi(Ij)*calc%Pwrhoi(Ij) )*C/calc%Zke(I, igr)
call calc%crossData%setSharedValNs(calc%row, 1, Ktru, B)
END IF
END DO
@@ -535,7 +489,7 @@ contains
Sig2 = Sig2 + A*F2sum
Kiso = If_Zke
IF (Kiso.GT.0) THEN
- val = A*Sum/VarAbn
+ val = A*Sum/calc%getAbundance(Igr)
call calc%crossData%setSharedValNs(calc%row, 1, Kiso, val)
END IF
END IF
@@ -547,16 +501,16 @@ contains
F1sum = Zero
F2sum = Zero
DO Jj=1,Next
- IF (Kkkfis.EQ.0 .OR. Kkkfis.EQ.Jj) THEN
+ IF (calc%Kkkfis.EQ.0 .OR. calc%Kkkfis.EQ.Jj) THEN
J = Nent + Jj
IF (J.LE.Ntot) THEN
DO I=1,Nent
- B = One/Zke(I)**2
+ B = One/calc%Zke(I, igr)**2
Ij = (J*(J-1))/2 + I
IF (Jj.EQ.1) F1sum = F1sum + &
- (Wr(Ij)**2+Wi(Ij)**2)*B
+ (calc%Wr(Ij)**2+calc%Wi(Ij)**2)*B
IF (Jj.EQ.2) F2sum = F2sum + &
- (Wr(Ij)**2+Wi(Ij)**2)*B
+ (calc%Wr(Ij)**2+calc%Wi(Ij)**2)*B
END DO
END IF
END IF
@@ -567,10 +521,10 @@ contains
call calc%crossData%setSharedValNs(calc%row, 1, 0, B*Sum)
Sig1 = Sig1 + F1Sum*B
Sig2 = Sig2 + F2Sum*B
- IF (Ksolve.NE.2) THEN
+ IF (calc%wantDerivs) THEN
Kiso = If_Zke
IF (Kiso.GT.0) THEN
- val = B*Sum/VarAbn
+ val = B*Sum/calc%getAbundance(Igr)
call calc%crossData%setSharedValNs(calc%row, 1, Kiso, val)
END IF
END IF
@@ -578,7 +532,6 @@ contains
END IF
!
IF (Lrmat.EQ.1) RETURN
- IF (Ksolve.EQ.2) RETURN
IF (.not.calc%wantDerivs) RETURN
if (.not.allocated(calc%tr)) return
!
@@ -587,7 +540,7 @@ contains
!
IF (Next.GE.1) THEN
DO Ll=1,Next
- IF (Kkkfis.EQ.0 .OR. Kkkfis.EQ.LL) THEN
+ IF (calc%Kkkfis.EQ.0 .OR. calc%Kkkfis.EQ.LL) THEN
L = Nent + Ll
IF (L.LE.Ntot) THEN
DO K=1,Nent
@@ -596,10 +549,10 @@ contains
DO I=1,Ntot
DO J=1,I
Ij = Ij + 1
- 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)
+ calc%Ti(1,Ij) = calc%Ti(1, Ij) - calc%Qr(Ij,Kl)*calc%Wr(Kl) &
+ - calc%Qi(Ij,Kl)*calc%Wi(Kl)
+ calc%Tr(1,Ij) = calc%Tr(1, Ij) - calc%Qi(Ij,Kl)*calc%Wr(Kl) &
+ + calc%Qr(Ij,Kl)*calc%Wi(Kl)
END DO
END DO
END DO
@@ -618,20 +571,14 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Captur (calc, spinInfo, &
- Wr, Wi, Pwrhor, Pwrhoi, &
- Lrmat, igr, Zke, If_Zke, ipar)
+ SUBROUTINE Captur (calc, spinInfo, Lrmat, igr, If_Zke, ipar)
!
! *** PURPOSE -- GENERATE CROSS SECTION
! *** AND PARTIAL DERIVATIVE OF CAPTURE
! *** CROSS SECTION WrT U-PARAMETER
!
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
- use constn_common_m
+ use constn_common_m, only : Pi100
use SammySpinGroupInfo_M
- use EndfData_common_m, only : radFitFlags
use SammySpinGroupInfo_M
IMPLICIT None
!
@@ -642,35 +589,31 @@ contains
integer :: Nent, Next, Ntot, Lrmat, &
igr, If_zke, ipar
- real(kind=8):: &
- Wr(*), Wi(*), &
- Pwrhor(*), Pwrhoi(*), Zke(*)
real(kind=8)::val
-!
-! DIMENSION
-! * 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
real(kind=8) :: A, B, C, Sum, Sumc
- integer :: I, Ij, J, Jj, K, Kl, L, Ll
+ integer :: I, Ij, J, Jj, K, Kl, L, Ll, Kiso, Ktru
logical::iflApe, iflApt
+ real(kind=8)::Su, Squ
!
Agoj = calc%getAbundance(igr)*spinInfo%getGFactor()
nent = spinInfo%getNumEntryChannels()
next = spinInfo%getNumExitChannels()
Ntot = spinInfo%getNumChannels()
+ Su = dAbs(calc%ener)
+ Squ = calc%enerSq
Sum = Zero
Sumc = Zero
C = Two*Agoj*Pi100/Squ
DO J=1,Nent
Jj = (J*(J-1))/2
- B = One/Zke(J)**2
+ B = One/calc%Zke(J, igr)**2
Sumc = Sumc + B
- A = C/Zke(J)
- Ktru = radFitFlags%getTrueFitFlag(Igr, J)
+ A = C/calc%Zke(J, igr)
+ Ktru = calc%radiusData%getTrueFitFlag(Igr, J)
if (.not.calc%wantDerivs) Ktru = 0
DO I=1,Ntot
IF (I.LE.J) THEN
@@ -678,10 +621,10 @@ contains
ELSE
Ij = (I*(I-1))/2 + J
END IF
- Sum = Sum + ( Wr(Ij)**2 + Wi(Ij)**2 )*B
+ Sum = Sum + ( calc%Wr(Ij)**2 + calc%Wi(Ij)**2 )*B
IF (Ktru.GT.0) THEN
val = - Two* &
- ( Wr(Ij)*Pwrhor(Ij)+Wi(Ij)*Pwrhoi(Ij) )*A
+ ( calc%Wr(Ij)*calc%Pwrhor(Ij)+calc%Wi(Ij)*calc%Pwrhoi(Ij) )*A
! ??????????? is this right ???????????? methinks not
call calc%crossData%setSharedValNs(calc%row, 1, Ktru, val)
END IF
@@ -691,13 +634,12 @@ contains
call calc%crossData%setSharedValNs(calc%row, 1, 0, B)
Kiso = If_Zke
IF (Kiso.GT.0.and.calc%wantDerivs) THEN
- val = B/VarAbn
+ val = B/calc%getAbundance(Igr)
call calc%crossData%setSharedValNs(calc%row, 1, Kiso, val)
END IF
!
!
IF (Lrmat.EQ.1) RETURN
- IF (Ksolve.EQ.2) RETURN
IF (.not.calc%wantDerivs) RETURN
if (.not.allocated(calc%tr)) return
!
@@ -708,8 +650,8 @@ contains
DO K=1,Nent
DO L=1,K
Kl = Kl + 1
- A = Wr(Kl)
- B = Wi(Kl)
+ A = calc%Wr(Kl)
+ B = calc%Wi(Kl)
IF (L.NE.K) A = A + A
IF (L.NE.K) B = B + B
Ij = 0
@@ -729,10 +671,10 @@ contains
IF (L.LE.Ntot) THEN
DO K=1,Nent
Kl = (L*(L-1))/2 + K
-! ?? A=2.*Wr(Kl)
- A = Wr(Kl)
- B = Wi(Kl)
-! ?? B=2.*Wi(Kl)
+! ?? A=2.*calc%Wr(Kl)
+ A = calc%Wr(Kl)
+ B = calc%Wi(Kl)
+! ?? B=2.*calc%Wi(Kl)
Ij = 0
DO I=1,Ntot
DO J=1,I
@@ -778,7 +720,7 @@ contains
ntot = spinInfo%getNumChannels()
Agoj = calc%getAbundance(igr)*spinInfo%getGFactor()
- Su = calc%ener
+ Su = dAbs(calc%ener)
DO Mm=1,calc%inumSize
@@ -840,7 +782,7 @@ contains
ntot = spinInfo%getNumChannels()
Agoj = calc%getAbundance(igr)*spinInfo%getGFactor()
- Su = calc%ener
+ Su = dAbs(calc%ener)
C = Fourpi*Agoj/Su
Ij = 0
DO I=1,Ntot
diff --git a/sammy/src/rec/mrec3.f90 b/sammy/src/rec/mrec3.f90
index b4851722e059a31d02b4c5f5b7c95370848f2292..cfd6732e775779bd7ace6b6f8d3f5e016af788cd 100644
--- a/sammy/src/rec/mrec3.f90
+++ b/sammy/src/rec/mrec3.f90
@@ -12,18 +12,18 @@ contains
! *** 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 varyr_common_m, only : Su, Squ
use xct4_m
use XctCrossCalc_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-!
+ IMPLICIT None
+
class(XctCrossCalc)::xct
- DIMENSION Ssseee(*)
+ real(kind=8):: Ssseee(*), Eee
+ integer::I, Nnndrc
!
Su = Eee
Squ = dSQRT(Su)
+ Nnndrc = 0
!
I = 0
! *** generate cross sections pieces
diff --git a/sammy/src/the/CrossSectionCalcDriver_M.f90 b/sammy/src/the/CrossSectionCalcDriver_M.f90
index c5ee33828b60e8f3b381f595f929a750f73be163..584cd40d43567736959a0db92639aaebb0a36ae3 100644
--- a/sammy/src/the/CrossSectionCalcDriver_M.f90
+++ b/sammy/src/the/CrossSectionCalcDriver_M.f90
@@ -173,13 +173,17 @@ module CrossSectionCalcDriver_M
call this%calculator%setEnergyIndependent(this%Kcros, Twomhb, this%kwcoul, Etac)
end subroutine
- subroutine CrossSectionCalcDriver_setAddtionalParams (this, lllmax, Kfinit, wantSelfIndicate, debug)
+ subroutine CrossSectionCalcDriver_setAddtionalParams (this, lllmax, Kfinit, wantSelfIndicate, Kkkfis, debug)
class(CrossSectionCalcDriver)::this
logical::debug ! do we want extra debug output
integer::lllmax ! maximum number of Clebsch-Gordon coefficients
integer::Kfinit ! finite-size corrections flag
+ integer::Kkkfis ! what fission channels for cro
logical::wantSelfIndicate ! do we need to calculate self-indicated cross section data
+ if (Kkkfis.ne.0.and.associated(this%croCalc)) then
+ this%croCalc%Kkkfis = Kkkfis
+ end if
if (.not.associated(this%xctCalc)) return
call this%xctCalc%setAddtionalParams (lllmax, Kfinit, wantSelfIndicate, this%Kssmsc, debug)
end subroutine
diff --git a/sammy/src/the/mthe0.f90 b/sammy/src/the/mthe0.f90
index 73befac0a396c46c4afa2c3b374f9b081e2872f1..bd9ef229fcabb1e550791a4e1940d1f4e9a3788c 100644
--- a/sammy/src/the/mthe0.f90
+++ b/sammy/src/the/mthe0.f90
@@ -178,7 +178,7 @@ module mthe0_M
use fixedi_m, only : Numiso, Ktruet, Nnniso, Kaddcr,lllmax, Kshift, Kaptur, Kpolar
use ifwrit_m, only : Ilzero, Itzero, Kcros, Knocor, Kpoten, Krmatx, Ksolve, &
Kssmsc, kwcoul, Maxwel, Knocor, Kkkdop, Kkclqx, Kkkclq, &
- Kartgd, Kpiece, Kfinit, Ksitmp, Ksindi, Kaverg, Krecon
+ Kartgd, Kpiece, Kfinit, Ksitmp, Ksindi, Kaverg, Krecon, Kkkfis
use fixedr_m, only : emax
use lbro_common_m, only : Yangle, Yaverg, Ydoppr, Yresol, Yssmsc, Ytrans, debug
use namfil_common_m, only : Faddcr
@@ -206,7 +206,6 @@ module mthe0_M
zeroKCalc%driver%Kaptur = Kaptur
zeroKCalc%driver%Kaverg = Kaverg
zeroKCalc%driver%Krecon = Krecon
- zeroKCalcInit = .true.
end if
! if using Leal-Hwang doppler broadening (Kkkdop.eq.1)
@@ -238,7 +237,7 @@ module mthe0_M
wantSelfIndicate = .false.
if (Ksindi.GT.0 .AND. Kcros.EQ.8) wantSelfIndicate = .true.
if (Ksitmp.GT.0) wantSelfIndicate = .true.
- call zeroKCalc%driver%setAddtionalParams(lllmax, Kfinit, wantSelfIndicate, debug)
+ call zeroKCalc%driver%setAddtionalParams(lllmax, Kfinit, wantSelfIndicate, Kkkfis, debug)
! by default we get the abundance (as expected) from the
! isotope
diff --git a/sammy/src/xct/mxct02.f90 b/sammy/src/xct/mxct02.f90
index d40f1bff61dca375ed8cd10c793a46d93b87a648..bb7ec853456eb97e427c1f1b9091bb437d072e27 100644
--- a/sammy/src/xct/mxct02.f90
+++ b/sammy/src/xct/mxct02.f90
@@ -16,7 +16,7 @@ module xct2_m
use samxxx_common_m
use oopsch_common_m
use fixedr_m
- use varyr_common_m
+ use varyr_common_m, only : Elz, Etz, Su, Squ
use templc_common_m
use cbro_common_m
use lbro_common_m
diff --git a/sammy/src/xct/mxct04.f90 b/sammy/src/xct/mxct04.f90
index 4995bf7acc636aaea220537edebf918d398c256d..ff57104d65cd9bf6aa5139fb0f05750887bcb83b 100644
--- a/sammy/src/xct/mxct04.f90
+++ b/sammy/src/xct/mxct04.f90
@@ -15,7 +15,6 @@ module xct4_m
use fixedi_m
use ifwrit_m
use exploc_common_m
- use varyr_common_m
use templc_common_m
use EndfData_common_m
use xct5_m
diff --git a/sammy/src/xct/mxct05.f90 b/sammy/src/xct/mxct05.f90
index fb20831253a0d989373a66c2f259b6748ed32a43..23c178df214cc7441551410864ad91ff104f553c 100644
--- a/sammy/src/xct/mxct05.f90
+++ b/sammy/src/xct/mxct05.f90
@@ -13,7 +13,7 @@ module xct5_m
!
use fixedi_m
use ifwrit_m
- use varyr_common_m
+ use varyr_common_m, only : Su
use EndfData_common_m
use SammyResonanceInfo_M
use RMatResonanceParam_M
@@ -172,7 +172,6 @@ module xct5_m
!
use fixedi_m
use ifwrit_m
- use varyr_common_m
use EndfData_common_m
use SammySpinGroupInfo_M
use XctCrossCalc_M
diff --git a/sammy/src/xxx/mxxx7.f90 b/sammy/src/xxx/mxxx7.f90
index 23d24951faffc9fdcee9cd52a3735d18dfa41ac3..03fdd7746ed0eec0c81a29e73f33c3bea577469e 100644
--- a/sammy/src/xxx/mxxx7.f90
+++ b/sammy/src/xxx/mxxx7.f90
@@ -11,9 +11,6 @@ module xxx7
! *** getting the appropriate signs
!
use sammy_CoulombSelector_I
- use fixedi_m
- use ifwrit_m
- use varyr_common_m
implicit none
real(8), intent(in) :: Rho