diff --git a/sammy/samtry/tr057/answers/rr.lpt b/sammy/samtry/tr057/answers/rr.lpt
index ac4b9c6f414685a202167c66edd8989f4a9ff8a2..09b430293d4451329d5d8040eafa297db9ca4051 100755
--- a/sammy/samtry/tr057/answers/rr.lpt
+++ b/sammy/samtry/tr057/answers/rr.lpt
@@ -632,9 +632,9 @@ __________________________
DeltaG = 0.00000
DeltaE = 0.00000
Emind Emins Eminr Emin
- 1300695.1778912749 1300970.2343750000 1300970.2343750000 1300970.2343750000
+ 1300695.1778912698 1300970.2343750000 1300970.2343750000 1300970.2343750000
Emax Emaxr Emaxs Emaxd
- 1699256.5312500000 1699256.5312500000 1699256.5312500000 1699570.9154586825
+ 1699256.5312500000 1699256.5312500000 1699256.5312500000 1699570.9154586885
DOPPLER WIDTHS
Nuclide Doppler Width (eV) Doppler FWHM (eV)
diff --git a/sammy/samtry/tr057/answers/rr.par b/sammy/samtry/tr057/answers/rr.par
index 4af81c87d927604241012c9153b249c40853295c..2d8e9b3ef486d19259c8d6c2f1f8ac25fb78eb58 100755
--- a/sammy/samtry/tr057/answers/rr.par
+++ b/sammy/samtry/tr057/answers/rr.par
@@ -132,6 +132,6 @@ BROADENING PARAMETERS FOLLOW
MISCEllaneous parameters follow
SELFI 1 1 291.84018 10.000000 1.5065823 .30000000
-SIABN 1 1 .93223521 .20000000 2.0141045 .20000000
+SIABN 1 1 .93223522 .20000000 2.0141045 .20000000
COVARIANCE MATRIX IS IN BINARY FORM
diff --git a/sammy/samtry/tr057/answers/rt.lpt b/sammy/samtry/tr057/answers/rt.lpt
index 7c61b91074eee7368ef0a2fde9d842dc32c61cbf..32785e4f44ffe70ef2038366f24360312b82718c 100755
--- a/sammy/samtry/tr057/answers/rt.lpt
+++ b/sammy/samtry/tr057/answers/rt.lpt
@@ -639,9 +639,9 @@ __________________________
DeltaG = 0.00000
DeltaE = 0.00000
Emind Emins Eminr Emin
- 1300379.4359482517 1300616.4825519433 1300616.4825519433 1300970.2031250000
+ 1300379.4359482457 1300616.4825519689 1300616.4825519689 1300970.2031250000
Emax Emaxr Emaxs Emaxd
- 1699256.7968750000 1699718.8075240660 1699718.8075240660 1699989.8171710928
+ 1699256.7968750000 1699718.8075240324 1699718.8075240324 1699989.8171710952
DOPPLER WIDTHS
Nuclide Doppler Width (eV) Doppler FWHM (eV)
diff --git a/sammy/samtry/tr057/answers/rt.par b/sammy/samtry/tr057/answers/rt.par
index 2f57a9749b4d53e4b980b6d1be9eac1307b9c03b..8ffeb708031c0d6299d4617fbadd25bb9cbefa8f 100755
--- a/sammy/samtry/tr057/answers/rt.par
+++ b/sammy/samtry/tr057/answers/rt.par
@@ -131,7 +131,7 @@ BROADENING PARAMETERS FOLLOW
4.13642000 79.376032 .01060163 .00532793 0. 0. 0 1 1 1 0 0
MISCEllaneous parameters follow
-SELFI 1 1 271.05828 10.000000 1.4981596 .30000000
-SIABN 1 1 .93136162 .20000000 2.0214670 .20000000
+SELFI 1 1 271.05828 10.000000 1.4981595 .30000000
+SIABN 1 1 .93136160 .20000000 2.0214670 .20000000
COVARIANCE MATRIX IS IN BINARY FORM
diff --git a/sammy/samtry/tr057/answers/rv.lpt b/sammy/samtry/tr057/answers/rv.lpt
index daea8273fc469c427a88735be2af4d3f7230dd61..5d92ab6c53a4a40255f5d2d4676c911247523dba 100755
--- a/sammy/samtry/tr057/answers/rv.lpt
+++ b/sammy/samtry/tr057/answers/rv.lpt
@@ -644,9 +644,9 @@ __________________________
DeltaG = 0.00000
DeltaE = 0.00000
Emind Emins Eminr Emin
- 1125646.9042793550 1125898.1216265869 1300641.2301131238 1300970.1718750000
+ 1125646.9042793582 1125898.1216265932 1300641.2301131312 1300970.1718750000
Emax Emaxr Emaxs Emaxd
- 1699256.9218750000 1699686.5678252652 1699686.5678252652 1699995.2620073126
+ 1699256.9218750000 1699686.5678252554 1699686.5678252554 1699995.2620073061
DOPPLER WIDTHS
Nuclide Doppler Width (eV) Doppler FWHM (eV)
diff --git a/sammy/samtry/tr057/answers/rw.lpt b/sammy/samtry/tr057/answers/rw.lpt
index 6b8cd836b8d38067d1e74d302648942041ec4f28..75e935d85c047d0c59f286690b0bf2f96813b20c 100755
--- a/sammy/samtry/tr057/answers/rw.lpt
+++ b/sammy/samtry/tr057/answers/rw.lpt
@@ -657,7 +657,7 @@ __________________________
DeltaG = 0.00000
DeltaE = 0.00000
Emind Emins Eminr Emin
- 1125646.8946453319 1125898.1094657907 1300641.2160649318 1300970.1718750000
+ 1125646.8946453319 1125898.1094657909 1300641.2160649321 1300970.1718750000
Emax Emaxr Emaxs Emaxd
1699256.9218750000 1699686.5861742541 1699686.5861742541 1699995.2772544394
@@ -685,5 +685,5 @@ __________________________
No resolution broadening occured 403 times of a possible 1061
CUSTOMARY CHI SQUARED = 5.58549
- CUSTOMARY CHI SQUARED DIVIDED BY NDAT = 5.264365E-03
+ CUSTOMARY CHI SQUARED DIVIDED BY NDAT = 5.264364E-03
Normal finish to SAMMY
diff --git a/sammy/samtry/tr066/answers/rd4.lpt b/sammy/samtry/tr066/answers/rd4.lpt
index 67cefdd0363da4fd2fd4d920bdf33c4a9e244be3..047270fe41d3a883be999ea3c16b1dcec9f811d0 100755
--- a/sammy/samtry/tr066/answers/rd4.lpt
+++ b/sammy/samtry/tr066/answers/rd4.lpt
@@ -5946,7 +5946,7 @@ There are no non-zero derivatives of this type for this nuclide.
37 1147.68 -4.83549E-07 -4.4134 0.0000 0.0000
38 1147.90 -5.57323E-07 -4.4161 0.0000 0.0000
39 1148.11 -6.45681E-07 -4.4192 0.0000 0.0000
- 40 1148.32 -7.52686E-07 -4.4226 0.0000 0.0000
+ 40 1148.32 -7.52685E-07 -4.4226 0.0000 0.0000
41 1148.54 -8.83582E-07 -4.4265 0.0000 0.0000
42 1148.75 -1.04595E-06 -4.4310 0.0000 0.0000
43 1148.97 -1.24802E-06 -4.4360 0.0000 0.0000
@@ -5987,7 +5987,7 @@ There are no non-zero derivatives of this type for this nuclide.
78 1154.42 3.27282E-04 -8.2569 0.0000 0.0000
79 1154.49 3.19437E-04 -8.2359 0.0000 0.0000
80 1154.56 3.06235E-04 -8.2003 0.0000 0.0000
- 81 1154.63 2.88023E-04 -8.1504 0.0000 0.0000
+ 81 1154.63 2.88022E-04 -8.1504 0.0000 0.0000
82 1154.71 2.65229E-04 -8.0865 0.0000 0.0000
83 1154.78 2.38412E-04 -8.0089 0.0000 0.0000
84 1154.85 2.08206E-04 -7.9184 0.0000 0.0000
@@ -6420,7 +6420,7 @@ There are no non-zero derivatives of this type for this nuclide.
113 1165.87 -4.80913E-08 -4.3662 -4.02124E-04 -1.69146E-04
114 1166.09 -4.45277E-08 -4.3654 -3.85219E-04 -1.62066E-04
115 1166.31 -4.13024E-08 -4.3647 -3.69154E-04 -1.55336E-04
- 116 1166.53 -3.83672E-08 -4.3641 -3.54259E-04 -1.49096E-04
+ 116 1166.53 -3.83671E-08 -4.3641 -3.54259E-04 -1.49096E-04
117 1166.75 -3.56760E-08 -4.3634 -3.41151E-04 -1.43606E-04
118 1166.97 -3.32300E-08 -4.3628 -3.28165E-04 -1.38166E-04
119 1167.19 -3.09814E-08 -4.3622 -3.16434E-04 -1.33252E-04
diff --git a/sammy/samtry/tr066/answers/re1.lpt b/sammy/samtry/tr066/answers/re1.lpt
index 65146c6fc3f0a70106cbc56b411295320dae70a3..463cbd6a62306b8c0346d6249135ec5be5c14fae 100755
--- a/sammy/samtry/tr066/answers/re1.lpt
+++ b/sammy/samtry/tr066/answers/re1.lpt
@@ -657,7 +657,7 @@ __________________________
DeltaG = 0.00000
DeltaE = 0.00000
Emind Emins Eminr Emin
- 1125646.8946453319 1125898.1094657907 1300641.2160649318 1300970.1718750000
+ 1125646.8946453319 1125898.1094657909 1300641.2160649321 1300970.1718750000
Emax Emaxr Emaxs Emaxd
1699256.9218750000 1699686.5861742541 1699686.5861742541 1699995.2772544394
@@ -685,5 +685,5 @@ __________________________
No resolution broadening occured 403 times of a possible 1061
CUSTOMARY CHI SQUARED = 5.58549
- CUSTOMARY CHI SQUARED DIVIDED BY NDAT = 5.264365E-03
+ CUSTOMARY CHI SQUARED DIVIDED BY NDAT = 5.264364E-03
Normal finish to SAMMY
diff --git a/sammy/samtry/tr066/answers/re2.lpt b/sammy/samtry/tr066/answers/re2.lpt
index 2edede468642c9b835c002fe1f930eb181915ec5..20ab10a1eb2fe08917177322f8e1dc1684baa8b7 100755
--- a/sammy/samtry/tr066/answers/re2.lpt
+++ b/sammy/samtry/tr066/answers/re2.lpt
@@ -653,9 +653,9 @@ __________________________
DeltaG = 0.00000
DeltaE = 0.00000
Emind Emins Eminr Emin
- 1125647.5568195195 1125898.2589740690 1300641.3887773890 1300970.1718750000
+ 1125647.5568195069 1125898.2589740823 1300641.3887774043 1300970.1718750000
Emax Emaxr Emaxs Emaxd
- 1699256.9218750000 1699686.3605865778 1699686.3605865778 1699994.4216018277
+ 1699256.9218750000 1699686.3605865578 1699686.3605865578 1699994.4216018401
DOPPLER WIDTHS
Nuclide Doppler Width (eV) Doppler FWHM (eV)
diff --git a/sammy/samtry/tr066/answers/re2.par b/sammy/samtry/tr066/answers/re2.par
index ea9535279cf6bb03a9753591e12d250b0af1d882..8779c799ef13db29509a3a8ebc4b77c3e5a9e0d6 100755
--- a/sammy/samtry/tr066/answers/re2.par
+++ b/sammy/samtry/tr066/answers/re2.par
@@ -34,18 +34,18 @@
1201238.750 3600.00000 4601200.00 0 0 0 1
1256447.250 3600.00000 17383000.0 0 0 0 1
1264441.750 1000.00000 843640.000 0 0 0 5
-1379920.000 2336.86209 65316.8563 0 1 1 4
-1408269.750 2661.70878 5192382.28 0 1 1 3
-1479927.250 1617.76933 3467622.45 0 1 1 4
-1482395.375 8873.00371 848.797549 0 1 1 2
-1512343.875 981.898836 91322.4810 0 1 1 5
-1528742.375 2356.25066 2926488.06 0 1 1 4
+1379920.000 2336.86210 65316.8563 0 1 1 4
+1408269.750 2661.70879 5192382.28 0 1 1 3
+1479927.250 1617.76934 3467622.45 0 1 1 4
+1482395.375 8873.00371 848.797551 0 1 1 2
+1512343.875 981.898838 91322.4810 0 1 1 5
+1528742.375 2356.25067 2926488.06 0 1 1 4
1580564.875 2308.13029 1488424.15 0 1 1 4
-1592844.250 8533.33865 11352161.1 0 1 1 2
-1597168.625 2349.29295 4010869.82 0 1 1 4
+1592844.250 8533.33866 11352161.1 0 1 1 2
+1597168.625 2349.29296 4010869.82 0 1 1 4
1639561.500 1001.74135 15156653.0 0 1 1 5
1651146.000 936.099135 21193334.1 0 1 1 5
-1658595.000 8342.63175 1553560.29 0 1 1 2
+1658595.000 8342.63176 1553560.29 0 1 1 2
1664961.125 2227.70639 214172.246 0 1 1 4
1784952.750 2400.00000 192940.000 0 0 0 4
1805652.625 2500.00000 1299100.00 0 0 0 3
diff --git a/sammy/samtry/tr066/answers/re4.lpt b/sammy/samtry/tr066/answers/re4.lpt
index 7fa309c424512ff0bb2a095be0419a8a44087622..2c10878563173683962ebf2bf0f4b9391e7eee3b 100755
--- a/sammy/samtry/tr066/answers/re4.lpt
+++ b/sammy/samtry/tr066/answers/re4.lpt
@@ -1977,7 +1977,7 @@ __________________________
179 1.386790E+06 2.96263E-15 -6.48497E-18 -1.48666E-08 -6.17824E-09
180 1.388091E+06 3.10144E-15 -3.94101E-18 -1.59591E-08 -6.62488E-09
181 1.389260E+06 3.27935E-15 -2.06439E-18 -1.71658E-08 -7.11504E-09
- 182 1.390430E+06 3.46835E-15 -5.14339E-20 -1.86355E-08 -7.70845E-09
+ 182 1.390430E+06 3.46835E-15 -5.14336E-20 -1.86355E-08 -7.70845E-09
183 1.391497E+06 3.64624E-15 1.78005E-18 -2.02573E-08 -8.35957E-09
184 1.392564E+06 3.85081E-15 4.04813E-18 -2.22192E-08 -9.14288E-09
185 1.393525E+06 4.03824E-15 5.82698E-18 -2.43609E-08 -9.99362E-09
diff --git a/sammy/src/amr/mamr2.f90 b/sammy/src/amr/mamr2.f90
index 73b31a1eb70f45922189e6ade6dd4a0674538ccd..2be1722f888d6bd71c061ad7f8fa825dd05afcf7 100644
--- a/sammy/src/amr/mamr2.f90
+++ b/sammy/src/amr/mamr2.f90
@@ -222,6 +222,9 @@ module amr2
!
call radFitFlags%addMatchingRadius(Dum(1))
Temp = Dum(2)
+ if (associated(dopplerInfo%broadener)) then
+ call dopplerInfo%broadener%setTemperature(temp)
+ end if
Thick = Dum(3)
Deltal = Dum(4)
Deltag = Dum(5)
@@ -231,6 +234,11 @@ module amr2
Co2 = Dum(9)
Do2 = Dum(10)
Dopple = Dum(11)
+ if (Dopple.ne.0.0d0) then
+ dopplerInfo%wantBroaden = .true.
+ else
+ dopplerInfo%wantBroaden = .false.
+ end if
call radFitFlags%setMatchingK(Dum(12))
Dist = Dum(13)
Anorm = Dum(14)
diff --git a/sammy/src/ang/mang0.f b/sammy/src/ang/mang0.f
index 676deda549b3bfc74ff1f955b1f69bc5bb7bae15..386cededc659bed30bf6d5a136a6992167bee496 100644
--- a/sammy/src/ang/mang0.f
+++ b/sammy/src/ang/mang0.f
@@ -2,15 +2,14 @@ C
C
SUBROUTINE Samang_0
C
- use fixedi_m, only : Ifdif, Jwwwww, K2reso, Kkkdex,
+ use fixedi_m, only : Ifdif, K2reso, Kkkdex,
* Kkkrsl, Lllmax, Nangle,
* Nudwhi, Numcro,
* Numorr, Numrpi
- use ifwrit_m, only : Kkkdop
use exploc_common_m
use array_sizes_common_m
use oopsch_common_m, only : Nowwww, Segmen
- use lbro_common_m, only : Debug, Ydoppr, Yresol
+ use lbro_common_m, only : Debug
use AuxGridHelper_M, only : getNumAuxGridPoints
use rsl7_m, only : Set_Kws
use mxct27_m
@@ -87,9 +86,7 @@ C
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
C
-C
- Jwwwww = 9
- Numcro = Nangle
+C
CALL Write_Commons_Many
C
END
diff --git a/sammy/src/ang/mang1.f b/sammy/src/ang/mang1.f
index a77049d17f5d5473d0047381525858552bc7ce72..a68607376df99d6ea4ed0ca2be891d1b7e79a38b 100644
--- a/sammy/src/ang/mang1.f
+++ b/sammy/src/ang/mang1.f
@@ -50,10 +50,8 @@ C
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToExpGrid(expData)
call auxGrid%initialize()
- call auxGrid%setParameters(numcro, ktzero)
call auxGrid%setToAuxGrid(expData)
C
Kkkmin = 0
@@ -195,18 +193,6 @@ C
190 CONTINUE
END DO
C *** end of loop on isotopes
-C
- if (.not.Another_Process_Will_Happen.or.
- * .not.Need_Isotopes) then
- call calcData%sumOverIsotopes(numUsedPar+1)
- end if
- if (.not.Another_Process_Will_Happen) then
- DO Jdat=1, grid%getNumEnergies(expData)
- Em = grid%getEnergy(Jdat, expData)
- CALL Only_Norm_Ang (Parnbk, Iflnbk,
- * Em, Jdat, Jdat, Nangle)
- end do
- end if
nauxStart = getAuxGridOffset()
nauxStart = nauxStart + Kkkmin - 1
@@ -214,11 +200,9 @@ C
call setAuxGridOffset(nauxStart)
call setAuxGridRowMax(Kkkdat - 1)
IF (Kkkdat.EQ.1) STOP '[STOP in Diffee in ang/mang1.f # 4]'
- IF (Another_Process_Will_Happen) THEN
- Kkkmin = Kkkmin - 1
- CALL Write_Cross_Sections (calcData,
- * Kkkkkk, Kkkmin, 0)
- END IF
+
+ Kksave = Kkkkkk
+
call grid%destroy()
call auxGrid%destroy()
RETURN
diff --git a/sammy/src/ang/mang2.f b/sammy/src/ang/mang2.f
index 2480ffb55d4ad95ad7b8aba6e2c029e8b24a09a4..f3ffae8ea1b12758371888fe811906f0e2ce8e08 100644
--- a/sammy/src/ang/mang2.f
+++ b/sammy/src/ang/mang2.f
@@ -75,8 +75,8 @@ C
SUBROUTINE Outnat (Parmsc, Iflmsc,
* Total, Dtotal, Prime, Ee, Jjdat, irow, iso)
C
- use fixedi_m, only : Nangle, numcro, numUsedPar
- use ifwrit_m, only : Nnpar, Kjatto, ktzero
+ use fixedi_m, only : Nangle, numUsedPar
+ use ifwrit_m, only : Nnpar, Kjatto
use EndfData_common_m, only : covData, expData
use SammyGridAccess_M
use array_sizes_common_m, only : calcData
@@ -97,8 +97,7 @@ C *** Theta-Dtheta to Theta+Dtheta. This is not really correct, but
C *** corresponds to what FGP (Francis Perey?) did in RFUNC.
C
N = Jjdat
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
Kkk = Kjatto - 1
DO Iangle=1,Nangle
diff --git a/sammy/src/avg/mavg4.f b/sammy/src/avg/mavg4.f
index 2a5169da25bdcc05b644df5bab6cc09ce5c4c4b5..9af17cf83fbc726d61bcc9a59ae942524b5797ba 100644
--- a/sammy/src/avg/mavg4.f
+++ b/sammy/src/avg/mavg4.f
@@ -60,7 +60,6 @@ C * Emn(Ndatq), Emx(Ndatq), Deld(Ndatq), Delu(Ndatq)
DATA Half /0.5d0/, Three /3.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
C
C
@@ -188,8 +187,7 @@ C * Emn(Ndatq), Emx(Ndatq), Deld(Ndatq), Delu(Ndatq)
* Emx(*), Deld(*), Delu(*)
DATA One /1.0d0/, Two /2.0d0/
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
C
C
diff --git a/sammy/src/blk/Abro_common.f90 b/sammy/src/blk/Abro_common.f90
index 46317cb405bef50234f972dba0fd2213c789bc23..9c70f35d297d7f53a680a98b7c1d7d374fccf47e 100644
--- a/sammy/src/blk/Abro_common.f90
+++ b/sammy/src/blk/Abro_common.f90
@@ -7,7 +7,6 @@ module abro_common_m
double precision, pointer :: Thck => Aabro(1)
double precision, pointer :: Tempe => Aabro(2)
double precision, pointer :: Delv => Aabro(3)
- double precision, pointer :: Delt => Aabro(4)
double precision, pointer :: Dddelt => Aabro(5)
double precision, pointer :: Odffff => Aabro(6)
double precision, pointer :: Abro1 => Aabro(7)
diff --git a/sammy/src/blk/AllocateFunctions.f90 b/sammy/src/blk/AllocateFunctions.f90
index 510eb1fe5327e786cf0e6ffebded8376f6663b5d..b2bfcbf9fa9a3873ec909bb49d228983d89ed3b0 100644
--- a/sammy/src/blk/AllocateFunctions.f90
+++ b/sammy/src/blk/AllocateFunctions.f90
@@ -148,6 +148,7 @@ module AllocateFunctions_m
if( .not.allocated(array)) then
allocate(array(nsize1, nsize2))
+ array = 0.0d0
return
end if
if (size(array,dim=1).ge.want1.and. size(array,dim=2).ge.want2) return
diff --git a/sammy/src/blk/Broad_common.f90 b/sammy/src/blk/Broad_common.f90
index 4bcdb15add6326dc267cced76a62c0a6adb7fe80..d86a67729a0e225bdc2cd26612ab21fe2d01930b 100644
--- a/sammy/src/blk/Broad_common.f90
+++ b/sammy/src/blk/Broad_common.f90
@@ -1,7 +1,13 @@
! replaces previous common block "Broad" in B04ZYX
module broad_common_m
use FreeGasDopplerBroadening_M
+ use HighEnergyFreeGasImpl_M
+ use LealHwangBroadeningImpl_M
+ use CrystalLatticeBroadeningImpl_M
use DopplerAndResolutionBroadener_M
+ use FreeGasDopplerBroadeningImpl_M
+ use DopplerBroadening_M
+ use FortranExtDopplerBroadening_M
use GridData_M
IMPLICIT NONE
@@ -33,15 +39,18 @@ module broad_common_m
double precision, pointer :: Deltc2 => Abcd_real(19)
type DopplerBroadenInfo
- type(FreeGasDopplerBroadening),pointer::freeGas
- type(DopplerAndResolutionBroadener),pointer::highEnergyFreeGas
- type(DopplerAndResolutionBroadener),pointer::lealHwang
- type(DopplerAndResolutionBroadener),pointer::crystalLattice
+ type(FreeGasDopplerBroadeningImpl),pointer::freeGas
+ type(HighEnergyFreeGasImpl),pointer::highEnergyFreeGas
+ type(LealHwangBroadeningImpl),pointer::lealHwang
+ type(CrystalLatticeBroadeningImpl),pointer::crystalLattice
- class(DopplerAndResolutionBroadener),pointer::broadener
+ class(FortranExtDopplerBroadening),pointer::broadener
integer::bType=2 ! default to freeGas
+ logical::wantBroaden=.false.
+ contains
+ procedure, pass(this) :: setDopple => DopplerBroadenInfo_setDopple
end type
- type(DopplerBroadenInfo)::dopplerOption
+ type(DopplerBroadenInfo)::dopplerInfo
type ResolutionBroadenInfo
type(DopplerAndResolutionBroadener),pointer::orrRes ! oak ridge resolution function
@@ -57,5 +66,13 @@ module broad_common_m
type(GridDataList)::workArray
logical::workArrayInit = .false.
+contains
+subroutine DopplerBroadenInfo_setDopple(this)
+ class(DopplerBroadenInfo)::this
+ if (associated(this%highEnergyFreeGas)) then
+ this%highEnergyFreeGas%Dopple = Dopple
+ end if
+
+end subroutine
end module broad_common_m
diff --git a/sammy/src/blk/Clm_common.f90 b/sammy/src/blk/Clm_common.f90
deleted file mode 100644
index ddfd9d60eeac7e41fbe4a5416dbf764423c7a7b3..0000000000000000000000000000000000000000
--- a/sammy/src/blk/Clm_common.f90
+++ /dev/null
@@ -1,33 +0,0 @@
-! replaces contents of B37ZYX which contains common block 'Clm'
-module clm_common_m
-! *** b37
-! TODO: Decrypt comment below
-! *** used only in clm
-!
- IMPLICIT NONE
- double precision,save :: Del_Phonon
- double precision,save :: Twt
- double precision,save :: C_Trans
- double precision,save :: Tbeta
- double precision,save :: Sub
- double precision,save :: Xdop
- double precision,save :: Eps
- double precision,save :: Epsc
- double precision,save :: F0
- double precision,save :: Tev
- double precision,save :: Dwpix
- double precision,save :: Tbar
- double precision,save :: Del_S_B
- double precision,save :: Dw0
- double precision,save :: Sum_Osc_Wts
- double precision,save :: Tsave
-
- integer,save :: Mode_S_Norm
- integer,save :: Nphon
- integer,save :: N_Contin
- integer,save :: N_Osc
- integer,save :: Nbeta
- integer,save :: Nbx
- integer,save :: Nbeta_Max
-
-end module clm_common_m
diff --git a/sammy/src/blk/Exploc_common.f90 b/sammy/src/blk/Exploc_common.f90
index e973c218b70c251a005d4affbab5bd1a2105d36a..17d751ab0bb64a196d7cb023e6e4df09f0601f20 100644
--- a/sammy/src/blk/Exploc_common.f90
+++ b/sammy/src/blk/Exploc_common.f90
@@ -29,7 +29,6 @@ module exploc_common_m
real(kind=8),allocatable,dimension(:)::A_Ispiso
integer,allocatable,dimension(:)::I_Ixciso
real(kind=8),allocatable,dimension(:)::A_Idpiso
- real(kind=8),allocatable,dimension(:)::A_Idsiso
real(kind=8),allocatable,dimension(:)::A_Iprdet
integer,allocatable,dimension(:)::I_Ifldet
@@ -222,12 +221,6 @@ module exploc_common_m
call allocate_real_data(A_Idpiso,want)
end subroutine make_A_Idpiso
-
- subroutine make_A_Idsiso(want)
- integer::want
- call allocate_real_data(A_Idsiso,want)
- end subroutine make_A_Idsiso
-
subroutine make_A_Iprdet(want)
integer::want
call allocate_real_data(A_Iprdet,want)
diff --git a/sammy/src/blk/Fixedi_common.f90 b/sammy/src/blk/Fixedi_common.f90
index d6b0d06897945fc1d8d96a2fa979d7f6e91fd794..9045efbb59c9073dcf93cf047c8f19d4d00d399a 100644
--- a/sammy/src/blk/Fixedi_common.f90
+++ b/sammy/src/blk/Fixedi_common.f90
@@ -122,11 +122,8 @@ module fixedi_m
integer,pointer :: Nres => lfdim(75)
integer,pointer :: Nrext => lfdim(76)
integer,pointer :: Nlfdimsiz => lfdim(77)
- integer,pointer :: Kjjjjj => lfdim(78)
- integer,pointer :: K2pls1 => lfdim(79)
integer,pointer :: Ngtvv => lfdim(80)
integer,pointer :: Nxtra => lfdim(81)
- integer,pointer :: Jwwwww => lfdim(82)
integer,pointer :: Nntype => lfdim(83)
integer,pointer :: Jcros => lfdim(84)
integer,pointer :: Jtrans => lfdim(85)
diff --git a/sammy/src/blk/Fixedr_common.f90 b/sammy/src/blk/Fixedr_common.f90
index 6266616648a36584d9983883f1d54b730abf9af3..4d07c589f38a69eb02d41df4c70130cc48df9874 100644
--- a/sammy/src/blk/Fixedr_common.f90
+++ b/sammy/src/blk/Fixedr_common.f90
@@ -13,7 +13,6 @@ module fixedr_m
double precision, pointer :: Thick => Ff(7)
double precision, pointer :: Dcova => Ff(8)
double precision, pointer :: Dcovb => Ff(9)
- double precision, pointer :: Elowbr => Ff(10)
double precision, pointer :: Emaxt => Ff(11)
double precision, pointer :: Datcr => Ff(12)
double precision, pointer :: Odfmul => Ff(13)
@@ -30,7 +29,6 @@ module fixedr_m
! old group 3
double precision, pointer :: Backd => Ff(21)
double precision, pointer :: Backf => Ff(22)
- double precision, pointer :: Delttt => Ff(23)
double precision, pointer :: Delttx => Ff(24)
double precision, pointer :: Delvvv => Ff(25)
double precision, pointer :: Delvvx => Ff(26)
@@ -69,7 +67,6 @@ module fixedr_m
! old group 8
double precision, pointer :: Ttoe => Ff(56)
- double precision, pointer :: Dosind => Ff(57)
double precision, pointer :: Sitemp => Ff(58)
double precision, pointer :: Sithck => Ff(59)
double precision, pointer :: Effcap => Ff(62)
diff --git a/sammy/src/blk/Ifwrit_common.f90 b/sammy/src/blk/Ifwrit_common.f90
index df2c07138e34ef5a557489b2d460f28c08a3838c..fd1bebafe5d7b2a985ab2f71e73ed6ba5fd69196 100644
--- a/sammy/src/blk/Ifwrit_common.f90
+++ b/sammy/src/blk/Ifwrit_common.f90
@@ -83,7 +83,6 @@ module ifwrit_m
! old group 8
integer,pointer :: Kedxfw => Lwrit(63)
- integer,pointer :: Jjjdop => Lwrit(64)
integer,pointer :: Inmdts => Lwrit(65)
integer,pointer :: Kexpsh => Lwrit(66)
integer,pointer :: Kendf => Lwrit(67)
diff --git a/sammy/src/blk/Lbro_common.f90 b/sammy/src/blk/Lbro_common.f90
index d3c5d877775cf408bfea4c8c93d5fd3e8d8b4838..bc705103568f12e759b49976a015c5dc8af52447 100644
--- a/sammy/src/blk/Lbro_common.f90
+++ b/sammy/src/blk/Lbro_common.f90
@@ -9,7 +9,6 @@ module lbro_common_m
LOGICAL,pointer:: Yresol => Lbro(3)
LOGICAL,pointer:: Ytotrs => Lbro(4)
LOGICAL,pointer:: Ynrmbk => Lbro(5)
- LOGICAL,pointer:: Yangle => Lbro(6)
LOGICAL,pointer:: Yssmsc => Lbro(7)
LOGICAL,pointer:: Debug => Lbro(8)
LOGICAL,pointer:: Yselfi => Lbro(9)
diff --git a/sammy/src/ccm/mccm1.F b/sammy/src/ccm/mccm1.F
index 05944eb5346b3cc534f29274590c9714fb73a8b4..1d1fbb1fa5c158de9f6adffbfc58814f8c36898d 100755
--- a/sammy/src/ccm/mccm1.F
+++ b/sammy/src/ccm/mccm1.F
@@ -34,8 +34,7 @@ C
type(ResonanceCovariance)::uCov
DATA Ncol/10/, Zero /0.0d0/
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToExpGrid(expData)
C
N = Nnndat
diff --git a/sammy/src/clm/CrystalLatticeBroadening_M.f90 b/sammy/src/clm/CrystalLatticeBroadening_M.f90
new file mode 100644
index 0000000000000000000000000000000000000000..249c5ef9264360788005054de97607a894d65a0a
--- /dev/null
+++ b/sammy/src/clm/CrystalLatticeBroadening_M.f90
@@ -0,0 +1,108 @@
+module CrystalLatticeBroadening_M
+use FortranExtDopplerBroadening_M
+use DopplerBroadening_M
+use DerivativeHandler_M
+use GridData_M
+use, intrinsic :: ISO_C_BINDING
+
+
+implicit none
+
+type, extends(FortranExtDopplerBroadening) :: CrystalLatticeBroadening
+real(kind=8) :: Del_Phonon = 0.0d0
+real(kind=8) :: Twt = 0.0d0
+real(kind=8) :: C_Trans = 0.0d0
+real(kind=8) :: Tbeta = 0.0d0
+real(kind=8) :: Sub = 0.0d0
+real(kind=8) :: Xdop = 0.0d0
+real(kind=8) :: Eps = 0.0d0
+real(kind=8) :: Epsc = 0.0d0
+real(kind=8) :: F0 = 0.0d0
+real(kind=8) :: Tev = 0.0d0
+real(kind=8) :: Dwpix = 0.0d0
+real(kind=8) :: Tbar = 0.0d0
+real(kind=8) :: Del_S_B = 0.0d0
+real(kind=8) :: Dw0 = 0.0d0
+real(kind=8) :: Sum_Osc_Wts = 0.0d0
+real(kind=8) :: Tsave = 0.0d0
+integer :: Mode_S_Norm = 0
+integer :: Nphon = 0
+integer :: N_Contin = 0
+integer :: N_Osc = 0
+integer :: Nbeta = 0
+integer :: Nbx = 0
+integer :: Nbeta_Max = 25999
+
+real(kind=8):: Aaawww
+
+real(kind=8),dimension(:,:),allocatable::Save
+real(kind=8),dimension(:,:),allocatable::Savex
+real(kind=8),dimension(:),allocatable::Osc_Wts
+real(kind=8),dimension(:),allocatable::Osc_Eng
+real(kind=8),dimension(:),allocatable::Phonon
+real(kind=8),dimension(:),allocatable::Ppp
+real(kind=8),dimension(:),allocatable::Beta
+real(kind=8),dimension(:),allocatable::Osc_Enx
+real(kind=8),dimension(:),allocatable::Osc_Snth
+real(kind=8),dimension(:),allocatable::Osc_Coth
+real(kind=8),dimension(:),allocatable::Bex
+real(kind=8),dimension(:),allocatable::Tlast
+real(kind=8),dimension(:),allocatable::Tnow
+real(kind=8),dimension(:),allocatable::S_Expb
+real(kind=8),dimension(:),allocatable::S_Ex
+real(kind=8),dimension(:),allocatable::Bs
+real(kind=8),dimension(:),allocatable::Ss
+real(kind=8),dimension(:),allocatable::Sab
+integer,dimension(:),allocatable::Max_T
+contains
+procedure, pass(this) :: initialize => CrystalLatticeBroadening_initialize
+procedure, pass(this) :: broaden => CrystalLatticeBroadening_broaden
+procedure, pass(this) :: destroy => CrystalLatticeBroadening_destroy
+end type CrystalLatticeBroadening
+
+contains
+subroutine CrystalLatticeBroadening_initialize(this, hand, list, work)
+ implicit none
+ class(CrystalLatticeBroadening) :: this
+ class(DerivativeHandler)::hand
+ class(GridDataList)::list
+ class(GridDataList)::work
+ call FortranExtDopplerBroadening_initialize(this, hand, list, work)
+end subroutine
+
+subroutine CrystalLatticeBroadening_destroy(this)
+ implicit none
+ class(CrystalLatticeBroadening) :: this
+ call FortranExtDopplerBroadening_destroy(this)
+ if (allocated(this%Save)) deallocate(this%Save)
+ if (allocated(this%Savex)) deallocate(this%Savex)
+ if (allocated(this%Osc_Wts)) deallocate(this%Osc_Wts)
+ if (allocated(this%Osc_Eng)) deallocate(this%Osc_Eng)
+ if (allocated(this%Phonon)) deallocate(this%Phonon)
+ if (allocated(this%Ppp)) deallocate(this%Ppp)
+ if (allocated(this%Beta)) deallocate(this%Beta)
+ if (allocated(this%Osc_Enx)) deallocate(this%Osc_Enx)
+ if (allocated(this%Osc_Snth)) deallocate(this%Osc_Snth)
+ if (allocated(this%Osc_Coth)) deallocate(this%Osc_Coth)
+ if (allocated(this%Bex)) deallocate(this%Bex)
+ if (allocated(this%Tlast)) deallocate(this%TLast)
+ if (allocated(this%TNow)) deallocate(this%TNow)
+ if (allocated(this%S_Ex)) deallocate(this%S_Ex)
+ if (allocated(this%S_Expb)) deallocate(this%S_Expb)
+ if (allocated(this%Bs)) deallocate(this%Bs)
+ if (allocated(this%Ss)) deallocate(this%Ss)
+ if (allocated(this%Sab)) deallocate(this%Sab)
+ if (allocated(this%Max_T)) deallocate(this%Max_T)
+end subroutine
+
+
+
+subroutine CrystalLatticeBroadening_broaden(this)
+ class(CrystalLatticeBroadening) :: this
+
+ integer::ndatb
+
+ call FortranExtDopplerBroadening_broaden(this)
+end subroutine
+
+end module CrystalLatticeBroadening_M
diff --git a/sammy/src/clm/dopush.f b/sammy/src/clm/dopush.f
index 1de204dccbbf71ddebd9346540b86836fe550a81..0feeb9accc5c1503bb17d265d0258c082f5fe48c 100644
--- a/sammy/src/clm/dopush.f
+++ b/sammy/src/clm/dopush.f
@@ -19,21 +19,23 @@ C
C
use fixedr_m
use broad_common_m
- use clm_common_m
use constn_common_m
use Isotop_common_m
use EndfData_common_m
use xxxb
+ use mclm2_M
+ use CrystalLatticeBroadening_M
+ use DopplerAndResolutionBroadener_M
+ use GridData_M
+ use array_sizes_common_m, only : calcData, calcDataInit
+ use AllocateFunctions_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
&
- DOUBLE PRECISION Osc_Eng(50), Osc_Wts(50), Phonon(1000),
- & Ar(1000), Beta(25999), Bex(25999), Sigp(4), Eref(500),
+ DOUBLE PRECISION
+ & Ar(1000), Sigp(4), Eref(500),
* Ecalc(5000),
- & Sigg(5000), Siggf(5000), Sigc(5000), E(100), Sig(100),
- & Save(25999,1000), Ppp(25999), Osc_Snth(50),
- * Osc_Enx(50),Osc_Coth(50), Tlast(25999), Tnow(25999),
- * Savex(25999,1000)
+ & Sigg(5000), Siggf(5000), Sigc(5000), E(100), Sig(100)
DOUBLE PRECISION Awr, Sigl, Dsig, Tempf,
& Rn, Toch, Kn, Sig1, Sig2, Sumgf, Arat, Rho, Ser,
& Per, EE, Sumg, Em, Sigm, Err
@@ -48,6 +50,9 @@ C & Per, EE, Sumg, Aaawww, Spi, Ap, Em, Sigm, Err
INTEGER CH, Nsyso, Nsysd, K, J, JJ,
& Ne, Nsysi, I, Nsysn, Nref
CHARACTER*40 Title
+ type(GridData)::grid
+ integer :: Mode_S_Norm
+ class(CrystalLatticeBroadening),pointer::calc
C
C
C
@@ -56,11 +61,26 @@ C
99999 FORMAT (' *** SAMMY-DOPUSH 9 Dec 05 ***')
CALL Timer (1)
CALL Timer (2)
- Nbeta_Max = 25999
C = size of Beta array (& others?)
C
C *** INITIALIZATION OF CONSTANTS
CALL Setcns (1,1)
+
+ if (.not.calcDataInit) then
+ calcDataInit = .true.
+ call calcData%initialize()
+ end if
+ if (.not.workArrayInit) then
+ call workArray%initialize()
+ workArrayInit = .true.
+ end if
+ call expData%initialize()
+ call grid%initialize()
+ call expData%addGrid(grid)
+ allocate(dopplerInfo%crystalLattice)
+ calc => dopplerInfo%crystalLattice
+ call calc%initialize(calcData,
+ & expData, workArray)
C
C
C
@@ -93,25 +113,29 @@ C *** NML added January 2006
C
C *** READ GLOBAL USER'S INPUT
READ (Nsysi,'(A40)') Title
- READ (Nsysi,*) CH, Mode_S_Norm, Sub
- READ (Nsysi,*) Emin, Emax, Xdop, Nphon
+ READ (Nsysi,*) CH, Mode_S_Norm, calc%Sub
+ READ (Nsysi,*) Emin, Emax, calc%Xdop, calc%Nphon
READ (Nsysi,*) Temp, Awr
- READ (Nsysi,*) Eps, Epsc, Err
+ READ (Nsysi,*) calc%Eps, calc%Epsc, Err
C
C *** READ IN CONTINUOUS DISTRIBUTION
- READ (Nsysi,*) Del_Phonon, N_Contin
- READ (Nsysi,*) (Phonon(I),I=1,N_Contin)
+ READ (Nsysi,*) calc%Del_Phonon, calc%N_Contin
+ call allocate_real_data(calc%Phonon, calc%N_Contin)
+ READ (Nsysi,*) (calc%Phonon(I),I=1,calc%N_Contin)
C
C *** READ IN DISCRETE MODES
- READ (Nsysi,*) N_Osc
- IF (N_Osc.NE.0) THEN
- READ (Nsysi,*) (Osc_Eng(I),I=1,N_Osc)
- READ (Nsysi,*) (Osc_Wts(I),I=1,N_Osc)
+ READ (Nsysi,*) calc%N_Osc
+ IF (calc%N_Osc.NE.0) THEN
+ call allocate_real_data(calc%Osc_Wts, calc%N_Osc)
+ call allocate_real_data(calc%Osc_Eng, calc%N_Osc)
+ READ (Nsysi,*) (calc%Osc_Eng(I),I=1,calc%N_Osc)
+ READ (Nsysi,*) (calc%Osc_Wts(I),I=1,calc%N_Osc)
END IF
+
C
C *** READ IN TRANSLATIONAL PART
- READ (Nsysi,*) Twt, C_Trans, Tbeta
- WRITE (Nsyso,60000) Twt, C_Trans, Tbeta
+ READ (Nsysi,*) calc%Twt, calc%C_Trans, calc%Tbeta
+ WRITE (Nsyso,60000) calc%Twt,calc%C_Trans,calc%Tbeta
60000 FORMAT (//, 'Twt, C, Tbeta=', 1p6g14.6)
C
C *** PRINTING
@@ -126,7 +150,8 @@ C *** PRINTING
& '' NORMALISATION PRECISION .................. '', F10.3, ''%'',/
& '' ERROR OF CROSS-SECTION RECONSTRuCTION .... '', F10.3, ''%'',/
& '' INTEGRATION PRECISION .................... '', F10.3, ''%'')')
- & Nphon, Temp, Awr, Emin, Emax, Xdop, Eps*100, Err*100, Epsc*100
+ & calc%Nphon, Temp, Awr, Emin, Emax,
+ & calc%Xdop, calc%Eps*100, Err*100, calc%Epsc*100
WRITE (Nsyso, '(//5X, ''RESULTS OF CONVOLUTION...'')')
WRITE (Nsyso, '(/5X, ''ENERGY'', 8X, ''SIG(NUCLEAR)'', 4X,
&''SIG(CRySTAL)'', 4X, ''SIG(fgm)'', 8X, ''SIG(fgmEFF)''/)')
@@ -138,8 +163,8 @@ c nml converted from "ratio to neutron" to "amu"
c nml so Arat should use Awr not Aaawww
Arat = Aaawww/(Aaawww+Aneutr)
Rn = Aneutr/(Aaawww+Aneutr)
- Tev = Temp*Boltzm
- Dopple = dSQRT(Tev/Awr)
+ calc%Tev = Temp*Boltzm
+ Dopple = dSQRT(calc%Tev/Awr)
C
C *** READ IN NUCLEAR CROSS-SECTION PARAMETERS
READ (Nsysn,*) Spi, Ap_Endf
@@ -149,32 +174,34 @@ C *** Endf version is in different units from sammy version
C
Zke = Twomhb*Arat
Zkte = Zke * Ap
+
+ dopplerInfo%crystalLattice%Mode_S_Norm = Mode_S_Norm
c
C
C
C *** EFFECTIVE TEMPERATURE CALCULATION FOR CREATION OF Beta GRID
- Del_Beta = Del_Phonon/Tev
- CALL Start_Clm (Phonon, Ppp, Del_Beta)
+ Del_Beta = calc%Del_Phonon/calc%Tev
+ CALL Start_Clm (dopplerInfo%crystalLattice,
+ & Del_Beta)
C *** INPUT -- Phonon, Tbeta, Del_Beta, N_Contin
C *** OUTPUT -- Ppp, F0, Tbar
- Tevf = Tev*Tbar
- Dwpix = F0
+ Tevf = calc%Tev*calc%Tbar
+ calc%Dwpix = calc%F0
Tevf_true = Tevf
C
C *** INITIAL Beta Mesh CALCULATION
- CALL Mesh (Beta, Tevf)
-C *** Input -- Tevf, Tev, Emax, Xdop, Del_Phonon, Sub, Nbeta_Max
+ CALL Mesh (calc, Tevf)
+C *** Input -- Tevf, Tev, Emax, Xdop, calc%Del_Phonon, Sub, Nbeta_Max
C *** Output -- Beta(Nbeta), Del_S_B, Nbeta
C
C *** Contin_X initializes things, generates Save
- CALL Contin_X (Ppp, Save, Tlast, Tnow, Savex, Del_Beta)
+ CALL Contin_X (calc, Del_Beta)
C *** Input -- Ppp(.), F0, Tbeta, Del_Beta, Sub,
C *** N_Contin, Nphon, Nbeta
C *** Output -- Save(?,Nphon)
C
C *** Discre_X initializes things for Discre
- CALL Discre_X (Osc_Eng, Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth,
- & Bex, Beta)
+ CALL Discre_X (calc)
C
C
C *** CREATION OF ARRAY OF RESONANCES ENERGIES (for starters)
@@ -207,15 +234,15 @@ C *** INVERTED STACK MODEL FOR RECONSTRuCTION OF RESONANCE LINE-SHAPE
E(J+1) = Eref(I )
E(J ) = Eref(I+1)
Tevf = Tevf_True
- CALL Sigcri (Ar, Beta, Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth,
- * Bex, Save, E(J+1), Sig2, Temp, Rn, Tevf, Ch)
+ CALL Sigcri (Ar,
+ * E(J+1), Sig2, Temp, Rn, Tevf, Ch)
Sig(J+1) = Sig2
- CALL Sigcri (Ar, Beta, Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth,
- * Bex, Save, E(J ), Sig1, Temp, Rn, Tevf, Ch)
+ CALL Sigcri (Ar,
+ * E(J ), Sig1, Temp, Rn, Tevf, Ch)
Sig(J) = Sig1
20 Em = (E(J+1)+E(J))/2.
- CALL Sigcri (Ar, Beta, Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth,
- * Bex, Save, Em, Sigm, Temp, Rn, Tevf, Ch)
+ CALL Sigcri (Ar,
+ * Em, Sigm, Temp, Rn, Tevf, Ch)
Sigl = Sig(J+1) + (Sig(J)-Sig(J+1))*(EM-E(J+1))/(E(J)-E(J+1))
Dsig = dABS(Sigm-Sigl)
Toch = Err*Sigm
@@ -228,8 +255,8 @@ C
Sig(J+1) = Sig(J)
Sig(J ) = Sigm
Em = (E(J+1)+E(J))/2.
- CALL Sigcri (Ar, Beta, Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth,
- * Bex, Save, Em, Sigm, Temp, Rn, Tevf, Ch)
+ CALL Sigcri (Ar,
+ * Em, Sigm, Temp, Rn, Tevf, Ch)
Sigl = Sig(J+1) +(Sig(J)-Sig(J+1))*(Em-E(J+1))/(E(J)-E(J+1))
Dsig = dABS(Sigm-Sigl)
Toch = Err*Sigm
@@ -247,9 +274,10 @@ C
END IF
END IF
C
- Tevf = Tbeta*Tevf + 0.5d0*Tsave
+ Tevf = calc%Tbeta*Tevf + 0.5d0*calc%Tsave
Ne = K - 1
Dopplef = dSQRT(Tevf/Awr)
+ dopplerInfo%wantBroaden = .true.
C
C *** FREE GAZ, FREE GAZ AT EFFECTIVE TEMPERATURE AND
C NUCLEAR CROSS-SECTION CALCULATIONS ON ADJUSTED ENERGY GRID
@@ -257,13 +285,13 @@ C
DO I=1,NE
C
C *** CONVOLUTION FOR FREE GAZ
- CALL Siggaz (Ecalc(I), AR, CH, Sumg, Epsc)
+ CALL Siggaz (Ecalc(I), AR, CH, Sumg, calc%Epsc)
Sigg(I) = Sumg
C
Dummmm = Dopple
Dopple = Dopplef
C *** CONVOLUTION FOR FREE GAZ AT EFFECTIVE TEMPERATURE
- CALL Siggaz (Ecalc(I), AR, CH, Sumgf, Epsc)
+ CALL Siggaz (Ecalc(I), AR, CH, Sumgf, calc%Epsc)
Siggf(I) = Sumgf
Dopple = Dummmm
C
@@ -289,7 +317,7 @@ C
& '' ADJUSTED XDOP INTERVAL ............... '', F10.3/
& '' EFFECTIVE TEMPERATURE................. '', F10.3/
& '' DEBAY-WALLER FACTOR................... '', F10.3/)')
- & K, Nbeta, Nphon, Xdop, Tempf, Dwpix
+ & K, calc%Nbeta, calc%Nphon, calc%Xdop, Tempf, calc%Dwpix
WRITE (6,*) 'correct run!!! '
C
CALL Timer (3)
diff --git a/sammy/src/clm/dopush3.f b/sammy/src/clm/dopush3.f
index 35e9c0586a77cca72b4caaec8f7ea800f8c76cfe..38855a1f03f12d0f36a74892f8573887c3e26ff4 100644
--- a/sammy/src/clm/dopush3.f
+++ b/sammy/src/clm/dopush3.f
@@ -2,10 +2,15 @@ C
C
C ----------------------------------------------------------------------
C
- SUBROUTINE Sigcri (Ar, Beta, Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth,
- * Bex, Save, Ei, Sigma, Temp, Rn, Tevf, Ch)
- use clm_common_m
+ SUBROUTINE Sigcri (Ar,
+ * Ei, Sigma, Temp, Rn, Tevf, Ch)
use constn_common_m
+ use mclm5_m
+ use mcml6_m
+ use mclm7_m
+ use broad_common_m
+ use CrystalLatticeBroadening_M
+ use AllocateFunctions_m
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C *** Purpose -- CRYSTAL MODEL CROSS-SECTION CALCULATION
@@ -13,28 +18,26 @@ C *** Input -- Ei,
C Rn, Recul, Tev
C *** Output -- Sigma
C
- DOUBLE PRECISION Ar, Beta, Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth,
- * Bex, Save
- DIMENSION Ar(*), Beta(*), Osc_Wts(*),
- & Osc_Enx(*), Osc_Snth(50), Osc_Coth(*),
- & Bex(*), Save(Nbeta_Max,*), Max_T(Nbeta_Max)
+ DOUBLE PRECISION Ar
+ DIMENSION Ar(*)
DOUBLE PRECISION Ei, Sigma, Temp, Rn
INTEGER Ch
C
- DOUBLE PRECISION Sab, Bs, Ss, Sign, S_Expb, S_Ex
- DIMENSION Sab(25999), Bs(25999), Ss(25999), Sign(4),
- * S_Expb(25999), S_Ex(25999)
+ DOUBLE PRECISION Ss, Sign
+ DIMENSION Bs(25999), Ss(25999), Sign(4)
DOUBLE PRECISION Norm1, Sumr1, Norm, Sumr, Sintc, Sel,
& Sumc, Recul
INTEGER K, Ik, Ns, J
DOUBLE PRECISION Zero, One, Five
PARAMETER (Zero=0.0d0, One=1.0d0, Five=5.0d0)
+ class(CrystalLatticeBroadening),pointer::calc
C
C
C EFFECTIVE TEMPERATURE CALCULATION FOR CREATION OF Beta GRID
C
+ calc => dopplerInfo%crystalLattice
Recul = Ei*Rn
- Alpha = Recul/Tev
+ Alpha = Recul/calc%Tev
C
C SCATTERING LaW CALCULATION
C Ei is in eV; Beta is unitless
@@ -42,35 +45,36 @@ C
C
ix=0
C *** Continuous part of distribution
- CALL Cconti (Save, Sab, Beta, Alpha, Norm, Sumr, Max_T)
+ call allocate_real_data(calc%Sab, calc%Nbeta)
+ CALL Cconti (calc, Alpha, Norm, Sumr)
C
C
Tra0 = Norm
Tra1 = Sumr
- Tbarx = Tbar
+ Tbarx = calc%Tbar
C *** Translational part, if any
- IF (Twt.NE.Zero) THEN
+ IF (calc%Twt.NE.Zero) THEN
Ndmax = 2000
- CALL Trans (Beta, Sab, Alpha, Deltab, Tra0, Tra1, Ndmax)
+ CALL Trans (calc, Alpha, Deltab, Tra0, Tra1, Ndmax)
C *** UPDATE EFfECTIVE TEMPERATURE (which is used only in Discre)
- Tevf = (Tbeta*Tevf+Twt*Tev)/(Tbeta+Twt)
- Tbarx = Tevf/Tev
+ Tevf = (calc%Tbeta*Tevf+calc%Twt*calc%Tev)/
+ & (calc%Tbeta+calc%Twt)
+ Tbarx = Tevf/calc%Tev
END IF
C
C
Osc0 = Tra0
Osc1 = Tra1
C *** Discrete oscillators, if any
- IF (N_Osc.NE.0) THEN
- CALL Discre (Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth, Sab, Beta,
- * Bex, S_Expb, S_Ex, Alpha, Tbarx, Osc0, Osc1)
+ IF (calc%N_Osc.NE.0) THEN
+ CALL Discre (calc, Alpha, Tbarx, Osc0, Osc1)
END IF
C
C
Norm1 = dABS(Norm-One)
Sumr1 = dABS(Sumr-One)
- IF (Norm1.GT.Eps .OR. Sumr1.GT.Eps) THEN
- Nphon = Nphon + 5
+ IF (Norm1.GT.calc%Eps .OR. Sumr1.GT.calc%Eps) THEN
+ calc%Nphon = calc%Nphon + 5
END IF
C
C
@@ -78,15 +82,15 @@ C Dimensioning of Alpha and Beta values
C Centering of Beta in Recul=<Beta>=Ei/(Awr+1)
C
K=0
- DO IK=Nbeta,1,-1
+ DO IK=calc%Nbeta,1,-1
K = K + 1
- Bs(K) = Recul - Beta(IK)*Tev
- Ss(K) = Sab(IK)/Tev
+ Bs(K) = Recul - calc%Beta(IK)*calc%Tev
+ Ss(K) = calc%Sab(IK)/calc%Tev
END DO
- DO IK=2,Nbeta
+ DO IK=2,calc%Nbeta
K = K + 1
- Bs(K) = Recul + Beta(IK)*Tev
- Ss(K) = Sab(IK)*dEXP(-Beta(IK))/Tev
+ Bs(K) = Recul + calc%Beta(IK)*calc%Tev
+ Ss(K) = calc%Sab(IK)*dEXP(-calc%Beta(IK))/calc%Tev
END DO
C
C
@@ -103,7 +107,7 @@ C
C Convolution for crystal between Ss and Sigman
C
DO J=1,Ns-1
- CALL Qtrapc (Ei, J, Sintc, Bs, Ss, Ns, Ar, Ch, Epsc)
+ CALL Qtrapc (Ei, J, Sintc, Bs, Ss, Ns, Ar, Ch, calc%Epsc)
Sumc = Sumc + Sintc
END DO
C
@@ -113,10 +117,10 @@ C Sigman(Ei+Recul)*EXP(-W*A)
C
CALL Csrmat (Ei+Recul, Sign, Ar)
C
- Sel = dEXP(-Dwpix*Alpha)
- IF (Mode_S_Norm.EQ.0) THEN
+ Sel = dEXP(-calc%Dwpix*Alpha)
+ IF (calc%Mode_S_Norm.EQ.0) THEN
Sigma = Sumc + Sign(Ch)*Sel
- ELSE IF (Mode_S_Norm.EQ.1) THEN
+ ELSE IF (calc%Mode_S_Norm.EQ.1) THEN
SIGMA = Sumc * (One-Sel)/(Norm-Sel) + Sign(Ch)*Sel
END IF
RETURN
diff --git a/sammy/src/clm/mclm0.f b/sammy/src/clm/mclm0.f
deleted file mode 100644
index 4d5c492e103083582425df449f1cf3c7a0d1317a..0000000000000000000000000000000000000000
--- a/sammy/src/clm/mclm0.f
+++ /dev/null
@@ -1,164 +0,0 @@
-C
-C
- Subroutine Samclm_0
-C
-C *** Purpose -- Calculate Doppler broadening using Crystal-Lattice Model
-C *** Coding based on Dmitri Naberejnev's DOPUSH code,
-C *** modified greatly by NML to conform to SAMMY conventions
-C
- use fixedi_m, only : Jwwwww, K2reso, Kkkdex, Kkkrsl,
- * Nudwhi, Numorr, Numrpi,
- * Ndatd
- use ifwrit_m, only : Kcros, Ksolve, Kvers7, Ndatb, Ntgrlq, Kplotu
- use exploc_common_m
- use array_sizes_common_m
- use oopsch_common_m, only : Nowwww, Segmen
- use clm_common_m, only : N_Contin, N_Osc, Nbeta_Max, Nphon
- use lbro_common_m, only : Debug, Yresol, Yssmsc
- use AllocateFunctions_m
- use rsl7_m
- use mxct27_m
- IMPLICIT None
- real(kind=8),allocatable,dimension(:)::A_Isave
- real(kind=8),allocatable,dimension(:)::A_Ioscwt
- real(kind=8),allocatable,dimension(:)::A_Ioscex
- real(kind=8),allocatable,dimension(:)::A_Ioscsn
- real(kind=8),allocatable,dimension(:)::A_Ioscco
- real(kind=8),allocatable,dimension(:)::A_Ibex
- real(kind=8),allocatable,dimension(:)::A_Iphono
- real(kind=8),allocatable,dimension(:)::A_Ioscen
- real(kind=8),allocatable,dimension(:)::A_Ippp
- real(kind=8),allocatable,dimension(:)::A_Itlast
- real(kind=8),allocatable,dimension(:)::A_Itnowx
- real(kind=8),allocatable,dimension(:)::A_Isavex
- real(kind=8),allocatable,dimension(:)::A_Isexpb
- real(kind=8),allocatable,dimension(:)::A_Isexxx
- real(kind=8),allocatable,dimension(:)::A_Ibs
- real(kind=8),allocatable,dimension(:)::A_Iss
- integer,allocatable,dimension(:)::I_Imaxt
- real(kind=8),allocatable,dimension(:)::A_IbetaGrid
- integer::M, N, N_Osc_Blank, Nn, Kdatb
-C
-C
- WRITE (6,99999)
-99999 FORMAT (' *** SAMMY-CLM 15 Nov 07 ***')
- Segmen(1) = 'C'
- Segmen(2) = 'L'
- Segmen(3) = 'M'
- Nowwww = 0
-C
- CALL Initix
- IF (Kplotu.NE.0) Kplotu = 0
-C
-C
- Kdatb = Ndatd
- IF (Kdatb.EQ.0) Kdatb = Ndatb
-C
-C *** Read through the CLM file to learn array dimensions
- CALL Readclm_0 (N_Osc_Blank)
-C
-C *** GUESSTIMATE SIZE OF ARRAY NEEDED FOR SAMCLM
- CALL Estclm (Kdatb)
-C
- Nbeta_Max = 25999
- call allocate_real_data(A_Isave, Nphon*Nbeta_Max)
- M = IABS (N_Contin)
- N = IABS (N_Osc)
- IF (M.EQ.0) M = 1
- IF (N.EQ.0) N = 1
- call allocate_real_data(A_Ioscwt, N)
- call allocate_real_data(A_IbetaGrid, Nbeta_Max)
- call allocate_real_data(A_Ioscex , N)
- call allocate_real_data(A_Ioscsn , N)
- call allocate_real_data(A_Ioscco , N)
- call allocate_real_data(A_Ibex , Nbeta_Max)
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- call allocate_real_data(A_Iphono , M)
- call allocate_real_data(A_Ioscen , N)
- call allocate_real_data(A_Ippp , Nbeta_Max)
- call allocate_real_data(A_Itlast , Nbeta_Max)
- call allocate_real_data(A_Itnowx , Nbeta_Max)
- call allocate_real_data(A_Isavex , Nbeta_Max*Nphon)
-C *** Read the CLM file for real
- CALL Readclm (A_Iphono , A_Ioscen , A_Ioscwt , N_Osc_Blank)
-C
-C *** Initialize the crystal-lattice calculation
- CALL Initclm (A_Isave , A_Iphono , A_Ioscen , A_Ioscwt , A_Ippp ,
- * A_IbetaGrid , A_Ioscex , A_Ioscsn , A_Ioscco , A_Ibex ,
- * A_Itlast , A_Itnowx , A_Isavex )
- deallocate(A_Iphono)
- deallocate(A_Ioscen)
- deallocate(A_Ippp)
- deallocate(A_Itlast)
- deallocate(A_Itnowx)
- deallocate(A_Isavex)
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
-C
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-C *** One ***
-C
- N = 1
- Nn = 1
- Jwwwww = 2
- IF (Kcros.EQ.8) THEN
- Jwwwww = 6
- END IF
-C
-C
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- call allocate_real_data(A_Isexpb , Nbeta_Max)
- call allocate_real_data(A_Isexxx , Nbeta_Max)
- call allocate_real_data(A_Ibs , Nbeta_Max)
- call allocate_real_data(A_Iss , Nbeta_Max)
- call allocate_integer_data(I_Imaxt , Nbeta_Max) ! now allocated as real integer
-C
-C *** Dopclm performs CLM Doppler operation
- CALL Dopclm ( I_Iflmsc ,
- * A_IbetaGrid, A_Ioscwt , A_Ioscex, A_Ioscsn, A_Ioscco , A_Ibex ,
- * A_Isexpb , A_Isexxx , A_Isave , A_Ibs , A_Iss , I_Imaxt )
-
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-C
-C
-C
- CALL Write_Commons_many
- deallocate(A_IbetaGrid)
- deallocate(A_Isave)
- deallocate(A_Ioscwt)
- deallocate(A_Ioscex)
- deallocate(A_Ioscsn)
- deallocate(A_Ioscco)
- deallocate(A_Ibex)
- deallocate(A_Isexpb)
- deallocate(A_Isexxx)
- deallocate(A_Ibs)
- deallocate(A_Iss)
- deallocate(I_Imaxt)
- RETURN
-C
- END
-C
-C
-C __________________________________________________________________
-C
- SUBROUTINE Estclm (Kdatb)
-C
-C *** purpose -- estimate array size for this segment
-C
- IMPLICIT None
- integer::Kdatb, Idimen
- integer::I, K
- logical Need_isotopes
- external Idimen
-C
-C
-C *** One
-cx CALL Figure_KWs_1 (Kone)
-C
-cx K = Kone + 2*Kdatb
- K = 2*Kdatb
- K = Idimen (K, 1, 'K, 1')
- I = Idimen (K, -1, 'K, -1')
- I = Idimen (0, 1, '0, 1')
- RETURN
- END
diff --git a/sammy/src/clm/mclm0.f90 b/sammy/src/clm/mclm0.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d37e073318d9b90165f3ea716240284bbfccb27f
--- /dev/null
+++ b/sammy/src/clm/mclm0.f90
@@ -0,0 +1,60 @@
+module CrystalLatticeBroadeningImpl_m
+use CrystalLatticeBroadening_M
+implicit none
+type, extends(CrystalLatticeBroadening) :: CrystalLatticeBroadeningImpl
+contains
+procedure, pass(this) :: initialize => CrystalLatticeBroadeningImpl_initialize
+procedure, pass(this) :: broaden => CrystalLatticeBroadeningImpl_broaden
+procedure, pass(this) :: destroy => CrystalLatticeBroadeningImpl_destroy
+end type CrystalLatticeBroadeningImpl
+
+contains
+subroutine CrystalLatticeBroadeningImpl_initialize(this, hand, list, work)
+ implicit none
+ class(CrystalLatticeBroadeningImpl) :: this
+ class(DerivativeHandler)::hand
+ class(GridDataList)::list
+ class(GridDataList)::work
+ call CrystalLatticeBroadening_initialize(this, hand, list, work)
+end subroutine
+
+subroutine CrystalLatticeBroadeningImpl_destroy(this)
+ implicit none
+ class(CrystalLatticeBroadeningImpl) :: this
+ call CrystalLatticeBroadening_destroy(this)
+end subroutine
+
+subroutine CrystalLatticeBroadeningImpl_broaden(this)
+ use fixedr_m, only : Aaawww
+ use exploc_common_m, only : I_Iflmsc
+ use Readclm_m
+ use mclm3_m
+ class(CrystalLatticeBroadeningImpl) :: this
+
+ integer::ndatb
+ type(DerivativeHandler)::data
+ integer::N_Osc_Blank, Nn
+
+
+ this%Aaawww = Aaawww
+
+ call CrystalLatticeBroadening_broaden(this)
+
+ WRITE (6,99999)
+99999 FORMAT (' *** SAMMY-CLM 15 Nov 07 ***')
+
+ ! *** Read through the CLM file to learn array dimensions
+ CALL Readclm_0 (this, N_Osc_Blank)
+
+ ! *** Read the CLM file for real
+ CALL Readclm (this, N_Osc_Blank)
+
+ ! *** Initialize the crystal-lattice calculation
+ CALL Initclm (this)
+
+ ! *** Dopclm performs CLM Doppler operation
+ CALL Dopclm (this, I_Iflmsc)
+end subroutine
+
+end module CrystalLatticeBroadeningImpl_M
+
diff --git a/sammy/src/clm/mclm1.f b/sammy/src/clm/mclm1.f
deleted file mode 100644
index 70b93ac778e7b9a273192ca7ba5c56edad95ecaa..0000000000000000000000000000000000000000
--- a/sammy/src/clm/mclm1.f
+++ /dev/null
@@ -1,376 +0,0 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Readclm_0 (N_Osc_Blank)
-C
-C *** Purpose -- Read CLM file to learn array dimensions
-C
- use namfil_common_m
- use clm_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- CHARACTER*80 Title
- CHARACTER*5 A, Blank
- CHARACTER*1 B(80)
- CHARACTER*89 B_one
- DATA Blank /' '/
-C
- equivalence(B,B_one)
-
- CALL Filopn (10, Fclmxx, 0)
-C
- READ (10,10200,END=400,ERR=500) Title
-10200 FORMAT (A80)
- READ (10,*) Mode_S_Norm, Nphon, Sub, Xdop, Eps, Epsc
- READ (10,10300) A
-10300 FORMAT (A5)
- IF (A.NE.Blank) STOP '[Stop in Readclm_0 in clm/mclm1.f # 4]'
-C
- READ (10,10300) A
- CALL Convert_To_Caps (A, 5, Kpound)
-C
- IF (A.EQ.'CONTI') THEN
- READ (10,10400) B
-10400 FORMAT (80A1)
- CALL Find_Con (B, B_one, N_Contin, Ixx)
-C *** Done reading Continuous Mode; Read next card
- IF (Ixx.EQ.1) GO TO 400
- READ (10,10300,End=400) A
- CALL Convert_To_Caps (A, 5, Kpound)
- END IF
-C
- IF (A.EQ.'DISCR') THEN
- READ (10,10400) B
- CALL Find_Osc (B, B_one, N_Osc, N_Osc_Blank, Ixx)
- IF (Ixx.EQ.1) GO TO 400
-C *** Done reading Discrete Mode; Read next card
- READ (10,10300,END=400) A
- CALL Convert_To_Caps (A, 5, Kpound)
- END IF
-C
- IF (A.EQ.'TRANS') THEN
- READ (10,10400,END=400) B
- END IF
-C
- 400 CONTINUE
- REWIND (UNIT=10)
- RETURN
-C
-C
- 500 CONTINUE
- CLOSE (UNIT=10)
- STOP '[Stop in Readclm_0 in clm/mclm1.f problem reading CLM file]'
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Find_Con (B, Bb, Nn, Ixx)
- CHARACTER*1 B(80)
- CHARACTER*80 Bb
- CHARACTER*10 A, Blank
- DIMENSION C(8)
- DATA Blank /' '/, Zero /0.0d0/
- Ixx = 0
- L = 0
- N = 0
- DO I=1,80
- IF (B(I).NE.' ') THEN
- L = I
- GO TO 10
- END IF
- END DO
- 10 CONTINUE
- DO I=L+1,80
- IF (B(I).EQ.' ') THEN
- N = I
- GO TO 20
- END IF
- END DO
- 20 CONTINUE
- DO I=N+1,80
- IF (B(I).NE.' ') THEN
- M = I
- GO TO 50
- END IF
- END DO
- Nn = 0
-C *** User did not count the phonons; ergo
-C *** i.e., fixed-format where SAMMY counts the number of points
- N = 0
- 30 CONTINUE
- READ (10,10500,END=400) C
-10500 FORMAT (8F10.1)
- DO I=1,8
- N = N + 1
- IF (C(I).EQ.Zero) THEN
- Nn = - N
- GO TO 40
- END IF
- END DO
- GO TO 30
- 40 CONTINUE
-C *** Note that we have read and counted the blank line
- RETURN
-C
- 50 CONTINUE
-C *** User did count the phonons, so now we need to count cards
- READ (10,10000) A
-10000 FORMAT (A10)
- IF (A.EQ.Blank) GO TO 60
- GO TO 50
- 60 CONTINUE
-C *** So number of cards read should now be Ncard + Ncardx; includes blank
- READ (Bb,*) Cx, Nn
- RETURN
-
- 400 CONTINUE
- Ixx = 1
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Find_Osc (B, Bb, Nn, N_Osc_Blank, Ixx)
- CHARACTER*1 B(80)
- CHARACTER*80 Bb
- DIMENSION C(8)
- CHARACTER*10 A, Blank
- DATA Blank /' '/, Zero /0.0d0/
-C
- Ixx = 0
- N_Osc_Blank = 0
-C *** Is card entirely blank?
- DO I=1,80
- IF (B(I).NE.' ') THEN
- L = I
- GO TO 10
- END IF
- END DO
- N = 0
- Nn = 0
- N_Osc_Blank = 1
- READ (10,10500,END=400) C
- READ (10,10500,END=400) C
-C *** User did not count the phonons; nothing is on the card
- GO TO 50
-C
- 10 CONTINUE
-C *** Does card have a decimal point?
- DO I=L+1,80
- IF (B(I).EQ.'.') THEN
-C *** User did not count the phonons
- GO TO 40
- ELSE IF (B(I).EQ.' ') THEN
- GO TO 20
- END IF
- END DO
-C
- 20 CONTINUE
-C *** User did count the oscillators, so now we need to count cards
- READ (10,10000) A
-10000 FORMAT (A10)
- IF (A.EQ.Blank) GO TO 30
- GO TO 20
- 30 CONTINUE
- READ (Bb,*) Nn
- RETURN
-C
- 40 CONTINUE
- N = 0
- Nn = 0
- READ (Bb,10500) C
- READ (10,10500) C
-10500 FORMAT (8F10.1)
- 50 CONTINUE
-C *** Fixed-format where SAMMY counts the number of points
- DO I=1,8
- N = N + 1
- IF (C(I).EQ.Zero) THEN
- Nn = - N + 1
- GO TO 60
- END IF
- END DO
- READ (10,10500,END=400) C
- READ (10,10500,END=400) C
- GO TO 50
- 60 CONTINUE
- RETURN
-C
- 400 CONTINUE
- Nn = - N
- Ixx = 1
- RETURN
- END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Readclm (Phonon, Osc_Eng, Osc_Wts, N_Osc_Blank)
-C
-C *** Purpose -- Read CLM file for real
-C
- use fixedr_m
- use namfil_common_m
- use clm_common_m
- use constn_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Phonon(*), Osc_Eng(*), Osc_Wts(*)
- CHARACTER*80 Title
- CHARACTER*5 A, Blank
- DATA Blank /' '/, Zero /0.0d0/, Half /0.5d0/, One /1.0d0/
-C
- READ (10,10200,END=400,ERR=400) Title
-10200 FORMAT (A80)
- READ (10,*) Mode_S_Norm, Nphon, Sub, Xdop, Eps, Epsc
- IF (Sub .EQ.Zero) Sub = One
- IF (Xdop.EQ.Zero) Xdop = One
- IF (Eps .EQ.Zero) Eps = 0.080d0
- IF (Epsc.EQ.Zero) Epsc = 0.001d0
- READ (10,10300) A
-10300 FORMAT (A5)
- IF (A.NE.Blank) STOP '[Stop in Readclm in clm/mclm1.f]'
-C
- READ (10,10300) A
- CALL Convert_To_Caps (A, 5, Kpound)
-C
- IF (A.EQ.'CONTI') THEN
- IF (N_Contin.LE.0) THEN
- READ (10,*) Del_Phonon
-C *** Fixed-format where SAMMY counts the number of points
- N_Contin = - N_Contin
- READ (10,10500,END=400) (Phonon(I),I=1,N_Contin)
-10500 FORMAT (8F10.1)
- ELSE
-C *** Free-format but user must count
- READ (10,*) Del_Phonon, N
- IF (N.NE.N_Contin) STOP '[Stop in Readclm in mclm1.f # 2]'
- READ (10,*) (Phonon(I),I=1,N_Contin)
- END IF
- READ (10,10300) A
-C *** Done reading Continuous Mode; Read next card
- READ (10,10300) A
- CALL Convert_To_Caps (A, 5, Kpound)
- END IF
-C
- IF (A.EQ.'DISCR') THEN
- IF (N_Osc_Blank.EQ.1) READ (10,10300) A
- IF (N_Osc.LE.0) THEN
-C *** Fixed-format where SAMMY counts the number of points
- N_Osc = - N_Osc
- READ (10,10500,END=400) (Osc_Eng(I),I=1,N_Osc)
- READ (10,10500,END=400) (Osc_Wts(I),I=1,N_Osc)
- ELSE
-C *** Free-format but user must count
- READ (10,*) N
- IF (N.NE.N_Osc) STOP '[Stop in Readclm in mclm1.f # 3]'
- READ (10,*) (Osc_Eng(I),I=1,N_Osc)
- READ (10,*) (Osc_Wts(I),I=1,N_Osc)
- END IF
- READ (10,10300,END=400) A
-C *** Done reading Discrete Mode; Read next card
- READ (10,10300,END=400) A
- CALL Convert_To_Caps (A, 5, Kpound)
- END IF
-C
- IF (A.EQ.'TRANS') THEN
- READ (10,*) Twt, C_Trans, Tbeta
- WRITE (21,10600) Twt, C_Trans, Tbeta
-10600 FORMAT (//, 'Twt, C, Tbeta=', 1P6G14.6)
- END IF
- IF (Tbeta.EQ.Zero) Tbeta = One
-C
- 400 CONTINUE
-C
-C *** Printing the input almost as DOPUSH does
- WRITE (21,10650) Title
-10650 FORMAT (//, 1X, A40)
- WRITE (21,10660) Nphon, Temp, Emin, Emax, Xdop, Eps*100, Epsc*100
-10660 FORMAT (//,
- & ' REQUIRED PHONON-EXPANSION ORDER .......... ', I10, /,
- & ' TEMPERATURE............................... ', F10.3, /,
- & ' MINIMAL ENERGY ........................... ', F10.3, /,
- & ' MAXIMAL ENERGY............................ ', F10.3, /,
- & ' INITIAL XDOP INTERVAL .................... ', F10.3, /,
- & ' NORMALISATION PRECISION .................. ', F10.3, '%', /,
- & ' INTEGRATION PRECISION .................... ', F10.3, '%')
-C
- CLOSE (UNIT=10)
-C
- WRITE (21,10700) N_Contin
-10700 FORMAT (/, ' Number of points in phonon distribution =', I5)
- Bbbb = Phonon(1)*Half
- DO I=2,N_Contin-1
- Bbbb = Bbbb + Phonon(I)
- END DO
- Bbbb = Bbbb + Phonon(N_Contin)*Half
- Cccc = Bbbb*Del_Phonon
- WRITE (21,10800) Bbbb, Del_Phonon, Cccc
-10800 FORMAT (' Sum of points=', 1PG14.6, ' Spacing=',G14.6,
- * ' *=',G14.6)
- WRITE (21,10900) (Phonon(I),I=1,N_Contin)
-10900 FORMAT (1P5G14.6)
- IF (Phonon(1).NE.Zero) THEN
- WRITE (6,11000) Phonon(1)
-11000 FORMAT ('First term must be zero, not', 1PG14.6)
- STOP '[STOP in Readclm in clm/mclm1.f]'
- END IF
-C
- RETURN
- END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Initclm (Save, Phonon, Osc_Eng, Osc_Wts, Ppp, Beta,
- * Osc_Enx, Osc_Snth, Osc_Coth, Bex, Tlast, Tnow, Savex)
-C
-C *** Purpose -- Initialize things
-C
- use ifwrit_m
- use fixedr_m
- use clm_common_m
- use constn_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Phonon(*), Osc_Eng(*), Osc_Wts(*), Ppp(*), Beta(*),
- * Osc_Enx(*), Osc_Snth(*), Osc_Coth(*), Bex(*)
- DIMENSION Save(Nbeta_Max,*), Tlast(*), Tnow(*), Savex(Nbeta_Max,*)
-C
-C
- Tev = Boltzm*Temp
-C *** Effective temperature calculation for creation of beta grid
- Del_Beta = Del_Phonon/Tev
- IF (N_Contin.GT.0) THEN
- CALL Start_Clm (Phonon, Ppp, Del_Beta)
-C *** INPUT -- Phonon, Tbeta, Del_Beta, N_Contin
-C *** OUTPUT -- Ppp, F0, Tbar
- END IF
- Tevf = Tev*Tbar
- Dwpix = F0
- Tevf_true = Tevf
-C
-C *** Initial beta mesh calculation
- CALL Mesh (Beta, Tevf)
-C *** Input -- Tevf, Tev, Emax, Xdop, Del_Phonon, Sub
-C *** Output -- Beta(Nbeta), Del_S_B, Nbeta
-C
- IF (N_Contin.GT.0) THEN
-C *** Contin_X initializes things, generates array Save
- CALL Contin_X (Ppp, Save, Tlast, Tnow, Savex, Del_Beta)
-C *** Input -- Pppppp(.), Alpha, Omega, F0, Tbeta, Del_Beta, Sub,
-C *** N_Contin, Nphon, Nbeta
-C *** Output -- Save(?,Nphon)
- END IF
-C
- IF (N_Osc.GT.0) THEN
-C *** Discre_X initializes things for Discre
- CALL Discre_X (Osc_Eng, Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth,
- * Bex, Beta)
-C *** Input -- Osc_Eng(), Osc_Wts(), Tev, Beta(Nbeta)
-C *** Output -- Osc_Enx()
- END IF
-C
-C
- RETURN
- END
diff --git a/sammy/src/clm/mclm1.f90 b/sammy/src/clm/mclm1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..295ab48db74c75e1929eef7af28313e07ead196f
--- /dev/null
+++ b/sammy/src/clm/mclm1.f90
@@ -0,0 +1,398 @@
+module Readclm_m
+ use CrystalLatticeBroadening_M
+ use AllocateFunctions_m, only : allocate_real_data
+
+ public Readclm_0, Readclm, Initclm
+contains
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Readclm_0 (calc, N_Osc_Blank)
+!
+! *** Purpose -- Read CLM file to learn array dimensions
+!
+ use namfil_common_m, only : Fclmxx
+ IMPLICIT None
+ class(CrystalLatticeBroadening)::calc
+ integer::N_Osc_Blank
+ CHARACTER(80)::Title
+ CHARACTER(5):: A
+ CHARACTER(1)::B(80)
+ CHARACTER(89)::B_one
+ CHARACTER(5), parameter :: Blank = ' '
+ integer::Ixx, Kpound
+!
+ equivalence(B,B_one)
+
+ CALL Filopn (10, Fclmxx, 0)
+!
+ READ (10,10200,END=400,ERR=500) Title
+10200 FORMAT (A80)
+ READ (10,*) calc%Mode_S_Norm, calc%Nphon, calc%Sub, calc%Xdop, calc%Eps, calc%Epsc
+ READ (10,10300) A
+10300 FORMAT (A5)
+ IF (A.NE.Blank) STOP '[Stop in Readclm_0 in clm/mclm1.f # 4]'
+!
+ READ (10,10300) A
+ CALL Convert_To_Caps (A, 5, Kpound)
+!
+ IF (A.EQ.'CONTI') THEN
+ READ (10,10400) B
+10400 FORMAT (80A1)
+ CALL Find_Con (B, B_one, calc%N_Contin, Ixx)
+! *** Done reading Continuous Mode; Read next card
+ IF (Ixx.EQ.1) GO TO 400
+ READ (10,10300,End=400) A
+ CALL Convert_To_Caps (A, 5, Kpound)
+ END IF
+!
+ IF (A.EQ.'DISCR') THEN
+ READ (10,10400) B
+ CALL Find_Osc (B, B_one, calc%N_Osc, N_Osc_Blank, Ixx)
+ IF (Ixx.EQ.1) GO TO 400
+! *** Done reading Discrete Mode; Read next card
+ READ (10,10300,END=400) A
+ CALL Convert_To_Caps (A, 5, Kpound)
+ END IF
+!
+ IF (A.EQ.'TRANS') THEN
+ READ (10,10400,END=400) B
+ END IF
+!
+ 400 CONTINUE
+ REWIND (UNIT=10)
+ RETURN
+!
+!
+ 500 CONTINUE
+ CLOSE (UNIT=10)
+ STOP '[Stop in Readclm_0 in clm/mclm1.f problem reading CLM file]'
+ END
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Find_Con (B, Bb, Nn, Ixx)
+ IMPLICIT none
+ CHARACTER(1):: B(80)
+ CHARACTER(80):: Bb
+ CHARACTER(10):: A
+ integer::Nn, Ixx
+ real(kind=8)::C(8)
+ CHARACTER(10), parameter ::Blank =' '
+ real(kind=8),parameter::Zero=0.0d0
+ real(kind=8)::Cx
+ integer::I, L, M, N
+ Ixx = 0
+ L = 0
+ N = 0
+ DO I=1,80
+ IF (B(I).NE.' ') THEN
+ L = I
+ GO TO 10
+ END IF
+ END DO
+ 10 CONTINUE
+ DO I=L+1,80
+ IF (B(I).EQ.' ') THEN
+ N = I
+ GO TO 20
+ END IF
+ END DO
+ 20 CONTINUE
+ DO I=N+1,80
+ IF (B(I).NE.' ') THEN
+ M = I
+ GO TO 50
+ END IF
+ END DO
+ Nn = 0
+! *** User did not count the phonons; ergo
+! *** i.e., fixed-format where SAMMY counts the number of points
+ N = 0
+ 30 CONTINUE
+ READ (10,10500,END=400) C
+10500 FORMAT (8F10.1)
+ DO I=1,8
+ N = N + 1
+ IF (C(I).EQ.Zero) THEN
+ Nn = - N
+ GO TO 40
+ END IF
+ END DO
+ GO TO 30
+ 40 CONTINUE
+! *** Note that we have read and counted the blank line
+ RETURN
+!
+ 50 CONTINUE
+! *** User did count the phonons, so now we need to count cards
+ READ (10,10000) A
+10000 FORMAT (A10)
+ IF (A.EQ.Blank) GO TO 60
+ GO TO 50
+ 60 CONTINUE
+! *** So number of cards read should now be Ncard + Ncardx; includes blank
+ READ (Bb,*) Cx, Nn
+ RETURN
+
+ 400 CONTINUE
+ Ixx = 1
+ RETURN
+ END
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Find_Osc (B, Bb, Nn, N_Osc_Blank, Ixx)
+ IMPLICIT none
+ CHARACTER(1):: B(80)
+ CHARACTER(80)::Bb
+ integer::Nn, N_Osc_Blank, Ixx
+ real(kind=8)::C(8)
+ CHARACTER(10)::A
+ CHARACTER(10), parameter :: Blank = ' '
+ real(kind=8),parameter:: Zero=0.0d0
+ integer::I, L, N
+
+!
+ Ixx = 0
+ N_Osc_Blank = 0
+! *** Is card entirely blank?
+ DO I=1,80
+ IF (B(I).NE.' ') THEN
+ L = I
+ GO TO 10
+ END IF
+ END DO
+ N = 0
+ Nn = 0
+ N_Osc_Blank = 1
+ READ (10,10500,END=400) C
+ READ (10,10500,END=400) C
+! *** User did not count the phonons; nothing is on the card
+ GO TO 50
+!
+ 10 CONTINUE
+! *** Does card have a decimal point?
+ DO I=L+1,80
+ IF (B(I).EQ.'.') THEN
+! *** User did not count the phonons
+ GO TO 40
+ ELSE IF (B(I).EQ.' ') THEN
+ GO TO 20
+ END IF
+ END DO
+!
+ 20 CONTINUE
+! *** User did count the oscillators, so now we need to count cards
+ READ (10,10000) A
+10000 FORMAT (A10)
+ IF (A.EQ.Blank) GO TO 30
+ GO TO 20
+ 30 CONTINUE
+ READ (Bb,*) Nn
+ RETURN
+!
+ 40 CONTINUE
+ N = 0
+ Nn = 0
+ READ (Bb,10500) C
+ READ (10,10500) C
+10500 FORMAT (8F10.1)
+ 50 CONTINUE
+! *** Fixed-format where SAMMY counts the number of points
+ DO I=1,8
+ N = N + 1
+ IF (C(I).EQ.Zero) THEN
+ Nn = - N + 1
+ GO TO 60
+ END IF
+ END DO
+ READ (10,10500,END=400) C
+ READ (10,10500,END=400) C
+ GO TO 50
+ 60 CONTINUE
+ RETURN
+!
+ 400 CONTINUE
+ Nn = - N
+ Ixx = 1
+ RETURN
+ END
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Readclm (calc, N_Osc_Blank)
+!
+! *** Purpose -- Read CLM file for real
+!
+ use fixedr_m, only : Emax, Emin, Temp
+ IMPLICIT None
+ class(CrystalLatticeBroadening)::calc
+ integer::N_Osc_Blank
+ CHARACTER(80):: Title
+ CHARACTER(5)::A
+ CHARACTER(5), parameter::Blank = ' '
+ real(kind=8),parameter::Zero=0.0d0, Half=0.5d0, One=1.0d0
+ real(kind=8)::Bbbb, Cccc
+ integer::I, Kpound, N
+!
+ READ (10,10200,END=400,ERR=400) Title
+10200 FORMAT (A80)
+ READ (10,*) calc%Mode_S_Norm, calc%Nphon, calc%Sub, calc%Xdop, calc%Eps, calc%Epsc
+ IF (calc%Sub .EQ.Zero) calc%Sub = One
+ IF (calc%Xdop.EQ.Zero) calc%Xdop = One
+ IF (calc%Eps .EQ.Zero) calc%Eps = 0.080d0
+ IF (calc%Epsc.EQ.Zero) calc%Epsc = 0.001d0
+ READ (10,10300) A
+10300 FORMAT (A5)
+ IF (A.NE.Blank) STOP '[Stop in Readclm in clm/mclm1.f]'
+!
+ READ (10,10300) A
+ CALL Convert_To_Caps (A, 5, Kpound)
+!
+ IF (A.EQ.'CONTI') THEN
+ IF (calc%N_Contin.LE.0) THEN
+ READ (10,*) calc%Del_Phonon
+! *** Fixed-format where SAMMY counts the number of points
+ calc%N_Contin = - calc%N_Contin
+ call allocate_real_data(calc%Phonon,calc%N_Contin)
+ READ (10,10500,END=400) (calc%Phonon(I),I=1,calc%N_Contin)
+10500 FORMAT (8F10.1)
+ ELSE
+! *** Free-format but user must count
+ READ (10,*) calc%Del_Phonon, N
+ IF (N.NE.calc%N_Contin) STOP '[Stop in Readclm in mclm1.f # 2]'
+ call allocate_real_data(calc%Phonon,calc%N_Contin)
+ READ (10,*) (calc%Phonon(I),I=1,calc%N_Contin)
+ END IF
+ READ (10,10300) A
+! *** Done reading Continuous Mode; Read next card
+ READ (10,10300) A
+ CALL Convert_To_Caps (A, 5, Kpound)
+ END IF
+!
+ IF (A.EQ.'DISCR') THEN
+ IF (N_Osc_Blank.EQ.1) READ (10,10300) A
+ IF (calc%N_Osc.LE.0) THEN
+! *** Fixed-format where SAMMY counts the number of points
+ calc%N_Osc = - calc%N_Osc
+ call allocate_real_data(calc%Osc_Wts,calc%N_Osc)
+ call allocate_real_data(calc%Osc_Eng,calc%N_Osc)
+ READ (10,10500,END=400) (calc%Osc_Eng(I),I=1,calc%N_Osc)
+ READ (10,10500,END=400) (calc%Osc_Wts(I),I=1,calc%N_Osc)
+ ELSE
+! *** Free-format but user must count
+ READ (10,*) N
+ IF (N.NE.calc%N_Osc) STOP '[Stop in Readclm in mclm1.f # 3]'
+ call allocate_real_data(calc%Osc_Wts, calc%N_Osc)
+ call allocate_real_data(calc%Osc_Eng,calc%N_Osc)
+ READ (10,*) (calc%Osc_Eng(I),I=1,calc%N_Osc)
+ READ (10,*) (calc%Osc_Wts(I),I=1,calc%N_Osc)
+ END IF
+ READ (10,10300,END=400) A
+! *** Done reading Discrete Mode; Read next card
+ READ (10,10300,END=400) A
+ CALL Convert_To_Caps (A, 5, Kpound)
+ END IF
+!
+ IF (A.EQ.'TRANS') THEN
+ READ (10,*) calc%Twt, calc%C_Trans, calc%Tbeta
+ WRITE (21,10600) calc%Twt, calc%C_Trans, calc%Tbeta
+10600 FORMAT (//, 'Twt, C, Tbeta=', 1P6G14.6)
+ END IF
+ IF (calc%Tbeta.EQ.Zero) calc%Tbeta = One
+!
+ 400 CONTINUE
+!
+! *** Printing the input almost as DOPUSH does
+ WRITE (21,10650) Title
+10650 FORMAT (//, 1X, A40)
+ WRITE (21,10660) calc%Nphon, Temp, Emin, Emax, calc%Xdop, calc%Eps*100, calc%Epsc*100
+10660 FORMAT (//, &
+ ' REQUIRED PHONON-EXPANSION ORDER .......... ', I10, /, &
+ ' TEMPERATURE............................... ', F10.3, /, &
+ ' MINIMAL ENERGY ........................... ', F10.3, /, &
+ ' MAXIMAL ENERGY............................ ', F10.3, /, &
+ ' INITIAL XDOP INTERVAL .................... ', F10.3, /, &
+ ' NORMALISATION PRECISION .................. ', F10.3, '%', /,&
+ ' INTEGRATION PRECISION .................... ', F10.3, '%')
+!
+ CLOSE (UNIT=10)
+!
+ WRITE (21,10700) calc%N_Contin
+10700 FORMAT (/, ' Number of points in phonon distribution =', I5)
+ Bbbb = calc%Phonon(1)*Half
+ DO I=2,calc%N_Contin-1
+ Bbbb = Bbbb + calc%Phonon(I)
+ END DO
+ Bbbb = Bbbb + calc%Phonon(calc%N_Contin)*Half
+ Cccc = Bbbb*calc%Del_Phonon
+ WRITE (21,10800) Bbbb, calc%Del_Phonon, Cccc
+10800 FORMAT (' Sum of points=', 1PG14.6, ' Spacing=',G14.6, &
+ ' *=',G14.6)
+ WRITE (21,10900) (calc%Phonon(I),I=1,calc%N_Contin)
+10900 FORMAT (1P5G14.6)
+ IF (calc%Phonon(1).NE.Zero) THEN
+ WRITE (6,11000) calc%Phonon(1)
+11000 FORMAT ('First term must be zero, not', 1PG14.6)
+ STOP '[STOP in Readclm in clm/mclm1.f]'
+ END IF
+!
+ RETURN
+ END
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Initclm (calc)
+!
+! *** Purpose -- Initialize things
+!
+ use fixedr_m, only : Temp
+ use constn_common_m, only : Boltzm
+ use mclm2_M
+ IMPLICIT None
+ class(CrystalLatticeBroadening)::calc
+ real(kind=8)::Del_Beta, Tevf, Tevf_true
+!
+!
+ calc%Tev = Boltzm*Temp
+! *** Effective temperature calculation for creation of beta grid
+ Del_Beta = calc%Del_Phonon/calc%Tev
+ IF (calc%N_Contin.GT.0) THEN
+ CALL Start_Clm (calc, Del_Beta)
+! *** INPUT -- Phonon, Tbeta, Del_Beta, N_Contin
+! *** OUTPUT -- Ppp, F0, Tbar
+ END IF
+ Tevf = calc%Tev*calc%Tbar
+ calc%Dwpix = calc%F0
+ Tevf_true = Tevf
+!
+! *** Initial beta mesh calculation
+ CALL Mesh (calc, Tevf)
+! *** Input -- Tevf, Tev, Emax, Xdop, calc%Del_Phonon, Sub
+! *** Output -- Beta(Nbeta), Del_S_B, Nbeta
+!
+ IF (calc%N_Contin.GT.0) THEN
+! *** Contin_X initializes things, generates array Save
+ CALL Contin_X (calc, Del_Beta)
+! *** Input -- Pppppp(.), Alpha, Omega, F0, Tbeta, Del_Beta, Sub,
+! *** N_Contin, Nphon, Nbeta
+! *** Output -- Save(?,Nphon)
+ END IF
+!
+ IF (calc%N_Osc.GT.0) THEN
+! *** Discre_X initializes things for Discre
+ CALL Discre_X (calc)
+! *** Input -- Osc_Eng(), Osc_Wts(), Tev, Beta(Nbeta)
+! *** Output -- Osc_Enx()
+ END IF
+!
+!
+ RETURN
+ END
+end module Readclm_m
diff --git a/sammy/src/clm/mclm2.f b/sammy/src/clm/mclm2.f
deleted file mode 100644
index 7f3cee7f259b8c28eeaddc8eac8492dd59394e56..0000000000000000000000000000000000000000
--- a/sammy/src/clm/mclm2.f
+++ /dev/null
@@ -1,359 +0,0 @@
-C
-C
-C -------------------------------------------------------------------
-C
- SUBROUTINE Start_Clm (Phonon, Ppp, Del_Beta)
-C
-C *** Purpose -- Compute several integral functions of the phonon
-C *** frequency distribution.
-C *** Called by -- Initclm
-C *** Input -- Phonon(.), Tbeta, Del_Beta, N_Contin
-C *** Output -- Ppp(.), F0, Tbar
-C *** Local -- Q, Annnnn, Ubeta, V, Vv, Fs0, Fs2, W2
-C
- use clm_common_m
- IMPLICIT NONE
- INTEGER I
- DIMENSION Phonon(*), Ppp(*)
- DOUBLE PRECISION Phonon, Ppp, Del_Beta,
- * Q, Annnnn, Ubeta, V, Vv, Fs0, Fs2, W2
- DOUBLE PRECISION Zero, Half, One
- DATA Zero /0.0d0/, Half /0.5d0/, One /1.0d0/
-C
-C
-C *** ---
-C *** Copy input spectrum into Ppp array
- DO I=1,N_Contin
- Ppp(I) = Phonon(I)
- END DO
-C
-C *** ---
-C *** Calculate normalizing constant = Annnnn
- Annnnn = Ppp(1)*Half
- DO I=2,N_Contin-1
- Annnnn = Annnnn + Ppp(I)
- END DO
- Annnnn = Annnnn + Ppp(N_Contin)*Half
-C
-C *** ---
-C *** Calculate Debye-Waller Lambda and effective temperature
-C *** at the same time as calculate Ppp = Phonon/sinth/beta
-C *** From here to next "C * ---" used to be Fsum(0...) and Fsum(2...)
-cq Ppp(1) = Ppp(2)/Del_Beta**2 Clearly this is wrong
-cq Ppp(1) = Ppp(1)/Del_Beta**2 This is also wrong
-cq Ppp(1) = Ppp(1)/Zero This is right! but ill-defined
- Ppp(1) = Ppp(1)/Del_Beta**2
- Ubeta = Del_Beta
- V = dEXP(Half*Del_Beta)
- Vv = V
-cq Fs0 = Ppp(1)
- Fs0 = Zero
- Fs2 = Zero
- DO I=2,N_Contin-1
- W2 = Ubeta**2
- Ppp(I) = ( Ppp(I)/Ubeta ) / (Vv-One/Vv)
- Q = Ppp(I) * (Vv+One/Vv)
-C nml so P(I )= Phonon(I+1 ) / sinth(I Del_Beta/2) / { I Del_Beta }
-C nml P(Beta)= Phonon(Beta) / sinth( Beta/2) / { Beta }
-C nml Q = Phonon(I+1 ) * coth (I Del_Beta/2) / { I Del_Beta }
-C nml Q(Beta)= Phonon(Beta) * coth ( Beta/2) / { Beta }
- Fs0 = Fs0 + Q
- Fs2 = Fs2 + Q * W2
- Vv = V*Vv
- Ubeta = Ubeta + Del_Beta
- END DO
- Ppp(N_Contin) = ( Ppp(N_Contin)/Ubeta ) / (Vv-One/Vv)
- Q = Ppp(N_Contin) * (Vv+One/Vv)
- W2 = Ubeta**2
- Fs0 = Fs0 + Q*Half
- Fs2 = Fs2 + Q*Half*W2
-C *** ---
- F0 = ( Fs0 * Tbeta) / Annnnn
- Tbar = ( Fs2 * Half ) / Annnnn
-C
-C *** ---
-C *** Convert Ppp(Beta) into first term in phonon expansion sum
- Q = Fs0*Del_Beta
- DO I=1,N_Contin
- Ubeta = Del_Beta*(I-1)
- Ppp(I) = Ppp(I)*dEXP(Half*Ubeta)/Q
- END DO
-C
- RETURN
- END
-C
-C
-C ----------------------------------------------------------------------
-C
- SUBROUTINE Mesh (Beta, Tevf)
-C
-C Beta GRID CALCULATION
-C
-C &&& Del_S_B - THE SOLID SPECTRUM GRID Mesh
-C Sub - NUMBER OF SubINTERVALS OF Beta GRID
-C Bmax - MAXIMAL VALUE OF Beta
-C Nbeta - NUMBER OF Beta VALUES IN THE INTERVAL (0,Bmax)
-C
-C *** Input -- Tevf, Tev, Awr, Emax, Xdop, Del_Phonon, Sub, Nbeta_Max
-C *** Output -- Beta(Nbeta), Del_S_B, Nbeta
-C
- use fixedr_m
- use clm_common_m
- use constn_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- INTEGER J
- DOUBLE PRECISION Beta(*), Bmax, Tevf
-C
- IF (Del_Phonon.GT.0.0d0) THEN
- Del_S_B = Del_Phonon/(Sub*Tev)
- Bmax = Xdop/Tev * dSQRT(4.0D0*Emax*Tevf*Aneutr/Aaawww)
- Nbeta = Int(Bmax/Del_S_B)
-C
- IF (Nbeta.GT.Nbeta_Max) THEN
- WRITE (6,10000) Nbeta, Nbeta_Max, Xdop
-10000 FORMAT ('Nbeta is too big', 2I10, 1P6G14.6)
- END IF
-C
- Beta(1) = 0.0D0
- DO J=2,Nbeta
- Beta(J) = Beta(J-1) + Del_S_B
- END DO
- ELSE
- Nbeta = 0
- END IF
- RETURN
- END
-C
-C
-C -------------------------------------------------------------------
-C
- SUBROUTINE Contin_X (Ppp, Save, Tlast, Tnow, Savex, Del_Beta)
-C
-C *** Purpose -- Generate array Save(Kbeta,Kphon) for use in Contin
-C *** Input -- Ppp(.), Alpha, Omega, F0, Tbeta, Del_Beta, Sub,
-C *** N_Contin, Nphon, Nbeta
-C *** Output -- Save (?,Nphon)
-C *** Dummy -- Savex(?,Nphon), Tlast(?), Tnow(?)
-C
- use fixedr_m
- use clm_common_m
- use constn_common_m
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- DOUBLE PRECISION Ppp(*), Save(Nbeta_Max,*),
- & Tlast(*), Tnow(*), Savex(Nbeta_Max,*)
- DOUBLE PRECISION Del_Beta, Exx, Exy, Alf0, Omf0, B, C, Bt, Btp, X
- INTEGER NLast, Nnow, I, K, N
- DOUBLE PRECISION Zero, One
- PARAMETER (Zero=0.0d0, One=1.0d0)
-C
-C *** Note that Ppp(Beta) = Phonon(Beta) * dEXP(Beta/2) /
-C *** [Beta sinh(Beta/2) normalization]
-C
-C *** ------
-C *** First term in the phonon expansion sum
-C
- CALL Zero_Array (Save , Nphon*Nbeta_Max)
- CALL Zero_Array (Savex, Nphon*Nbeta_Max)
-C
- DO I=1,N_Contin
- Tlast(I) = Ppp(I)
- Savex(I,1) = Ppp(I)
- END DO
- N = Nphon
- NLast = N_Contin
-C
-C
-C *** ------
-C *** Add other terms in the phonon expansion sum
- IF (Tbeta.NE.Zero) THEN
- Rn = Aneutr/(Aaawww+Aneutr)
- Alf0 = Emin*Rn/Tev * F0
- Omf0 = Emax*Rn/Tev * F0
- Exx = Alf0*dEXP(-Alf0)
- Exy = Omf0*dEXP(-Omf0)
- B = Exx
- C = Exy
- DO N=2,Nphon
- Exx = Alf0*Exx/N
- Exy = Omf0*Exy/N
- IF (B+Exx.EQ.B .AND. C+Exy.EQ.C) GO TO 10
- B = B + Exx
- C = C + Exy
- Nnow = N_Contin + NLast - 1
- CALL Convol (Ppp, Tlast, Tnow, N_Contin, NLast, Nnow,
- & Del_Beta)
- DO I=1,Nnow
- Tlast(I) = Tnow(I)
- Savex(I,N) = Tnow(I)
- END DO
- NLast = Nnow
- END DO
- IF (N.GT.Nphon) N = Nphon
- END IF
-C
- 10 CONTINUE
- IF (Nphon.EQ.N) WRITE (6,10000) Nphon
-10000 FORMAT (' ### Caution ### Number of phonons may not be enough to',
- & ' ###', /,
- & ' ### reach convergence. Try more than', I4,
- & ' ###')
- Nphon = N
-C
- DO K=1,Nbeta
- X = (K-1)/Sub
- I = X
-C *** Note that equally-spaced points in Beta are assumed throughout
- IF (I.LT.0 .OR. I.GE.Nnow-1) THEN
-C *** Don't need to zero Save cuz is already zero
- ELSE IF (I.EQ.0) THEN
- Bt = Zero
- Btp = One
- I = I + 1
- DO N=1,Nphon
- Save(K,N) = Savex(I,N)*(Btp-X) + X*Savex(I+1,N)
- END DO
- ELSE IF (I.LT.Nnow-1) THEN
- Bt = dFLOAT(I)
- Btp = Bt + One
- I = I + 1
- DO N=1,Nphon
- Save(K,N) = Savex(I,N)*(Btp-X) + (X-Bt)*Savex(I+1,N)
- END DO
- ELSE
- STOP '[Should never get here in Contin_X in clm/mclm3.f]'
- END IF
- END DO
-C
- RETURN
- END
-C
-C
-C ----------------------------------------------------------------------
-C
- SUBROUTINE Convol (Ppp, TLast, Tnow, N_Contin, NLast, Nnow,
- & Del_Beta)
-C
-C *** PURPOSE -- Calculate the next term in the phonon expansion by
-C *** convolving P with Tlast and writing the result into
-C *** Tnow. The integral of Tnow is also checked.
-C *** METHOD -- Trapazoidal integration
-C *** CALLED BY -- Contin_X
-C
- IMPLICIT NONE
- INTEGER N_Contin, NLast, Nnow, K, J, I1, I2, Kmax
- DOUBLE PRECISION Ppp(*), Tlast(*), Tnow(*),
- & EP, Be, Del_Beta, F2, Cc, F1, Zero, Half, One, Small
- DATA Zero /0.0d0/, Half /0.5d0/, One /1.0d0/, Small /1.d-20/
-C
- Kmax = 0
- DO K=1,Nnow
- Tnow(K) = Zero
- EP = One
-C
- DO J=1,N_Contin
- I1 = K + J - 2
- I2 = K - J
- F1 = Zero
- Be = (J-1)*Del_Beta
-C
- IF (Ppp(J).GT.Zero) THEN
- IF (I1+1.LE.NLast) F1 = Tlast(I1+1)*dEXP(-Be)
- F2 = Zero
- IF (I2.GE.0 .AND. I2+1.LE.NLast) THEN
- F2 = Tlast(I2+1)
- ELSE IF (I2.LT.0 .AND. 1-I2.LE.NLast) THEN
- Be = -I2*Del_Beta
- F2 = Tlast(1-I2)*dEXP(-Be)
- ENDIF
- Cc = Ppp(J)*(F1+F2)
- IF (J.EQ.1 .OR. J.EQ.N_Contin) Cc = Half*Cc
- Tnow(K) = Tnow(K)+Cc
- END IF
-C
- END DO
-C
- Tnow(K) = Tnow(K)*Del_Beta
- IF (Tnow(K).LT.Small) THEN
- Tnow(K) = Zero
- ELSE
- IF (K.GT.Kmax) Kmax = K
- END IF
- END DO
-C
- IF (Kmax.LT.Nnow) Nnow = Kmax
- RETURN
- END
-C
-C
-C ----------------------------------------------------------------------
-C
- SUBROUTINE Discre_X (Osc_Eng, Osc_Wts, Osc_Enx, Osc_Snth,
- * Osc_Coth, Bex, Beta)
-C
-C
-C *** PURPOSE -- Do energy-independent bits of Discre calculations
-C *** Called by -- Samclm_0
-C *** Uses -- no routines
-C
-C
- use fixedr_m
- use clm_common_m
- use constn_common_m
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- DOUBLE PRECISION Osc_Eng(*), Osc_Wts(*), Osc_Enx(*), Osc_Snth(*),
- & Osc_Coth(*), Bex(*), Beta(Nbeta)
- DOUBLE PRECISION Sn, Cn, Eb
- INTEGER K, I
- DOUBLE PRECISION Zero, Half, One
- PARAMETER (Zero=0.0d0, Half=0.5d0, One=1.0d0)
-C
-C *** SET UP OSCILLATOR PARAMETERS
-C
- Sum_Osc_Wts = Zero
- DO I=1,N_Osc
- Sum_Osc_Wts = Sum_Osc_Wts + Osc_Wts(I)
- END DO
-C
- DO I=1,N_Osc
- Osc_Enx(I) = Osc_Eng(I)/Tev
- END DO
-C
- Tsave = Zero
- Dw0 = Dwpix
- DO I=1,N_Osc
- Eb = dEXP(Half*Osc_Enx(I))
- Sn = Half* (Eb-One/Eb)
- Cn = Half* (Eb+One/Eb)
- Osc_Snth(I) = Osc_Wts(I)/(Sn*Osc_Enx(I))
- Osc_Coth(I) = Osc_Snth(I)*Cn
- IF (Dwpix.GT.Zero) Dwpix = Dwpix + Osc_Coth(I)
- Tsave = Tsave + Osc_Wts(I) * Osc_Eng(I) *Cn/Sn
- END DO
-C
-C
- K = Nbeta
- DO I=1,Nbeta
- Bex(I) = - Beta(K)
- K = K - 1
- END DO
-C
- IF (Beta(1).LE.0.000000001) THEN
- Bex(Nbeta) = Zero
- K = Nbeta + 1
- ELSE
- K = Nbeta + 2
- Bex(Nbeta+1) = Beta(1)
- END IF
-C
- DO I=2,Nbeta
- Bex(K) = Beta(I)
- K = K + 1
- END DO
- Nbx = K - 1
- IF (Nbx.GT.Nbeta_Max) THEN
- WRITE (6,10000) Nbx, Nbeta_Max
-10000 FORMAT ('Nbeta_Max must be', I5, ' but is only', I5)
- STOP '[Stop in Discre_X in clm/mclm2.f]'
- END IF
- RETURN
- END
diff --git a/sammy/src/clm/mclm2.f90 b/sammy/src/clm/mclm2.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b4dd8ab46c65e0f9ed6149542ca1cafe0bf88384
--- /dev/null
+++ b/sammy/src/clm/mclm2.f90
@@ -0,0 +1,361 @@
+module mclm2_M
+use CrystalLatticeBroadening_M
+use AllocateFunctions_m
+implicit none
+contains
+!
+!
+! -------------------------------------------------------------------
+!
+ SUBROUTINE Start_Clm (calc, Del_Beta)
+!
+! *** Purpose -- Compute several integral functions of the phonon
+! *** frequency distribution.
+! *** Called by -- Initclm
+! *** Input -- Phonon(.), Tbeta, Del_Beta, N_Contin
+! *** Output -- Ppp(.), F0, Tbar
+! *** Local -- Q, Annnnn, Ubeta, V, Vv, Fs0, Fs2, W2
+!
+ class(CrystalLatticeBroadening)::calc
+ INTEGER I
+ DOUBLE PRECISION Del_Beta, &
+ Q, Annnnn, Ubeta, V, Vv, Fs0, Fs2, W2
+ DOUBLE PRECISION Zero, Half, One
+ DATA Zero /0.0d0/, Half /0.5d0/, One /1.0d0/
+!
+!
+! *** ---
+! *** Copy input spectrum into Ppp array
+ call allocate_real_data(calc%Ppp, calc%N_Contin)
+ DO I=1,calc%N_Contin
+ calc%Ppp(I) = calc%Phonon(I)
+ END DO
+!
+! *** ---
+! *** Calculate normalizing constant = Annnnn
+ Annnnn = calc%Ppp(1)*Half
+ DO I=2,calc%N_Contin-1
+ Annnnn = Annnnn + calc%Ppp(I)
+ END DO
+ Annnnn = Annnnn + calc%Ppp(calc%N_Contin)*Half
+!
+! *** ---
+! *** Calculate Debye-Waller Lambda and effective temperature
+! *** at the same time as calculate calc%Ppp = calc%Phonon/sinth/beta
+! *** From here to next "C * ---" used to be Fsum(0...) and Fsum(2...)
+!q calc%Ppp(1) = calc%Ppp(2)/Del_Beta**2 Clearly this is wrong
+!q calc%Ppp(1) = calc%Ppp(1)/Del_Beta**2 This is also wrong
+!q calc%Ppp(1) = calc%Ppp(1)/Zero This is right! but ill-defined
+ calc%Ppp(1) = calc%Ppp(1)/Del_Beta**2
+ Ubeta = Del_Beta
+ V = dEXP(Half*Del_Beta)
+ Vv = V
+!q Fs0 = calc%Ppp(1)
+ Fs0 = Zero
+ Fs2 = Zero
+ DO I=2,calc%N_Contin-1
+ W2 = Ubeta**2
+ calc%Ppp(I) = ( calc%Ppp(I)/Ubeta ) / (Vv-One/Vv)
+ Q = calc%Ppp(I) * (Vv+One/Vv)
+! nml so P(I )= calc%Phonon(I+1 ) / sinth(I Del_Beta/2) / { I Del_Beta }
+! nml P(Beta)= calc%Phonon(Beta) / sinth( Beta/2) / { Beta }
+! nml Q = calc%Phonon(I+1 ) * coth (I Del_Beta/2) / { I Del_Beta }
+! nml Q(Beta)= calc%Phonon(Beta) * coth ( Beta/2) / { Beta }
+ Fs0 = Fs0 + Q
+ Fs2 = Fs2 + Q * W2
+ Vv = V*Vv
+ Ubeta = Ubeta + Del_Beta
+ END DO
+ calc%Ppp(calc%N_Contin) = ( calc%Ppp(calc%N_Contin)/Ubeta ) / (Vv-One/Vv)
+ Q = calc%Ppp(calc%N_Contin) * (Vv+One/Vv)
+ W2 = Ubeta**2
+ Fs0 = Fs0 + Q*Half
+ Fs2 = Fs2 + Q*Half*W2
+! *** ---
+ calc%F0 = ( Fs0 * calc%Tbeta) / Annnnn
+ calc%Tbar = ( Fs2 * Half ) / Annnnn
+!
+! *** ---
+! *** Convert Ppp(Beta) into first term in phonon expansion sum
+ Q = Fs0*Del_Beta
+ DO I=1,calc%N_Contin
+ Ubeta = Del_Beta*(I-1)
+ calc%Ppp(I) = calc%Ppp(I)*dEXP(Half*Ubeta)/Q
+ END DO
+!
+ RETURN
+ END
+!
+!
+! ----------------------------------------------------------------------
+!
+ SUBROUTINE Mesh (calc, Tevf)
+!
+! Beta GRID CALCULATION
+!
+! &&& Del_S_B - THE SOLID SPECTRUM GRID Mesh
+! Sub - NUMBER OF SubINTERVALS OF Beta GRID
+! Bmax - MAXIMAL VALUE OF Beta
+! Nbeta - NUMBER OF Beta VALUES IN THE INTERVAL (0,Bmax)
+!
+! *** Input -- Tevf, Tev, Awr, Emax, Xdop, calc%Del_Phonon, Sub, Nbeta_Max
+! *** Output -- Beta(Nbeta), Del_S_B, Nbeta
+!
+ use fixedr_m, only : Aaawww, Emax
+ use constn_common_m, only : Aneutr
+ class(CrystalLatticeBroadening)::calc
+ INTEGER J
+ DOUBLE PRECISION Bmax, Tevf
+!
+ IF (calc%Del_Phonon.GT.0.0d0) THEN
+ calc%Del_S_B = calc%Del_Phonon/(calc%Sub*calc%Tev)
+ Bmax = calc%Xdop/calc%Tev * dSQRT(4.0D0*Emax*Tevf*Aneutr/Aaawww)
+ calc%Nbeta = Int(Bmax/calc%Del_S_B)
+!
+ IF (calc%Nbeta.GT.calc%Nbeta_Max) THEN
+ WRITE (6,10000) calc%Nbeta, calc%Nbeta_Max, calc%Xdop
+10000 FORMAT ('Nbeta is too big', 2I10, 1P6G14.6)
+ END IF
+!
+ call allocate_real_data(calc%Beta, calc%Nbeta)
+ calc%Beta(1) = 0.0D0
+ DO J=2,calc%Nbeta
+ calc%Beta(J) = calc%Beta(J-1) + calc%Del_S_B
+ END DO
+ ELSE
+ calc%Nbeta = 0
+ END IF
+ RETURN
+ END
+!
+!
+! -------------------------------------------------------------------
+!
+ SUBROUTINE Contin_X (calc, Del_Beta)
+!
+! *** Purpose -- Generate array Save(Kbeta,Kphon) for use in Contin
+! *** Input -- Ppp(.), Alpha, Omega, F0, Tbeta, Del_Beta, Sub,
+! *** N_Contin, Nphon, Nbeta
+! *** Output -- Save (?,Nphon)
+! *** Dummy -- Savex(?,Nphon)
+!
+ use fixedr_m, only : Aaawww, Emax, Emin
+ use constn_common_m, only : Aneutr
+ class(CrystalLatticeBroadening)::calc
+ DOUBLE PRECISION Del_Beta, Exx, Exy, Alf0, Omf0, B, C, Bt, Btp, X, Rn
+ INTEGER NLast, Nnow, I, K, N
+ real(kind=8),parameter::Zero=0.0d0, One=1.0d0
+!
+! *** Note that Ppp(Beta) = Phonon(Beta) * dEXP(Beta/2) /
+! *** [Beta sinh(Beta/2) normalization]
+!
+! *** ------
+! *** First term in the phonon expansion sum
+!
+!
+ call allocate_real_data(calc%Tlast, calc%N_Contin)
+ call reallocate_real_data_2d(calc%savex, calc%NBeta, 0, calc%Nphon, 0)
+ DO I=1,calc%N_Contin
+ calc%Tlast(I) = calc%Ppp(I)
+ calc%Savex(I,1) = calc%Ppp(I)
+ END DO
+ N = calc%Nphon
+ NLast = calc%N_Contin
+!
+!
+! *** ------
+! *** Add other terms in the phonon expansion sum
+ IF (calc%Tbeta.NE.Zero) THEN
+ Rn = Aneutr/(Aaawww+Aneutr)
+ Alf0 = Emin*Rn/calc%Tev * calc%F0
+ Omf0 = Emax*Rn/calc%Tev * calc%F0
+ Exx = Alf0*dEXP(-Alf0)
+ Exy = Omf0*dEXP(-Omf0)
+ B = Exx
+ C = Exy
+ DO N=2,calc%Nphon
+ Exx = Alf0*Exx/N
+ Exy = Omf0*Exy/N
+ IF (B+Exx.EQ.B .AND. C+Exy.EQ.C) GO TO 10
+ B = B + Exx
+ C = C + Exy
+ Nnow = calc%N_Contin + NLast - 1
+ CALL Convol (calc, NLast, Nnow, Del_Beta)
+ call reallocate_real_data(calc%Tlast, Nnow, 10)
+ call reallocate_real_data(calc%Tnow, Nnow, 10)
+ call reallocate_real_data_2d(calc%savex, Nnow, 0, calc%Nphon, 0)
+ DO I=1,Nnow
+ calc%Tlast(I) = calc%Tnow(I)
+ calc%Savex(I,N) = calc%Tnow(I)
+ END DO
+ NLast = Nnow
+ END DO
+ IF (N.GT.calc%Nphon) N = calc%Nphon
+ END IF
+!
+ 10 CONTINUE
+ IF (calc%Nphon.EQ.N) WRITE (6,10000) calc%Nphon
+10000 FORMAT (' ### Caution ### Number of phonons may not be enough to', &
+ ' ###', /, &
+ ' ### reach convergence. Try more than', I4, &
+ ' ###')
+ calc%Nphon = N
+!
+ call reallocate_real_data_2d(calc%save, calc%NBeta, 0, calc%Nphon, 0)
+ calc%save = 0.0d0
+ DO K=1,calc%Nbeta
+ X = (K-1)/calc%Sub
+ I = X
+! *** Note that equally-spaced points in Beta are assumed throughout
+ IF (I.LT.0 .OR. I.GE.Nnow-1) THEN
+! *** Don't need to zero Save cuz is already zero
+ ELSE IF (I.EQ.0) THEN
+ Bt = Zero
+ Btp = One
+ I = I + 1
+ DO N=1,calc%Nphon
+ calc%Save(K,N) = calc%Savex(I,N)*(Btp-X) + X*calc%Savex(I+1,N)
+ END DO
+ ELSE IF (I.LT.Nnow-1) THEN
+ Bt = dFLOAT(I)
+ Btp = Bt + One
+ I = I + 1
+ DO N=1,calc%Nphon
+ calc%Save(K,N) = calc%Savex(I,N)*(Btp-X) + (X-Bt)*calc%Savex(I+1,N)
+ END DO
+ ELSE
+ STOP '[Should never get here in Contin_X in clm/mclm3.f]'
+ END IF
+ END DO
+!
+ RETURN
+ END
+!
+!
+! ----------------------------------------------------------------------
+!
+ SUBROUTINE Convol (calc, NLast, Nnow, Del_Beta)
+!
+! *** PURPOSE -- Calculate the next term in the phonon expansion by
+! *** convolving P with Tlast and writing the result into
+! *** Tnow. The integral of Tnow is also checked.
+! *** METHOD -- Trapazoidal integration
+! *** CALLED BY -- Contin_X
+!
+ class(CrystalLatticeBroadening)::calc
+ INTEGER NLast, Nnow, K, J, I1, I2, Kmax
+ DOUBLE PRECISION EP, Be, Del_Beta, F2, Cc, F1
+ real(kind=8),parameter:: Zero = 0.0d0, Half = 0.5d0, One = 1.0d0, Small = 1.d-20
+!
+ Kmax = 0
+ call reallocate_real_data(calc%Tnow, Nnow, 10)
+ DO K=1,Nnow
+ calc%Tnow(K) = Zero
+ EP = One
+!
+ DO J=1,calc%N_Contin
+ I1 = K + J - 2
+ I2 = K - J
+ F1 = Zero
+ Be = (J-1)*Del_Beta
+!
+ IF (calc%Ppp(J).GT.Zero) THEN
+ call reallocate_real_data(calc%Tlast, NLast, 10)
+ IF (I1+1.LE.NLast) F1 = calc%Tlast(I1+1)*dEXP(-Be)
+ F2 = Zero
+ IF (I2.GE.0 .AND. I2+1.LE.NLast) THEN
+ F2 = calc%Tlast(I2+1)
+ ELSE IF (I2.LT.0 .AND. 1-I2.LE.NLast) THEN
+ Be = -I2*Del_Beta
+ F2 = calc%Tlast(1-I2)*dEXP(-Be)
+ ENDIF
+ Cc = calc%Ppp(J)*(F1+F2)
+ IF (J.EQ.1 .OR. J.EQ.calc%N_Contin) Cc = Half*Cc
+ calc%Tnow(K) = calc%Tnow(K)+Cc
+ END IF
+!
+ END DO
+!
+ calc%Tnow(K) = calc%Tnow(K)*Del_Beta
+ IF (calc%Tnow(K).LT.Small) THEN
+ calc%Tnow(K) = Zero
+ ELSE
+ IF (K.GT.Kmax) Kmax = K
+ END IF
+ END DO
+!
+ IF (Kmax.LT.Nnow) Nnow = Kmax
+ RETURN
+ END
+!
+!
+! ----------------------------------------------------------------------
+!
+ SUBROUTINE Discre_X (calc)
+!
+!
+! *** PURPOSE -- Do energy-independent bits of Discre calculations
+! *** Called by -- Samclm_0
+! *** Uses -- no routines
+!
+!
+ class(CrystalLatticeBroadening)::calc
+ real(kind=8)::Sn, Cn, Eb
+ INTEGER::K, I
+ real(kind=8),parameter::Zero=0.0d0, Half=0.5d0, One=1.0d0
+!
+! *** SET UP OSCILLATOR PARAMETERS
+!
+ calc%Sum_Osc_Wts = Zero
+ DO I=1,calc%N_Osc
+ calc%Sum_Osc_Wts = calc%Sum_Osc_Wts + calc%Osc_Wts(I)
+ END DO
+!
+ call allocate_real_data(calc%Osc_Enx, calc%N_Osc)
+ DO I=1,calc%N_Osc
+ calc%Osc_Enx(I) = calc%Osc_Eng(I)/calc%Tev
+ END DO
+!
+ calc%Tsave = Zero
+ calc%Dw0 = calc%Dwpix
+ call allocate_real_data(calc%Osc_Snth, calc%N_Osc)
+ call allocate_real_data(calc%Osc_Coth, calc%N_Osc)
+ DO I=1,calc%N_Osc
+ Eb = dEXP(Half*calc%Osc_Enx(I))
+ Sn = Half* (Eb-One/Eb)
+ Cn = Half* (Eb+One/Eb)
+ calc%Osc_Snth(I) = calc%Osc_Wts(I)/(Sn*calc%Osc_Enx(I))
+ calc%Osc_Coth(I) = calc%Osc_Snth(I)*Cn
+ IF (calc%Dwpix.GT.Zero) calc%Dwpix = calc%Dwpix + calc%Osc_Coth(I)
+ calc%Tsave = calc%Tsave + calc%Osc_Wts(I) * calc%Osc_Eng(I) *Cn/Sn
+ END DO
+!
+!
+ K = calc%Nbeta
+ call allocate_real_data(calc%Bex, 2*calc%Nbeta)
+ DO I=1,calc%Nbeta
+ calc%Bex(I) = - calc%Beta(K)
+ K = K - 1
+ END DO
+!
+ IF (calc%Beta(1).LE.0.000000001) THEN
+ calc%Bex(calc%Nbeta) = Zero
+ K = calc%Nbeta + 1
+ ELSE
+ K = calc%Nbeta + 2
+ calc%Bex(calc%Nbeta+1) = calc%Beta(1)
+ END IF
+!
+ DO I=2,calc%Nbeta
+ calc%Bex(K) = calc%Beta(I)
+ K = K + 1
+ END DO
+ calc%Nbx = K - 1
+ IF (calc%Nbx.GT.calc%Nbeta_Max) THEN
+ WRITE (6,10000) calc%Nbx, calc%Nbeta_Max
+10000 FORMAT ('Nbeta_Max must be', I5, ' but is only', I5)
+ STOP '[Stop in Discre_X in clm/mclm2.f]'
+ END IF
+ RETURN
+ END
+end module mclm2_M
diff --git a/sammy/src/clm/mclm3.f b/sammy/src/clm/mclm3.f
deleted file mode 100644
index c4638ab379af5d35e7d25c3df91fcf8fe83e7786..0000000000000000000000000000000000000000
--- a/sammy/src/clm/mclm3.f
+++ /dev/null
@@ -1,258 +0,0 @@
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Dopclm (Iflmsc,
- * Beta, Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth,
- * Bex, S_Expb, S_Ex, Save, Bs, Ss, Max_T)
-
-C
-C *** PURPOSE -- FORM DOPPLER-BROADENED CROSS SECTION AND DERIVATIVES
-C
- use fixedi_m, only : Ktruet, Lllmax,
- * Numiso, numcro, numUsedPar
- use ifwrit_m, only : Kcros, Kdebug, Kfinit, Ksindi, Ksitmp,
- * ktzero, Kvtemp, Kvthck, Nonu
- use fixedr_m, only : Emax, Emaxs, Emin, Emins, Temp, Thick,
- * Sitemp
- use brdd_common_m, only : Iup, Kc
- use clm_common_m, only : Nbeta_Max, Tev
- use lbro_common_m, only : Yresol, Yssmsc, Ytrans
- use constn_common_m, only : Boltzm
- use EndfData_common_m, only : expData, resparData,
- * radFitFlags
- use AuxGridHelper_M, only : setAuxGridOffset,
- * setAuxGridRowMax
- use SammyGridAccess_M
- use xct2_m
- use mxct27_m
- use mfgm3_M
- use Qtrap_Clm_m
- use array_sizes_common_m, only : calcData, calcDataSelf
- use convert_to_transmission_m
- use DerivativeHandler_M
- use broad_common_m
- use SumIsoAndConvertToTrans_M
- IMPLICIT None
- LOGICAL Need_Isotopes
- LOGICAL Another_Process_Will_Happen
- type(SammyGridAccess)::grid, auxGrid
-C
- integer::Iflmsc(*)
- real(kind=8):: Beta(*), Osc_Wts(*), Osc_Enx(*), Osc_Snth(*),
- * Osc_Coth(*), Bex(*), S_Expb(*), S_Ex(*), Save(Nbeta_Max,*),
- * Bs(*), Ss(*), Max_T(*)
- real(kind=8)::C_Norm, eaux, em, Tevf, Tevx
- integer::Isomax, Isox, Iv, Iw, J, Jdat, Kkkdat, insig
- integer(C_SIZE_T)::Iso
- integer::Kkkmin, Now, Nowx, Ns, numEl, numElAux, Kkkkkk, nauxStart
- type(DerivativeHandler)::tmpCalc
-
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
- call grid%setToExpGrid(expData)
- call auxGrid%initialize()
- call auxGrid%setParameters(numcro, ktzero)
- call auxGrid%setToAuxGrid(expData)
- call setAuxGridOffset(1) ! reset auxillary grid starting point
- numEl = grid%getNumEnergies(expData)
- numElAux = auxGrid%getNumEnergies(expData)
- call tmpCalc%initialize()
- call tmpCalc%setUpList(resparData, radFitFlags, 1)
-C
-C *** Note that Sigxxx does not keep track of isotope, but calcData does
-C
-C DIMENSION Iflmsc(Nummsc), Parnbk(Numnbk), Iflnbk(Numnbk),
-C * Parbgf(Numbgf), Iflbgf(*), Kndbgf(*), Bgfmin(*), Bgfmax(*)
-C
- Tev = Boltzm*Temp
- Need_Isotopes = Yssmsc
- Another_Process_Will_Happen = Yresol.OR.Yssmsc
-C
- IF (Kcros.EQ.8 .AND. Ksindi.GT.0) THEN
- Iv = 1
- ELSE
- Iv = 0
- END IF
-C
- Iw = 0
- call calcData%nullify()
- IF (Kcros.EQ.8 .AND. (Ksindi.GT.0 .OR. Ksitmp.GT.0)) Iw = 1
- call calcDataSelf%nullify()
- call calcData%reserve(numElAux*calcData%getNnnsig(), numUsedPar+1)
- IF ((Ksindi.GT.0.OR.Ksitmp.GT.0).AND. Kcros.EQ.8) THEN
- call calcDataSelf%reserve(numElAux, numUsedPar+1)
- end if
-C
-C
- Now = 0
- Nowx = 0
- Kkkdat = 0
-C
- Isomax = calcData%getUsedIsotopes()
- IF (Isomax.EQ.0) STOP '[STOP in Dopclm in clm/mclm3.f]'
-C
-C *** Do separately for each isotope (nuclide), since Doppler-width is
-C *** isotope-dependent
- DO Iso=1,Isomax
- Isox = Iso
- if (Isomax.gt.1.and.
- * calcData%getRealIsotopeIndex(Iso).le.0) then
- GO TO 80
- end if
-C
- Kc = 1
- Iup = 0
-C
- Kkkmin = 0
- Kkkkkk = 0
- Kkkdat = 0
- nauxStart = 0
-C
-C *** Start of major loop over energy-points
- DO 70 J=1,numElAux
- Jdat = J
-C
- IF ((J/1000)*1000.EQ.J .AND. Isomax.GT.1) WRITE (6,10000) J,
- * Isox
-10000 FORMAT (' *** on data point number', i10,
- * ' for nuclide number', i3)
- IF ((J/1000)*1000.EQ.J .AND. Isomax.EQ.1) WRITE (6,10001) J
-10001 FORMAT (' *** on data point number', I10)
-C
- IF (Another_Process_Will_Happen) THEN
- em = auxGrid%getEnergy(J, expData)
- ELSE
- IF (J.GT.numEl) THEN
- GO TO 80
- ELSE
- Em = grid%getEnergy(J, expData)
- END IF
- END IF
-C
- IF (Em.LT.Emins) THEN
-C These points are the very low-energy limit,
-C of very little interest, ergo "stetd"
- eaux = auxGrid%getEnergy(J + 1, expData)
- IF (eaux.GE.Emin) THEN
- CALL Stetd (calcData, calcData,Kkkkkk+1,
- * Now, Kvtemp, Isox,
- * Jdat, 0)
- IF (Kcros.EQ.8) THEN
- IF (Ksindi.GT.0) THEN
- CALL Stetd (calcDataSelf,calcDataSelf,
- * Kkkkkk+1, Nowx, Iflmsc(Ksitmp),
- * Isox, Jdat, 0)
- ELSE IF (Ksitmp.GT.0) THEN
- CALL Stetd (calcData, calcDataSelf,
- * Kkkkkk+1, Nowx, Iflmsc(Ksitmp),
- * Isox, Jdat, Lllmax+1)
- END IF
- END IF
- GO TO 40
- ELSE
- nauxStart = J
- GO TO 70
- END IF
- ELSE IF (Em.GT.Emaxs) THEN
-C These points are the very high-energy limit,
-C of very little interest, ergo "stetd"
- eaux = auxGrid%getEnergy(J - 1, expData)
- IF (eaux.LE.Emax) THEN
- CALL Stetd (calcData, calcData,Kkkkkk+1,
- * Now, Kvtemp, Isox,
- * Jdat, 0)
- IF (Kcros.EQ.8) THEN
- IF (Ksindi.GT.0) THEN
- CALL Stetd (calcDataSelf, calcDataSelf,
- * Kkkkkk+1, Nowx, Iflmsc(Ksitmp),
- * Isox, Jdat, 0)
- ELSE IF (Ksitmp.gt.0) THEN
- Call Stetd (calcData, calcDataSelf,
- * Kkkkkk+1, Nowx, Iflmsc(Ksitmp),
- * Isox, Jdat, Lllmax+1)
- END IF
- END IF
- GO TO 40
- ELSE
- GO TO 80
- END IF
- END IF
-C
-C
-C "ELSE" but others have "GO TO" so not inside "IF" test.
-C ********* regular CLM Doppler for most cross sections
- CALL Getsab (Beta, Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth,
- * Bex, S_Expb, S_Ex, Save, Bs, Ss, Max_T, Em, Tev, C_Norm,
- * Tevf, Ns)
- CALL Qtrap_Clm (tmpCalc,
- * calcData, Bs, Ss, Tev, Temp, Em,
- * C_Norm, Kvtemp, calcData%getNnnsig(),
- * Isox, 0, Ns, calcData,
- * Kkkkkk+1)
-C
-C ********* Doppler widths etc for self-indication transmission
- IF (Ksitmp.GT.0) THEN
- Tevx = Boltzm*Sitemp
- ELSE
- Tevx = Tev
- END IF
-C
-C ********* Broaden self-indication transmission separately
- IF (Ksindi.GT.0 .AND. Kcros.EQ.8) THEN
- CALL Getsab (Beta, Osc_Wts, Osc_Enx, Osc_Snth,
- * Osc_Coth, Bex, S_Expb, S_Ex, Save, Bs, Ss, Max_T,
- * Em, Tevx, C_Norm, Tevf, Ns)
- CALL Qtrap_Clm (tmpCalc,
- * calcDataSelf,
- * Bs, Ss, Tevx, Sitemp, Em,
- * C_Norm, Iflmsc(Ksitmp), 1, Isox, 0, Ns, calcDataSelf,
- * Kkkkkk+1)
- END IF
-C
-C ********* Broaden self-indication transm; but stored in calcData old data originally
- IF (Ksindi.EQ.0 .AND. Ksitmp.GT.0 .AND. Kcros.EQ.8) THEN
- CALL Getsab (Beta, Osc_Wts, Osc_Enx, Osc_Snth,
- * Osc_Coth, Bex, S_Expb, S_Ex, Save, Bs, Ss, Max_T,
- * Em, Tevx, C_Norm, Tevf, Ns)
- CALL Qtrap_Clm (tmpCalc,
- * calcData, Bs, Ss, Tevx, Sitemp, Em,
- * C_Norm, Iflmsc(Ksitmp), 1, Isox,
- * Lllmax+1, Ns, calcDataSelf, Kkkkkk+1)
- END IF
-C
- 40 CONTINUE
-
- Kkkkkk = Kkkkkk + 1
-C
-C
- Kkkdat = Kkkdat + 1
-C
-C
-
- 70 CONTINUE
-C *** END of do-loop on energy
-C
- 80 CONTINUE
- END DO
-C *** end of do-loop on isotopes (nuclides)
-C
-C
- nauxStart = nauxStart + 1
- call setAuxGridRowMax(Kkkdat)
- IF (Now.NE.0) WRITE (21,99997) Now, Kkkdat*Isomax
- IF (Now.NE.0 .AND. Kdebug.NE.0) WRITE (06,99997) Now,Kkkdat*Isomax
-99997 FORMAT (' No Doppler broadening occured', I8,
- * ' times of a possible', I8)
-C
- call dopplerOption%crystalLattice%updateBroadenedOffset(
- * nauxStart)
- call dopplerOption%crystalLattice%setLength(Kkkkkk)
-
- call grid%destroy()
- call auxGrid%destroy()
- call setAuxGridOffset(nauxStart)
- call tmpCalc%destroy()
- RETURN
-C
- END
diff --git a/sammy/src/clm/mclm3.f90 b/sammy/src/clm/mclm3.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a9bf46bcaceda142d1d025c03f4d8f81a5af6afa
--- /dev/null
+++ b/sammy/src/clm/mclm3.f90
@@ -0,0 +1,154 @@
+module mclm3_m
+use CrystalLatticeBroadening_M
+
+contains
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Dopclm (calc, Iflmsc)
+
+!
+! *** PURPOSE -- FORM DOPPLER-BROADENED CROSS SECTION AND DERIVATIVES
+!
+ use ifwrit_m, only : Ksitmp,Kvtemp
+ use fixedr_m, only : Emax, Emaxs, Emin, Emins, Sitemp
+ use constn_common_m, only : Boltzm
+ use EndfData_common_m, only : resparData,radFitFlags
+ use Qtrap_Clm_m
+ use Getsab_m
+ use convert_to_transmission_m
+ use DerivativeHandler_M
+ IMPLICIT None
+
+ class(CrystalLatticeBroadening)::calc
+!
+ integer::Iflmsc(*)
+ real(kind=8)::C_Norm, eaux, em, Tevf, Tevx
+ integer::Isomax, Isox, J, Jdat, insig
+ integer(C_SIZE_T)::Iso
+ integer::Kkkmin, Now, Ns, numEl, numElAux, Kkkkkk, nauxStart
+ type(DerivativeHandler)::tmpCalc
+ type(DerivativeHandler)::calcData
+
+ numElAux = calc%getNumEnergyUnbroadened()
+ numEl = calc%getNumEnergyBroadened()
+ call tmpCalc%initialize()
+ call tmpCalc%setUpList(resparData, radFitFlags, 1)
+!
+! *** Note that Sigxxx does not keep track of isotope, but calcData does
+!
+! DIMENSION Iflmsc(Nummsc), Parnbk(Numnbk), Iflnbk(Numnbk),
+! * Parbgf(Numbgf), Iflbgf(*), Kndbgf(*), Bgfmin(*), Bgfmax(*)
+!
+ calc%Tev = Boltzm*calc%getTemperature()
+ call calc%getData(calcData)
+
+!
+!
+ Now = 0
+!
+ Isomax = calcData%getUsedIsotopes()
+ IF (Isomax.EQ.0) STOP '[STOP in Dopclm in clm/mclm3.f]'
+!
+! *** Do separately for each isotope (nuclide), since Doppler-width is
+! *** isotope-dependent
+ DO Iso=1,Isomax
+ Isox = Iso
+ if (Isomax.gt.1.and. &
+ calcData%getRealIsotopeIndex(Iso).le.0) then
+ cycle
+ end if
+!
+ Kkkmin = 0
+ Kkkkkk = 0
+ nauxStart = 0
+!
+! *** Start of major loop over energy-points
+ Jdat = 0
+ DO J=1,numEl
+ call calc%setCurrentPos(Kkkkkk+1)
+!
+ IF ((J/1000)*1000.EQ.J .AND. Isomax.GT.1) WRITE (6,10000) J, Isox
+10000 FORMAT (' *** on data point number', i10, ' for nuclide number', i3)
+ IF ((J/1000)*1000.EQ.J .AND. Isomax.EQ.1) WRITE (6,10001) J
+10001 FORMAT (' *** on data point number', I10)
+!
+ Em = calc%getEnergyBroadened(J)
+ Jdat = calc%getEmInUnbroadened(Em, Jdat)
+!
+ IF (Em.LT.Emins) THEN
+! These points are the very low-energy limit,
+! of very little interest, ergo "stetd"
+ eaux = calc%getEnergyUnbroadened(Jdat + 1)
+ IF (eaux.GE.Emin) THEN
+ NOW = NOW + 1
+ call calc%transferUnbroadenedAll(Jdat, Isox, Kvtemp, Iflmsc(Ksitmp))
+ Kkkkkk = Kkkkkk + 1
+ cycle
+ ELSE
+ nauxStart = J
+ cycle
+ END IF
+ ELSE IF (Em.GT.Emaxs) THEN
+! These points are the very high-energy limit,
+! of very little interest, ergo "stetd"
+ eaux = calc%getEnergyUnbroadened(Jdat - 1)
+ IF (eaux.LE.Emax) THEN
+ NOW = NOW + 1
+ call calc%transferUnbroadenedAll(Jdat, Isox, Kvtemp, Iflmsc(Ksitmp))
+ Kkkkkk = Kkkkkk + 1
+ cycle
+ ELSE
+ exit
+ END IF
+ END IF
+!
+!
+! "ELSE" but others have "GO TO" so not inside "IF" test.
+! ********* regular CLM Doppler for most cross sections
+ CALL Getsab (calc, Em, calc%Tev, C_Norm, Tevf, Ns)
+ CALL Qtrap_Clm (calc, tmpCalc, calcData, calc%Tev, calc%getTemperature(), Em, &
+ C_Norm, Kvtemp, Isox, Ns)
+!
+! ********* Doppler widths etc for self-indication transmission
+ IF (Ksitmp.GT.0) THEN
+ Tevx = Boltzm*Sitemp
+ ELSE
+ Tevx = calc%Tev
+ END IF
+!
+! ********* Broaden self-indication transmission separately
+! necessary copies have been made so we do need to
+! distinguish between where the data are saved
+!
+ IF (calc%hasSelf) THEN
+ CALL Getsab (calc, Em, Tevx, C_Norm, Tevf, Ns)
+ CALL Qtrap_Clm (calc, tmpCalc, &
+ calc%dataSelf, &
+ Tevx, Sitemp, Em, &
+ C_Norm, Iflmsc(Ksitmp), Isox,Ns)
+ END IF
+
+
+ Kkkkkk = Kkkkkk + 1
+
+ end do ! *** END of do-loop on energy
+!
+ END DO
+! *** end of do-loop on isotopes (nuclides)
+!
+!
+ nauxStart = nauxStart + 1
+ IF (Now.NE.0) WRITE (21,99997) Now, Kkkkkk*Isomax
+ IF (Now.NE.0 .AND. calc%debugOutput) WRITE (06,99997) Now,Kkkkkk*Isomax
+99997 FORMAT (' No Doppler broadening occured', I8, ' times of a possible', I8)
+!
+ call calc%updateBroadenedOffset( nauxStart)
+ call calc%setLength(Kkkkkk)
+
+ call tmpCalc%destroy()
+ RETURN
+!
+ END
+end module mclm3_m
diff --git a/sammy/src/clm/mclm4.f b/sammy/src/clm/mclm4.f
deleted file mode 100644
index a4db678152a45cf4c2e566f20ba607b0fc06c593..0000000000000000000000000000000000000000
--- a/sammy/src/clm/mclm4.f
+++ /dev/null
@@ -1,101 +0,0 @@
-C
-C
-C ----------------------------------------------------------------------
-C
- SUBROUTINE Getsab (Beta, Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth,
- * Bex, S_Expb, S_Ex, Save, Bs, Ss, Max_T, Em, Tevx, C_Norm, Tevf,
- * Ns)
-C
-C *** Purpose -- CRYSTAL MODEL CROSS-SECTION CALCULATION
-C *** Input -- Em, etc.
-C *** Output -- Bs, Ss
-C
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use broad_common_m
- use clm_common_m
- use constn_common_m
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
-C
- DIMENSION Beta(*), Osc_Wts(*), Osc_Enx(*), Osc_Snth(*),
- * Osc_Coth(*), Bex(*), S_Expb(*), S_Ex(*), Save(Nbeta_Max,*),
- * Bs(*), Ss(*), Max_T(*)
-cx DOUBLE PRECISION Em, Tevx
-C
- DIMENSION Sab(25999)
-cx DOUBLE PRECISION C_Norm1, C_Sumr1, C_Norm, C_Sumr, Recul
- INTEGER K, Ik, Ns
-cx DOUBLE PRECISION Zero, One, Five
- PARAMETER (Zero=0.0d0, One=1.0d0, Five=5.0d0)
-C
-C
-C EFFECTIVE TEMPERATURE CALCULATION FOR CREATION OF Beta GRID
-C SCATTERING LaW CALCULATION
-C Em is in eV; Beta is unitless
-C
-C
-C *** Temporarily assume (1) neutrons only, (2) one isotope only
-C *** Eventually need to fix this!
- Recul = Em*(Aneutr/(Aaawww+Aneutr))
- Alpha = Recul/Tevx
-C
-C
-C *** Continuous part of distribution
- CALL Cconti (Save, Sab, Beta, Alpha, C_Norm, C_Sumr, Max_T)
-C
-C
- Tra0 = C_Norm
- Tra1 = C_Sumr
- Tbarx = Tbar
-C *** Translational part, if any
- IF (Twt.NE.Zero) THEN
- Ndmax = 2000
- CALL Trans (Beta, Sab, Alpha, Deltab, Tra0, Tra1, Ndmax)
-C *** UPDATE EFfECTIVE TEMPERATURE (which is used only in Discre)
- Tevf = (Tbeta*Tevf+Twt*Tevx)/(Tbeta+Twt)
- Tbarx = Tevf/Tevx
- END IF
-C
-C
- Osc0 = Tra0
- Osc1 = Tra1
-C *** Discrete oscillators, if any
- IF (N_Osc.NE.0) THEN
- CALL Discre (Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth, Sab, Beta,
- * Bex, S_Expb, S_Ex, Alpha, Tbarx, Osc0, Osc1)
- END IF
-C
-C
- C_Norm1 = dABS(C_Norm-One)
- C_Sumr1 = dABS(C_Sumr-One)
- IF (C_Norm1.GT.Eps .OR. C_Sumr1.GT.Eps) THEN
- Nphon = Nphon + 5
- END IF
-C
-C
-C Dimensioning of Alpha and Beta values
-C Centering of Beta in Recul=<Beta>=Em/(Awr+1)
-C
- K=0
- DO IK=Nbeta,1,-1
- K = K + 1
- Bs(K) = Recul - Beta(IK)*Tevx
- Ss(K) = Sab(IK)/Tevx
- END DO
- DO IK=2,Nbeta
- K = K + 1
- Bs(K) = Recul + Beta(IK)*Tevx
- Ss(K) = Sab(IK)*dEXP(-Beta(IK))/Tevx
- END DO
-C
-C
-C ATTENTION!!! Betas ARE NOW CENTERED AROUND Recul!!!
-C THE ELASTIC SCATTERING CONTRIBUTION
-C S(A,B) = Smult(A,B) + Delta(B)
-C IS ADDED DIRECTLY TO THE CROSS-SECTION OUT OF CONVOLUTION
-C Sigma = SigmaCONVOL + Sigma*EXP(-W*A)
-C
- NS = K
- RETURN
- END
diff --git a/sammy/src/clm/mclm4.f90 b/sammy/src/clm/mclm4.f90
new file mode 100644
index 0000000000000000000000000000000000000000..da6926973aa255d237ab4c356d229bc947f41d0d
--- /dev/null
+++ b/sammy/src/clm/mclm4.f90
@@ -0,0 +1,106 @@
+module Getsab_m
+use AllocateFunctions_m
+use CrystalLatticeBroadening_M
+use mclm5_m
+use mcml6_m
+use mclm7_m
+use constn_common_m, only : Aneutr
+IMPLICIT None
+contains
+!
+!
+! ----------------------------------------------------------------------
+!
+ SUBROUTINE Getsab (calc, Em, Tevx, C_Norm, Tevf, &
+ Ns)
+!
+! *** Purpose -- CRYSTAL MODEL CROSS-SECTION CALCULATION
+! *** Input -- Em, etc.
+! *** Output -- Bs, Ss
+!
+!
+ class(CrystalLatticeBroadening)::calc
+ real(Kind=8)::Em, Tevx, Tevf, C_Norm
+!x DOUBLE PRECISION Em, Tevx
+!
+!x DOUBLE PRECISION C_Norm1, C_Sumr1, C_Norm, C_Sumr, Recul
+ INTEGER K, Ik, Ns
+!x DOUBLE PRECISION Zero, One, Five
+ real(kind=8),PARAMETER::Zero=0.0d0, One=1.0d0, Five=5.0d0
+ real(kind=8)::Alpha, C_Norm1, C_Sumr, C_Sumr1, Deltab
+ integer::Ndmax
+ real(kind=8)::Osc0, Osc1, Recul, Tra0, Tra1, Tbarx
+!
+!
+! EFFECTIVE TEMPERATURE CALCULATION FOR CREATION OF Beta GRID
+! SCATTERING LaW CALCULATION
+! Em is in eV; Beta is unitless
+!
+!
+! *** Temporarily assume (1) neutrons only, (2) one isotope only
+! *** Eventually need to fix this!
+ Recul = Em*(Aneutr/(calc%Aaawww+Aneutr))
+ Alpha = Recul/Tevx
+ call allocate_real_data(calc%Sab, calc%Nbeta)
+!
+!
+! *** Continuous part of distribution
+ CALL Cconti (calc, Alpha, C_Norm, C_Sumr)
+!
+!
+ Tra0 = C_Norm
+ Tra1 = C_Sumr
+ Tbarx = calc%Tbar
+! *** Translational part, if any
+ IF (calc%Twt.NE.Zero) THEN
+ Ndmax = 2000
+ CALL Trans (calc, Alpha, Deltab, Tra0, Tra1, Ndmax)
+! *** UPDATE EFfECTIVE TEMPERATURE (which is used only in Discre)
+ Tevf = (calc%Tbeta*Tevf+calc%Twt*Tevx)/(calc%Tbeta+calc%Twt)
+ Tbarx = Tevf/Tevx
+ END IF
+!
+!
+ Osc0 = Tra0
+ Osc1 = Tra1
+! *** Discrete oscillators, if any
+ IF (calc%N_Osc.NE.0) THEN
+ CALL Discre (calc, Alpha, Tbarx, Osc0, Osc1)
+ END IF
+!
+!
+ C_Norm1 = dABS(C_Norm-One)
+ C_Sumr1 = dABS(C_Sumr-One)
+ IF (C_Norm1.GT.calc%Eps .OR. C_Sumr1.GT.calc%Eps) THEN
+ calc%Nphon = calc%Nphon + 5
+ END IF
+!
+!
+! Dimensioning of Alpha and Beta values
+! Centering of Beta in Recul=<Beta>=Em/(Awr+1)
+!
+ K=0
+ call allocate_real_data(calc%Bs, 2*calc%Nbeta)
+ call allocate_real_data(calc%Ss, 2*calc%Nbeta)
+ DO IK=calc%Nbeta,1,-1
+ K = K + 1
+ calc%Bs(K) = Recul - calc%Beta(IK)*Tevx
+ calc%Ss(K) = calc%Sab(IK)/Tevx
+ END DO
+ DO IK=2,calc%Nbeta
+ K = K + 1
+ calc%Bs(K) = Recul + calc%Beta(IK)*Tevx
+ calc%Ss(K) = calc%Sab(IK)*dEXP(-calc%Beta(IK))/Tevx
+ END DO
+!
+!
+! ATTENTION!!! Betas ARE NOW CENTERED AROUND Recul!!!
+! THE ELASTIC SCATTERING CONTRIBUTION
+! S(A,B) = Smult(A,B) + Delta(B)
+! IS ADDED DIRECTLY TO THE CROSS-SECTION OUT OF CONVOLUTION
+! Sigma = SigmaCONVOL + Sigma*EXP(-W*A)
+!
+ NS = K
+ RETURN
+ END
+end module Getsab_m
diff --git a/sammy/src/clm/mclm5.f b/sammy/src/clm/mclm5.f
deleted file mode 100644
index a9ab9eb27ca3afa26e27e4651ef89a867e04d57f..0000000000000000000000000000000000000000
--- a/sammy/src/clm/mclm5.f
+++ /dev/null
@@ -1,146 +0,0 @@
-C
-C
-C -------------------------------------------------------------------
-C
- SUBROUTINE Cconti (Save, Sab, Beta, Alpha, C_Norm, C_Sumr, Max_T)
-C
-C
-C Phonon expansion method for scattering low calculation
-C Continuous frequency distribution case
-C Calculation of two first moments of S(Alpha,Beta)
-C
-C Main routine for calculating S(Alpha,Beta) at temperature "Tev"
-C for continuous phonon frequency distributions.
-C Called by Sigcri
-C
- use fixedr_m
- use clm_common_m
- use constn_common_m
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- DIMENSION Save(Nbeta_Max,*), Sab(*), Beta(*), Max_T(*)
-cx DOUBLE PRECISION Alpha, C_Sumr, C_Norm,
-cx & Exx, Be, St, Add, Alw, Alp, Ssct, Ff2, Ff1, Ff1m, Ff2m,
-cx & Bem, Alf0, Sab_Max, X
- INTEGER K, N, Ksmall, Kountr
-cx DOUBLE PRECISION Zero, Half, One, Four, Small, Pi
- PARAMETER (Zero=0.0d0, Half =0.5d0, One=1.0d0, Four=4.0d0,
- & Small=1.d-20)
-C
-C
- Sab_Max = Zero
- Alf0 = Alpha*F0
- Exx = Alf0*dEXP(-Alf0)
- DO K=1,Nbeta
- Add = Save(K,1)*Exx
- IF (Add.GT.Sab_Max) Sab_Max = Add
- Sab(K) = Add
- END DO
-C
-C
-C *** Add other terms in the phonon expansion sum
-C
- DO K=1,Nbeta
- Max_T(K) = 2
- END DO
- Ksmall = 1
- DO N=2,Nphon
- IF (Ksmall.EQ.0) THEN
- GO TO 20
- END IF
- Exx = Alf0*Exx/N
- IF (Exx.EQ.Zero) THEN
- GO TO 20
- ELSE IF (Exx.NE.Zero) THEN
- Ksmall = 0
- Kountr = 0
- DO K=1,Nbeta-1
- IF (Kountr.GT.10) GO TO 10
- St = Save(K,N)
- Add = St*Exx
- IF (Add+Sab(K).NE.Sab(K)) THEN
- Ksmall = 1
- Sab(K) = Sab(K) + Add
- IF (N.EQ.Nphon .AND. Sab(K)+Sab_Max.NE.Sab_Max) THEN
- IF (Add.GT.Sab(K)*0.001d0 .AND. Max_T(K).EQ.2) THEN
-C *** IF (still adding a significant amount) THEN
-C *** switch to using asymptotic form
-C *** [NML: but why bother? we already know Sab more
-C *** accurately than this.]
- Max_T(K) = 1
- END IF
- END IF
- ELSE
- Kountr = Kountr + 1
- END IF
- END DO
- 10 CONTINUE
- END IF
- END DO
- 20 CONTINUE
-C
-C
-C *** ------
-C *** Start of SCT range for each Beta
-C
- DO K=2,Nbeta
- IF (Max_T(K).GT.Max_T(K-1)) Max_T(K) = Max_T(K-1)
- END DO
-C
-C
-C *** ------
-C *** Check the moments of S(Alpha,Beta); Also redefine Sab if Max_T=1
-C
- Ntime = 0
- Alw = ALpha*Tbeta
- Alp = Alw*Tbar*Four
- X = dSQRT(Pi*Alp)
- K = 1
- Bem = Beta(K)
- Ff2m = Sab(K)
- Ff1m = Sab(K)*dEXP(-Bem)
- C_Norm = Zero
- C_Sumr = Zero
- IF (Max_T(K).EQ.1) THEN
-C (asymptotic redefinition of Sab)
- Exx = -(Alw-Bem)**2/Alp
- Ssct = Zero
- IF (Exx.GT.-45.0d0) Ssct = dEXP(Exx)/X
- Sab(K) = Ssct
- END IF
- DO K=2,Nbeta
- Be = Beta(K)
- IF (Max_T(K).EQ.1) THEN
-C (asymptotic redefinition of Sab)
- Exx = -(Alw-Be)**2/Alp
- Ssct = Zero
- IF (Exx.GT.-45.0d0) Ssct = dEXP(Exx)/X
- Sab(K) = Ssct
- END IF
- IF (Sab(K).EQ.Zero) THEN
- Ntime = Ntime + 1
- IF (Ntime.GT.20) GO TO 30
- ELSE
- Ntime = 0
- END IF
- Ff2 = Sab(K)
- Ff1 = Sab(K)*dEXP(-Be)
- C_Norm =C_Norm +Half*(Be-Bem)*(Ff2m +Ff2 +Ff1m +Ff1 )
- C_Sumr =C_Sumr +Half*(Be-Bem)*(Ff2m*Bem+Ff2*Be-Ff1m*Bem-Ff1*Be)
- Ff1m = Ff1
- Ff2m = Ff2
- Bem = Be
- END DO
- 30 CONTINUE
-C
-C
-C *** ------
-C *** Add the Del_Beta contribution to the norm
-C
- C_Norm = C_Norm + dEXP(-F0*ALpha)
- C_Sumr = C_Sumr/ALpha/Tbeta
-C
-C *** ------
-C *** Finished with continuous distribution
-C
- RETURN
- END
diff --git a/sammy/src/clm/mclm5.f90 b/sammy/src/clm/mclm5.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bbf1ebc3c5edf051babb57ad62a2fc7bf77da9d4
--- /dev/null
+++ b/sammy/src/clm/mclm5.f90
@@ -0,0 +1,155 @@
+module mclm5_m
+use AllocateFunctions_m
+use constn_common_m, only : Pi
+use CrystalLatticeBroadening_M
+IMPLICIT None
+public Cconti
+contains
+!
+!
+! -------------------------------------------------------------------
+!
+ SUBROUTINE Cconti (calc, Alpha, C_Norm, C_Sumr)
+!
+!
+! Phonon expansion method for scattering low calculation
+! Continuous frequency distribution case
+! Calculation of two first moments of S(Alpha,Beta)
+!
+! Main routine for calculating S(Alpha,Beta) at temperature "Tev"
+! for continuous phonon frequency distributions.
+! Called by Sigcri
+!
+ class(CrystalLatticeBroadening)::calc
+ real(kind=8)::Alpha, C_Norm, C_Sumr
+!x DOUBLE PRECISION Alpha, C_Sumr, C_Norm,
+!x & Exx, Be, St, Add, Alw, Alp, Ssct, Ff2, Ff1, Ff1m, Ff2m,
+!x & Bem, Alf0, Sab_Max, X
+ INTEGER K, N, Ksmall, Kountr
+!x DOUBLE PRECISION Zero, Half, One, Four, Small, Pi
+ real(kind=8),PARAMETER::Zero=0.0d0, Half =0.5d0, One=1.0d0, Four=4.0d0, &
+ Small=1.d-20
+ real(kind=8)::Add, Alf0, Alp, Alw, Be, Bem, Exx, Ff1, Ff1m, Ff2, Ff2m
+ integer::Ntime
+ real(kind=8)::Sab_Max, Ssct, St, X
+!
+!
+ Sab_Max = Zero
+ Alf0 = Alpha*calc%F0
+ Exx = Alf0*dEXP(-Alf0)
+ DO K=1,calc%Nbeta
+ Add = calc%Save(K,1)*Exx
+ IF (Add.GT.Sab_Max) Sab_Max = Add
+ calc%Sab(K) = Add
+ END DO
+!
+!
+! *** Add other terms in the phonon expansion sum
+!
+ call reallocate_integer_data(calc%Max_T, calc%Nbeta, 0)
+ DO K=1,calc%Nbeta
+ calc%Max_T(K) = 2
+ END DO
+ Ksmall = 1
+ DO N=2,calc%Nphon
+ IF (Ksmall.EQ.0) THEN
+ GO TO 20
+ END IF
+ Exx = Alf0*Exx/N
+ IF (Exx.EQ.Zero) THEN
+ GO TO 20
+ ELSE IF (Exx.NE.Zero) THEN
+ Ksmall = 0
+ Kountr = 0
+ DO K=1,calc%Nbeta-1
+ IF (Kountr.GT.10) GO TO 10
+ St = calc%Save(K,N)
+ Add = St*Exx
+ IF (Add+calc%Sab(K).NE.calc%Sab(K)) THEN
+ Ksmall = 1
+ calc%Sab(K) = calc%Sab(K) + Add
+ IF (N.EQ.calc%Nphon .AND. calc%Sab(K)+Sab_Max.NE.Sab_Max) THEN
+ IF (Add.GT.calc%Sab(K)*0.001d0 .AND. calc%Max_T(K).EQ.2) THEN
+! *** IF (still adding a significant amount) THEN
+! *** switch to using asymptotic form
+! *** [NML: but why bother? we already know Sab more
+! *** accurately than this.]
+ calc%Max_T(K) = 1
+ END IF
+ END IF
+ ELSE
+ Kountr = Kountr + 1
+ END IF
+ END DO
+ 10 CONTINUE
+ END IF
+ END DO
+ 20 CONTINUE
+!
+!
+! *** ------
+! *** Start of SCT range for each Beta
+!
+ DO K=2,calc%Nbeta
+ IF (calc%Max_T(K).GT.calc%Max_T(K-1)) calc%Max_T(K) = calc%Max_T(K-1)
+ END DO
+!
+!
+! *** ------
+! *** Check the moments of S(Alpha,Beta); Also redefine Sab if Max_T=1
+!
+ Ntime = 0
+ Alw = ALpha*calc%Tbeta
+ Alp = Alw*calc%Tbar*Four
+ X = dSQRT(Pi*Alp)
+ K = 1
+ Bem = calc%Beta(K)
+ Ff2m = calc%Sab(K)
+ Ff1m = calc%Sab(K)*dEXP(-Bem)
+ C_Norm = Zero
+ C_Sumr = Zero
+ IF (calc%Max_T(K).EQ.1) THEN
+! (asymptotic redefinition of Sab)
+ Exx = -(Alw-Bem)**2/Alp
+ Ssct = Zero
+ IF (Exx.GT.-45.0d0) Ssct = dEXP(Exx)/X
+ calc%Sab(K) = Ssct
+ END IF
+ DO K=2,calc%Nbeta
+ Be = calc%Beta(K)
+ IF (calc%Max_T(K).EQ.1) THEN
+! (asymptotic redefinition of Sab)
+ Exx = -(Alw-Be)**2/Alp
+ Ssct = Zero
+ IF (Exx.GT.-45.0d0) Ssct = dEXP(Exx)/X
+ calc%Sab(K) = Ssct
+ END IF
+ IF (calc%Sab(K).EQ.Zero) THEN
+ Ntime = Ntime + 1
+ IF (Ntime.GT.20) GO TO 30
+ ELSE
+ Ntime = 0
+ END IF
+ Ff2 = calc%Sab(K)
+ Ff1 = calc%Sab(K)*dEXP(-Be)
+ C_Norm =C_Norm +Half*(Be-Bem)*(Ff2m +Ff2 +Ff1m +Ff1 )
+ C_Sumr =C_Sumr +Half*(Be-Bem)*(Ff2m*Bem+Ff2*Be-Ff1m*Bem-Ff1*Be)
+ Ff1m = Ff1
+ Ff2m = Ff2
+ Bem = Be
+ END DO
+ 30 CONTINUE
+!
+!
+! *** ------
+! *** Add the Del_Beta contribution to the norm
+!
+ C_Norm = C_Norm + dEXP(-calc%F0*ALpha)
+ C_Sumr = C_Sumr/ALpha/calc%Tbeta
+!
+! *** ------
+! *** Finished with continuous distribution
+!
+ RETURN
+ END
+end module mclm5_m
diff --git a/sammy/src/clm/mclm6.f b/sammy/src/clm/mclm6.f90
similarity index 52%
rename from sammy/src/clm/mclm6.f
rename to sammy/src/clm/mclm6.f90
index c44e2d54777a4d68dd1ffc0f9cc561e9e8c28162..f0b7eec906888ddd0248c2719477a0f32eefbca0 100644
--- a/sammy/src/clm/mclm6.f
+++ b/sammy/src/clm/mclm6.f90
@@ -1,79 +1,82 @@
-C
-C
-C ----------------------------------------------------------------------
-C
- SUBROUTINE Trans (Beta, Sab, Alpha, Deltab, Tra0, Tra1, Ndmax)
-C
-C *** PURPOSE -- Control the addition of a translational contribution
-C *** to a continuous S(Alpha,Beta). The translational
-C *** component can be either diffusion, or a free gas.
-C *** The values of the input S(Alpha,Beta) for the
-C *** convoltion are obtained by interpolation.
-C *** CALLED BY -- Sigcri.
-C *** USES -- Stable, Sbfill, Terps.
-C *** Input -- Beta(), Sab()
-C *** -- Alpha, F0, Deltab, Twt, C_Trans, Tbeta
-C *** Output -- Sab(), Tra0, Tra1
-C *** Dummies -- Betax(), Sabx(), Sd(), Sb()
-C
- use clm_common_m
- IMPLICIT NONE
- DOUBLE PRECISION Beta(*), Sab(*)
+module mcml6_m
+use CrystalLatticeBroadening_M
+IMPLICIT NONE
+
+public Trans
+contains
+!
+!
+! ----------------------------------------------------------------------
+!
+ SUBROUTINE Trans (calc, Alpha, Deltab, Tra0, Tra1, Ndmax)
+!
+! *** PURPOSE -- Control the addition of a translational contribution
+! *** to a continuous S(Alpha,Beta). The translational
+! *** component can be either diffusion, or a free gas.
+! *** The values of the input S(Alpha,Beta) for the
+! *** convoltion are obtained by interpolation.
+! *** CALLED BY -- Sigcri.
+! *** USES -- Stable, Sbfill, Terps.
+! *** Input -- Beta(), Sab()
+! *** -- Alpha, F0, Deltab, Twt, C_Trans, Tbeta
+! *** Output -- Sab(), Tra0, Tra1
+! *** Dummies -- Betax(), Sabx(), Sd(), Sb()
+!
+ class(CrystalLatticeBroadening)::calc
DOUBLE PRECISION Alpha, Deltab, Tra0, Tra1
INTEGER Ndmax
-C
+!
DOUBLE PRECISION Betax(2000), Sabx(2000), Sd(2000), Sb(2000)
- DOUBLE PRECISION Ded, Deb, Delta, S, St, Be, Bb, Ff1, Ff2,
- & Ff1_Km1, Ff2_Km1, Be_Km1, AL, F, Ebe, Ebe_Km1, Tcal
- DOUBLE PRECISION Terps
+ DOUBLE PRECISION Ded, Deb, Delta, S, St, Be, Bb, Ff1, Ff2, &
+ Ff1_Km1, Ff2_Km1, Be_Km1, AL, F, Ebe, Ebe_Km1, Tcal
INTEGER Nsd, Iprt, Nu, I, Ibeta, Nbt
DOUBLE PRECISION Zero, Half, One, Two, Small
- PARAMETER (Zero=0.0d0, Half=0.5d0, One=1.0d0, Two=2.0d0,
- * Small=1.d-20)
-C
-C
+ PARAMETER (Zero=0.0d0, Half=0.5d0, One=1.0d0, Two=2.0d0, &
+ Small=1.d-20)
+!
+!
AL = Alpha
Iprt = 1
-C
-C
-C *** Choose Beta interval for convolution
-C
- Tcal = Twt*C_Trans*AL
- Ded = 0.4*(Tcal)/dSQRT(One+1.42*(Tcal)*C_Trans)
+!
+!
+! *** Choose Beta interval for convolution
+!
+ Tcal = calc%Twt*calc%C_Trans*AL
+ Ded = 0.4*(Tcal)/dSQRT(One+1.42*(Tcal)*calc%C_Trans)
IF (Ded.EQ.Zero ) Ded = 1000.0d0
- IF (Ded.EQ.1000.) Ded = 0.2d0*dSQRT(Twt*AL)
+ IF (Ded.EQ.1000.) Ded = 0.2d0*dSQRT(calc%Twt*AL)
Deb = 10.0d0 *AL*Deltab
Delta = dMIN1 (Deb, Ded)
Nu = 1
-C
-C
-C *** Make table of S-diffusion or S-free on this interval
-C
- CALL Stable (Sabx, Sd, Alpha, Delta, Twt, C_Trans,
- * Nu, Nsd, Ndmax)
-C
-C
+!
+!
+! *** Make table of S-diffusion or S-free on this interval
+!
+ CALL Stable (Sabx, Sd, Alpha, Delta, calc%Twt, calc%C_Trans, &
+ Nu, Nsd, Ndmax)
+!
+!
IF (Nsd.GT.1) THEN
-C
-C *** Copy original Ss(-Beta) to a temporary array
- DO I=1,Nbeta
- Betax(I) = Beta(I)
- Sabx (I) = Sab (I)
+!
+! *** Copy original Ss(-Beta) to a temporary array
+ DO I=1,calc%Nbeta
+ Betax(I) = calc%Beta(I)
+ Sabx (I) = calc%Sab (I)
END DO
-C
-C *** Loop over Beta values
- DO Ibeta=1,Nbeta
+!
+! *** Loop over Beta values
+ DO Ibeta=1,calc%Nbeta
S = Zero
Be = Betax(Ibeta)
-C
-C *** Prepare table of continuous Ss on new interval
+!
+! *** Prepare table of continuous Ss on new interval
Nbt = Nsd
- CALL Sbfill (Sb, Sabx, Betax, Delta, Be, Nbt, Nbeta, Ibeta)
-C
-C *** Convolve S-transport with S-continuous
+ CALL Sbfill (Sb, Sabx, Betax, Delta, Be, Nbt, calc%Nbeta, Ibeta)
+!
+! *** Convolve S-transport with S-continuous
DO I=1,Nbt
F = Two*(MOD(I-1,2)+1)
-C *** If I=even, F=4. If I=odd, F=2.
+! *** If I=even, F=4. If I=odd, F=2.
IF (I.EQ.1 .OR. I.EQ.Nbt) F = One
Bb = (I-1)*Delta
S = S + F*Sd(I)* ( Sb(Nbt+I-1) + Sb(Nbt-I+1)*dEXP(-Bb) )
@@ -81,27 +84,27 @@ C *** If I=even, F=4. If I=odd, F=2.
S = S*Delta/3.0D0
IF (S.LT.Small) S = Zero
St = Terps (Sd, Nbt, Delta, Be)
- IF (St.GT.Zero) S = S + dEXP(-AL*F0)*St
-C
-C *** Store results and continue Beta loop
- Sab(Ibeta) = S
+ IF (St.GT.Zero) S = S + dEXP(-AL*calc%F0)*St
+!
+! *** Store results and continue Beta loop
+ calc%Sab(Ibeta) = S
END DO
-C
-C
-C *** Check moments of calculated S(Alpha, Beta).
-C
+!
+!
+! *** Check moments of calculated S(Alpha, Beta).
+!
IF (Iprt.EQ.1) THEN
Tra0 = Zero
Tra1 = Zero
Be_Km1 = Betax(1)
Ebe_Km1 = dEXP(-Be_Km1)
- Ff1_Km1 = Sab(1) * (One+Ebe_Km1)
- Ff2_Km1 = Sab(1) * (One-Ebe_Km1) * Be_Km1
- DO Ibeta=2,Nbeta
+ Ff1_Km1 = calc%Sab(1) * (One+Ebe_Km1)
+ Ff2_Km1 = calc%Sab(1) * (One-Ebe_Km1) * Be_Km1
+ DO Ibeta=2,calc%Nbeta
Be = Betax(Ibeta)
Ebe = dEXP(-Be)
- Ff1 = Sab(Ibeta) * (One+Ebe)
- Ff2 = Sab(Ibeta) * (One-Ebe) * Be
+ Ff1 = calc%Sab(Ibeta) * (One+Ebe)
+ Ff2 = calc%Sab(Ibeta) * (One-Ebe) * Be
Tra0 = Tra0 + Half*(Be-Be_Km1) * ( Ff1_Km1 + Ff1 )
Tra1 = Tra1 + Half*(Be-Be_Km1) * ( Ff2_Km1 + Ff2 )
Ff1_Km1 = Ff1
@@ -109,131 +112,129 @@ C
Be_Km1 = Be
Ebe_Km1 = Ebe
END DO
- Tra1 = Tra1/AL/(Tbeta+Twt)
+ Tra1 = Tra1/AL/(calc%Tbeta+calc%Twt)
END IF
-C
+!
END IF
-C
+!
RETURN
END
-C
-C
-C ----------------------------------------------------------------------
-C
+!
+!
+! ----------------------------------------------------------------------
+!
SUBROUTINE Sbfill (Sb, Sabx, Betax, Delta, Be, Nbt, Nbeta, Ibeta)
-C
-C *** PURPOSE -- Generate S(Beta) on a new energy grid for convolution
-C *** with a diffusion or free-gas shape. Interpolation
-C *** is used.
-C *** For translational cases only.
-C *** CALLED BY -- Trans.
-C
- IMPLICIT NONE
+!
+! *** PURPOSE -- Generate S(Beta) on a new energy grid for convolution
+! *** with a diffusion or free-gas shape. Interpolation
+! *** is used.
+! *** For translational cases only.
+! *** CALLED BY -- Trans.
+!
INTEGER Nbt, Nbeta, Ibeta
DOUBLE PRECISION Sb(*), Sabx(*), Betax(Nbeta), Delta, Be
-C *** note that Ibeta is not used, but maybe should be ?!?
-C
+! *** note that Ibeta is not used, but maybe should be ?!?
+!
DOUBLE PRECISION Bmin, Bmax, Bet, B, St, Stm
INTEGER J, I
DOUBLE PRECISION Zero, Hundth
PARAMETER (Zero=0.0d0, Hundth=0.01d0)
-C
+!
Bmin = - Be - (Nbt-1)*Delta
Bmax = - Be + (Nbt-1)*Delta + Hundth*Delta
J = Nbeta
I = 0
Bet = Bmin
-C
+!
10 CONTINUE
-C
+!
I = I + 1
B = dABS(Bet)
-C
+!
20 CONTINUE
-C
-C *** SEARCH FOR CORRECT Beta RANGE
+!
+! *** SEARCH FOR CORRECT Beta RANGE
IF (B.GT.Betax(J)) THEN
IF (J.EQ.Nbeta) THEN
Sb(I) = Zero
GO TO 30
END IF
-C MOVE UP
+! MOVE UP
J = J + 1
GO TO 20
END IF
-C
+!
IF (B.LE.Betax(J-1)) THEN
IF (J.EQ.2) THEN
Sb(I) = Zero
GO TO 30
END IF
-C MOVE DOWN
+! MOVE DOWN
J = J - 1
GO TO 20
END IF
-C
-C
-C INTERPOLATE IN THIS RANGE
-C
+!
+!
+! INTERPOLATE IN THIS RANGE
+!
IF (Sabx(J).LE.Zero) THEN
St = -225.d0
ELSE
St = dLOG(Sabx(J))
END IF
-C
+!
IF (Sabx(J-1).LE.Zero) THEN
Stm = -225.d0
ELSE
Stm = dLOG(Sabx(J-1))
END IF
-C
+!
Sb(I) = St + (B-Betax(J))*(Stm-St) / (Betax(J-1)-Betax(J))
IF (Bet.GT.Zero) Sb(I) = Sb(I) - Bet
Sb(I) = dEXP(Sb(I))
-C
+!
30 CONTINUE
Bet = Bet + Delta
IF (Bet.LE.Bmax) GO TO 10
-C
-C *** end of loop on Bet
-C
+!
+! *** end of loop on Bet
+!
RETURN
END
-C
-C
-C ----------------------------------------------------------------------
-C
- SUBROUTINE Stable (Sabx, Sd, Alpha, Delta, Twt, C_Trans,
- * Nu, Nsd, Ndmax)
-C
-C *** PURPOSE -- Set up a table of S-Diffusion or S-Free in the array
-C *** Sd, evaluated at intervals Delta determined by Trans.
-C *** Tabulation is continued until
-C *** Sd(J) is less than 1.0d-7 * Sd(1), or Nsd is 1999
-C *** Nsd is always odd for use with Simpson's rule.
-C *** Array Sabx is used for temporary storage of Beta values.
-C *** Stable returns -Beta side of asymmetric S(Alpha,Beta).
-C *** CALLED BY- Trans.
-C *** USES -- Besk1.
-C
- IMPLICIT NONE
+!
+!
+! ----------------------------------------------------------------------
+!
+ SUBROUTINE Stable (Sabx, Sd, Alpha, Delta, Twt, C_Trans, &
+ Nu, Nsd, Ndmax)
+!
+! *** PURPOSE -- Set up a table of S-Diffusion or S-Free in the array
+! *** Sd, evaluated at intervals Delta determined by Trans.
+! *** Tabulation is continued until
+! *** Sd(J) is less than 1.0d-7 * Sd(1), or Nsd is 1999
+! *** Nsd is always odd for use with Simpson's rule.
+! *** Array Sabx is used for temporary storage of Beta values.
+! *** Stable returns -Beta side of asymmetric S(Alpha,Beta).
+! *** CALLED BY- Trans.
+! *** USES -- Besk1.
+!
INTEGER Nu, Nsd, Ndmax
DOUBLE PRECISION Sabx(Ndmax), Sd(Ndmax)
DOUBLE PRECISION Alpha, Delta, Twt, C_Trans
INTEGER Icheck, J, I
- DOUBLE PRECISION C2, C3, C4, C8, Be, C6, C7, Wal, Check0, Check1,
- & Eps, D, C5, Ex, Sfree, F, Bb, Besk1
+ DOUBLE PRECISION C2, C3, C4, C8, Be, C6, C7, Wal, Check0, Check1, &
+ Eps, D, C5, Ex, Sfree, F, Bb
DOUBLE PRECISION Pi, Zero, Quarter, Half, One, Two, Three, Four
- PARAMETER (PI=3.141592653589793238462643d0, Zero=0.0d0,
- & Quarter=0.25d0, Half=0.5d0, One=1.0d0, Two=2.0d0, Three=3.0d0,
- & Four=4.0d0)
-C
+ PARAMETER (PI=3.141592653589793238462643d0, Zero=0.0d0, &
+ Quarter=0.25d0, Half=0.5d0, One=1.0d0, Two=2.0d0, Three=3.0d0, &
+ Four=4.0d0)
+!
Icheck = 0
Eps = 1.E-7
-C
+!
IF (C_Trans.NE.Zero) THEN
-C
-C *** DIFFUSION BRANCH
+!
+! *** DIFFUSION BRANCH
D = Twt*C_Trans
C2 = dSQRT(C_Trans**2+Quarter)
C3 = Two*D*Alpha
@@ -245,33 +246,33 @@ C *** DIFFUSION BRANCH
100 CONTINUE
C6 = dSQRT(Be*Be+C4)
C7 = C6*C2
-C
+!
IF (C7.LE.One) THEN
C5 = C8*dEXP(C3+Half*Be)
ELSE
-C ELSE IF (C7.GT.One) THEN
+! ELSE IF (C7.GT.One) THEN
C5 = Zero
Ex = C3 - C7 + Half*Be
C5 = C8*dEXP(Ex)
END IF
-C
+!
Sd(J) = C5*Besk1(C7)/C6
Sabx(J) = Be
Be = Be + Delta
J = J + 1
-C
+!
IF (MOD(J,2).NE.0) THEN
GO TO 100
ELSE IF (J.LT.2000) THEN
IF (Eps*Sd(1).LT.Sd(J-1)) GO TO 100
END IF
-C
+!
J = J - 1
Nsd = J
-C
+!
ELSE
-C
-C *** FREE-GAS BRANCH
+!
+! *** FREE-GAS BRANCH
Be = Zero
J = 1
Wal = Twt*Alpha
@@ -282,22 +283,22 @@ C *** FREE-GAS BRANCH
Sabx(J) = Be
Be = Be + Delta
J = J + 1
-C
+!
IF (MOD(J,2).NE.0) THEN
GO TO 170
ELSE IF (J.LT.2000) THEN
IF (Eps*Sd(1).LT.Sd(J-1)) GO TO 170
END IF
-C
+!
J = J - 1
Nsd = J
-C
+!
END IF
-C
-C
-C
+!
+!
+!
IF (Icheck.NE.0) THEN
-C *** Check the moments of the distribution
+! *** Check the moments of the distribution
Check0 = Zero
Check1 = Zero
DO I=1,Nsd
@@ -312,93 +313,92 @@ C *** Check the moments of the distribution
Check0 = Check0*Delta/Three
Check1 = Check1*Delta/Three
Check1 = Check1/(Alpha*Twt)
-C *** Huh? Must return these values or print them or something?
-C *** Otherwise they are just ignored
+! *** Huh? Must return these values or print them or something?
+! *** Otherwise they are just ignored
END IF
-C
+!
RETURN
END
-C
-C
-C -------------------------------------------------------------------
-C
- FUNCTION Besk1 (X)
-C
-C *** PURPOSE -- Compute modified Bessel Function K1
-C *** The exponential part for X>1 is omitted (See Stable).
-C CALLED BY- Stable.
-C
- IMPLICIT NONE
- DOUBLE PRECISION X, V, U, BI1, BI3, Besk1
-C
+!
+!
+! -------------------------------------------------------------------
+!
+ real(kind=8) FUNCTION Besk1 (X)
+!
+! *** PURPOSE -- Compute modified Bessel Function K1
+! *** The exponential part for X>1 is omitted (See Stable).
+! CALLED BY- Stable.
+!
+ DOUBLE PRECISION X, V, U, BI1, BI3
+!
IF (X.LE.1.0) THEN
V = 0.125d0 * X
U = V*V
- Bi1 = ((((((((( 0.442850424d0 *U + 0.584115288d0)*U
- & + 6.070134559d0)*U + 17.864913364d0)*U
- & + 48.858995315d0)*U + 90.924600045d0)*U
- & + 113.795967431d0)*U + 85.331474517d0)*U
- & + 32.00008698 d0)*U + 3.999998802d0 )*V
- Bi3 = ((((((((( 1.304923514d0 *U + 1.47785657 d0)*U
- & + 16.402802501d0)*U + 44.732901977d0)*U
- & + 115.837493464d0)*U +198.437197312d0)*U
- & + 222.869709703d0)*U +142.216613971d0)*U
- & + 40.000262262d0)*U + 1.999996391d0)
+ Bi1 = ((((((((( 0.442850424d0 *U + 0.584115288d0)*U &
+ + 6.070134559d0)*U + 17.864913364d0)*U &
+ + 48.858995315d0)*U + 90.924600045d0)*U &
+ + 113.795967431d0)*U + 85.331474517d0)*U &
+ + 32.00008698d0)*U + 3.999998802d0 )*V
+ Bi3 = ((((((((( 1.304923514d0 *U + 1.47785657d0)*U &
+ + 16.402802501d0)*U + 44.732901977d0)*U &
+ + 115.837493464d0)*U +198.437197312d0)*U &
+ + 222.869709703d0)*U +142.216613971d0)*U &
+ + 40.000262262d0)*U + 1.999996391d0)
Besk1 = 1.0d0/X + Bi1*(dLOG(0.5d0*X)+0.5772156649d0) - V*Bi3
-C
+!
ELSE
-C
+!
U = 1.0d0/X
- Bi3 = ((((((((((((- 0.0108241775d0 *U + 0.0788000118d0)*U
- & - 0.2581303765d0)*U + 0.5050238576d0)*U
- & - 0.663229543 d0)*U + 0.6283380681d0)*U
- & - 0.4594342117d0)*U + 0.2847618149d0)*U
- & - 0.1736431637d0)*U + 0.1280426636d0)*U
- & - 0.1468582957d0)*U + 0.4699927013d0)*U
- & + 1.2533141373d0)
+ Bi3 = ((((((((((((- 0.0108241775d0 *U + 0.0788000118d0)*U &
+ - 0.2581303765d0)*U + 0.5050238576d0)*U &
+ - 0.663229543d0)*U + 0.6283380681d0)*U &
+ - 0.4594342117d0)*U + 0.2847618149d0)*U &
+ - 0.1736431637d0)*U + 0.1280426636d0)*U &
+ - 0.1468582957d0)*U + 0.4699927013d0)*U &
+ + 1.2533141373d0)
Besk1 = dSQRT(U)*Bi3
END IF
RETURN
END
-C
-C
-C ----------------------------------------------------------------------
-C
+!
+!
+! ----------------------------------------------------------------------
+!
DOUBLE PRECISION FUNCTION Terps (Sd, Nsd, Delta, Be)
-C
-C *** PURPOSE -- Interpolate for Beta=Be in table of S(Alpha,Beta).
-C *** USED IN -- Trans.
-C
- IMPLICIT NONE
+!
+! *** PURPOSE -- Interpolate for Beta=Be in table of S(Alpha,Beta).
+! *** USED IN -- Trans.
+!
INTEGER Nsd, I
DOUBLE PRECISION Sd(Nsd), Bt, Btp, ST, Delta, Stp, Stt, Be
DOUBLE PRECISION Zero
PARAMETER (Zero=0.0d0)
-C
+!
I = Be/Delta
-C
+!
IF (I.GE.Nsd-1) THEN
Terps = Zero
RETURN
END IF
-C
+!
Bt = I*Delta
Btp = Bt + Delta
I = I + 1
-C
+!
IF (Sd(I).LE.Zero) THEN
St = -225.d0
ELSE
St = dLOG(Sd(I))
END IF
-C
+!
IF (SD(I+1).LE.Zero) THEN
Stp = -225.d0
ELSE
Stp = dLOG(Sd(I+1))
END IF
-C
+!
Stt = St + (Be-Bt)*(Stp-ST)/(Btp-Bt)
Terps = dEXP(Stt)
RETURN
END
+end module mcml6_m
diff --git a/sammy/src/clm/mclm7.f b/sammy/src/clm/mclm7.f90
similarity index 52%
rename from sammy/src/clm/mclm7.f
rename to sammy/src/clm/mclm7.f90
index d63b954fd39e36db48fa41cb58e9ca90b06c72dd..8b8cce6a04b906163ea956b98990e5757df1d1ec 100644
--- a/sammy/src/clm/mclm7.f
+++ b/sammy/src/clm/mclm7.f90
@@ -1,80 +1,79 @@
-C
-C
-C ----------------------------------------------------------------------
-C
- SUBROUTINE Discre (Osc_Wts, Osc_Enx, Osc_Snth, Osc_Coth, Sab,
- & Beta, Bex, S_Expb, S_Ex, Alpha, Tbarx, Osc0, Osc1)
-C
-C
-C Scattering low calculation for discrete frequency distribution
-C
-C *** PURPOSE -- Control the convolution of discrete oscillators with
-C *** the continuous S(Alpha,Beta) computed in Contin.
-C *** Called by -- Sigcri
-C *** Uses -- Bfact, Exts, Sint
-C *** Input -- Osc_Wts(), Osc_Enx(), Osc_Snth(), Osc_Coth(),
-C *** Beta(), Bex()
-C *** -- Alpha, Dwpix, Tbeta, Tbarx
-C *** Output -- Sab()
-C *** -- Osc0, Osc1
-C *** Dummies -- Bplus(), Bminus(), S_Expb(), S_Ex(),
-C *** Bes(), Wts(), Ben(), Wtn()
-C
-C
- use clm_common_m
- use constn_common_m
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- DOUBLE PRECISION Osc_Wts(*), Osc_Enx(*), Osc_Snth(*), Osc_Coth(*),
- * Sab(*), Beta(*), Bex(*), S_Expb(*), S_Ex(*)
- DOUBLE PRECISION Bplus(50), Bminus(50), Bes(2000), Wts(2000),
- * Ben(2000), Wtn(2000)
+module mclm7_m
+use AllocateFunctions_m
+use CrystalLatticeBroadening_M
+IMPLICIT none
+contains
+!
+!
+! ----------------------------------------------------------------------
+!
+ SUBROUTINE Discre (calc, Alpha, Tbarx, Osc0, Osc1)
+!
+!
+! Scattering low calculation for discrete frequency distribution
+!
+! *** PURPOSE -- Control the convolution of discrete oscillators with
+! *** the continuous S(Alpha,Beta) computed in Contin.
+! *** Called by -- Sigcri
+! *** Uses -- Bfact, Exts, Sint
+! *** Input -- Osc_Wts(), Osc_Enx(), Osc_Snth(), Osc_Coth(),
+! *** Beta(), Bex()
+! *** -- Alpha, Dwpix, Tbeta, Tbarx
+! *** Output -- Sab()
+! *** -- Osc0, Osc1
+! *** Dummies -- Bplus(), Bminus(), S_Expb(), S_Ex(),
+! *** Bes(), Wts(), Ben(), Wtn()
+!
+!
+ class(CrystalLatticeBroadening)::calc
+ DOUBLE PRECISION Bplus(50), Bminus(50), Bes(2000), Wts(2000), &
+ Ben(2000), Wtn(2000)
DOUBLE PRECISION Alpha, Tbarx, Osc0, Osc1
- INTEGER Maxdd
- DATA Maxdd /2000/
-C
- DOUBLE PRECISION Dwf, Wt, X, Y, Besn, Wtsn, Wsave,
- & Ff1, Ff2, Ff1m, Ff2m, Bem, Be, Qqq, AL,
- & Bzero, St, Add, Db, Sint, Enx, Sum0, Sum1, Alwt
+ INTEGER, parameter:: Maxdd = 2000
+!
+ DOUBLE PRECISION Dwf, Wt, X, Y, Besn, Wtsn, Wsave, &
+ Ff1, Ff2, Ff1m, Ff2m, Bem, Be, Qqq, AL, &
+ Bzero, St, Add, Db, Enx, Sum0, Sum1, Alwt
INTEGER I, J, Nn, N, M, K, Jj, Ibeta
- DOUBLE PRECISION Zero, Half, One
- PARAMETER (Zero=0.0d0, Half=0.5d0, One=1.0d0)
-C
-C
-C *** SET UP OSCILLATOR PARAMETERS
- CALL Exts (Sab, S_Ex, Beta, Nbeta)
-C *** initializes S_Ex as needed by Sint
-C
- Wt = Tbeta
+ real(kind=8),PARAMETER::Zero=0.0d0, Half=0.5d0, One=1.0d0
+!
+!
+! *** SET UP OSCILLATOR PARAMETERS
+ call allocate_real_data(calc%S_Ex, 2*calc%Nbeta)
+ CALL Exts (calc%Sab, calc%S_Ex, calc%Beta, calc%Nbeta)
+! *** initializes S_Ex as needed by Sint
+!
+ Wt = calc%Tbeta
Qqq = Tbarx
AL = Alpha
Dwf = Zero
- IF (AL*Dw0.LT.45.0d0) Dwf = dEXP(-AL*Dw0)
-C
- CALL Zero_Array (S_Expb,Nbeta)
-C
-C
-C *** INITIALIZE FOR DELTA FUNCTION CALCULATION
+ IF (AL*calc%Dw0.LT.45.0d0) Dwf = dEXP(-AL*calc%Dw0)
+!
+ call allocate_real_data(calc%S_Expb,calc%Nbeta)
+!
+!
+! *** INITIALIZE FOR DELTA FUNCTION CALCULATION
Ben(1) = Zero
Wtn(1) = One
Nn = 1
N = 0
-C
-C
-C *** -----
-C *** LOOP OVER ALL OSCILLATORS
-C
- DO 10 I=1,N_Osc
- X = AL*Osc_Snth(I)
- Y = AL*Osc_Coth(I)
- Enx = Osc_Enx(I)
+!
+!
+! *** -----
+! *** LOOP OVER ALL OSCILLATORS
+!
+ DO 10 I=1,calc%N_Osc
+ X = AL*calc%Osc_Snth(I)
+ Y = AL*calc%Osc_Coth(I)
+ Enx = calc%Osc_Enx(I)
CALL Bfact (Bplus, Bminus, Bzero, X, Y, Enx)
- Qqq = Qqq + Osc_Coth(I)*Enx**2
-C
-C
-C *** Do convolution for the delta functions
-C *** -----
-C *** N = 0 TERM
-C
+ Qqq = Qqq + calc%Osc_Coth(I)*Enx**2
+!
+!
+! *** Do convolution for the delta functions
+! *** -----
+! *** N = 0 TERM
+!
DO M=1,Nn
Besn = Ben(M)
Wtsn = Wtn(M)*Bzero
@@ -86,12 +85,12 @@ C
END IF
END IF
END DO
-C
-C
-C *** -----
-C *** NEGATIVE N TERMS
-C ########## DO K=1,50 ? #######
-C ### BFACT is hard-wired for max of 30, not 50
+!
+!
+! *** -----
+! *** NEGATIVE N TERMS
+! ########## DO K=1,50 ? #######
+! ### BFACT is hard-wired for max of 30, not 50
DO K=1,30
IF (Bminus(K).GT.Zero) THEN
DO M=1,Nn
@@ -105,12 +104,12 @@ C ### BFACT is hard-wired for max of 30, not 50
END DO
END IF
END DO
-C
-C
-C *** -----
-C *** POSITIVE N TERMS
-C ########## DO K=1,50 ? #######
-C ### BFACT is hard-wired for max of 30, not 50
+!
+!
+! *** -----
+! *** POSITIVE N TERMS
+! ########## DO K=1,50 ? #######
+! ### BFACT is hard-wired for max of 30, not 50
DO K=1,30
IF (Bplus(K).GT.Zero) THEN
DO M=1,Nn
@@ -124,27 +123,27 @@ C ### BFACT is hard-wired for max of 30, not 50
END DO
END IF
END DO
-C
-C
-C *** -----
-C *** CONTINUE OSCILLATOR LOOP
-C
+!
+!
+! *** -----
+! *** CONTINUE OSCILLATOR LOOP
+!
Nn = N
DO M=1,Nn
Ben(M) = Bes(M)
Wtn(M) = Wts(M)
END DO
N = 0
- Wt = Wt + Osc_Wts(I)
-C
+ Wt = Wt + calc%Osc_Wts(I)
+!
10 CONTINUE
-C *** END OF LOOP OVER ALL OSCILLATORS
+! *** END OF LOOP OVER ALL OSCILLATORS
N = Nn
-C
-C
-C
-C *** -----
-C *** Sort the discrete lines and throw out the smallest ones
+!
+!
+!
+! *** -----
+! *** Sort the discrete lines and throw out the smallest ones
Nn = N - 1
DO I=1,N-1
K = 0
@@ -162,128 +161,125 @@ C *** Sort the discrete lines and throw out the smallest ones
IF (K.EQ.0) GO TO 20
END DO
20 CONTINUE
-C
+!
DO I=1,Nn
N = I
IF (Wts(I).LT.1.E-5) GO TO 30
END DO
30 CONTINUE
-C
-C
-C
-C *** -----
-C *** Add the continuum part to the scattering law
+!
+!
+!
+! *** -----
+! *** Add the continuum part to the scattering law
Alwt = Alpha * Wt
Qqq = Qqq * Alwt * 2.0d0
DO M=1,N
IF (Wts(M).NE.Zero) THEN
- DO J=1,Nbeta
- Be = - Beta(J) - Bes(M)
- St = Sint (Beta, Bex, S_Ex, Be, Alwt, Qqq, Del_S_B, Nbx,
- * Nbeta)
+ DO J=1,calc%Nbeta
+ Be = - calc%Beta(J) - Bes(M)
+ St = Sint (calc%Beta, calc%Bex, calc%S_Ex, Be, Alwt, Qqq, calc%Del_S_B, calc%Nbx, calc%Nbeta)
IF (St.NE.Zero) THEN
Add = Wts(M)*St
IF (Add.GE.1.E-20) THEN
- S_Expb(J) = S_Expb(J) + Add
+ calc%S_Expb(J) = calc%S_Expb(J) + Add
END IF
END IF
END DO
END IF
END DO
-C
-C
-C *** -----
-C *** Add the delta functions to the scattering law
-C *** Delta(0.) is saved fro [from? for?] the incoherent elastic
-C
+!
+!
+! *** -----
+! *** Add the delta functions to the scattering law
+! *** Delta(0.) is saved fro [from? for?] the incoherent elastic
+!
JJ = 0
IF (Dwf.GE.1.E-10) THEN
- IF (Twt.LE.Zero) THEN
+ IF (calc%Twt.LE.Zero) THEN
DO M=1,N
IF (Bes(M).LT.Zero) THEN
Be = -Bes(M)
-C
- IF (Be.LE.Beta(Nbeta-1)) THEN
+!
+ IF (Be.LE.calc%Beta(calc%Nbeta-1)) THEN
Db = 1000.d0
- DO J=1,Nbeta
+ DO J=1,calc%Nbeta
JJ = J
- IF (dABS(Be-Beta(J)).GT.Db) GO TO 40
- Db = dABS(Be-Beta(J))
+ IF (dABS(Be-calc%Beta(J)).GT.Db) GO TO 40
+ Db = dABS(Be-calc%Beta(J))
END DO
40 CONTINUE
-C
+!
IF (JJ.LE.2) THEN
- Add = Wts(M)/Beta(JJ)
+ Add = Wts(M)/calc%Beta(JJ)
ELSE
- Add = 2*Wts(M)/(Beta(JJ)-Beta(JJ-2))
+ Add = 2*Wts(M)/(calc%Beta(JJ)-calc%Beta(JJ-2))
END IF
-C
+!
Add = Add*Dwf
IF (Add.GE.1.d-20) THEN
- S_Expb(JJ-1) = S_Expb(JJ-1) + Add
+ calc%S_Expb(JJ-1) = calc%S_Expb(JJ-1) + Add
END IF
-C
+!
END IF
END IF
END DO
END IF
END IF
-C
-C
-C *** -----
-C *** Record the results
- DO J=1,Nbeta
- Sab(J) = S_Expb(J)
+!
+!
+! *** -----
+! *** Record the results
+ DO J=1,calc%Nbeta
+ calc%Sab(J) = calc%S_Expb(J)
END DO
-C
-C
-C *** -----
-C *** Check moments of calculated S(Alpha,Beta).
-C Ibeta = 1
- Bem = Beta(1)
- Ff1m = Sab(1)
- Ff2m = Sab(1)*dEXP(-Bem)
+!
+!
+! *** -----
+! *** Check moments of calculated S(Alpha,Beta).
+! Ibeta = 1
+ Bem = calc%Beta(1)
+ Ff1m = calc%Sab(1)
+ Ff2m = calc%Sab(1)*dEXP(-Bem)
Sum0 = Zero
Sum1 = Zero
- DO Ibeta=2,Nbeta
- Be = Beta(Ibeta)
- Ff2 = Sab(Ibeta)
- Ff1 = Sab(Ibeta)*dEXP(-Be)
+ DO Ibeta=2,calc%Nbeta
+ Be = calc%Beta(Ibeta)
+ Ff2 = calc%Sab(Ibeta)
+ Ff1 = calc%Sab(Ibeta)*dEXP(-Be)
Sum0 = Sum0 + Half*(Be-Bem)*(Ff1m+Ff2m+Ff1+Ff2)
- Sum1 = Sum1 + Half*(Be-Bem)
- & *(Ff2m*Bem+Ff2*Be-Ff1m*Bem-Ff1*Be)
+ Sum1 = Sum1 + Half*(Be-Bem)*(Ff2m*Bem+Ff2*Be-Ff1m*Bem-Ff1*Be)
Ff1m = Ff1
Ff2m = Ff2
Bem = Be
END DO
- IF (Twt.EQ.Zero) Sum0 = Sum0 + dEXP(-AL*Dwpix)
+ IF (calc%Twt.EQ.Zero) Sum0 = Sum0 + dEXP(-AL*calc%Dwpix)
Sum1 = Sum1/AL
Osc0 = Sum0
Osc1 = Sum1
RETURN
END
-C
-C
-C ----------------------------------------------------------------------
-C
+!
+!
+! ----------------------------------------------------------------------
+!
SUBROUTINE Exts (Sab, S_Ex, Beta, Nbeta)
-C
-C *** PURPOSE -- Set up the Array S_Ex for Sint.
-C *** Sab contains the asymmetric S(alpha,beta) for negative
-C *** Beta, and S_Ex contains the asymmetrix S(alpha,beta)
-C *** extended to plus and minus Beta.
-C *** CALLED BY -- Discre.
-C
- IMPLICIT NONE
+!
+! *** PURPOSE -- Set up the Array S_Ex for Sint.
+! *** Sab contains the asymmetric S(alpha,beta) for negative
+! *** Beta, and S_Ex contains the asymmetrix S(alpha,beta)
+! *** extended to plus and minus Beta.
+! *** CALLED BY -- Discre.
+!
INTEGER Nbeta, K, I
- DOUBLE PRECISION Sab(*), S_Ex(*), Beta(Nbeta)
-C
+ real(kind=8)::Beta(:), S_Ex(:), Sab(:)
+!
K = Nbeta
DO I=1,Nbeta
S_Ex(I) = Sab(K)
K = K - 1
END DO
-C
+!
IF (Beta(1).LE.0.000000001) THEN
S_Ex(Nbeta) = Sab(1)
K = Nbeta + 1
@@ -291,40 +287,39 @@ C
K = Nbeta + 2
S_Ex(Nbeta+1) = Sab(1)
END IF
-C
+!
DO I=2,Nbeta
S_Ex(K) = Sab(I)*dEXP(-Beta(I))
K = K + 1
END DO
-C
+!
RETURN
END
-C
-C
-C ----------------------------------------------------------------------
-C
- DOUBLE PRECISION FUNCTION Sint (Beta, Bex, S_Ex, Be, Alwt,
- * Qqq, Del_S_B, Nbx, Nbeta)
-C
-C INTERPOLATES IN SCATTERING FUNCTION, OR USES SCT APPROX
-C TO EXTRAPOLATE OUTSIDE THE RANGE IN MEMORY.
-C CALLED BY DISCRE.
-C
- IMPLICIT NONE
- DOUBLE PRECISION Beta(*), Bex(*), S_Ex(*)
+!
+!
+! ----------------------------------------------------------------------
+!
+ DOUBLE PRECISION FUNCTION Sint (Beta, Bex, S_Ex, Be, Alwt, &
+ Qqq, Del_S_B, Nbx, Nbeta)
+!
+! INTERPOLATES IN SCATTERING FUNCTION, OR USES SCT APPROX
+! TO EXTRAPOLATE OUTSIDE THE RANGE IN MEMORY.
+! CALLED BY DISCRE.
+!
+ real(kind=8)::Beta(:), Bex(:), S_Ex(:)
DOUBLE PRECISION Be, Alwt, Qqq, Del_S_B
INTEGER Nbx, Nbeta
-C
+!
DOUBLE PRECISION Sv, Ex, Ss1, Ss3
INTEGER K1, K2, K3
DOUBLE PRECISION Zero, Pi
PARAMETER (Zero=0.0d0, Pi=3.141592653589793238462643d0)
-C
-C
+!
+!
IF (dABS(Be).GT.Beta(Nbeta)) THEN
-C
-C *** -----
-C *** SCT approximation [extrapolation]
+!
+! *** -----
+! *** SCT approximation [extrapolation]
IF (Alwt.LE.Zero) THEN
Sv = Zero
ELSE
@@ -332,16 +327,16 @@ C *** SCT approximation [extrapolation]
IF (Be.GT.Zero) Ex = Ex - Be
Sv = dEXP(Ex)/(Pi*Qqq)
END IF
-C
+!
ELSE
-C
-C *** -----
-C *** Interpolation
+!
+! *** -----
+! *** Interpolation
K1 = 1
K2 = Nbeta
K3 = Nbx
-C
-C ** Bisect for Be
+!
+! ** Bisect for Be
130 CONTINUE
IF (Be.EQ.Bex(K2)) THEN
Sv = S_Ex(K2)
@@ -369,61 +364,60 @@ C ** Bisect for Be
END IF
END IF
END IF
-C
+!
Sint = Sv
-C
+!
RETURN
END
-C
-C
-C -------------------------------------------------------------------
-C
+!
+!
+! -------------------------------------------------------------------
+!
SUBROUTINE Bfact (Bplus, Bminus, Bzero, X, Y, Enx)
-C
-C CALCULATES THE Bessel-FUNCTION TERMS FOR DISCRETE OSCILLATORS.
-C CALLED BY DISCRE.
-C
- IMPLICIT NONE
+!
+! CALCULATES THE Bessel-FUNCTION TERMS FOR DISCRETE OSCILLATORS.
+! CALLED BY DISCRE.
+!
DOUBLE PRECISION Bplus(*), Bminus(*), Bzero, X, Y, Enx
- DOUBLE PRECISION Xx, Yy, Xy, Xt, U, V,
- & Bessio, Bessi1, Zero, One, Half
+ DOUBLE PRECISION Xx, Yy, Xy, Xt, U, V, &
+ Bessio, Bessi1, Zero, One, Half
INTEGER Imax, I, J, K
PARAMETER (Zero=0.0d0, Half=0.5d0, One=1.0D0)
-C
-C
+!
+!
Xx = X
Yy = Y
Xy = Enx
Xt = Xx/3.75d0
-C
-C
-C *** Compute Bessio and Bessi1
-C
+!
+!
+! *** Compute Bessio and Bessi1
+!
IF (Xt.LE.One) THEN
U = Xt*Xt
- Bessio = One
- & + U * (3.5156229 + U * (3.0899424 + U * (1.2067492
- & + U * (0.2659732 + U * (0.0360768 + U * 0.0045813 )))))
- Bessi1 = (0.5
- & + U * (0.87890594 + U * (0.51498869 + U *(0.15084934
- & + U * (0.02658733 + U * (0.00301532 + U * 0.00032411))))))*Xx
+ Bessio = One &
+ + U * (3.5156229 + U * (3.0899424 + U * (1.2067492 &
+ + U * (0.2659732 + U * (0.0360768 + U * 0.0045813 )))))
+ Bessi1 = (0.5 &
+ + U * (0.87890594 + U * (0.51498869 + U *(0.15084934 &
+ + U * (0.02658733 + U * (0.00301532 + U * 0.00032411))))))*Xx
ELSE
U = One/Xt
- Bessio = (
- & 0.39894228 + U * (0.01328592 + U * ( 0.00225319
- & + U * (-0.00157565 + U * (0.00916281 + U * (-0.02057706
- & + U * ( 0.02635537 + U * (-.01647633 + U * 0.00392377
- & )))))))) / SQRT(Xx)
- Bessi1 = 0.02282967 + U * (-0.02895312 + U * ( 0.01787654
- & -U * 0.00420059 ))
- Bessi1 = 0.39894228 + U * (-0.03988024 + U * (-0.00362018
- & + U * ( 0.00163801 + U * (-0.01031555 + U * Bessi1 ))))
+ Bessio = ( &
+ 0.39894228 + U * (0.01328592 + U * ( 0.00225319 &
+ + U * (-0.00157565 + U * (0.00916281 + U * (-0.02057706 &
+ + U * ( 0.02635537 + U * (-.01647633 + U * 0.00392377 &
+ )))))))) / SQRT(Xx)
+ Bessi1 = 0.02282967 + U * (-0.02895312 + U * ( 0.01787654 &
+ -U * 0.00420059 ))
+ Bessi1 = 0.39894228 + U * (-0.03988024 + U * (-0.00362018 &
+ + U * ( 0.00163801 + U * (-0.01031555 + U * Bessi1 ))))
Bessi1 = Bessi1/SQRT(Xx)
END IF
-C
-C
-C *** Generate higher-order Bessel functions by reverse recursion
-C
+!
+!
+! *** Generate higher-order Bessel functions by reverse recursion
+!
Imax = 30
Bplus(Imax ) = Zero
Bplus(Imax-1) = One
@@ -436,17 +430,17 @@ C
Bplus(J) = Bplus(J)*1.0d-10
END DO
END IF
-C end of loop on I
+! end of loop on I
END DO
-C
+!
U = Bessi1/Bplus(1)
DO I=1,Imax-1
Bplus(I) = Bplus(I)*U
END DO
-C
-C
-C *** Apply exponential terms to Bessel Functiions
-C
+!
+!
+! *** Apply exponential terms to Bessel Functiions
+!
U = Xy*Half
IF (Xt.LT.One) THEN
V = - Yy
@@ -462,3 +456,4 @@ C
END DO
RETURN
END
+end module mclm7_m
diff --git a/sammy/src/clm/mclm8.f b/sammy/src/clm/mclm8.f90
similarity index 60%
rename from sammy/src/clm/mclm8.f
rename to sammy/src/clm/mclm8.f90
index b8816fe2a46fc465fb9052dcdee146ea2a7e9dc9..9d10f02a4c5df27d6ef0c207779892b4c6aba0ce 100644
--- a/sammy/src/clm/mclm8.f
+++ b/sammy/src/clm/mclm8.f90
@@ -1,22 +1,22 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Find_L (grid, Xx, L1, L2, Lstart, L1_Error,
- * L2_Error)
-C *** Purpose -- find L1 & L2 such that Energy(L1) < Xx < Energy(L2)
-C
- use SammyGridAccess_M
- use EndfData_common_m
- IMPLICIT NONE
+module mcml8_m
+use CrystalLatticeBroadening_M
+implicit none
+contains
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Find_L (calc, Xx, L1, L2, Lstart, L1_Error, L2_Error)
+! *** Purpose -- find L1 & L2 such that Energy(L1) < Xx < Energy(L2)
+!
+ class(CrystalLatticeBroadening)::calc
DOUBLE PRECISION Xx
- type(SammyGridAccess)::grid ! can pass even in f77 as in same compile unit
INTEGER L1, L2, Lstart, Lk, L1_Error, L2_Error
real(kind=8)::eLstart, eL1, eL2, eLk
integer::numEl
-C
- numEl = grid%getNumEnergies(expData)
- eLstart = grid%getEnergy(Lstart, expData)
+!
+ numEl = calc%getNumEnergyUnbroadened()
+ eLstart = calc%getEnergyUnbroadened(Lstart)
IF (Xx.EQ.eLstart) THEN
L1 = Lstart
L2 = Lstart
@@ -25,24 +25,24 @@ C
L1_Error = L1_Error + 1
L1 = 1
L2 = 2
-CX STOP '[Stop in Find_L in clm/mclm8.f # 1]'
+!X STOP '[Stop in Find_L in clm/mclm8.f # 1]'
ELSE
DO Lk=Lstart-1,1,-1
- eLk = grid%getEnergy(Lk, expData)
+ eLk = calc%getEnergyUnbroadened(Lk)
IF (Xx.GE.eLk) THEN
L1 = Lk
L2 = Lk + 1
- eL1 = grid%getEnergy(L1, expData)
- eL2 = grid%getEnergy(L2, expData)
+ eL1 = calc%getEnergyUnbroadened(L1)
+ eL2 = calc%getEnergyUnbroadened(L2)
IF (Xx.LT.eL2) RETURN
WRITE (6,10000) L1, eL1, Xx, L2, eL2
-10000 FORMAT (' Eb(', I5, ')=',1PG14.6,' Xx=', 1PG14.6,
- * ' Eb(', I5, ')=', 1PG14.6)
+10000 FORMAT (' Eb(', I5, ')=',1PG14.6,' Xx=', 1PG14.6, &
+ ' Eb(', I5, ')=', 1PG14.6)
STOP '[Stop in Find_L in clm/mclm8.f # 2]'
END IF
END DO
Lk = 1
- eLk = grid%getEnergy(Lk, expData)
+ eLk = calc%getEnergyUnbroadened(Lk)
WRITE (6,10000) Lstart, eLstart, Xx, Lk, eLk
STOP '[Stop in Find_L in clm/mclm8.f # 3]'
END IF
@@ -53,24 +53,25 @@ CX STOP '[Stop in Find_L in clm/mclm8.f # 1]'
L2 = numEl
ELSE
DO Lk=Lstart+1,numEl
- eLk = grid%getEnergy(Lk, expData)
+ eLk = calc%getEnergyUnbroadened(Lk)
IF (Xx.LE.eLk) THEN
L2 = Lk
L1 = Lk - 1
- eL1 = grid%getEnergy(L1, expData)
- eL2 = grid%getEnergy(L2, expData)
+ eL1 = calc%getEnergyUnbroadened(L1)
+ eL2 = calc%getEnergyUnbroadened(L2)
IF (Xx.GE.eL1) RETURN
WRITE (6,10000) L1, eL1, Xx, L2, eL2
STOP '[Stop in Find_L in clm/mclm8.f # 5]'
END IF
END DO
- eL2 = grid%getEnergy(numEl, expData)
+ eL2 = calc%getEnergyUnbroadened(numEl)
WRITE (6,10100) numEl, eL2, Xx
10100 FORMAT (' Eb(', I5, ')=',1PG14.6,' Xx=', 1PG14.6)
L1 = numEl - 1
L2 = numEl
-cx STOP '[Stop in Find_L in clm/mclm8.f # 6]'
+!x STOP '[Stop in Find_L in clm/mclm8.f # 6]'
END IF
END IF
RETURN
END
+end module mcml8_m
diff --git a/sammy/src/clm/mclm8a.f90 b/sammy/src/clm/mclm8a.f90
index 601c779b31aaa9069d47b158b6c62082b2a3b7cc..129246c46728076b6b394764cd50ff2d5d22dd16 100644
--- a/sammy/src/clm/mclm8a.f90
+++ b/sammy/src/clm/mclm8a.f90
@@ -1,4 +1,11 @@
module Qtrap_Clm_m
+ use CrystalLatticeBroadening_M
+ use constn_common_m, only : Aneutr
+ use DerivativeHandler_M
+ use mcml8_m
+ use, intrinsic :: ISO_C_BINDING
+ IMPLICIT none
+
private
public Qtrap_Clm
contains
@@ -6,9 +13,8 @@ module Qtrap_Clm_m
!
! -----------------------------------------------------------------
!
- SUBROUTINE Qtrap_Clm (tmpCalc, derivs, &
- Bs, Ss, Tevx, Tempx, Em, C_Norm, Ktempx, Na, &
- Isox, Locate, Ns, derivsNew, irow)
+ SUBROUTINE Qtrap_Clm (calc, tmpCalc, derivs, &
+ Tevx, Tempx, Em, C_Norm, Ktempx, Isox, Ns)
!
! *** INTEGRATION BY TRAPEZOIDAL METHOD
! CRySTAL SCATTERING FUNCTION INTEGRATION
@@ -19,39 +25,24 @@ module Qtrap_Clm_m
! *** Bs - Beta array (variable of integration)
! *** Ss - Weighting function (S_alpha_beta)
!
- use fixedi_m, only : numcro,numUsedPar
- use ifwrit_m, only : ktzero
- use fixedr_m, only : Aaawww
- use clm_common_m, only : Dwpix, Eps, Mode_S_Norm
- use constn_common_m, only : Aneutr
- use SammyGridAccess_M
- use EndfData_common_m
- use DerivativeHandler_M
- use, intrinsic :: ISO_C_BINDING
- IMPLICIT None
- INTEGER Ktempx, Na, Isox, Locate, Ns
- DOUBLE PRECISION Bs(*), Ss(*)
+ class(CrystalLatticeBroadening)::calc
+ INTEGER Ktempx, Na, Isox, Ns
DOUBLE PRECISION Tevx, Tempx, Em, C_Norm
DOUBLE PRECISION S, Olds, Xxa, Xxb, Del, Sel, E_Prime
DOUBLE PRECISION Aaa, Xx, Yy, val
INTEGER Jmax, Ibet, Lstart, L1, L2, irow, Ipar, N
- type(SammyGridAccess)::grid
- type(DerivativeHandler)::derivs, derivsNew, tmpCalc
+ type(DerivativeHandler)::derivs, tmpCalc
real(kind=8),parameter:: Zero=0.0d0, Half=0.5d0, One=1.0d0
real(kind=8)::Alpha, Recul
- integer::It, J, Jj, L1er, L2er, Nax, numEl
+ integer::It, J, Jj, L1er, L2er, numEl
logical(C_BOOL)::accu
-!
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
- call grid%setToAuxGrid(expData)
!
L1er = 0
L2er = 0
- Nax = derivsNew%getNnnsig()
- call tmpCalc%setNnsig(Nax)
- call tmpCalc%reserve(Nax, numUsedPar+1)
- IF (Locate.NE.0) Nax = 1
+ irow = calc%getCurrentPos()
+ Na = derivs%getNnnsig()
+ call tmpCalc%setNnsig(Na)
+ call tmpCalc%reserve(Na, calc%getNumParams()+1)
!
Lstart = 1
Jmax = 10
@@ -60,35 +51,35 @@ module Qtrap_Clm_m
!
call tmpCalc%nullify()
!
- Xxa = Bs(Ibet)
- Xxb = Bs(Ibet+1)
+ Xxa = calc%Bs(Ibet)
+ Xxb = calc%Bs(Ibet+1)
Del = Xxb - Xxa
Aaa = Del*Half
!
! *** First Point (Xxa)
Xx = Em + Xxa
- Call Find_L (grid, Xx, L1, L2, Lstart, L1er, L2er)
+ Call Find_L (calc, Xx, L1, L2, Lstart, L1er, L2er)
Lstart = L1
- Yy = Ss(Ibet)
+ Yy = calc%Ss(Ibet)
IF (Yy.EQ.Zero) THEN
ELSE
Yy = Yy*Aaa
- Call Sig_Int (grid, tmpCalc, derivs, &
+ Call Sig_Int (calc, tmpCalc, derivs, &
Tempx, Xx, Yy, Ktempx, Na, Isox, &
- Locate, L1, L2, 1, 1)
+ L1, L2, 1, 1)
END IF
!
! *** Last Point (Xxb)
Xx = Em + Xxb
- Call Find_L (grid, Xx, L1, L2, Lstart, L1er, L2er)
- Yy = Ss(Ibet+1)
+ Call Find_L (calc, Xx, L1, L2, Lstart, L1er, L2er)
+ Yy = calc%Ss(Ibet+1)
IF (Yy.EQ.Zero) THEN
ELSE
Yy = Yy*Aaa
- Call Sig_Int (grid, tmpCalc, derivs, &
+ Call Sig_Int (calc, tmpCalc, derivs, &
Tempx, Xx, Yy, Ktempx, Na, Isox, &
- Locate, L1, L2, 1, 1)
+ L1, L2, 1, 1)
END IF
!
Aaa = Half
@@ -99,8 +90,8 @@ module Qtrap_Clm_m
E_Prime = Xxa + Half*Del
!
! *** Take half of what's already there
- do ipar = 0, numUsedPar
- do N = 1, Nax
+ do ipar = 0, calc%getNumParams()
+ do N = 1, Na
val = tmpCalc%getDataNs(1, N, ipar, 1)*Half
if (val.eq.0.0d0) cycle
call tmpCalc%addDataNs(1, N, Ipar, 1, val)
@@ -110,14 +101,14 @@ module Qtrap_Clm_m
DO Jj=1,It
!
! *** Find multiplier Yy
- IF (Ss(Ibet).EQ.Zero) THEN
+ IF (calc%Ss(Ibet).EQ.Zero) THEN
Yy = Zero
ELSE
- Yy = Ss(Ibet)*(Xxb-E_Prime)
+ Yy = calc%Ss(Ibet)*(Xxb-E_Prime)
END IF
- IF (Ss(Ibet+1).EQ.Zero) THEN
+ IF (calc%Ss(Ibet+1).EQ.Zero) THEN
ELSE
- Yy = Yy + Ss(Ibet+1)*(E_Prime-Xxa)
+ Yy = Yy + calc%Ss(Ibet+1)*(E_Prime-Xxa)
END IF
!
! *** Add new piece
@@ -125,18 +116,18 @@ module Qtrap_Clm_m
ELSE
Yy = Yy*Aaa
Xx = Em + E_Prime
- Call Find_L (grid, Xx, L1, L2, Lstart, L1er, L2er)
+ Call Find_L (calc, Xx, L1, L2, Lstart, L1er, L2er)
- Call Sig_Int (grid, tmpCalc, derivs, &
- Tempx, Xx, Yy, Ktempx, Nax, Isox, &
- Locate, L1, L2, 1, 1)
+ Call Sig_Int (calc, tmpCalc, derivs, &
+ Tempx, Xx, Yy, Ktempx, Na, Isox, &
+ L1, L2, 1, 1)
END IF
E_Prime = E_Prime + Del
!
END DO
!
S = tmpCalc%getDataNs(1,1,0,1)
- IF (ABS(S-Olds).LT.Eps*ABS(Olds)) GO TO 10
+ IF (ABS(S-Olds).LT.calc%Eps*ABS(Olds)) GO TO 10
It = It*2
Aaa = Aaa*Half
Del = Del*Half
@@ -148,16 +139,16 @@ module Qtrap_Clm_m
10 CONTINUE
accu = .true.
- call derivsNew%setAccumulate(accu)
- do ipar = 0, numUsedPar
- do N = 1, Nax
+ call derivs%setAccumulate(accu)
+ do ipar = 0, calc%getNumParams()
+ do N = 1, Na
val = tmpCalc%getDataNs(1, N, ipar, 1)
if (val.eq.0.0d0) cycle
- call derivsNew%addDataNs(irow, N, Ipar, Isox, val)
+ call derivs%addDataNs(irow, N, Ipar, Isox, val)
end do
end do
accu = .false.
- call derivsNew%setAccumulate(accu)
+ call derivs%setAccumulate(accu)
end do
!
!
@@ -165,18 +156,18 @@ module Qtrap_Clm_m
20 CONTINUE
! *** Temporarily assume (1) neutrons only, (2) one isotope only
! *** Eventually need to fix this!
- Recul = Em*(Aneutr/(Aaawww+Aneutr))
+ Recul = Em*(Aneutr/(calc%Aaawww+Aneutr))
Alpha = Recul/Tevx
!
- Sel = dEXP(-Dwpix*Alpha)
- IF (Mode_S_Norm.EQ.0) THEN
- ELSE IF (Mode_S_Norm.EQ.1) THEN
+ Sel = dEXP(-calc%Dwpix*Alpha)
+ IF (calc%Mode_S_Norm.EQ.0) THEN
+ ELSE IF (calc%Mode_S_Norm.EQ.1) THEN
Yy = (One-Sel)/(C_Norm-Sel)
- do ipar = 0, numUsedPar
- do N = 1, Nax
- val = Yy * derivsNew%getDataNs( irow, N, Ipar, Isox)
+ do ipar = 0, calc%getNumParams()
+ do N = 1, Na
+ val = Yy * derivs%getDataNs( irow, N, Ipar, Isox)
if (val.eq.0.0d0) cycle
- call derivsNew%addDataNs(irow, N, Ipar, Isox, val)
+ call derivs%addDataNs(irow, N, Ipar, Isox, val)
end do
end do
END IF
@@ -185,25 +176,23 @@ module Qtrap_Clm_m
! Sigman(Em+Recul)*EXP(-W*A)
Xx = Em + Recul
Yy = Sel
- Call Find_L (grid, Xx, L1, L2, Lstart, L1er, L2er)
- Call Sig_Int (grid, derivsNew, derivs, &
+ Call Find_L (calc, Xx, L1, L2, Lstart, L1er, L2er)
+ Call Sig_Int (calc, derivs, derivs, &
Tempx, Xx, Yy, Ktempx, Na, Isox, &
- Locate, L1, L2, irow, Isox)
+ L1, L2, irow, Isox)
!
IF (L1er.GT.0) THEN
- WRITE (6,10100) L1er, Em, grid%getEnergy(1, expData)
+ WRITE (6,10100) L1er, Em, calc%getEnergyUnbroadened(1)
10100 FORMAT ('###', I5, '= number of omitted terms', 1X, &
'for E=', 1PG13.5, ' at Eb(1)=', 1PG13.5)
END IF
IF (L2er.GT.0) THEN
- numEl = grid%getNumEnergies(expData)
+ numEl = calc%getNumEnergyUnbroadened()
WRITE (6,10200) L2er, numEl, Em, &
- grid%getEnergy(numEl, expData)
+ calc%getEnergyUnbroadened(numEl)
10200 FORMAT ('###', I5, '= omitted terms', 1X, &
'for E=', 1PG13.5, ' at Eb(', I5, ')=', 1PG13.5)
END IF
-!
- call grid%destroy()
RETURN
END SUBROUTINE Qtrap_Clm
@@ -212,21 +201,15 @@ module Qtrap_Clm_m
!
! -----------------------------------------------------------------
!
- SUBROUTINE Sig_Int_L (grid, tmpCalc, derivs, &
+ SUBROUTINE Sig_Int_L (calc, tmpCalc, derivs, &
Tempx, Xx, Yy, Ktempx, Na, Isox, &
- Locate, L1, L2, irow, ourIso)
+ L1, L2, irow, ourIso)
!
! *** Purpose -- Linear interpolate to get CrossSection(Xx) using
! *** CrossSection(Energb(L1)) and CrossSection(Energb(L2))
!
- use fixedi_m, only : numUsedPar
- use constn_common_m
- use SammyGridAccess_M
- use EndfData_common_m
- use DerivativeHandler_M
- IMPLICIT none
- type(SammyGridAccess)::grid
- INTEGER Ktempx, Na, Isox, Locate, L1, L2
+ class(CrystalLatticeBroadening)::calc
+ INTEGER Ktempx, Na, Isox, L1, L2
type(DerivativeHandler)::derivs, tmpCalc
real(kind=8)::Tempx, Xx, Yy
real(kind=8):: Aa(4)
@@ -239,19 +222,15 @@ module Qtrap_Clm_m
Aa(1) = Yy
Aa(2) = Zero
ELSE
- E1 = grid%getEnergy(L1, expData)
- E2 = grid%getEnergy(L2, expData)
+ E1 = calc%getEnergyUnbroadened(L1)
+ E2 = calc%getEnergyUnbroadened(L2)
D = E2 - E1
Aa(1) = (E2-Xx)/D * Yy
Aa(2) = (Xx-E1)/D * Yy
END IF
-!
-! ***
- IF (Locate.EQ.0) THEN
-! ***
-! ---
+
! update cross section (ipar=0) as well as derivatives
- do Ipar = 0, numUsedPar
+ do Ipar = 0, calc%getNumParams()
DO N=1,Na
L = 0
val = 0.0d0
@@ -264,23 +243,6 @@ module Qtrap_Clm_m
END DO
END DO
! ***
- ELSE
-! IF (Locate.NE.0) THEN
-! ***
-! ---
- ! update cross section (ipar=0) as well as derivatives
- do Ipar = 0, numUsedPar
- L = 0
- val = 0.0d0
- DO LL=L1,L2
- L = L + 1
- val = val + Aa(L)*derivs%getDataNsOld(LL, Locate, Ipar, Iso)
- end do
- if (val.eq.0.0d0) cycle
- call tmpCalc%addDataNs(irow, 1, Ipar, ourIso, val)
- END DO
-! ***
- END IF
! ***
!
RETURN
@@ -289,22 +251,15 @@ module Qtrap_Clm_m
!
! -----------------------------------------------------------------
!
- SUBROUTINE Sig_Int (grid, tmpCalc, derivs, &
+ SUBROUTINE Sig_Int (calc, tmpCalc, derivs, &
Tempx, Xx, Yy, Ktempx, Na, Isox, &
- Locate, L1, L2, irow, ourIso)
+ L1, L2, irow, ourIso)
!
! *** Purpose -- Quadratic interpolate to get CrossSection(Xx) using
! *** CrossSection(Energb(L1-1)) to CrossSection(Energb(L2+1))
!
- use fixedi_m, only : numUsedPar
- use constn_common_m
- use SammyGridAccess_M
- use EndfData_common_m
- use DerivativeHandler_M
- use, intrinsic :: ISO_C_BINDING
- IMPLICIT none
- type(SammyGridAccess)::grid
- INTEGER Ktempx, Na, Isox, Locate, L1, L2
+ class(CrystalLatticeBroadening)::calc
+ INTEGER Ktempx, Na, Isox, L1, L2
real(kind=8)::Tempx, Xx, Yy
type(DerivativeHandler)::derivs, tmpCalc
real(kind=8)::Aa(4)
@@ -315,19 +270,19 @@ module Qtrap_Clm_m
logical(C_BOOL)::accu
!
- Ndatb = grid%getNumEnergies(expData)
+ Ndatb = calc%getNumEnergyUnbroadened()
IF (L1.EQ.1 .OR. L2.EQ.Ndatb .OR. L1.EQ.L2) THEN
- CALL Sig_Int_L (grid, tmpCalc, derivs, &
+ CALL Sig_Int_L (calc, tmpCalc, derivs, &
Tempx, Xx, Yy, Ktempx, Na, Isox, &
- Locate, L1, L2, irow, ourIso)
+ L1, L2, irow, ourIso)
RETURN
END IF
!
Iso = Isox
- E1 = grid%getEnergy(L1-1, expData)
- E2 = grid%getEnergy(L1 , expData)
- E3 = grid%getEnergy(L2 , expData)
- E4 = grid%getEnergy(L2+1, expData)
+ E1 = calc%getEnergyUnbroadened(L1-1)
+ E2 = calc%getEnergyUnbroadened(L1)
+ E3 = calc%getEnergyUnbroadened(L2)
+ E4 = calc%getEnergyUnbroadened(L2+1)
!
D21 = E2 - E1
D32 = E3 - E2
@@ -351,11 +306,9 @@ module Qtrap_Clm_m
!
!
! ***
- IF (Locate.EQ.0) THEN
-! ***
-! ---
+
! update cross section (ipar=0) as well as derivatives
- Do Ipar = 0, numUsedPar
+ Do Ipar = 0, calc%getNumParams()
DO N=1,Na
L = 0
val = 0.0d0
@@ -367,25 +320,6 @@ module Qtrap_Clm_m
call tmpCalc%addDataNs(irow, N, Ipar, ourIso, val)
end do
END DO
-! ---
-! ***
- ELSE
-! IF (Locate.NE.0) THEN
-! ***
- ! update cross section (ipar=0) as well as derivatives
- Do Ipar = 0, numUsedPar
- L = 0
- val = 0.0d0
- DO LL=L1-1,L2+1
- L = L + 1
- val = val + Aa(L) * derivs%getDataNsOld(LL, Locate, Ipar, Iso)
- end do
- if (val.eq.0.0d0) cycle
- call tmpCalc%addDataNs(irow, 1, Ipar, ourIso, val)
- END DO
-! ***
- END IF
-! ***
!
accu = .false.
diff --git a/sammy/src/convolution/CMakeLists.txt b/sammy/src/convolution/CMakeLists.txt
index 51936cfc0465900a23c196c364480bb27f17653d..33308c90251f05126aac60df4e62a313740bdc5c 100644
--- a/sammy/src/convolution/CMakeLists.txt
+++ b/sammy/src/convolution/CMakeLists.txt
@@ -18,6 +18,9 @@ SET(HEADERS
DopplerAndResolutionBroadener.h
interface/cpp/DopplerAndResolutionBroadenerInterface.h
+
+ DopplerBroadening.h
+ interface/cpp/DopplerBroadeningInterface.h
)
APPEND_SET(CONVOLUTION_SOURCES
@@ -36,6 +39,13 @@ APPEND_SET(CONVOLUTION_SOURCES
interface/cpp/DopplerAndResolutionBroadenerInterface.cpp
interface/fortran/DopplerAndResolutionBroadener_I.f90
interface/fortran/DopplerAndResolutionBroadener_M.f90
+
+ DopplerBroadening.cpp
+ interface/cpp/DopplerBroadeningInterface.cpp
+ interface/fortran/DopplerBroadening_I.f90
+ interface/fortran/DopplerBroadening_M.f90
+
+ FortranExtDopplerBroadening_M.f90
)
diff --git a/sammy/src/convolution/DopplerAndResolutionBroadener.cpp b/sammy/src/convolution/DopplerAndResolutionBroadener.cpp
index a2bf61a4bbfa092f1aa84259fbca5c3479c08363..a63353c9a97a24560b43bf1065e4a3b0dd353f7c 100644
--- a/sammy/src/convolution/DopplerAndResolutionBroadener.cpp
+++ b/sammy/src/convolution/DopplerAndResolutionBroadener.cpp
@@ -9,10 +9,10 @@ DopplerAndResolutionBroadener::DopplerAndResolutionBroadener(DerivativeHandler &
GridDataList & list,
GridDataList & work):handler(hand), gridList(list), workSpace(work)
{
- numIso = 0;
numPerEner = 1;
posUn = posBroad = 0;
offUn = offBroad = 0;
+ numParams = 0;
if( !(list.getLength() > 0)) throw std::runtime_error( "We need at least one energy grid in order to broaden");
unGrid = 0;
broadGrid = 0;
@@ -70,6 +70,16 @@ void DopplerAndResolutionBroadener::updateBroadenedOffset(int offSet){
}
}
+void DopplerAndResolutionBroadener::setLength(int l){
+ length = l;
+
+ if (broadGrid > 0){
+ int ii = l - 1;
+ if (ii < 0) ii = 0;
+ gridList.getGrid(broadGrid)->setRowMax(ii);
+ }
+}
+
int DopplerAndResolutionBroadener::getUpperLimitBroadened() const{
int jj = gridList.getGrid(broadGrid)->getRowMax();
if (jj > 0) {
@@ -127,8 +137,24 @@ void DopplerAndResolutionBroadener::insertEnergyBroadened(int pos){
}
-void DopplerAndResolutionBroadener::broaden(bool makebroadGrid){}
+void DopplerAndResolutionBroadener::broaden(bool makebroadGrid){
+ // reserve the data
+ int ndatb = getNumEnergyBroadened();
+ handler.nullify();
+ handler.reserve(ndatb*handler.getNnnsig(), numParams+1);
+}
+void DopplerAndResolutionBroadener::transferUnbroadened(int ipos, int iso){
+ int nsig = handler.getNnnsig();
+ for (int ipar = 0; ipar < numParams+1; ipar++){
+ for (int n = 0; n < nsig; n++){
+ double val = handler.getDataNs(ipos, n, ipar, iso, false);
+ if (val != 0.0){
+ handler.addDataNs(currentPos, n, ipar, iso, val);
+ }
+ }
+ }
+}
int DopplerAndResolutionBroadener::getEmInUnbroadened(double em, int istart) const{
int nener = getNumEnergyUnbroadened();
@@ -170,10 +196,17 @@ int DopplerAndResolutionBroadener::getEmInUnbroadened(double em, int istart) con
void DopplerAndResolutionBroadener::calcIntegralSpan(double elow, double ehigh, bool oneExtra){
int nener = getNumEnergyUnbroadened();
+ int ihigh = integralStart + integralPts;
+ if (ihigh < 0) ihigh = 0;
+ if (ihigh >= nener) ihigh = nener -1;
+ double eCurrent = getEnergyUnbroadened(ihigh);
+ if (eCurrent > ehigh) ihigh = 0;
+
+
if ( integralStart < 0) integralStart = 0;
if ( integralStart >= nener) integralStart = nener - 1;
- double eCurrent = getEnergyUnbroadened(integralStart);
+ eCurrent = getEnergyUnbroadened(integralStart);
// assume data are ascending in energy
while (eCurrent > elow && integralStart > 0){
@@ -195,6 +228,7 @@ void DopplerAndResolutionBroadener::calcIntegralSpan(double elow, double ehigh,
int i = integralStart;
for (; i < nener-1; i++){
integralPts = integralPts + 1;
+ if (i < ihigh) continue;
eCurrent = getEnergyUnbroadened(i);
if ( eCurrent >= ehigh) break;
}
@@ -231,28 +265,31 @@ void DopplerAndResolutionBroadener::ensureWorkGridLength(int length){
}
}
-void DopplerAndResolutionBroadener::setupBroadnener(int numcro, int ktzero, bool moreBroadening){
- int nn = numcro;
- if (nn == 0) nn = 1;
- setNumPerEnergy(nn);
-
- nn = 0;
- if (ktzero != 0){
- if (numcro > 1){
- nn = 2;
- }
- else{
- nn = 1;
- }
+void DopplerAndResolutionBroadener::setupBroadener(bool moreBroadening, int num){
+ const std::unique_ptr<GridData> & grid = gridList.getGrid(0);
+ int numcro = 1;
+ int ipos = 0;
+ if (grid != nullptr) {
+ numcro = grid->getNumPerEnergy();
+
+ // ipos is only relevant for the experimental grid (index 0)
+ // it is ignored for auxillary grid (index > 0)
+ ipos = grid->getDataColumn() - 1;
+ if (numcro > 1) ipos--;
+ if (ipos < 0) ipos = 0;
}
+ if (numcro == 0) numcro = 1;
+ setNumPerEnergy(numcro);
- setUnbroadenedGrid(1, nn); // unbroadened grid is always auxillary grid
+ setUnbroadenedGrid(1, ipos); // unbroadened grid is always auxillary grid
if (moreBroadening){
- setBroadenedGrid(1,nn); // and if more brodening is to happen, it is also broadened to the auxillary grid
+ setBroadenedGrid(1,ipos); // and if more brodening is to happen, it is also broadened to the auxillary grid
}
else{
- setBroadenedGrid(0,nn); // if last broadening it is on the experimental grid
+ setBroadenedGrid(0,ipos); // if last broadening it is on the experimental grid
}
+
+ numParams = num;
}
void DopplerAndResolutionBroadener::setXoefWeights(int index){
diff --git a/sammy/src/convolution/DopplerAndResolutionBroadener.h b/sammy/src/convolution/DopplerAndResolutionBroadener.h
index 4798a18dbc8a31cd19f6942760380b1b2a73be82..b3c6a265bd70ca33ea51db09464523d8c46b3e2a 100644
--- a/sammy/src/convolution/DopplerAndResolutionBroadener.h
+++ b/sammy/src/convolution/DopplerAndResolutionBroadener.h
@@ -28,21 +28,6 @@ public:
DopplerAndResolutionBroadener(const DopplerAndResolutionBroadener & orig)=delete;
virtual ~DopplerAndResolutionBroadener(){}
- /**
- * Get the number of isotopes to consider.
- *
- * @return the number of isotopes to consider
- */
- int getNumIso() const{ return numIso;}
-
- /**
- * Set the number of isotopes.
- * If 1, only shared values in DerivativeHandler are considered
- *
- * @param iso the number of isotopes
- */
- void setNumIso(int iso) { numIso = iso;}
-
/**
* Get the number of points per energy
*
@@ -272,11 +257,11 @@ public:
/**
* Set up the grid
- * @param numcro the number of points per energy
- * @param ktzero if t_0 is adjusted, the position of the energy in the grid shifts
+ *
* @param moreBroadening true if more broadening is to happen after
+ * @param the number of parameters that have derivatives
*/
- void setupBroadnener(int numcro, int ktzero, bool moreBroadening);
+ void setupBroadener(bool moreBroadening, int num);
/**
* Indicate where broadenend data actually start on the
@@ -290,7 +275,7 @@ public:
* The the number of broadened data actually added
* @param l the number of broadened data actually added
*/
- void setLength(int l) { length = l; }
+ void setLength(int l);
/**
* Get the number of broadened data actually added
@@ -298,11 +283,27 @@ public:
*/
int getLength() const { return length;}
+ /**
+ * Get the number of parameters for which derivatives exist
+ * @return the number of parameters for which derivatives exist
+ */
+ int getNumParams() const { return numParams; }
+
+ /**
+ * Transfer the unbroadened data unchanged to the broadened
+ * data array.
+ * The broadened data will be storted at position
+ * getCurrentPos() and the unbroadened data are retrieved from
+ * ipos.
+ *
+ * @param ipos the position of the unbroadened data
+ * @param iso the isotope for which to transfer the data
+ */
+ void transferUnbroadened(int ipos, int iso);
private:
void ensureWorkGridLength(int length);
- int numIso; // number of isotopes (if 1 - always use shared value)
int numPerEner; // number of points per energy
int posUn, posBroad; // the position of the energy in the unbroadened and braodened grid
@@ -319,6 +320,8 @@ private:
int integralStart, integralPts;
+ int numParams;
+
int currentPos;
int length;
};
diff --git a/sammy/src/convolution/DopplerBroadening.cpp b/sammy/src/convolution/DopplerBroadening.cpp
new file mode 100644
index 0000000000000000000000000000000000000000..c3bff21aadaa6141b248f9ea2cbd9cf5a6aa1474
--- /dev/null
+++ b/sammy/src/convolution/DopplerBroadening.cpp
@@ -0,0 +1,5 @@
+#include "DopplerBroadening.h"
+
+namespace sammy{
+
+}
diff --git a/sammy/src/convolution/DopplerBroadening.h b/sammy/src/convolution/DopplerBroadening.h
new file mode 100644
index 0000000000000000000000000000000000000000..0b4637d4ba6043b2a8f9bab4554caa59c27d4395
--- /dev/null
+++ b/sammy/src/convolution/DopplerBroadening.h
@@ -0,0 +1,30 @@
+#ifndef SAMMY_DOPPLERBROADENING_H
+#define SAMMY_DOPPLERBROADENING_H
+
+#include "DopplerAndResolutionBroadener.h"
+#include "salmon/GridData.h"
+#include "salmon/DerivativeHandler.h"
+
+namespace sammy{
+class DopplerBroadening : public DopplerAndResolutionBroadener
+{
+public:
+ DopplerBroadening(DerivativeHandler & hand, GridDataList & list, GridDataList & work):
+ DopplerAndResolutionBroadener(hand, list, work), temp(0.0), brdLim(5.0){}
+ DopplerBroadening(const DopplerBroadening & orig) = delete;
+ virtual ~DopplerBroadening(){}
+
+ void setTemperature(double t) { temp = t; }
+
+ double getTemperature() const { return temp; }
+
+ void setBrdLim( double b) { brdLim = b; }
+
+ double getBrdLim() const { return brdLim; }
+private:
+ double temp; // the temperature
+
+ double brdLim;
+};
+}
+#endif // SAMMY_DOPPLERBROADENING_H
diff --git a/sammy/src/convolution/FortranExtDopplerBroadening_M.f90 b/sammy/src/convolution/FortranExtDopplerBroadening_M.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8a6089ba25d3e6a2b223a754fbc9c3cbf0ff050d
--- /dev/null
+++ b/sammy/src/convolution/FortranExtDopplerBroadening_M.f90
@@ -0,0 +1,165 @@
+module FortranExtDopplerBroadening_M
+use, intrinsic :: ISO_C_BINDING
+use DopplerBroadening_M
+use DerivativeHandler_M
+use GridData_M
+
+implicit none
+
+type, extends(DopplerBroadening) :: FortranExtDopplerBroadening
+real(kind=8),allocatable,dimension(:,:)::rowData
+logical::debugOutput
+type(DerivativeHandler)::dataSelf
+real(kind=8)::Sitemp
+logical::hasSelf = .false.
+
+integer::Kc, Ipnts
+real(kind=8)::Brdlim
+
+real(kind=8)::Elowbr ! energy below which no broadening is wanted, for high- energy Gaussian approximation to Doppler broadening (eV)
+contains
+procedure, pass(this) :: initialize => FortranExtDopplerBroadening_initialize
+procedure, pass(this) :: broaden => FortranExtDopplerBroadening_broaden
+procedure, pass(this) :: addSelfData => FortranExtDopplerBroadening_addSelfData
+procedure, pass(this) :: transferUnbroadenedAll => FortranExtDopplerBroadening_transferUnbroadenedAll
+procedure, pass(this) :: transferUnbroadenedBroad => FortranExtDopplerBroadening_transferUnbroadened
+procedure, pass(this) :: copyRowData => FortranExtDopplerBroadening_copyRowData
+procedure, pass(this) :: destroy => FortranExtDopplerBroadening_destroy
+end type FortranExtDopplerBroadening
+
+contains
+subroutine FortranExtDopplerBroadening_initialize(this, hand, list, work)
+ implicit none
+ class(FortranExtDopplerBroadening) :: this
+ class(DerivativeHandler)::hand
+ class(GridDataList)::list
+ class(GridDataList)::work
+ call DopplerBroadening_initialize(this, hand, list, work)
+ this%debugOutput = .false.
+ this%Elowbr = 0.0d0
+ this%Sitemp = 0.0d0
+end subroutine
+
+subroutine FortranExtDopplerBroadening_destroy(this)
+ implicit none
+ class(FortranExtDopplerBroadening) :: this
+ call DopplerBroadening_destroy(this)
+end subroutine
+
+subroutine FortranExtDopplerBroadening_addSelfData(this, copyData, ipos)
+ class(FortranExtDopplerBroadening) :: this
+ type(DerivativeHandler)::self
+ type(DerivativeHandler)::data
+ logical::copyData
+
+ integer::iso, jdat, Ii, ipos
+ real(kind=8)::val
+
+ this%hasSelf = .true.
+ if( .not.copyData) return
+
+ call this%getData(data)
+
+
+ ! Note this is after the switch, ergo operate on old data
+ DO Iso=1,this%dataSelf%getUsedIsotopes()
+ do jdat = 1, this%getNumEnergyUnbroadened()
+ DO Ii=0,this%getNumParams()
+ val = data%getDataNsOld(Jdat, ipos, Ii, Iso)
+ if (val.ne.0.0d0) then
+ call this%dataSelf%addDataNsOld(Jdat, 1, Ii, Iso, val)
+ else
+ if (this%dataSelf%getDataNsOld(Jdat, 1, Ii, Iso).ne.0.0d0) then
+ call this%dataSelf%addDataNsOld(Jdat, 1, Ii, Iso, val)
+ end if
+ end if
+ end do
+ end do
+ end do
+end subroutine
+
+subroutine FortranExtDopplerBroadening_transferUnbroadened(this, data, ipos, iso, iflag)
+ class(FortranExtDopplerBroadening) :: this
+ integer::ipos, iso, iflag
+
+ type(DerivativeHandler)::data
+ integer::ipar, n, inew
+ real(kind=8)::val
+
+ inew = this%getCurrentPos()
+ do ipar = 0, this%getNumParams()
+ if (ipar.gt.0.and.iflag.eq.ipar) cycle
+ do n = 1, data%getNnnsig()
+ val = data%getDataNsOld(ipos, N, ipar, iso)
+ if (val.eq.0.0d0) cycle
+ call data%addDataNs(inew, N, ipar, Iso, val)
+ end do
+ end do
+end subroutine
+
+subroutine FortranExtDopplerBroadening_transferUnbroadenedAll(this, ipos, iso, iflag, iflagSelf)
+ class(FortranExtDopplerBroadening) :: this
+ integer::ipos, iso, iflag, iflagSelf
+ type(DerivativeHandler)::data
+
+ call this%getData(data)
+ call FortranExtDopplerBroadening_transferUnbroadened(this, data, ipos, iso, iflag)
+ if (this%hasSelf) then
+ call FortranExtDopplerBroadening_transferUnbroadened(this, this%dataSelf, ipos, iso, iflagSelf)
+ end if
+end subroutine
+
+subroutine FortranExtDopplerBroadening_broaden(this)
+ class(FortranExtDopplerBroadening) :: this
+
+ integer::ndatb, i,current1, current2
+ real(kind=8)::ener
+ type(DerivativeHandler)::data
+
+ call DopplerBroadening_broaden(this)
+
+
+ ndatb = this%getNumEnergyUnbroadened()
+
+ ! reserve the data for self indication experiments
+ ndatb = this%getNumEnergyBroadened()
+ if( this%hasSelf) then
+ call this%dataSelf%nullify()
+ call this%dataSelf%reserve(ndatb*this%dataSelf%getNnnsig(), this%getNumParams()+1)
+ end if
+
+ call this%getData(data)
+
+
+ if (allocated(this%rowData)) then
+ current1 = size(this%rowData,dim=1)
+ current2 = size(this%rowData,dim=2)
+ if (current1.lt.data%getNnnsig().or. &
+ current2.lt.this%getNumParams()+ 1) then
+ deallocate(this%rowData)
+ end if
+ end if
+ if( .not.allocated(this%rowData)) then
+ allocate(this%rowData(data%getNnnsig(), 0:this%getNumParams()))
+ end if
+end subroutine
+
+subroutine FortranExtDopplerBroadening_copyRowData(this, data, iso)
+ class(FortranExtDopplerBroadening) :: this
+ type(DerivativeHandler)::data
+ integer::iso
+
+ integer::ipar, n, inew
+ real(kind=8)::val
+
+ inew = this%getCurrentPos()
+ do ipar = 0, this%getNumParams()
+ do n = 1, data%getNnnsig()
+ val = this%rowData(N, ipar)
+ if (val.eq.0.0d0) cycle
+ call data%addDataNs(inew, N, ipar, Iso, val)
+ end do
+ end do
+end subroutine
+
+end module FortranExtDopplerBroadening_M
diff --git a/sammy/src/convolution/interface/cix/DopplerAndResolutionBroadener.cpp2f.xml b/sammy/src/convolution/interface/cix/DopplerAndResolutionBroadener.cpp2f.xml
index 6a18bf648f32d512d9e653d321be2559b0dbcb59..af0dc3779a4b419d018d0560e56e0a46f8d569b1 100644
--- a/sammy/src/convolution/interface/cix/DopplerAndResolutionBroadener.cpp2f.xml
+++ b/sammy/src/convolution/interface/cix/DopplerAndResolutionBroadener.cpp2f.xml
@@ -11,11 +11,6 @@
<param name="work" type="GridDataList"/>
</constructor>
- <method name="getNumIso" return_type="int"/>
- <method name="setNumIso">
- <param name="iso" type="int"/>
- </method>
-
<method name="getNumPerEnergy" return_type="int"/>
<method name="setNumPerEnergy">
<param name="n" type="int"/>
@@ -94,11 +89,11 @@
<method name="setXoefWeights">
<param name="index" type="int" offset="-1"/>
</method>
- <method name="setupBroadnener">
- <param name="numcro" type="int"/>
- <param name="ktzero" type="int"/>
+ <method name="setupBroadener">
<param name="moreBroadening" type="bool"/>
+ <param name="num" type="int"/>
</method>
+ <method name="getNumParams" return_type="int"/>
<method name="updateBroadenedOffset">
<param name="offSet" type="int" offset="-1"/>
@@ -110,6 +105,11 @@
<method name="getLength" return_type="int"/>
<method name="broaden"/>
+
+ <method name="transferUnbroadened">
+ <param name="ipos" type="int" offset="-1"/>
+ <param name="iso" type="int" offset="-1"/>
+ </method>
</class>
</generate>
diff --git a/sammy/src/convolution/interface/cix/DopplerBroadening.cpp2f.xml b/sammy/src/convolution/interface/cix/DopplerBroadening.cpp2f.xml
new file mode 100644
index 0000000000000000000000000000000000000000..423d51c66794a94a91d00711967250be3c4a26f1
--- /dev/null
+++ b/sammy/src/convolution/interface/cix/DopplerBroadening.cpp2f.xml
@@ -0,0 +1,27 @@
+<generate name="DopplerBroadening">
+ <include_relative name="../../DopplerAndResolutionBroadener.h"/>
+ <include_relative name="../../DopplerBroadening.h"/>
+ <include name="salmon/GridData.h"/>
+ <include name="salmon/DerivativeHandler.h"/>
+ <using_namespace name="sammy"/>
+
+ <class name="DopplerBroadening" abstract="yes" parent="DopplerAndResolutionBroadener">
+ <constructor name="initialize">
+ <param name="hand" type="DerivativeHandler"/>
+ <param name="list" type="GridDataList"/>
+ <param name="work" type="GridDataList"/>
+ </constructor>
+
+ <method name="getTemperature" return_type="double"/>
+ <method name="setTemperature">
+ <param name="t" type="double"/>
+ </method>
+
+ <method name="getBrdLim" return_type="double"/>
+ <method name="setBrdLim">
+ <param name="b" type="double"/>
+ </method>
+
+ <method name="broaden"/>
+ </class>
+</generate>
diff --git a/sammy/src/convolution/interface/cpp/DopplerAndResolutionBroadenerInterface.cpp b/sammy/src/convolution/interface/cpp/DopplerAndResolutionBroadenerInterface.cpp
index 1262a7cfaf455ffd141df543da4d1f3879cbbced..50feec0f176c96f7732209bfc5e91b30d47ff2c4 100644
--- a/sammy/src/convolution/interface/cpp/DopplerAndResolutionBroadenerInterface.cpp
+++ b/sammy/src/convolution/interface/cpp/DopplerAndResolutionBroadenerInterface.cpp
@@ -2,7 +2,7 @@
* This file has been dynamically generated by Class Interface Xml (CIX)
* DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
* If changes need to occur, modify the appropriate CIX xml file
-* Date Generated: Fri Feb 11 16:55:04 EST 2022
+* Date Generated: Tue Apr 19 09:05:33 EDT 2022
* If any issues are experiences with this generated file that cannot be fixed
* with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
*/
@@ -14,16 +14,6 @@ void* DopplerAndResolutionBroadener_initialize(DerivativeHandler * hand,GridData
return new DopplerAndResolutionBroadener(*hand,*list,*work);
}
-int DopplerAndResolutionBroadener_getNumIso(void * DopplerAndResolutionBroadener_ptr)
-{
- return ((DopplerAndResolutionBroadener*)DopplerAndResolutionBroadener_ptr)->getNumIso();
-}
-
-void DopplerAndResolutionBroadener_setNumIso(void * DopplerAndResolutionBroadener_ptr,int * iso)
-{
- ((DopplerAndResolutionBroadener*)DopplerAndResolutionBroadener_ptr)->setNumIso(*iso);
-}
-
int DopplerAndResolutionBroadener_getNumPerEnergy(void * DopplerAndResolutionBroadener_ptr)
{
return ((DopplerAndResolutionBroadener*)DopplerAndResolutionBroadener_ptr)->getNumPerEnergy();
@@ -144,9 +134,14 @@ void DopplerAndResolutionBroadener_setXoefWeights(void * DopplerAndResolutionBro
((DopplerAndResolutionBroadener*)DopplerAndResolutionBroadener_ptr)->setXoefWeights(*index);
}
-void DopplerAndResolutionBroadener_setupBroadnener(void * DopplerAndResolutionBroadener_ptr,int * numcro,int * ktzero,bool * moreBroadening)
+void DopplerAndResolutionBroadener_setupBroadener(void * DopplerAndResolutionBroadener_ptr,bool * moreBroadening,int * num)
{
- ((DopplerAndResolutionBroadener*)DopplerAndResolutionBroadener_ptr)->setupBroadnener(*numcro,*ktzero,*moreBroadening);
+ ((DopplerAndResolutionBroadener*)DopplerAndResolutionBroadener_ptr)->setupBroadener(*moreBroadening,*num);
+}
+
+int DopplerAndResolutionBroadener_getNumParams(void * DopplerAndResolutionBroadener_ptr)
+{
+ return ((DopplerAndResolutionBroadener*)DopplerAndResolutionBroadener_ptr)->getNumParams();
}
void DopplerAndResolutionBroadener_updateBroadenedOffset(void * DopplerAndResolutionBroadener_ptr,int * offSet)
@@ -169,6 +164,11 @@ void DopplerAndResolutionBroadener_broaden(void * DopplerAndResolutionBroadener_
((DopplerAndResolutionBroadener*)DopplerAndResolutionBroadener_ptr)->broaden();
}
+void DopplerAndResolutionBroadener_transferUnbroadened(void * DopplerAndResolutionBroadener_ptr,int * ipos,int * iso)
+{
+ ((DopplerAndResolutionBroadener*)DopplerAndResolutionBroadener_ptr)->transferUnbroadened(*ipos,*iso);
+}
+
void DopplerAndResolutionBroadener_destroy(void * DopplerAndResolutionBroadener_ptr)
{
delete (DopplerAndResolutionBroadener*)DopplerAndResolutionBroadener_ptr;
diff --git a/sammy/src/convolution/interface/cpp/DopplerAndResolutionBroadenerInterface.h b/sammy/src/convolution/interface/cpp/DopplerAndResolutionBroadenerInterface.h
index 5aa65f409c5c2278a84c474ac5180743e5dff8c6..14186fd61076fb758bba22e1c394f8f308245870 100644
--- a/sammy/src/convolution/interface/cpp/DopplerAndResolutionBroadenerInterface.h
+++ b/sammy/src/convolution/interface/cpp/DopplerAndResolutionBroadenerInterface.h
@@ -2,7 +2,7 @@
* This file has been dynamically generated by Class Interface Xml (CIX)
* DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
* If changes need to occur, modify the appropriate CIX xml file
-* Date Generated: Fri Feb 11 16:55:04 EST 2022
+* Date Generated: Tue Apr 19 09:05:33 EDT 2022
* If any issues are experiences with this generated file that cannot be fixed
* with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
*/
@@ -15,8 +15,6 @@ using namespace sammy;
extern "C" {
#endif
void* DopplerAndResolutionBroadener_initialize(DerivativeHandler * hand,GridDataList * list,GridDataList * work );
-int DopplerAndResolutionBroadener_getNumIso(void * DopplerAndResolutionBroadener_ptr);
-void DopplerAndResolutionBroadener_setNumIso(void * DopplerAndResolutionBroadener_ptr,int * iso);
int DopplerAndResolutionBroadener_getNumPerEnergy(void * DopplerAndResolutionBroadener_ptr);
void DopplerAndResolutionBroadener_setNumPerEnergy(void * DopplerAndResolutionBroadener_ptr,int * n);
int DopplerAndResolutionBroadener_getIntegralStart(void * DopplerAndResolutionBroadener_ptr);
@@ -41,11 +39,13 @@ void DopplerAndResolutionBroadener_nullifyWorkGrid(void * DopplerAndResolutionBr
double DopplerAndResolutionBroadener_getWorkData(void * DopplerAndResolutionBroadener_ptr,int * index,int * row,int * col);
void DopplerAndResolutionBroadener_setWorkData(void * DopplerAndResolutionBroadener_ptr,int * index,int * row,int * col,double * val);
void DopplerAndResolutionBroadener_setXoefWeights(void * DopplerAndResolutionBroadener_ptr,int * index);
-void DopplerAndResolutionBroadener_setupBroadnener(void * DopplerAndResolutionBroadener_ptr,int * numcro,int * ktzero,bool * moreBroadening);
+void DopplerAndResolutionBroadener_setupBroadener(void * DopplerAndResolutionBroadener_ptr,bool * moreBroadening,int * num);
+int DopplerAndResolutionBroadener_getNumParams(void * DopplerAndResolutionBroadener_ptr);
void DopplerAndResolutionBroadener_updateBroadenedOffset(void * DopplerAndResolutionBroadener_ptr,int * offSet);
void DopplerAndResolutionBroadener_setLength(void * DopplerAndResolutionBroadener_ptr,int * l);
int DopplerAndResolutionBroadener_getLength(void * DopplerAndResolutionBroadener_ptr);
void DopplerAndResolutionBroadener_broaden(void * DopplerAndResolutionBroadener_ptr);
+void DopplerAndResolutionBroadener_transferUnbroadened(void * DopplerAndResolutionBroadener_ptr,int * ipos,int * iso);
void DopplerAndResolutionBroadener_destroy(void * DopplerAndResolutionBroadener_ptr);
#ifdef __cplusplus
}
diff --git a/sammy/src/convolution/interface/cpp/DopplerBroadeningInterface.cpp b/sammy/src/convolution/interface/cpp/DopplerBroadeningInterface.cpp
new file mode 100644
index 0000000000000000000000000000000000000000..e7a565a951261b1d18012bfb58848b12d904809b
--- /dev/null
+++ b/sammy/src/convolution/interface/cpp/DopplerBroadeningInterface.cpp
@@ -0,0 +1,46 @@
+/*!
+* This file has been dynamically generated by Class Interface Xml (CIX)
+* DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
+* If changes need to occur, modify the appropriate CIX xml file
+* Date Generated: Tue Apr 19 10:21:53 EDT 2022
+* If any issues are experiences with this generated file that cannot be fixed
+* with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
+*/
+#include <string.h>
+#include "DopplerBroadeningInterface.h"
+using namespace sammy;
+void* DopplerBroadening_initialize(DerivativeHandler * hand,GridDataList * list,GridDataList * work )
+{
+ return new DopplerBroadening(*hand,*list,*work);
+}
+
+double DopplerBroadening_getTemperature(void * DopplerBroadening_ptr)
+{
+ return ((DopplerBroadening*)DopplerBroadening_ptr)->getTemperature();
+}
+
+void DopplerBroadening_setTemperature(void * DopplerBroadening_ptr,double * t)
+{
+ ((DopplerBroadening*)DopplerBroadening_ptr)->setTemperature(*t);
+}
+
+double DopplerBroadening_getBrdLim(void * DopplerBroadening_ptr)
+{
+ return ((DopplerBroadening*)DopplerBroadening_ptr)->getBrdLim();
+}
+
+void DopplerBroadening_setBrdLim(void * DopplerBroadening_ptr,double * b)
+{
+ ((DopplerBroadening*)DopplerBroadening_ptr)->setBrdLim(*b);
+}
+
+void DopplerBroadening_broaden(void * DopplerBroadening_ptr)
+{
+ ((DopplerBroadening*)DopplerBroadening_ptr)->broaden();
+}
+
+void DopplerBroadening_destroy(void * DopplerBroadening_ptr)
+{
+ delete (DopplerBroadening*)DopplerBroadening_ptr;
+}
+
diff --git a/sammy/src/convolution/interface/cpp/DopplerBroadeningInterface.h b/sammy/src/convolution/interface/cpp/DopplerBroadeningInterface.h
new file mode 100644
index 0000000000000000000000000000000000000000..0008d6585ff5ba4fe85f1d8e5ed371c9e0dd39ee
--- /dev/null
+++ b/sammy/src/convolution/interface/cpp/DopplerBroadeningInterface.h
@@ -0,0 +1,31 @@
+/*!
+* This file has been dynamically generated by Class Interface Xml (CIX)
+* DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
+* If changes need to occur, modify the appropriate CIX xml file
+* Date Generated: Tue Apr 19 10:21:53 EDT 2022
+* If any issues are experiences with this generated file that cannot be fixed
+* with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
+*/
+#ifndef DOPPLERBROADENINGINTERFACE_H
+#define DOPPLERBROADENINGINTERFACE_H
+#include "salmon/DerivativeHandler.h"
+#include "salmon/GridData.h"
+#include "../../DopplerAndResolutionBroadener.h"
+#include "../../DopplerBroadening.h"
+
+
+using namespace sammy;
+#ifdef __cplusplus
+extern "C" {
+#endif
+void* DopplerBroadening_initialize(DerivativeHandler * hand,GridDataList * list,GridDataList * work );
+double DopplerBroadening_getTemperature(void * DopplerBroadening_ptr);
+void DopplerBroadening_setTemperature(void * DopplerBroadening_ptr,double * t);
+double DopplerBroadening_getBrdLim(void * DopplerBroadening_ptr);
+void DopplerBroadening_setBrdLim(void * DopplerBroadening_ptr,double * b);
+void DopplerBroadening_broaden(void * DopplerBroadening_ptr);
+void DopplerBroadening_destroy(void * DopplerBroadening_ptr);
+#ifdef __cplusplus
+}
+#endif
+#endif /* DOPPLERBROADENINGINTERFACE_H */
diff --git a/sammy/src/convolution/interface/fortran/DopplerAndResolutionBroadener_I.f90 b/sammy/src/convolution/interface/fortran/DopplerAndResolutionBroadener_I.f90
index 0cfe834e4d94dc5eb090824d6c1586b523a76e5a..dfa816925c873b8c2112742aab87967809ec80c2 100644
--- a/sammy/src/convolution/interface/fortran/DopplerAndResolutionBroadener_I.f90
+++ b/sammy/src/convolution/interface/fortran/DopplerAndResolutionBroadener_I.f90
@@ -2,7 +2,7 @@
!! This file has been dynamically generated by Class Interface Xml (CIX)
!! DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
!! If changes need to occur, modify the appropriate CIX xml file
-!! Date Generated: Fri Feb 11 16:55:04 EST 2022
+!! Date Generated: Tue Apr 19 09:05:33 EDT 2022
!! If any issues are experiences with this generated file that cannot be fixed
!! with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
!!/
@@ -17,17 +17,6 @@ type(C_PTR) function f_DopplerAndResolutionBroadener_initialize( hand,list,work
type(C_PTR), value :: list;
type(C_PTR), value :: work;
end function
-integer(C_INT) function f_DopplerAndResolutionBroadener_getNumIso(DopplerAndResolutionBroadener_ptr ) BIND(C,name="DopplerAndResolutionBroadener_getNumIso")
- use,intrinsic :: ISO_C_BINDING
- implicit none
- type(C_PTR), value :: DopplerAndResolutionBroadener_ptr;
-end function
-subroutine f_DopplerAndResolutionBroadener_setNumIso(DopplerAndResolutionBroadener_ptr, iso ) BIND(C,name="DopplerAndResolutionBroadener_setNumIso")
- use,intrinsic :: ISO_C_BINDING
- implicit none
- type(C_PTR), value :: DopplerAndResolutionBroadener_ptr;
- integer(C_INT) :: iso;
-end subroutine
integer(C_INT) function f_DopplerAndResolutionBroadener_getNumPerEnergy(DopplerAndResolutionBroadener_ptr ) BIND(C,name="DopplerAndResolutionBroadener_getNumPerEnergy")
use,intrinsic :: ISO_C_BINDING
implicit none
@@ -175,14 +164,18 @@ subroutine f_DopplerAndResolutionBroadener_setXoefWeights(DopplerAndResolutionBr
type(C_PTR), value :: DopplerAndResolutionBroadener_ptr;
integer(C_INT) :: index;
end subroutine
-subroutine f_DopplerAndResolutionBroadener_setupBroadnener(DopplerAndResolutionBroadener_ptr, numcro,ktzero,moreBroadening ) BIND(C,name="DopplerAndResolutionBroadener_setupBroadnener")
+subroutine f_DopplerAndResolutionBroadener_setupBroadener(DopplerAndResolutionBroadener_ptr, moreBroadening,num ) BIND(C,name="DopplerAndResolutionBroadener_setupBroadener")
use,intrinsic :: ISO_C_BINDING
implicit none
type(C_PTR), value :: DopplerAndResolutionBroadener_ptr;
- integer(C_INT) :: numcro;
- integer(C_INT) :: ktzero;
logical(C_BOOL) :: moreBroadening;
+ integer(C_INT) :: num;
end subroutine
+integer(C_INT) function f_DopplerAndResolutionBroadener_getNumParams(DopplerAndResolutionBroadener_ptr ) BIND(C,name="DopplerAndResolutionBroadener_getNumParams")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: DopplerAndResolutionBroadener_ptr;
+end function
subroutine f_DopplerAndResolutionBroadener_updateBroadenedOffset(DopplerAndResolutionBroadener_ptr, offSet ) BIND(C,name="DopplerAndResolutionBroadener_updateBroadenedOffset")
use,intrinsic :: ISO_C_BINDING
implicit none
@@ -205,6 +198,13 @@ subroutine f_DopplerAndResolutionBroadener_broaden(DopplerAndResolutionBroadener
implicit none
type(C_PTR), value :: DopplerAndResolutionBroadener_ptr;
end subroutine
+subroutine f_DopplerAndResolutionBroadener_transferUnbroadened(DopplerAndResolutionBroadener_ptr, ipos,iso ) BIND(C,name="DopplerAndResolutionBroadener_transferUnbroadened")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: DopplerAndResolutionBroadener_ptr;
+ integer(C_INT) :: ipos;
+ integer(C_INT) :: iso;
+end subroutine
subroutine f_DopplerAndResolutionBroadener_destroy(this) BIND(C,name="DopplerAndResolutionBroadener_destroy")
use,intrinsic :: ISO_C_BINDING
implicit none
diff --git a/sammy/src/convolution/interface/fortran/DopplerAndResolutionBroadener_M.f90 b/sammy/src/convolution/interface/fortran/DopplerAndResolutionBroadener_M.f90
index c49b5640f6e8d49b40e46caad109fee15e9f373f..d53ed0dbc79288de13c4e4611f0240490312fdac 100644
--- a/sammy/src/convolution/interface/fortran/DopplerAndResolutionBroadener_M.f90
+++ b/sammy/src/convolution/interface/fortran/DopplerAndResolutionBroadener_M.f90
@@ -2,7 +2,7 @@
!! This file has been dynamically generated by Class Interface Xml (CIX)
!! DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
!! If changes need to occur, modify the appropriate CIX xml file
-!! Date Generated: Fri Feb 11 16:55:04 EST 2022
+!! Date Generated: Tue Apr 19 09:05:33 EDT 2022
!! If any issues are experiences with this generated file that cannot be fixed
!! with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
!!/
@@ -15,8 +15,6 @@ type DopplerAndResolutionBroadener
type(C_PTR) :: instance_ptr=C_NULL_PTR
contains
procedure, pass(this) :: initialize => DopplerAndResolutionBroadener_initialize
- procedure, pass(this) :: getNumIso => DopplerAndResolutionBroadener_getNumIso
- procedure, pass(this) :: setNumIso => DopplerAndResolutionBroadener_setNumIso
procedure, pass(this) :: getNumPerEnergy => DopplerAndResolutionBroadener_getNumPerEnergy
procedure, pass(this) :: setNumPerEnergy => DopplerAndResolutionBroadener_setNumPerEnergy
procedure, pass(this) :: getIntegralStart => DopplerAndResolutionBroadener_getIntegralStart
@@ -41,11 +39,13 @@ type DopplerAndResolutionBroadener
procedure, pass(this) :: getWorkData => DopplerAndResolutionBroadener_getWorkData
procedure, pass(this) :: setWorkData => DopplerAndResolutionBroadener_setWorkData
procedure, pass(this) :: setXoefWeights => DopplerAndResolutionBroadener_setXoefWeights
- procedure, pass(this) :: setupBroadnener => DopplerAndResolutionBroadener_setupBroadnener
+ procedure, pass(this) :: setupBroadener => DopplerAndResolutionBroadener_setupBroadener
+ procedure, pass(this) :: getNumParams => DopplerAndResolutionBroadener_getNumParams
procedure, pass(this) :: updateBroadenedOffset => DopplerAndResolutionBroadener_updateBroadenedOffset
procedure, pass(this) :: setLength => DopplerAndResolutionBroadener_setLength
procedure, pass(this) :: getLength => DopplerAndResolutionBroadener_getLength
procedure, pass(this) :: broaden => DopplerAndResolutionBroadener_broaden
+ procedure, pass(this) :: transferUnbroadened => DopplerAndResolutionBroadener_transferUnbroadened
procedure, pass(this) :: destroy => DopplerAndResolutionBroadener_destroy
end type DopplerAndResolutionBroadener
contains
@@ -57,18 +57,6 @@ subroutine DopplerAndResolutionBroadener_initialize(this, hand, list, work)
class(GridDataList)::work
this%instance_ptr = f_DopplerAndResolutionBroadener_initialize( hand%instance_ptr,list%instance_ptr,work%instance_ptr)
end subroutine
-function DopplerAndResolutionBroadener_getNumIso(this) result(result2Return)
- implicit none
- class(DopplerAndResolutionBroadener)::this
- integer(C_INT):: result2Return
- result2Return=f_DopplerAndResolutionBroadener_getNumIso(this%instance_ptr)
-end function
-subroutine DopplerAndResolutionBroadener_setNumIso(this, iso)
- implicit none
- class(DopplerAndResolutionBroadener)::this
- integer(C_INT)::iso
- call f_DopplerAndResolutionBroadener_setNumIso(this%instance_ptr, iso)
-end subroutine
function DopplerAndResolutionBroadener_getNumPerEnergy(this) result(result2Return)
implicit none
class(DopplerAndResolutionBroadener)::this
@@ -233,14 +221,19 @@ subroutine DopplerAndResolutionBroadener_setXoefWeights(this, index)
integer(C_INT)::index
call f_DopplerAndResolutionBroadener_setXoefWeights(this%instance_ptr, index-1)
end subroutine
-subroutine DopplerAndResolutionBroadener_setupBroadnener(this, numcro, ktzero, moreBroadening)
+subroutine DopplerAndResolutionBroadener_setupBroadener(this, moreBroadening, num)
implicit none
class(DopplerAndResolutionBroadener)::this
- integer(C_INT)::numcro
- integer(C_INT)::ktzero
logical(C_BOOL)::moreBroadening
- call f_DopplerAndResolutionBroadener_setupBroadnener(this%instance_ptr, numcro,ktzero,moreBroadening)
+ integer(C_INT)::num
+ call f_DopplerAndResolutionBroadener_setupBroadener(this%instance_ptr, moreBroadening,num)
end subroutine
+function DopplerAndResolutionBroadener_getNumParams(this) result(result2Return)
+ implicit none
+ class(DopplerAndResolutionBroadener)::this
+ integer(C_INT):: result2Return
+ result2Return=f_DopplerAndResolutionBroadener_getNumParams(this%instance_ptr)
+end function
subroutine DopplerAndResolutionBroadener_updateBroadenedOffset(this, offSet)
implicit none
class(DopplerAndResolutionBroadener)::this
@@ -264,6 +257,13 @@ subroutine DopplerAndResolutionBroadener_broaden(this)
class(DopplerAndResolutionBroadener)::this
call f_DopplerAndResolutionBroadener_broaden(this%instance_ptr)
end subroutine
+subroutine DopplerAndResolutionBroadener_transferUnbroadened(this, ipos, iso)
+ implicit none
+ class(DopplerAndResolutionBroadener)::this
+ integer(C_INT)::ipos
+ integer(C_INT)::iso
+ call f_DopplerAndResolutionBroadener_transferUnbroadened(this%instance_ptr, ipos-1,iso-1)
+end subroutine
subroutine DopplerAndResolutionBroadener_destroy(this)
implicit none
class(DopplerAndResolutionBroadener) :: this
diff --git a/sammy/src/convolution/interface/fortran/DopplerBroadening_I.f90 b/sammy/src/convolution/interface/fortran/DopplerBroadening_I.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1860946f0e3a4473e38e32dffeca2df623bae2f9
--- /dev/null
+++ b/sammy/src/convolution/interface/fortran/DopplerBroadening_I.f90
@@ -0,0 +1,53 @@
+!>
+!! This file has been dynamically generated by Class Interface Xml (CIX)
+!! DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
+!! If changes need to occur, modify the appropriate CIX xml file
+!! Date Generated: Tue Apr 19 10:21:53 EDT 2022
+!! If any issues are experiences with this generated file that cannot be fixed
+!! with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
+!!/
+module DopplerBroadening_I
+use, intrinsic :: ISO_C_BINDING
+interface
+type(C_PTR) function f_DopplerBroadening_initialize( hand,list,work )BIND(C,name="DopplerBroadening_initialize")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR) :: DopplerBroadening_ptr;
+ type(C_PTR), value :: hand;
+ type(C_PTR), value :: list;
+ type(C_PTR), value :: work;
+end function
+real(C_DOUBLE) function f_DopplerBroadening_getTemperature(DopplerBroadening_ptr ) BIND(C,name="DopplerBroadening_getTemperature")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: DopplerBroadening_ptr;
+end function
+subroutine f_DopplerBroadening_setTemperature(DopplerBroadening_ptr, t ) BIND(C,name="DopplerBroadening_setTemperature")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: DopplerBroadening_ptr;
+ real(C_DOUBLE) :: t;
+end subroutine
+real(C_DOUBLE) function f_DopplerBroadening_getBrdLim(DopplerBroadening_ptr ) BIND(C,name="DopplerBroadening_getBrdLim")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: DopplerBroadening_ptr;
+end function
+subroutine f_DopplerBroadening_setBrdLim(DopplerBroadening_ptr, b ) BIND(C,name="DopplerBroadening_setBrdLim")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: DopplerBroadening_ptr;
+ real(C_DOUBLE) :: b;
+end subroutine
+subroutine f_DopplerBroadening_broaden(DopplerBroadening_ptr ) BIND(C,name="DopplerBroadening_broaden")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: DopplerBroadening_ptr;
+end subroutine
+subroutine f_DopplerBroadening_destroy(this) BIND(C,name="DopplerBroadening_destroy")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: this;
+end subroutine
+end interface
+end module DopplerBroadening_I
diff --git a/sammy/src/convolution/interface/fortran/DopplerBroadening_M.f90 b/sammy/src/convolution/interface/fortran/DopplerBroadening_M.f90
new file mode 100644
index 0000000000000000000000000000000000000000..669e667ae770b759c5927e4af9db4ddc72967473
--- /dev/null
+++ b/sammy/src/convolution/interface/fortran/DopplerBroadening_M.f90
@@ -0,0 +1,69 @@
+!>
+!! This file has been dynamically generated by Class Interface Xml (CIX)
+!! DO NOT MODIFY THIS FILE -- CHANGES WILL BE OVERWRITTEN UPON REGENERATION
+!! If changes need to occur, modify the appropriate CIX xml file
+!! Date Generated: Tue Apr 19 10:21:53 EDT 2022
+!! If any issues are experiences with this generated file that cannot be fixed
+!! with adjustment of the CIX xml file, please contact Robert A. Lefebvre, raq@ornl.gov
+!!/
+module DopplerBroadening_M
+use, intrinsic :: ISO_C_BINDING
+use DopplerBroadening_I
+use DopplerAndResolutionBroadener_M
+use DerivativeHandler_M
+use GridData_M
+type , extends(DopplerAndResolutionBroadener) :: DopplerBroadening
+ contains
+ procedure, pass(this) :: initialize => DopplerBroadening_initialize
+ procedure, pass(this) :: getTemperature => DopplerBroadening_getTemperature
+ procedure, pass(this) :: setTemperature => DopplerBroadening_setTemperature
+ procedure, pass(this) :: getBrdLim => DopplerBroadening_getBrdLim
+ procedure, pass(this) :: setBrdLim => DopplerBroadening_setBrdLim
+ procedure, pass(this) :: broaden => DopplerBroadening_broaden
+ procedure, pass(this) :: destroy => DopplerBroadening_destroy
+end type DopplerBroadening
+contains
+subroutine DopplerBroadening_initialize(this, hand, list, work)
+ implicit none
+ class(DopplerBroadening) :: this
+ class(DerivativeHandler)::hand
+ class(GridDataList)::list
+ class(GridDataList)::work
+ this%instance_ptr = f_DopplerBroadening_initialize( hand%instance_ptr,list%instance_ptr,work%instance_ptr)
+end subroutine
+function DopplerBroadening_getTemperature(this) result(result2Return)
+ implicit none
+ class(DopplerBroadening)::this
+ real(C_DOUBLE):: result2Return
+ result2Return=f_DopplerBroadening_getTemperature(this%instance_ptr)
+end function
+subroutine DopplerBroadening_setTemperature(this, t)
+ implicit none
+ class(DopplerBroadening)::this
+ real(C_DOUBLE)::t
+ call f_DopplerBroadening_setTemperature(this%instance_ptr, t)
+end subroutine
+function DopplerBroadening_getBrdLim(this) result(result2Return)
+ implicit none
+ class(DopplerBroadening)::this
+ real(C_DOUBLE):: result2Return
+ result2Return=f_DopplerBroadening_getBrdLim(this%instance_ptr)
+end function
+subroutine DopplerBroadening_setBrdLim(this, b)
+ implicit none
+ class(DopplerBroadening)::this
+ real(C_DOUBLE)::b
+ call f_DopplerBroadening_setBrdLim(this%instance_ptr, b)
+end subroutine
+subroutine DopplerBroadening_broaden(this)
+ implicit none
+ class(DopplerBroadening)::this
+ call f_DopplerBroadening_broaden(this%instance_ptr)
+end subroutine
+subroutine DopplerBroadening_destroy(this)
+ implicit none
+ class(DopplerBroadening) :: this
+ call f_DopplerBroadening_destroy(this%instance_ptr)
+ this%instance_ptr = C_NULL_PTR
+end subroutine
+end module DopplerBroadening_M
diff --git a/sammy/src/cro/mcro5.f90 b/sammy/src/cro/mcro5.f90
index 3ed9e6ff64e1ac9bf40348705ec5e7657a87346d..57e4186c6b65086fd5267375560e459aa0740e53 100644
--- a/sammy/src/cro/mcro5.f90
+++ b/sammy/src/cro/mcro5.f90
@@ -5,6 +5,9 @@ contains
use DopplerAndResolutionBroadener_M
use SumIsoAndConvertToTrans_M
use array_sizes_common_m, only : calcData, calcDataSelf
+ use normalize_and_background, only : Nnneta
+ use broad_common_m, only : dopplerInfo
+ use exploc_common_m, only : I_Iflmsc
use ifwrit_m, only : Kcros
use fixedi_m, only : numUsedPar
use, intrinsic :: ISO_C_BINDING
@@ -14,10 +17,12 @@ contains
class(DopplerAndResolutionBroadener)::broadener
type(SumIsoAndConvertToTrans)::summer
-
call summer%initialize(broadener, calcDataSelf, Kcros.eq.8)
summer%Need_Isotopes=needIso
summer%Another_Process_Will_Happen=moreBroadening
+ if (.not.moreBroadening.and.Kcros.EQ.6.and.dopplerInfo%bType.EQ.0) then
+ CALL Nnneta (I_Iflmsc, calcData)
+ end if
call summer%sumAndConvert(numUsedPar)
call summer%destroy
end subroutine sumAndConvertAfterBroadening
@@ -42,6 +47,27 @@ contains
call summer%normalize(numUsedPar)
call summer%destroy
end subroutine normAndBack
+
+ subroutine normAfterAng(moreBroadening, needIsos, broadener)
+ use DerivativeHandler_M
+ use DopplerAndResolutionBroadener_M
+ use SumIsoAndConvertToTrans_M
+ use array_sizes_common_m, only : calcData, calcDataSelf
+ use ifwrit_m, only : Kcros
+ use fixedi_m, only : numUsedPar
+ use, intrinsic :: ISO_C_BINDING
+ implicit none
+ logical(C_BOOL)::moreBroadening, needIsos
+ class(DopplerAndResolutionBroadener)::broadener
+
+ type(SumIsoAndConvertToTrans)::summer
+
+ call summer%initialize(broadener, calcDataSelf, Kcros.eq.8)
+ summer%Need_Isotopes= needIsos
+ summer%Another_Process_Will_Happen=moreBroadening
+ call summer%angPostProcessing(numUsedPar)
+ call summer%destroy
+ end subroutine normAfterAng
end module sumAndConvertAfterBroadening_m
!
@@ -58,25 +84,19 @@ end module sumAndConvertAfterBroadening_m
use cbro_common_m
use lbro_common_m
use EndfData_common_m, only : covData, radFitFlags
+ use broad_common_m, only : dopplerInfo
IMPLICIT none
integer::icr, Ntotal
- logical::haveDerivs
-!
-! deltdp => delttt from fixedr_m (Ff(23) assigned to delt (from common block b39
-! dpdelv => delvvv from fixedr_m (Ff(25) assigned to delv (from common block b39
-! dpdelt => Gammmm from fixedr_m (Ff(27) assigned to Dddelt (from common block b39
-!
-! EQUIVALENCE (Deltdp,Delttt), (Dpdelv,Delvvv), (Dpdelt,Gammmm)
-!
- Jwwwww = 1
+ logical::haveDerivs, doAngle
+
Jcros = Kcros
Icr = Kcros
+ doAngle = Kcros.EQ.7 .OR. Kcros.eq.11
Jtrans = Ktrans
!
Thck = Thick
Tempe = Temp
Delv = Delvvv ! Dpdelv
- Delt = Delttt ! Deltdp
Dddelt = Gammmm ! Dpdelt
Odffff = Odfmul
!
@@ -102,13 +122,13 @@ end module sumAndConvertAfterBroadening_m
! *** here there is no broadening and no angular distributions and
! *** no multiple-scattering, so all affected theory parameters
! *** occur in output files
- IF (.Not.Ydoppr .AND. .Not.Yresol .AND. .Not.Yangle .AND. &
+ IF (.Not.Ydoppr .AND. .Not.Yresol .AND. .Not.doAngle .AND. &
.Not.Yssmsc) Ngbout = Ntotal
!
! *** if there is broadening (or ang dis or mul sct), figure ngbout =
! *** # of par in output GB file. Note that this number may be
! *** smaller than in the above case (where all are needed).
- IF (Ydoppr .OR. Yresol .OR. Yangle .OR. Yssmsc .OR. Ntgrlq.EQ.1) &
+ IF (Ydoppr .OR. Yresol .OR. doAngle .OR. Yssmsc .OR. Ntgrlq.EQ.1) &
Ngbout = Nfpres + Nvpext + &
radFitFlags%getNumPupedVaried(covData) + Nvpiso + Nvpdet + &
Nvpbrd + Nvpmsc + Nvppmc
@@ -117,7 +137,6 @@ end module sumAndConvertAfterBroadening_m
Filein = 'SAM51.DAT'
Filout = 'SAM54.DAT'
!
- Jjjdop = Kkkdop
RETURN
END
@@ -130,40 +149,49 @@ end module sumAndConvertAfterBroadening_m
use abro_common_m
use cbro_common_m
use lbro_common_m
- use dop_m
use ssm_m
use orr_m
use rpi_m
use rsl_m
- use dop_m
use ssm_m
use rsl_m
use rpi_m
use orr_m
use rsl7_m
use broad_common_m
- use FreeGasDopplerBroadening_M
use DopplerAndResolutionBroadener_M
use GridData_M
use EndfData_common_m, only : expData
use array_sizes_common_m, only : calcData, calcDataSelf
use sumAndConvertAfterBroadening_m
use, intrinsic :: ISO_C_BINDING
+
IMPLICIT none
logical::debugOut
- logical(C_BOOL)::moreBroadening
+ logical(C_BOOL)::moreBroadening, needIsos
+ type(FreeGasDopplerBroadening)::broadener
+ integer::Jwwwww, Jjjdop, btypeSave
- !TODO: break up this function that is now too long
+ if (Kresol.EQ.1) Kplotu = 0
debugOut = debug.or.Kplotu.ne.0
+ ! jjjdop = 1 is for special print-out in
+ ! Samint_0 right after Leal Hwang broadening
+ ! Samint_0 will reset to 0, for normal
+ ! intermediate printout
+ Jjjdop = dopplerInfo%bType
+
+ ! Jwwwww sets the title for intermediate or final output
+ Jwwwww = 1
+ IF (Ksindi.GT.0 .and. Kcros.EQ.8) jwwwww = 5
! do maxwellian if desired
if (Maxwel.eq.1) then
! if we want intermediate output, do so
- if (debugOut) call Samint_0(debugOut, Yssmsc)
- if (Ksolve.ne.2) then
+ if (debugOut) call Samint_0(debugOut, Yssmsc, Jwwwww, Jjjdop)
+ if (Ksolve.ne.2) then
call Samsqu_0
- end if
+ end if
call Sammxw_0
call Samend_0
return
@@ -176,7 +204,7 @@ end module sumAndConvertAfterBroadening_m
call calcDataSelf%sumOverIsotopes(numUsedPar+1)
! if we want intermediate output, do so
- if (debugOut) call Samint_0(debugOut, Yssmsc)
+ if (debugOut) call Samint_0(debugOut, Yssmsc, Jwwwww, Jjjdop)
! if fit: set's fitoption and 'genfit'
call Samsqu_0
@@ -184,14 +212,25 @@ end module sumAndConvertAfterBroadening_m
end if
! any angles to calculate
- if (Yangle) then
+ IF (Kcros.EQ.7 .OR. Kcros.EQ.11) then
! if we want intermediate output, do so
- if (debugOut) call Samint_0(debugOut, Yssmsc)
+ if (debugOut) call Samint_0(debugOut, Yssmsc, Jwwwww, Jjjdop)
call Samang_0
+ Jwwwww = 9
+
+ moreBroadening = Ydoppr.or.Yresol.or.Yssmsc
+ needIsos = Ydoppr.or.Yssmsc
+ if (.not.workArrayInit) then
+ call workArray%initialize()
+ workArrayInit = .true.
+ end if
+ call broadener%initialize(calcData, expData, workArray)
+ call normAfterAng(moreBroadening, needIsos, broadener)
+ call broadener%destroy()
end if
! any doppler broadening
- if (Ydoppr) then
+ if (Ydoppr) then
moreBroadening = Yresol.OR.Yssmsc
if (.not.workArrayInit) then
call workArray%initialize()
@@ -199,73 +238,58 @@ end module sumAndConvertAfterBroadening_m
end if
! if we want intermediate output, do so
- if (debugOut) call Samint_0(debugOut, Yssmsc)
+ if (debugOut) call Samint_0(debugOut, Yssmsc, Jwwwww, Jjjdop)
! switch handler data grid
call Set_Kws
- IF (Kkkdop.EQ.0) then
- if (.not.associated(dopplerOption%highEnergyFreeGas)) then
- allocate(dopplerOption%highEnergyFreeGas)
- dopplerOption%broadener => dopplerOption%highEnergyFreeGas
- call dopplerOption%broadener%initialize(calcData, expData, workArray)
- end if
- else IF (Kkkdop.EQ.1) then
- if (.not.associated(dopplerOption%lealHwang)) then
- allocate(dopplerOption%lealHwang)
- dopplerOption%broadener => dopplerOption%lealHwang
- call dopplerOption%broadener%initialize(calcData, expData, workArray)
- end if
- else IF ( Kkkdop.EQ.2) then
- if (.not.associated(dopplerOption%freeGas)) then
- allocate(dopplerOption%freeGas)
- dopplerOption%broadener => dopplerOption%freeGas
- call dopplerOption%broadener%initialize(calcData, expData, workArray)
- end if
- else IF ( Kkkdop.EQ.3) then
- if (.not.associated(dopplerOption%crystalLattice)) then
- allocate(dopplerOption%crystalLattice)
- dopplerOption%broadener => dopplerOption%crystalLattice
- call dopplerOption%broadener%initialize(calcData, expData, workArray)
- end if
- else
- STOP 'Invalid doppler broadening option in cro/mcro5.f'
- end if
- call dopplerOption%broadener%setupBroadnener(numcro, ktzero, moreBroadening)
-
- IF (Kkkdop.EQ.0) then
- call Samdbd_0
- else IF (Kkkdop.EQ.1) then
- call Samdop_0
- else IF ( Kkkdop.EQ.2) then
- call Samfgm_0(dopplerOption%freeGas)
- else IF ( Kkkdop.EQ.3) then
- call Samclm_0
- end if
- call sumAndConvertAfterBroadening(moreBroadening, Yssmsc, dopplerOption%broadener)
+ dopplerInfo%broadener%debugOutput = .false.
+ if (Kdebug.ne.0) dopplerInfo%broadener%debugOutput = .true.
+
+ call dopplerInfo%broadener%setupBroadener(moreBroadening, numUsedPar)
+ if (Kcros.EQ.8) THEN
+ call dopplerInfo%broadener%addSelfData(Ksindi.le.0.and.Ksitmp.GT.0, Lllmax+1)
+ END IF
+ call dopplerInfo%setDopple()
+ dopplerInfo%broadener%Sitemp = Sitemp
+ CALL Initix
+ call dopplerInfo%broadener%broaden()
+ CALL Write_Commons_Many
+
+ IF (dopplerInfo%bType.EQ.1) Jjjdop = 1
+
+ call sumAndConvertAfterBroadening(moreBroadening, Yssmsc, dopplerInfo%broadener)
+
+ Jwwwww = 2
+ IF (Kcros.EQ.8) Jwwwww = 6
+ IF (Kaverg.NE.2 .AND. Kaverg.NE.3) Kplotu = 0
end if
+
! integral experiments
- if (Ntgrlq.EQ.1) then
- ! if we want intermediate output, do so
- if (debugOut) call Samint_0(debugOut, Yssmsc)
+ if (Ntgrlq.EQ.1) then
if (Ksolve.NE.2) then
+ ! if we want intermediate output, do so
+ if (debugOut) call Samint_0(debugOut, Yssmsc, Jwwwww, Jjjdop)
call Samsqu_0
else if (Ksolve.EQ.2) then
call Samntg_0
- end if
+ Kplotu = 0
+ end if
return ! can't have multiple scattering or resolution broadening
end if
! multiple scattering
IF (Yssmsc) THEN
! if we want intermediate output, do so
- if (debugOut) call Samint_0(debugOut, Yssmsc)
+ if (debugOut) call Samint_0(debugOut, Yssmsc, Jwwwww, Jjjdop)
+ Jjjdop = 0
IF (Kvers7.EQ.0) then
call Samssm_0
else IF (Kvers7.EQ.1) then
call Sammso_0
end if
+ Jwwwww = 8
END IF
! sum over isotopes
@@ -275,7 +299,9 @@ end module sumAndConvertAfterBroadening_m
! resolution brodening
IF (Yresol) THEN
! if we want intermediate output, do so
- if (debugOut) call Samint_0(debugOut, Yssmsc)
+ if (debugOut) call Samint_0(debugOut, Yssmsc, Jwwwww, Jjjdop)
+ Jjjdop = 0
+ Kplotu = 0
! allowed is:
!1. one occurrence of the Gaussian plus exponential function; and/or
@@ -372,7 +398,7 @@ end module sumAndConvertAfterBroadening_m
! switch handler data grid
call Set_Kws
- call resolutionOption%resBroad1%setupBroadnener(numcro, ktzero, moreBroadening)
+ call resolutionOption%resBroad1%setupBroadener(moreBroadening, numUsedPar)
if (Nudwhi.ne.0) then
call samudr_0
@@ -386,6 +412,7 @@ end module sumAndConvertAfterBroadening_m
call Samrsl_0
end if
call normAndBack(moreBroadening, resolutionOption%resBroad1)
+ Jwwwww = 4
else ! two resolution functions
! dex is first
@@ -393,7 +420,7 @@ end module sumAndConvertAfterBroadening_m
! switch handler data grid
call Set_Kws
- call resolutionOption%resBroad1%setupBroadnener(numcro, ktzero, moreBroadening)
+ call resolutionOption%resBroad1%setupBroadener(moreBroadening, numUsedPar)
if (Kkkdex.ne.0) then
call samdex_0
@@ -402,15 +429,24 @@ end module sumAndConvertAfterBroadening_m
end if
call normAndBack(moreBroadening, resolutionOption%resBroad1)
+ ! if Leal Hwang we use a different auxillary grid
+ ! after first resolution function this is the
+ ! normal grid, so signal that to the
+ ! second resolution function
+ btypeSave = dopplerInfo%bType
+ dopplerInfo%bType = 2
+
+ Jwwwww = 4
+
! if we want output after first resolution function
- if (debugOut) call Samint_0(debugOut, Yssmsc)
+ if (debugOut) call Samint_0(debugOut, Yssmsc, Jwwwww, Jjjdop)
moreBroadening = .false.
! switch handler data grid
call Set_Kws
- call resolutionOption%resBroad2%setupBroadnener(numcro, ktzero, moreBroadening)
+ call resolutionOption%resBroad2%setupBroadener(moreBroadening, numUsedPar)
if (Nudwhi.ne.0) then
@@ -423,12 +459,20 @@ end module sumAndConvertAfterBroadening_m
call Samrsl_0
end if
+ ! ensure that doppler broadening is reset to the user desired type
+ dopplerInfo%bType = btypeSave
+
+ Jwwwww = 4
+
call normAndBack(moreBroadening, resolutionOption%resBroad2)
end if
END IF
+
! final output
- call Samint_0 (.false., Yssmsc) ! which will set the correct values for where to next
+ ! TODO: check whether we should set Jjjdop to 0 to make sure we print
+ ! final output. Tr058 will fail if that is done
+ call Samint_0 (.false., Yssmsc, Jwwwww, Jjjdop) ! which will set the correct values for where to next
end subroutine
diff --git a/sammy/src/cro/mnrm1.f90 b/sammy/src/cro/mnrm1.f90
index ef2d17e2e1f686da4998222227eaaf69cab58905..3509409454926a720982e774eb8ef3d52a8bd09b 100644
--- a/sammy/src/cro/mnrm1.f90
+++ b/sammy/src/cro/mnrm1.f90
@@ -359,7 +359,7 @@ contains
!
! --------------------------------------------------------------
!
- SUBROUTINE Nnneta (Iflmsc, deriv, irow, Niso)
+ SUBROUTINE Nnneta (Iflmsc, deriv)
!
! *** Purpose -- Generate derivative with respect to NU
!
@@ -369,7 +369,7 @@ contains
use DerivativeHandler_M
IMPLICIT None
!
- integer::irow, Niso
+ integer::irow
integer::Iflmsc(*)
real(kind=8)::val
type(DerivativeHandler)::deriv
@@ -380,10 +380,12 @@ contains
IF (Kjetan.LE.0) RETURN
IF (Iflmsc(Kjetan).EQ.0) RETURN
N = Iflmsc(Kjetan)
- DO Iso=1,Niso
- val = deriv%getDataNs(irow, 1, 0, iso)
- val = val/Etanuu
- call deriv%addDataNs(irow, 1, N, iso, val)
+ Do irow = 1, deriv%getLength()
+ DO Iso=1,deriv%getUsedIsotopes()
+ val = deriv%getDataNs(irow, 1, 0, iso)
+ val = val/Etanuu
+ call deriv%addDataNs(irow, 1, N, iso, val)
+ end do
end do
RETURN
END
diff --git a/sammy/src/dat/mdat0.f90 b/sammy/src/dat/mdat0.f90
index 31bf3d2c9c63bea00c184d247fb3881b0b74f3c6..58b020b9ab6ae31abf47ca7f6dfc7518029cf959 100644
--- a/sammy/src/dat/mdat0.f90
+++ b/sammy/src/dat/mdat0.f90
@@ -5,8 +5,8 @@ contains
!
SUBROUTINE Samdat_0(secondPass)
!
- use fixedi_m, only : Krefit, Medrpi, Mmmrpi, Ngtvv, Nres, Nrext, Ntotc, Nudtim, Numcro, Numdtp, Numorr
- use ifwrit_m, only : Iptdop, Iptwid, Kartgd, Kdata, Kdatv, Kdebug, Kendbd, Keveng, Kidcxx, Kkkdop, &
+ use fixedi_m, only : Krefit, Medrpi, Mmmrpi, Ngtvv, Nres, Nrext, Ntotc, Nudtim, Numdtp, Numorr
+ use ifwrit_m, only : Iptdop, Iptwid, Kartgd, Kdata, Kdatv, Kdebug, Kendbd, Keveng, Kidcxx, &
Kphase, Kresol, Ktzero, Ndat, Ndatb, kkclqx
use exploc_common_m
use oopsch_common_m, only : If_Odf, Nowwww, Segmen
@@ -23,6 +23,7 @@ contains
use mdat7_M
use xxx4
use rst_m
+ use broad_common_m, only : dopplerInfo
IMPLICIT none
real(kind=8),allocatable,dimension(:)::A_Iedrpi, A_Ixxrpi
real(kind=8),allocatable,dimension(:)::A_J1, A_J2
@@ -52,13 +53,19 @@ contains
integer::ipos, j, Kdatbm, Krext, Maxd, Maxe, Mind
integer::minDataIndex, Mine, Mnp, Mnr, N, Ndatbm
integer,save::Ndatt
- integer::Nmax, Nn, Nnndat, Np, Nr, Nwd
+ integer::Nmax, Nn, Nnndat, Np, Nr, Nwd, numPerEner
real(kind=8),save::oldEmin,oldEmax
!
Segmen(1) = 'D'
Segmen(2) = 'A'
Segmen(3) = 'T'
Nowwww = 0
+ if (expData%getLength().eq.0) then
+ numPerEner = 1
+ else
+ call expData%getGrid(grid, 1)
+ numPerEner = grid%getNumPerEnergy()
+ end if
!
CALL Initil
hasAuxGrid = .true.
@@ -116,7 +123,7 @@ contains
!
!
! *** GUESSTIMATE ARRAY Sizes
- CALL Estdat (Ndatt, Ndatbm, Nnndat, Nr, Np)
+ CALL Estdat (Ndatt, Ndatbm, Nnndat, Nr, Np, numPerEner)
!
!
! ### one ###
@@ -128,7 +135,7 @@ contains
! ### two ###
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
call allocate_real_data(A_Id, Ndatb)
- call allocate_real_data(A_Idata, Ndat*Numcro)
+ call allocate_real_data(A_Idata, Ndat*numPerEner)
call allocate_real_data(A_Ivarda, Ndatt)
call allocate_integer_data(I_Iiflag, Ndat)
Igtild = 1
@@ -155,12 +162,12 @@ contains
indat = 1
minDataIndex = 2
if(Ktzero.NE.0) minDataIndex = minDataIndex + 1
- if(Numcro.gt.1) minDataIndex = minDataIndex + 1
- call grid%setDataIndex(minDataIndex)
- maxRow = Ndat * Numcro
+ if(numPerEner.gt.1) minDataIndex = minDataIndex + 1
+ call grid%setDataIndex(minDataIndex)
+ maxRow = Ndat * numPerEner
maxCol = 2
- if (Numcro.gt.1) maxCol = 3
- if (Ktzero.NE.0) maxCol = maxCol + 1
+ if (numPerEner.gt.1) maxCol = 3
+ if (Ktzero.NE.0) maxCol = maxCol + 1
call grid%reserve(maxRow, maxCol)
do i = 1, Ndat
@@ -171,8 +178,8 @@ contains
end if
! if not angle data
- if ( Numcro.gt.1) then
- do j = 1, Numcro
+ if ( numPerEner.gt.1) then
+ do j = 1, numPerEner
call grid%addData(indat, 1, ee)
call grid%addData(indat, 2, A_Iangle(j))
if (Ktzero.NE.0) then
@@ -210,7 +217,7 @@ contains
end do
end if
- call read_implict_data_cov(expData, numcro)
+ call read_implict_data_cov(expData, numPerEner)
if (.not.(Kartgd.EQ.1 .OR. Kkclqx.NE.0)) then ! only if not an articial grid - in which case read data is only called once
! articial grid is not included here because
! we mulitply and and divide A_Ienerg by a factor before and after saving to ODF file
@@ -238,7 +245,7 @@ contains
I_Inud_E , I_Inud_T , A_Iude , A_Iudr , A_Iudt, A_J1, A_J2, Krext, I_Iflrpi)
! preserve output
- CALL Estdat (Ndatt, Ndatbm, Nnndat, Nr, Np)
+ CALL Estdat (Ndatt, Ndatbm, Nnndat, Nr, Np, numPerEner)
WRITE (21,99998) Emin, Emax, Ndat
99998 FORMAT (/' Energy range of data is from ', 1PE11.5, ' to ', &
E11.5, ' eV.', /, &
@@ -255,7 +262,7 @@ contains
! *** Write data onto ascii files
IF (Kdata.NE.0) THEN
CALL Outdat (A_Iptild , Ndat)
- call reallocate_real_data(A_Id, Ndat*Numcro)
+ call reallocate_real_data(A_Id, Ndat*numPerEner)
CALL Outv (A_Id , I_Iiflag ) ! temporary arrays used in the subroutine
END IF
END IF
@@ -325,7 +332,7 @@ contains
! *** (Kdatbm is the maximum Ndatb could ever be)
!
!
- IF (Kkkdop.NE.1) THEN
+ IF (dopplerInfo%bType.NE.1) THEN
!
IF (Numorr.NE.0) Kendbd = 2
! *** IF (use OR Resolution function) THEN (use grid evenly spaced
@@ -367,7 +374,7 @@ contains
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
!
!
- ELSE IF (Kkkdop.EQ.1) THEN
+ ELSE IF (dopplerInfo%bType.EQ.1) THEN
!
! *** Here for Leal-Hwang version of Doppler broadening and
! *** choice of auxiliary grid
@@ -408,18 +415,19 @@ contains
else
call auxGrid%initialize()
call expData%addGrid(auxGrid)
+ call auxGrid%setNumPerEnergy(numPerEner)
end if
- maxRow = Ndatb * Numcro
+ maxRow = Ndatb * numPerEner
maxCol = 1
call auxGrid%reserve(maxRow, maxCol)
ipos = 1
do i = 1, Ndatb
- do ii = 1, numcro
+ do ii = 1, numPerEner
call auxGrid%addData(ipos, 1, A_Ie(i))
ipos = ipos + 1
end do
end do
- call auxGrid%setDataIndex(0)
+ call auxGrid%setDataIndex(2)
end if
!
@@ -451,19 +459,19 @@ contains
subroutine fill_initial_aux(ener, nn, Emind, Emaxd)
use EndfData_common_m, only : expData, auxEndData
- use fixedi_m, only : numcro
use GridData_M
implicit none
real(kind=8)::ener(:)
real(kind=8)::Emind, Emaxd, val
- integer::nn
+ integer::nn, numPerEner
integer::ii, i, ndat
real(kind=8)::ee
type(GridData)::grid
call expData%getGrid(grid, 1)
- ndat = grid%getLength()/numcro
+ numPerEner = grid%getNumPerEnergy()
+ ndat = grid%getLength()/numPerEner
nn = 0
@@ -489,7 +497,7 @@ contains
! add experimental data
do i = 1, ndat
- ee = grid%getData((i-1)*numcro + 1, 1)
+ ee = grid%getData((i-1)*numPerEner + 1, 1)
nn = nn + 1
ener(nn) = ee
end do
@@ -509,14 +517,15 @@ contains
!
! ______________________________________________________________
!
- SUBROUTINE Estdat (Ndatt, Ndatbm, Nnndat, Nr, Np)
+ SUBROUTINE Estdat (Ndatt, Ndatbm, Nnndat, Nr, Np, numPerEner)
!
use oops_common_m, only : Msize
- use fixedi_m, only : Krefit, Nres, Ntotc, numcro, Numdtp
- use ifwrit_m, only : Iptdop, Iptwid, Jjjdop, Kartgd, Kdatv, Kkkdop, Ktzero, Ndat, Ndatb
+ use fixedi_m, only : Krefit, Nres, Ntotc, Numdtp
+ use ifwrit_m, only : Iptdop, Iptwid, Kartgd, Kdatv, Ktzero, Ndat, Ndatb
use fixedr_m
+ use broad_common_m, only : dopplerInfo
IMPLICIT none
- integer::Ndatt, Ndatbm, Nnndat, Nr, Np
+ integer::Ndatt, Ndatbm, Nnndat, Nr, Np, numPerEner
integer::I,II, K, K1, K1x, K2, K3, K4, K5, K6
integer::Mnp, Mnr, N, N1, N2, Ne, Nnn, Idimen
external Idimen
@@ -527,7 +536,7 @@ contains
IF (Ktzero.NE.0) K1 = K1 + Ndat
!
! ### two ###
- Nnndat = Ndat*Numcro
+ Nnndat = Ndat*numPerEner
IF (Kdatv.NE.0) THEN
Ndatt = (Nnndat*(Nnndat+1))/2
ELSE
@@ -535,7 +544,7 @@ contains
END IF
N = Numdtp*Ndat
IF (N.EQ.0) N = 1
- K2 = Ndatb + Ndat*Numcro + Ndatt + Ndat + N
+ K2 = Ndatb + Ndat*numPerEner + Ndatt + Ndat + N
!
! ### three ###
K3 = 8*Ntotc
@@ -548,7 +557,7 @@ contains
!
I = Idimen (1, 1, '1, 1')
II = I + K1 + K2
- IF (Kkkdop.NE.1) THEN
+ IF (dopplerInfo%bType.NE.1) THEN
! --- from ### five ###
N = Nres
IF (Nres.EQ.0) N = 1
@@ -593,7 +602,6 @@ contains
END IF
! ### four ###
K4 = Ndatbm
- Jjjdop = 1
!
END IF
I = Idimen (I, -1, 'I, -1')
diff --git a/sammy/src/dat/mdat1.f90 b/sammy/src/dat/mdat1.f90
index 305546d5fbbf52e32a19346f11571b5ff39bb879..b72f1e5a4427cc2204095582ea610eaf058cfbc5 100644
--- a/sammy/src/dat/mdat1.f90
+++ b/sammy/src/dat/mdat1.f90
@@ -31,6 +31,7 @@ contains
use rpi2_m
use rpi3_m
use orr3_m
+ use broad_common_m, only : dopplerInfo
IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
DIMENSION Bcf(*), Cf2(*), Dopwid(*), &
@@ -164,12 +165,9 @@ contains
! -----------------------------------------
!
! *** angular dispersion
- Yangle = .FALSE.
Emins = Eminr
Emaxs = Emaxr
- IF (Kcros.EQ.7) Yangle = .TRUE.
IF (Kssmsc.GT.0) THEN
- Yangle = .TRUE.
! *** Mass of projectile, default value
Emins = Eminr* ((Aaawww-A_Mass_Small)/(Aaawww+A_Mass_Small))**2
IF (Kssdbl.GT.0) Emins = Eminr * &
@@ -186,7 +184,7 @@ contains
Emaxd = Emaxs
IF (Dopple.GT.Zero) THEN
Ydoppr = .TRUE.
- IF (Kkkdop.EQ.0 .OR. Kkkdop.EQ.1) THEN
+ IF (dopplerInfo%bType.EQ.0 .OR. dopplerInfo%bType.EQ.1) THEN
! *** Here for high-Energy Gaussian approximation to Doppler brdng
! *** Or for Leal-Hwang Doppler broadening
IF (Nolowb.EQ.0) Emind = Emind - Two*Brdlim*Dopple*dSQRT(Emind)
@@ -194,12 +192,12 @@ contains
IF (Maxwel.EQ.1) THEN
Emind = Emins/10.0d0
ELSE
- IF (Kkkdop.NE.1) STOP '[STOP in Limits in mdat1.f]'
+ IF (dopplerInfo%bType.NE.1) STOP '[STOP in Limits in mdat1.f]'
END IF
ELSE
END IF
Emaxd = Emaxd + Two*Brdlim*Dopple*dSQRT(Emaxd)
- ELSE IF (Kkkdop.EQ.2 .OR. Kkkdop.EQ.3) THEN
+ ELSE IF (dopplerInfo%bType.EQ.2 .OR. dopplerInfo%bType.EQ.3) THEN
! *** here for free gas Model of Doppler broadening
! *** Also (but may change this) for crystal-lattice Doppler brdng
IF (Emins.LE.Zero) THEN
@@ -207,7 +205,7 @@ contains
ELSE
V = dSQRT(Emins)
END IF
- IF (Kkkdop.EQ.2) THEN
+ IF (dopplerInfo%bType.EQ.2) THEN
V = V - Brdlim*1.001d0*Dopple
ELSE
! temporary, eventually do this more logically
@@ -221,7 +219,7 @@ contains
END IF
END IF
V = dSQRT(Emaxd)
- IF (Kkkdop.EQ.2) THEN
+ IF (dopplerInfo%bType.EQ.2) THEN
V = V + Brdlim*1.001d0*Dopple
ELSE
! *** temporary, eventually do this more logically ?
@@ -251,6 +249,7 @@ contains
use broad_common_m
use lbro_common_m
use Wdsint_m
+ use broad_common_m, only : dopplerInfo
IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
DIMENSION Bcf(*), Cf2(*), Dopwid(*)
@@ -294,7 +293,7 @@ contains
DO Iso=1,Numiso
A = Dopwid(Iso)*dSQRT(Emin)
B = Dopwid(Iso)*dSQRT(Emax)
- IF (Kkkdop.EQ.2) THEN
+ IF (dopplerInfo%bType.EQ.2) THEN
A = Two*A
B = Two*B
END IF
@@ -438,6 +437,7 @@ contains
use fixedr_m
use mdat9_m
use GridData_M
+ use broad_common_m, only : dopplerInfo
use AuxGridHelper_M, only : setAuxGridRowMax
IMPLICIT DOUBLE PRECISION (a-h,o-z)
real(kind=8),allocatable,dimension(:)::E(:), Energy(:)
@@ -519,7 +519,7 @@ contains
Ndatr = Ndatry - Ndatrx + 1
Ndatx = Ndatxy - Ndatxx + 1
IF (Ndatx+1.LT.Ndat .AND. Kartgd.NE.1 .AND. Maxwel.NE.1) THEN
- IF (Kkkdop.NE.1) THEN
+ IF (dopplerInfo%bType.NE.1) THEN
WRITE (6,20000) Ndatx, Ndat
20000 FORMAT (' Possible problem in FIX -- Ndatx < Ndat', 2I6)
END IF
diff --git a/sammy/src/dat/mdat4.f90 b/sammy/src/dat/mdat4.f90
index 9f98163741dd25b8cc456997e9a17e4314ff7017..5e8795f8c71251ed0587f4b49d045b33b3b17aa3 100644
--- a/sammy/src/dat/mdat4.f90
+++ b/sammy/src/dat/mdat4.f90
@@ -20,6 +20,7 @@ contains
use EndfData_common_m
use SammyGridAccess_M
use mthe0_M
+ use broad_common_m, only : dopplerInfo
IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
type(SammyGridAccess)::grid
@@ -52,7 +53,7 @@ contains
N5 = 5
IF (Ndatb.LT.N5) N5 = Ndatb
!
- IF (Kkkdop.NE.2) THEN
+ IF (dopplerInfo%bType.NE.2) THEN
D = (Ee(N5)-Ee(1))/Dfloat(N5-1)
! = average spacing between first N5 data points
X = Ee(1) - Emind
@@ -99,7 +100,7 @@ contains
N5 = 5
IF (Ndatb.LT.N5) N5 = Ndatb
!
- IF (Kkkdop.EQ.2) THEN
+ IF (dopplerInfo%bType.EQ.2) THEN
! *** Here equally-spaced in velocity (Ie in sqrt(E)) for
! *** free-gas Doppler
D = ( DSQRT(Ee(Ndatb))-DSQRT(Ee(Ndatb-N5+1)) )/Dfloat(N5-1)
@@ -174,8 +175,7 @@ contains
ELSE
!
! *** Here there's really no broadening
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToExpGrid(expData)
numEl = grid%getNumEnergies(expData)
diff --git a/sammy/src/dat/mdat7.f90 b/sammy/src/dat/mdat7.f90
index 84af315fdc9c3782c4faa27b31d9dcdd2bbc5442..95fe7ae5540953c9841e2dbf5dadc7dd59588f86 100644
--- a/sammy/src/dat/mdat7.f90
+++ b/sammy/src/dat/mdat7.f90
@@ -22,21 +22,16 @@ module mdat7_M
use dop2_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
- type(GridData)::coefGrid
real(kind=8),allocatable,dimension(:)::Energb
-!
-! delt => delttt from fixedr_m (Ff(23) assigned to delt
-! dpdelt => gammmm from fixedr_m (Ff(27)
-! dpdelv => delvvv from fixedr_m (Ff(25) assigned t
-!
-! EQUIVALENCE (Delttt,Delt), (Gammmm,Dpdelt), (Delvvv,Dpdelv)
+
! Todo: Retrieve Boltzman constant from the SAMMY constant module.
DATA Xkb /8.617065D-05/, Zero /0.0d0/
!
- double precision, pointer::delt => Ff(23)
+
double precision, pointer::Dpdelt => Ff(27)
double precision, pointer::Dpdelv => Ff(25)
+ if (.not.associated(dopplerInfo%lealHwang)) return
Emid = (Emin+Emax)*0.5d0
Vvmin = DSQRT(Eminr)
@@ -44,15 +39,17 @@ module mdat7_M
Xvmin = DSQRT(Emin)
Xvmax = DSQRT(Emax)
!
- Delt = Delttt
- IF (Delt.EQ.0.0D0) Delt = 5.0D0
+ delT = dopplerInfo%lealHwang%Delt
+ if (delT.eq.0.0d0) Delt = 5.0d0
+!
! *** a reasonable number ? probably will want to change eventually
!
Itime = 0
- AJ = Temp/Delt
+ AJ = Temp/delT
J = AJ
IF (J.LE.10) J = 10
Delt = Temp/Dfloat(J)
+ dopplerInfo%lealHwang%Delt = Delt
! *** adjust delt slightly so that "j" steps gets us exactly to Temp
!
Dpdelt = (Delt*Xkb)/(4.0D0*Aaawww)
@@ -70,22 +67,22 @@ module mdat7_M
/,' xvmin, xvmax =', 23X, 3(1pg14.5))
!
!
- Kjjjjj = J
- K2pls1 = J + J + 1
+ dopplerInfo%lealHwang%Kjjjjj = J
+ dopplerInfo%wantBroaden = .true.
+ dopplerInfo%lealHwang%K2pls1 = J + J + 1
!
!
! *** Coefgn generates coefficients Coef (which we put into Energb
! *** for now) for solving heat equation for performing Doppler
-! *** broadening
- call coefGrid%initialize()
- CALL Coefgn (coefGrid, Kjjjjj, K2pls1, Mkkkkk, M2pls1, 0)
- call reallocate_real_data(Energb, coefGrid%getLength())
+! *** broadening
+ CALL Coefgn (dopplerInfo%lealHwang%coefGrid, dopplerInfo%lealHwang%Kjjjjj, Mkkkkk, M2pls1)
+ call reallocate_real_data(Energb, dopplerInfo%lealHwang%coefGrid%getLength())
! *** Mkkkkk is the number actually used, since the rest are
! *** effectively zero
!
- WRITE (21,10002) Mkkkkk, Kjjjjj
- WRITE ( 6,10002) Mkkkkk, Kjjjjj
+ WRITE (21,10002) Mkkkkk, dopplerInfo%lealHwang%Kjjjjj
+ WRITE ( 6,10002) Mkkkkk, dopplerInfo%lealHwang%Kjjjjj
10002 FORMAT (' New and actual values of J = ', 2I8)
!
N = (Vmax-Vvmin)/Dpdelv
@@ -96,7 +93,6 @@ module mdat7_M
IF (Ndatb.GT.Kdatbm) STOP '[STOP in Llgrid in dat/mdat7.f]'
!
! Delvvv = Dpdelv
-! Delttt = Dpdelt
! Gammmm = Dpdelt
!
!
@@ -116,28 +112,25 @@ module mdat7_M
!
IF (Ngtvv.NE.0) THEN
DO I=1,Ngtvv
- call coefGrid%addData(I, 1, -(Vvmin + Dpdelv*Dfloat(I)) **2)
+ call dopplerInfo%lealHwang%coefGrid%addData(I, 1, -(Vvmin + Dpdelv*Dfloat(I)) **2)
END DO
- call coefGrid%addData(Ngtvv+1, 1, Zero)
+ call dopplerInfo%lealHwang%coefGrid%addData(Ngtvv+1, 1, Zero)
Ngtvv = Ngtvv + 1
Nnn = Ngtvv + 1
END IF
END IF
!
DO I=Nnn,Ndatb
- call coefGrid%addData(I, 1, (Vvmin + Dpdelv*Dfloat(I)) **2)
+ call dopplerInfo%lealHwang%coefGrid%addData(I, 1, (Vvmin + Dpdelv*Dfloat(I)) **2)
END DO
- call reallocate_real_data(Energb, coefGrid%getLength())
- do i = 1, coefGrid%getLength()
- Energb(i) = coefGrid%getData(i,1)
+ call reallocate_real_data(Energb, dopplerInfo%lealHwang%coefGrid%getLength())
+ do i = 1, dopplerInfo%lealHwang%coefGrid%getLength()
+ Energb(i) = dopplerInfo%lealHwang%coefGrid%getData(i,1)
end do
- call coefGrid%destroy()
-
-
!
- Nwd = K2pls1
+ Nwd = dopplerInfo%lealHwang%K2pls1
Awid = Dpdelv*(2.0D0*DSQRT(Emid+Dpdelv))
RETURN
!
diff --git a/sammy/src/dat/mdat9.f90 b/sammy/src/dat/mdat9.f90
index cc41467e6fd464443743f0cfc3af730d24b5b86a..b25c0231a981dcd99f38195a7935c580b6343313 100755
--- a/sammy/src/dat/mdat9.f90
+++ b/sammy/src/dat/mdat9.f90
@@ -115,16 +115,13 @@ module mdat9_m
! *** Purpose -- Locate position Nwhere, such that
! *** grid%getEnergy(Nwhere, expData) =< E < grid%getEnergy(Nwhere+1, expData),
! *** for Nn < 2**K points in En
- use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+ use EndfData_common_m
use SammyGridAccess_M
DOUBLE PRECISION E
type(SammyGridAccess)::grid
N = istart
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
IF (E.GT.grid%getEnergy(istart, expData)) THEN
diff --git a/sammy/src/dbd/HighEnergyFreeGas_m.f90 b/sammy/src/dbd/HighEnergyFreeGas_m.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c0378e5b342b174ac64200b9b48bf0f96aa14206
--- /dev/null
+++ b/sammy/src/dbd/HighEnergyFreeGas_m.f90
@@ -0,0 +1,45 @@
+module HighEnergyFreeGas_m
+use FortranExtDopplerBroadening_M
+use DopplerBroadening_M
+use DerivativeHandler_M
+use GridData_M
+use, intrinsic :: ISO_C_BINDING
+
+
+implicit none
+
+type, extends(FortranExtDopplerBroadening) :: HighEnergyFreeGas
+real(kind=8)::Dopple
+contains
+procedure, pass(this) :: initialize => HighEnergyFreeGas_initialize
+procedure, pass(this) :: broaden => HighEnergyFreeGas_broaden
+procedure, pass(this) :: destroy => HighEnergyFreeGas_destroy
+end type HighEnergyFreeGas
+
+contains
+subroutine HighEnergyFreeGas_initialize(this, hand, list, work)
+ implicit none
+ class(HighEnergyFreeGas) :: this
+ class(DerivativeHandler)::hand
+ class(GridDataList)::list
+ class(GridDataList)::work
+ call FortranExtDopplerBroadening_initialize(this, hand, list, work)
+end subroutine
+
+subroutine HighEnergyFreeGas_destroy(this)
+ implicit none
+ class(HighEnergyFreeGas) :: this
+ call FortranExtDopplerBroadening_destroy(this)
+end subroutine
+
+
+
+subroutine HighEnergyFreeGas_broaden(this)
+ class(HighEnergyFreeGas) :: this
+
+ call FortranExtDopplerBroadening_broaden(this)
+ call this%setXoefWeights(2)
+ call this%nullifyWorkGrid(1)
+end subroutine
+
+end module HighEnergyFreeGas_m
diff --git a/sammy/src/dbd/mdbd0.f b/sammy/src/dbd/mdbd0.f
deleted file mode 100644
index 69abf941628f60617ba65fb91438c060a402de59..0000000000000000000000000000000000000000
--- a/sammy/src/dbd/mdbd0.f
+++ /dev/null
@@ -1,83 +0,0 @@
-C
-C
- SUBROUTINE Samdbd_0
-C
-C *** purpose -- perform High-Energy-Gaussian Approximation version of
-c Doppler broadening
-C
- use fixedi_m, only : Jwwwww, K2reso, Kkkdex, Kkkrsl, Ndatd,
- * Nudwhi, Numorr, Numorr, Numrpi
- use ifwrit_m, only : Kplotu, Kvers7, Ndatb
- use exploc_common_m
- use array_sizes_common_m
- use oopsch_common_m, only : Nowwww, Segmen
- use brdd_common_m, only : Weights
- use lbro_common_m, only : Debug, Yresol, Yssmsc
- use AllocateFunctions_m
- use rsl7_m
- use mxct27_m
- IMPLICIT None
-C
- real(kind=8),allocatable,dimension(:)::A_Iwts
- integer::Nm, Kdatb
-C
- WRITE (6,99999)
-99999 FORMAT (' *** SAMMY-DBD 15 Nov 07 ***')
- Segmen(1) = 'D'
- Segmen(2) = 'B'
- Segmen(3) = 'D'
- Nowwww = 0
-C
- CALL Initix
- IF (Kplotu.NE.0) Kplotu = 0
-C
- Kdatb = Ndatd
- IF (Kdatb.EQ.0) Kdatb = Ndatb
-C
-C
-C *** GUESSTIMATE SIZE OF ARRAY NEEDED FOR SAMDBD
- CALL Estdbd (Kdatb)
-C
- Nm = Kdatb
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -<
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
-C *** Xcoef generates coefficients to be used in broadening
- CALL Xcoef (Nm)
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
-C
- call allocate_real_data(A_Iwts, Kdatb)
-C *** Dopplr PERFORMS DOPPLER BROADENING OPERATION (HEGA)
- CALL Dopplr(A_Idpiso , I_Iflmsc , Weights , A_Iwts)
-C
- deallocate(A_Iwts)
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ->
-C
- Jwwwww = 2
-C
- CALL Write_Commons_Many
- RETURN
-C
- END
-C
-C
-C __________________________________________________________________
-C
- SUBROUTINE Estdbd (Kdatb)
-C
-C *** purpose -- estimate array size for this segment
-C
- IMPLICIT none
- integer::Kdatb
- logical Need_Isotopes
- integer::I, K, Idimen
- external Idimen
-C
-cx CALL Figure_Kws_1 (Kone)
-cx k = Kone + 2*Kdatb
- K = 2*Kdatb
- K = Idimen (K, 1, 'K, 1')
- I = Idimen (K, -1, 'K, -1')
- I = Idimen (0, 0, '0, 0')
-C
- RETURN
- END
diff --git a/sammy/src/dbd/mdbd0.f90 b/sammy/src/dbd/mdbd0.f90
new file mode 100644
index 0000000000000000000000000000000000000000..116c59225f0485e0ef0866c8dd4db115ae841ad5
--- /dev/null
+++ b/sammy/src/dbd/mdbd0.f90
@@ -0,0 +1,46 @@
+module HighEnergyFreeGasImpl_m
+use HighEnergyFreeGas_m
+implicit none
+type, extends(HighEnergyFreeGas) :: HighEnergyFreeGasImpl
+contains
+procedure, pass(this) :: initialize => HighEnergyFreeGasImpl_initialize
+procedure, pass(this) :: broaden => HighEnergyFreeGasImpl_broaden
+procedure, pass(this) :: destroy => HighEnergyFreeGasImpl_destroy
+end type HighEnergyFreeGasImpl
+
+contains
+subroutine HighEnergyFreeGasImpl_initialize(this, hand, list, work)
+ implicit none
+ class(HighEnergyFreeGasImpl) :: this
+ class(DerivativeHandler)::hand
+ class(GridDataList)::list
+ class(GridDataList)::work
+ call HighEnergyFreeGas_initialize(this, hand, list, work)
+end subroutine
+
+subroutine HighEnergyFreeGasImpl_destroy(this)
+ implicit none
+ class(HighEnergyFreeGasImpl) :: this
+ call HighEnergyFreeGas_destroy(this)
+end subroutine
+
+subroutine HighEnergyFreeGasImpl_broaden(this)
+!
+ use Dopplr_m
+ IMPLICIT None
+!
+ class(HighEnergyFreeGasImpl)::this
+!
+ WRITE (6,99999)
+99999 FORMAT (' *** SAMMY-DBD 15 Nov 07 ***')
+
+!
+ call HighEnergyFreeGas_broaden(this)
+!
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
+!
+! *** Dopplr PERFORMS DOPPLER BROADENING OPERATION (HEGA)
+ CALL Dopplr_calc(this)
+
+ END subroutine
+end module HighEnergyFreeGasImpl_m
diff --git a/sammy/src/dbd/mdbd1.f b/sammy/src/dbd/mdbd1.f
deleted file mode 100644
index 0538f73101075910ef503f47c84872abf11bdc2c..0000000000000000000000000000000000000000
--- a/sammy/src/dbd/mdbd1.f
+++ /dev/null
@@ -1,430 +0,0 @@
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Dopplr (Dopwid, Iflmsc, Weight, Wts)
-C
-C *** PURPOSE -- FORM DOPPLER-BROADENED CROSS SECTION and derivatives
-C
- use fixedi_m, only : Ktruet,
- * Ndats, numcro, numUsedPar
- use ifwrit_m, only : ktzero, Kcros, Kdebug, Kfinit, Kvthck,
- * Ndat, Nolowb, Nonu, Kvtemp
- use fixedr_m, only : Elowbr, Emaxs, Emins, Thick
- use broad_common_m, only : Brdlim, Dopple
- use brdd_common_m, only : Ipnts, Iup, Kc
- use lbro_common_m, only : Yresol, Yssmsc, Ytrans
- use xct2_m
- use mxct27_m
- use broad_common_m
- use EndfData_common_m, only : expData
- use AuxGridHelper_M, only : setAuxGridOffset,
- * setAuxGridRowMax, getNumAuxGridPoints
- use SammyGridAccess_M
- use array_sizes_common_m, only : calcData, calcDataSelf
- use convert_to_transmission_m
- use normalize_and_background
- IMPLICIT none
- logical Another_Process_will_Happen
-C
- type(SammyGridAccess)::grid, auxGrid
- real(kind=8):: Weight(*), Wts(*), Dopwid(*)
- integer::Iflmsc(*)
- real(kind=8)::Two, val
- real(kind=8)::Ddo, e1, eKdatb, Elow, EM, Eup
- real(kind=8)::Vv, Wdop
- integer::Iffy, Iso, Isox, J, Jwhich, nauxStart, Ipar, N
- integer::Kkkdat, Kkkkkk, Kkkmin, Now, numEl, nauxMax,insig
- integer(C_SIZE_T)::isoC
-
-C *** Brdlim is now set in segment DAT
- DATA Two /2.0d0/
-
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
- call grid%setToExpGrid(expData)
- numEl = grid%getNumEnergies(expData)
- call auxGrid%initialize()
- call auxGrid%setParameters(numcro, ktzero)
- call auxGrid%setToAuxGrid(expData)
- call setAuxGridOffset(1) ! reset the auxillary grid starting point
-
-C
-C
-C *** FORM DOPPLER-BROADENED CROSS SECTION, STORE IN Wg..
-C *** ALSO DOPPLER-BROADEN THE PARTIAL DERIVATIVES.
-C
- Another_Process_will_Happen = Yresol.OR.Yssmsc
- nauxMax = getNumAuxGridPoints()
-C
- call calcData%nullify()
- call calcData%reserve(nauxMax*calcData%getNnnsig(),
- * numUsedPar+1)
- Now = 0
-C
-C
-C *** Do separately for each isotope (Nuclide), since Doppler-width is
-C *** isotope-dependent
- DO Iso=1,calcData%getUsedIsotopes()
- Isox = Iso
- isoC = iso
- Isox = calcData%getRealIsotopeIndex(isoC)
- if (Isox.lt.0) cycle ! this isotope is exclude from the calculation
- Ddo = Dopwid(Isox)
- Isox = iso
-C
- Iffy = 0
- Kc = 1
- Iup = 0
- Ddo = Dopple
-C
-C *** start of major loop over energy-points
- Kkkkkk = 0
- Kkkmin = 0
- Kkkdat = 0
- nauxStart = 0
- DO 70 J=1,nauxMax
- IF ((J/10000)*10000.EQ.J) WRITE (6,10000) J
-10000 FORMAT (' *** on data point number', i10)
-cq
-cqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq
-cq
-cq November 9, 2001 -- the following are not right because Sigsin, Dasigs,
-cq and Dbsigs are not defined here. Probably, they
-cq should be (cf mfgm1.f sbrtine Dopfgm).
-cq
-cqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq
-C
- IF (Another_Process_will_Happen) THEN
- EM = auxGrid%getEnergy(J, expData)
- ELSE
- IF (J.GT.Ndat) THEN
- GO TO 80
- ELSE
- Em = grid%getEnergy(J, expData)
- END IF
- END IF
-C
- IF (Em.LT.Emins) nauxStart = J
- IF (Em.LT.Emins) GO TO 70
- IF (Em.GT.Emaxs) GO TO 80
- Kkkdat = Kkkdat + 1
- Vv = dSQRT(Em)
-C
- Wdop = Two*Ddo*Vv
-C Wdop=DOPPLER WIDTH AT Energy EM
-C
- Eup = Em + Brdlim*Wdop
- eKdatb = auxGrid%getEnergy(nauxMax, expData)
- IF (Eup.GT.eKdatb) Eup = eKdatb
- Elow = Em - Brdlim*Wdop
- e1 = auxGrid%getEnergy(1, expData)
- IF (Elow.LT.e1) Elow = e1
-C
-C ********* find how many and which points are in integral for j
- CALL Kountd_Dbd (Elow, Eup)
- IF (Iup.GT.nauxMax) Iup = nauxMax
-C
- Kkkkkk = Kkkkkk + 1
- IF ((Nolowb.NE.0 .AND. Elowbr.GT.Em) .OR. Ipnts.le.5) THEN
-C ********* IF (don't want low-E brdng, or) too few points, do not broaden
- CALL Which_Dbd (Em, Ipnts, Jwhich, Kc)
- Now = Now + 1
- do ipar = 0, numUsedPar
- DO N=1, calcData%getNnnsig()
- val = calcData%getDataNsOld(Jwhich, N, Ipar, Isox)
- if ( val.eq.0.0d0) cycle
- call calcData%addDataNs(Kkkkkk, N, Ipar, Isox, val)
- end do
- end do
- IF (numUsedPar.gt.0.and.Kvtemp.GT.0) THEN
- DO N=1, calcData%getNnnsig()
- call calcData%addDataNs(Kkkkkk, N, Kvtemp, Isox,
- * 0.0d0)
- end do
- END IF
- ELSE
-C ********* Doppler-broaden
- CALL Xdoppl (auxGrid, Weight, Wts,
- * Em, Wdop, Iffy, Isox, Kkkkkk)
-
- END IF
-C
-C
-
- IF (.NOT. Another_Process_will_Happen) THEN
-C ********* eta?
- IF (Kcros.EQ.6) CALL Nnneta (Iflmsc, calcData, Kkkkkk, 1)
- END IF
-C
- 70 CONTINUE
-C ****** end of energy do-loop
-C
- 80 CONTINUE
- END DO
-C *** End of do loop on nuclides
-C
- nauxStart = nauxStart + 1
- call setAuxGridRowMax(Kkkdat)
- IF (Iffy.EQ.0) WRITE (21,99998)
-99998 FORMAT (/,' ** NOTE -- NO DOPPLER BROADENING ACTUALLY OCCURED **')
- IF (Now.NE.0) WRITE (21,99997) Now,
- * Kkkdat*calcData%getUsedIsotopes()
- IF (Now.NE.0 .AND. Kdebug.NE.0) WRITE (06,99997) Now,
- * Kkkdat*calcData%getUsedIsotopes()
-99997 FORMAT (' No Doppler broadening occured', I8,
- * ' times of a possible', I8)
- IF (Kkkdat.LT.Ndats-2) WRITE (6,10100) Kkkdat, Ndats
-10100 FORMAT (' Kkkdat, ndats =', 2I10)
-C
- call grid%destroy()
- call auxGrid%destroy()
- call dopplerOption%highEnergyFreeGas%updateBroadenedOffset(
- * nauxStart)
- call dopplerOption%highEnergyFreeGas%setLength(Kkkdat)
- call setAuxGridOffset(nauxStart)
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Xdoppl ( grid, Weight, Wts,
- * EM, Wdop, Iffy, Isox, irow)
-C
-C *** Perform integration for Doppler-Broadening from point number
-C *** Kc to point number Iup
-C
- use fixedi_m, only : numUsedPar
- use ifwrit_m, only : Kdebug, Kvtemp
- use fixedr_m, only : Temp
- use brdd_common_m, only : Ipnts, Iup, Kc
- use EndfData_common_m, only : expData
- use SammyGridAccess_M
- use, intrinsic :: ISO_C_BINDING
- use array_sizes_common_m, only : calcData
- IMPLICIT None
-
- type(SammyGridAccess)::grid
-C
- real(kind=8)::Weight(*), Wts(*)
- real(kind=8)::Em, Wdop, val
- integer::Iffy, Isox, Ipos, irow
-C
- real(kind=8)::Sigpls(100), Sigmns(100), Derdop(100)
- real(kind=8)::Zero, One
- real(kind=8)::Del, Derdp1, Derdp2, ewhich, Sigt, W
- integer::I, Ikc, Ipar, Iso, Jwhich, K, KS, N, Iparx
- logical(C_BOOL)::accu
- DATA Zero /0.0d0/, One /1.0d0/
- IF (calcData%getNnnsig().GT.100) then
- STOP '[STOP in Xdoppl in dbd/mdbd1.f]'
- end if
-C
-
- Iffy = Iffy + 1
- KS = 1
- Iso = Isox
-C
- Del = 0.02d0
- Derdop = 0d0
- IF (numUsedPar.gt.0 .AND. Kvtemp.GT.0) THEN
- W = Wdop*(One+Del)
- CALL Fundop (W, EM, grid, Weight, Wts, Sigpls, Isox)
- W = Wdop*(One-Del)
- CALL Fundop (W, EM, grid, Weight, Wts, Sigmns, Isox)
- DO I=1,calcData%getNnnsig()
- Derdop(I) = 0.5d0*(Sigpls(I)-Sigmns(I))/(Del*Wdop)
- END DO
- END IF
-C
-C *** Simpson rule -- figure Wts = 0.5 * gaussian *
-C *** [ Energy(I+1)-Energy(I-1) ]
- IF (Ipnts.LE.12) CALL Simpsn (EM, grid, Wts, Wdop)
-C
-C *** 4-point quadrature rule Wts = Weight * gaussian
- IF (Ipnts.GT.12) CALL Dopbrd (EM, grid, Weight, Wts, Wdop)
-C
- accu = .true.
- call calcData%setAccumulate(accu)
- DO N=1,calcData%getNnnsig()
- ! update cross section (ipar=0) as well as derivatives
- Do Ipar = 0, numUsedPar
- val = 0.0
- DO I=1,Ipnts
- IF (Wts(I).eq.Zero) cycle
- Ikc = I + Kc - 1
- val = val +
- * calcData%getDataNsOld(Ikc,N, Ipar, Iso)*Wts(I)
- end do
- if (val.eq.0) cycle
- call calcData%addDataNs(irow, N, Ipar, Iso, val)
- END DO
- END DO
- accu = .false.
- call calcData%setAccumulate(accu)
-C
- IF (Kvtemp.GT.0.and.numUsedPar.GT.0) THEN
- DO N=1,calcData%getNnnsig()
- val = Derdop(N)*Wdop*0.5d0/Temp
- call calcData%addDataNs(irow, N, Kvtemp, Iso, val)
- END DO
- END IF
-C
- IF (Kdebug.EQ.0 .OR. Kvtemp.LE.0) RETURN
- IF (numUsedPar.EQ.0) RETURN
-C
-C *** here for debug info only
- Sigt = calcData%getDataNs(irow, 1, 0, Iso)
- Derdp1 = (Sigpls(1)-Sigt)/(Del*Wdop)
- Derdp2 = (Sigt-Sigmns(1))/(Del*Wdop)
- IF (Derdop(1).EQ.Zero .AND. Derdp2.EQ.Zero) RETURN
- IF (Derdop(1).EQ.Zero .AND. Derdp2.NE.Zero) GO TO 60
- IF (Derdop(1).NE.Zero .AND. Derdp2.EQ.Zero) GO TO 60
- IF (dABS(Derdp1/Derdop(1)-1.0d0).GT.0.05d0) GO TO 60
- IF (dABS(Derdp2/Derdop(1)-1.0d0).GT.0.05d0) GO TO 60
- IF (dABS(Derdp1/Derdp2 -1.0d0).GT.0.08d0) GO TO 60
- RETURN
-C
- 60 CONTINUE
- Jwhich = (Kc+Iup)/2
- ewhich = grid%getEnergy(Jwhich, expData)
- WRITE (6,99999) ewhich, Derdp1, Derdop(1), Derdp2
-99999 FORMAT (' ** WARNING ON Dopplr DERIV--E,D1,D,D2=', F8.1,
- * 3(1PG11.3))
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Dopbrd (Em, grid, Weight, Wts, Widgau)
-C
-C *** FORM THE GAUSSIAN DOPPLER WeightS AND NORMALIZE THEM
-C
- use brdd_common_m, only : Ipnts, Kc
- use EndfData_common_m, only : expData
- use SammyGridAccess_M
- IMPLICIT None
-C
- real(kind=8)::Weight(*), Wts(*), Em, Widgau
- type(SammyGridAccess)::grid ! this is possible in fixed form g77 as in same compile unit
- real(kind=8)::e1, S, Y, Z
- integer::I
-C
- Y = 85.0D0
- DO I=1,Ipnts
- e1 = grid%getEnergy(I+Kc-1, expData)
- Z = (e1-Em)/Widgau
- Z = Z*Z
- IF (Z.GT.Y) Z = Y
- Z = dEXP(-Z)
- Wts(I) = Weight(I+kc-1)*Z
- END DO
-C
- S = 0.0D0
- DO I=1,Ipnts
- S = S + Wts(I)
- END DO
- S = 1.0D0/S
- DO I=1,Ipnts
- Wts(I) = Wts(I)*S
- END DO
-C
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Simpsn (Em, grid, Wts, Widgau)
-C
-C *** Form the Gaussian Doppler Weights via Simpson's rule, and
-C *** normalize them
-C
- use brdd_common_m, only : Ipnts, Kc
- use EndfData_common_m, only : expData
- use AuxGridHelper_M, only : getNumAuxGridPoints
- use SammyGridAccess_M
- IMPLICIT None
-C
- real(kind=8)::Wts(*)
- real(kind=8)::Em, Widgau
- type(SammyGridAccess)::grid ! this is possible in fixed form g77 as in same compile unit
-
- real(kind=8)::eval1, eval2, eval3, S, Y, Z
- integer::I, J, nauxMax
-C
- J = Ipnts
- nauxMax = getNumAuxGridPoints()
- IF (Kc+Ipnts.GT.nauxMax) J = Ipnts - 1
- Ipnts = J
-C
- Y = 85.0D0
- I = 1
- eval1 = grid%getEnergy(I+Kc-1, expData)
- Z = (eval1-Em)/Widgau
- Z = Z*Z
- IF (Z.GT.Y) Z = Y
- Z = dEXP(-Z)
- eval2 = grid%getEnergy(I+Kc, expData)
- Wts(I) = (eval2-eval1)*Z
-C *** note that we must treat i=1 case separately to avoid
-C *** trying to use index at 0
- DO I=2,Ipnts
- eval1 = grid%getEnergy(I+Kc-1, expData)
- Z = (eval1-Em)/Widgau
- Z = Z*Z
- IF (Z.GT.Y) Z = Y
- Z = dEXP(-Z)
- eval2 = grid%getEnergy(I+Kc, expData)
- eval3 = grid%getEnergy(I+Kc - 2, expData)
- Wts(I) = (eval2-eval3)*Z
-C ****** note there should be a 1/2 factor, but we'll normalize anyway
- END DO
-C
- S = 0.0D0
- DO I=1,Ipnts
- S = S + Wts(I)
- END DO
- S = 1.0D0/S
- DO I=1,Ipnts
- Wts(I) = Wts(I)*S
- END DO
-C
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Fundop (Wdop, Em, grid, Weight, Wts, Sum,
- * Isox)
-C
- use brdd_common_m, only : Ipnts, Kc
- use EndfData_common_m, only : expData
- use SammyGridAccess_M
- use array_sizes_common_m, only : calcData
- IMPLICIT None
- type(SammyGridAccess)::grid ! this is possible in fixed form g77 as in same compile unit
- real(kind=8):: Wts(*), Sum(*),
- * weight(*), Wdop, Em
- integer::isox
- real(kind=8)::Zero, val
- integer::I, Ikc, N
- DATA Zero /0.0d0/
-C
- IF (Ipnts.LE.12) CALL Simpsn (Em, grid, Wts, Wdop)
- IF (Ipnts.GT.12) CALL Dopbrd (Em, grid, Weight, Wts, Wdop)
- CALL Zero_Array (Sum, calcData%getNnnsig())
- DO I=1,Ipnts
- IF (Wts(I).NE.Zero) THEN
- Ikc = I + Kc - 1
- DO N=1,calcData%getNnnsig()
- val = calcData%getDataNsOld(Ikc, N, 0, Isox)
- Sum(N) = Sum(N) + Wts(I)*val
- END DO
- END IF
- END DO
- RETURN
- END
diff --git a/sammy/src/dbd/mdbd1.f90 b/sammy/src/dbd/mdbd1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..56f0b2a8ba72b265d8a3b3f4a81871168c2b5ab9
--- /dev/null
+++ b/sammy/src/dbd/mdbd1.f90
@@ -0,0 +1,378 @@
+module Dopplr_m
+use HighEnergyFreeGas_m
+use DerivativeHandler_M
+use ifwrit_m, only : Kvtemp, Nolowb
+use fixedr_m, only : Emaxs, Emins
+use exploc_common_m, only : A_Idpiso, I_Iflmsc
+use, intrinsic :: ISO_C_BINDING
+implicit none
+public Dopplr_calc
+contains
+ SUBROUTINE Dopplr_calc(calc)
+ class(HighEnergyFreeGas)::calc
+ call Dopplr(calc, A_Idpiso , I_Iflmsc)
+ end SUBROUTINE
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Dopplr (calc, Dopwid, Iflmsc)
+!
+! *** PURPOSE -- FORM DOPPLER-BROADENED CROSS SECTION and derivatives
+!
+!
+ class(HighEnergyFreeGas)::calc
+ real(kind=8):: Dopwid(*)
+ integer::Iflmsc(*)
+ real(kind=8)::Two, val
+ real(kind=8)::Ddo, e1, eKdatb, Elow, EM, Eup
+ real(kind=8)::Vv, Wdop
+ integer::Iffy, Iso, Isox, J, Jwhich, nauxStart, Ipar, N, iposVel
+ integer::Kkkdat, Kkkkkk, Kkkmin, Now, numEl, nauxMax,insig
+ integer(C_SIZE_T)::isoC
+ type(DerivativeHandler) :: calcData
+ logical(C_BOOL)::oneExtra
+ integer::Ipnts, Kc, Ndats
+
+! *** Brdlim is now set in segment DAT
+ DATA Two /2.0d0/
+
+ oneExtra = .false.
+ numEl = calc%getNumEnergyBroadened()
+ nauxMax = calc%getNumEnergyUnbroadened()
+!
+ call calc%getdata(calcData)
+ call calcData%nullify()
+ call calcData%reserve(nauxMax*calcData%getNnnsig(),calc%getNumParams()+1)
+ Now = 0
+
+!
+!
+! *** Do separately for each isotope (Nuclide), since Doppler-width is
+! *** isotope-dependent
+ DO Iso=1,calcData%getUsedIsotopes()
+ Isox = Iso
+ isoC = iso
+ Isox = calcData%getRealIsotopeIndex(isoC)
+ if (Isox.lt.0) cycle ! this isotope is exclude from the calculation
+ Ddo = Dopwid(Isox)
+ Isox = iso
+!
+ Iffy = 0
+ Ddo = calc%Dopple
+!
+! *** start of major loop over energy-points
+ Kkkkkk = 0
+ Kkkmin = 0
+ Kkkdat = 0
+ nauxStart = 0
+ DO 70 J=1,numEl
+ IF ((J/10000)*10000.EQ.J) WRITE (6,10000) J
+10000 FORMAT (' *** on data point number', i10)
+!q
+!qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq
+!q
+!q November 9, 2001 -- the following are not right because Sigsin, Dasigs,
+!q and Dbsigs are not defined here. Probably, they
+!q should be (cf mfgm1.f sbrtine Dopfgm).
+!q
+!qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq
+!
+ Em = calc%getEnergyBroadened(J) ! desired energy
+ iposVel = calc%getEmInUnbroadened(Em, iposVel) ! find position (iposVel) in un-broadened grid and get the velocity
+!
+ IF (Em.LT.Emins) nauxStart = J
+ IF (Em.LT.Emins) GO TO 70
+ IF (Em.GT.Emaxs) GO TO 80
+ Kkkdat = Kkkdat + 1
+ Vv = dSQRT(Em)
+!
+ Wdop = Two*Ddo*Vv
+! Wdop=DOPPLER WIDTH AT Energy EM
+!
+ Eup = Em + calc%Brdlim*Wdop
+ eKdatb = calc%getEnergyUnbroadened(nauxMax)
+ IF (Eup.GT.eKdatb) Eup = eKdatb
+ Elow = Em - calc%Brdlim*Wdop
+ e1 = calc%getEnergyUnbroadened(1)
+ IF (Elow.LT.e1) Elow = e1
+!
+! ********* find how many and which points are in integral for j
+ call calc%calcIntegralSpan(Elow, Eup, oneExtra)
+ Kc = calc%getIntegralStart()
+ Ipnts = calc%getIntegralSpan()
+!
+ Kkkkkk = Kkkkkk + 1
+ IF ((Nolowb.NE.0 .AND. calc%Elowbr.GT.Em) .OR. Ipnts.le.5) THEN
+! ********* IF (don't want low-E brdng, or) too few points, do not broaden
+ Now = Now + 1
+ do ipar = 0, calc%getNumParams()
+ DO N=1, calcData%getNnnsig()
+ val = calcData%getDataNsOld(iposVel, N, Ipar, Isox)
+ if ( Kvtemp.gt.0.and.Kvtemp.eq.ipar) cycle
+ if ( val.eq.0.0d0) cycle
+ call calcData%addDataNs(Kkkkkk, N, Ipar, Isox, val)
+ end do
+ end do
+ ELSE
+! ********* Doppler-broaden
+ CALL Xdoppl (calc, Em, Wdop, Iffy, Isox, Kkkkkk)
+
+ END IF
+!
+!
+!
+ 70 CONTINUE
+! ****** end of energy do-loop
+!
+ 80 CONTINUE
+ END DO
+
+
+! *** End of do loop on nuclides
+!
+ nauxStart = nauxStart + 1
+ IF (Iffy.EQ.0) WRITE (21,99998)
+99998 FORMAT (/,' ** NOTE -- NO DOPPLER BROADENING ACTUALLY OCCURED **')
+ IF (Now.NE.0) WRITE (21,99997) Now, Kkkdat*calcData%getUsedIsotopes()
+ IF (Now.NE.0 .AND. calc%debugOutput) WRITE (06,99997) Now, Kkkdat*calcData%getUsedIsotopes()
+99997 FORMAT (' No Doppler broadening occured', I8, ' times of a possible', I8)
+ Ndats = 1
+ Ndats = calc%getEmInUnbroadened(Emins, Ndats)
+ IF (Kkkdat.LT.Ndats-2) WRITE (6,10100) Kkkdat, Ndats
+10100 FORMAT (' Kkkdat, ndats =', 2I10)
+!
+ call calc%updateBroadenedOffset(nauxStart)
+ call calc%setLength(Kkkdat)
+ RETURN
+ END
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Xdoppl ( calc, EM, Wdop, Iffy, Isox, irow)
+!
+! *** Perform integration for Doppler-Broadening from point number
+! *** Kc to point number Iup
+!
+
+ class(HighEnergyFreeGas)::calc
+ type(DerivativeHandler) :: calcData
+!
+ real(kind=8)::Em, Wdop, val
+ integer::Iffy, Isox, Ipos, irow
+!
+ real(kind=8)::Sigpls(100), Sigmns(100), Derdop(100)
+ real(kind=8)::Del, Derdp1, Derdp2, ewhich, Sigt, W
+ integer::I, Ikc, Ipar, Iso, Jwhich, K, KS, N, Iparx
+ real(kind=8),parameter::Zero=0.0d0, One=1.0d0
+ integer::Kc, Ipnts
+ real(kind=8)::Wts
+
+ call calc%getData(calcData)
+ IF (calcData%getNnnsig().GT.100) then
+ STOP '[STOP in Xdoppl in dbd/mdbd1.f]'
+ end if
+!
+
+ Iffy = Iffy + 1
+ KS = 1
+ Iso = Isox
+ Kc = calc%getIntegralStart()
+ Ipnts = calc%getIntegralSpan()
+!
+ Del = 0.02d0
+ Derdop = 0d0
+ IF (calc%getNumParams().gt.0 .AND. Kvtemp.GT.0) THEN
+ W = Wdop*(One+Del)
+ CALL Fundop (calc, W, EM, Sigpls, Isox)
+ W = Wdop*(One-Del)
+ CALL Fundop (calc, W, EM, Sigmns, Isox)
+ DO I=1,calcData%getNnnsig()
+ Derdop(I) = 0.5d0*(Sigpls(I)-Sigmns(I))/(Del*Wdop)
+ END DO
+ END IF
+!
+! *** Simpson rule -- figure Wts = 0.5 * gaussian *
+! *** [ Energy(I+1)-Energy(I-1) ]
+ IF (Ipnts.LE.12) CALL Simpsn (calc, EM, Wdop)
+!
+! *** 4-point quadrature rule Wts = Weight * gaussian
+ IF (Ipnts.GT.12) CALL Dopbrd (calc, EM, Wdop)
+!
+ DO N=1,calcData%getNnnsig()
+ ! update cross section (ipar=0) as well as derivatives
+ Do Ipar = 0, calc%getNumParams()
+ val = 0.0
+ DO I=1,Ipnts
+ Wts = calc%getWorkData(1, 1, I)
+ IF (Wts.eq.Zero) cycle
+ Ikc = I + Kc - 1
+ val = val + calcData%getDataNsOld(Ikc,N, Ipar, Iso)*Wts
+ end do
+ if (Kvtemp.gt.0.and.Kvtemp.eq.Ipar) then
+ val = Derdop(N)*Wdop*0.5d0/calc%getTemperature()
+ end if
+ if (val.eq.0) cycle
+ call calcData%addDataNs(irow, N, Ipar, Iso, val)
+ END DO
+ END DO
+!
+ IF (.not.calc%debugOutput.OR. Kvtemp.LE.0) RETURN
+ IF (calc%getNumParams().EQ.0) RETURN
+!
+! *** here for debug info only
+ Sigt = calcData%getDataNs(irow, 1, 0, Iso)
+ Derdp1 = (Sigpls(1)-Sigt)/(Del*Wdop)
+ Derdp2 = (Sigt-Sigmns(1))/(Del*Wdop)
+ IF (Derdop(1).EQ.Zero .AND. Derdp2.EQ.Zero) RETURN
+ IF (Derdop(1).EQ.Zero .AND. Derdp2.NE.Zero) GO TO 60
+ IF (Derdop(1).NE.Zero .AND. Derdp2.EQ.Zero) GO TO 60
+ IF (dABS(Derdp1/Derdop(1)-1.0d0).GT.0.05d0) GO TO 60
+ IF (dABS(Derdp2/Derdop(1)-1.0d0).GT.0.05d0) GO TO 60
+ IF (dABS(Derdp1/Derdp2 -1.0d0).GT.0.08d0) GO TO 60
+ RETURN
+!
+ 60 CONTINUE
+ ewhich = em
+ WRITE (6,99999) ewhich, Derdp1, Derdop(1), Derdp2
+99999 FORMAT (' ** WARNING ON Dopplr DERIV--E,D1,D,D2=', F8.1, &
+ 3(1PG11.3))
+ RETURN
+ END
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Dopbrd (calc, Em, Widgau)
+!
+! *** FORM THE GAUSSIAN DOPPLER WeightS AND NORMALIZE THEM
+!
+ real(kind=8):: Em, Widgau
+ real(kind=8)::e1, S, Y, Z
+ integer::I
+ class(HighEnergyFreeGas)::calc
+ integer::Ipnts, Kc
+ real(kind=8)::Wts
+
+!
+ Y = 85.0D0
+ Ipnts = calc%getIntegralSpan()
+ Kc = calc%getIntegralStart()
+ DO I=1,Ipnts
+ e1 = calc%getEnergyUnbroadened(I+Kc-1)
+ Z = (e1-Em)/Widgau
+ Z = Z*Z
+ IF (Z.GT.Y) Z = Y
+ Z = dEXP(-Z)
+ Wts = calc%getWorkData(2,1, I+kc-1)*Z
+ call calc%setWorkData(1, 1, I, Wts)
+ END DO
+!
+ S = 0.0D0
+ DO I=1,Ipnts
+ S = S + calc%getWorkData(1,1, I)
+ END DO
+ S = 1.0D0/S
+ DO I=1,Ipnts
+ Wts = calc%getWorkData(1,1, I)*S
+ call calc%setWorkData(1, 1, I, Wts)
+ END DO
+!
+ RETURN
+ END
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Simpsn (calc, Em, Widgau)
+!
+! *** Form the Gaussian Doppler Weights via Simpson's rule, and
+! *** normalize them
+!
+!
+ real(kind=8)::Wts
+ real(kind=8)::Em, Widgau
+ class(HighEnergyFreeGas)::calc
+
+ real(kind=8)::eval1, eval2, eval3, S, Y, Z
+ integer::I, J, nauxMax, Ipnts, Kc
+!
+ Ipnts = calc%getIntegralSpan()
+ Kc = calc%getIntegralStart()
+ J = Ipnts
+ nauxMax = calc%getNumEnergyUnbroadened()
+ IF (Kc+Ipnts.GT.nauxMax) J = Ipnts - 1
+ Ipnts = J
+!
+ Y = 85.0D0
+ I = 1
+ eval1 = calc%getEnergyUnbroadened(I+Kc-1)
+ Z = (eval1-Em)/Widgau
+ Z = Z*Z
+ IF (Z.GT.Y) Z = Y
+ Z = dEXP(-Z)
+ eval2 = calc%getEnergyUnbroadened(I+Kc)
+ Wts = (eval2-eval1)*Z
+ call calc%setWorkData(1,1, I, Wts)
+! *** note that we must treat i=1 case separately to avoid
+! *** trying to use index at 0
+ DO I=2,Ipnts
+ eval1 = calc%getEnergyUnbroadened(I+Kc-1)
+ Z = (eval1-Em)/Widgau
+ Z = Z*Z
+ IF (Z.GT.Y) Z = Y
+ Z = dEXP(-Z)
+ eval2 = calc%getEnergyUnbroadened(I+Kc)
+ eval3 = calc%getEnergyUnbroadened(I+Kc - 2)
+ Wts = (eval2-eval3)*Z
+ call calc%setWorkData(1,1, I, Wts)
+! ****** note there should be a 1/2 factor, but we'll normalize anyway
+ END DO
+!
+ S = 0.0D0
+ DO I=1,Ipnts
+ S = S + calc%getWorkData(1,1,I)
+ END DO
+ S = 1.0D0/S
+ DO I=1,Ipnts
+ Wts = calc%getWorkData(1,1,I)*S
+ call calc%setWorkData(1,1, I, Wts)
+ END DO
+!
+ RETURN
+ END
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Fundop (calc, Wdop, Em, Sum, Isox)
+!
+ type(DerivativeHandler) :: calcData
+ real(kind=8):: Sum(*), Wdop, Em
+ integer::isox
+ real(kind=8)::val
+ integer::I, Ikc, N, Ipnts, Kc
+ class(HighEnergyFreeGas)::calc
+ real(kind=8),parameter :: Zero = 0.0d0
+ real(kind=8)::Wts
+!
+ Ipnts = calc%getIntegralSpan()
+ Kc = calc%getIntegralStart()
+ call calc%getdata(calcData)
+ IF (Ipnts.LE.12) CALL Simpsn (calc, Em, Wdop)
+ IF (Ipnts.GT.12) CALL Dopbrd (calc, Em, Wdop)
+ Sum(1:calcData%getNnnsig()) = Zero
+ DO I=1,Ipnts
+ Wts = calc%getWorkData(1,1,I)
+ IF (Wts.NE.Zero) THEN
+ Ikc = I + Kc - 1
+ DO N=1,calcData%getNnnsig()
+ val = calcData%getDataNsOld(Ikc, N, 0, Isox)
+ Sum(N) = Sum(N) + Wts*val
+ END DO
+ END IF
+ END DO
+ RETURN
+ END
+end module Dopplr_m
diff --git a/sammy/src/dbd/mdbd2.f b/sammy/src/dbd/mdbd2.f90
similarity index 57%
rename from sammy/src/dbd/mdbd2.f
rename to sammy/src/dbd/mdbd2.f90
index f37bd8cdaa65427d2fb714d2c996ad6f5b42fc45..b35eae64d9095e485002d27ddb37825943081608 100644
--- a/sammy/src/dbd/mdbd2.f
+++ b/sammy/src/dbd/mdbd2.f90
@@ -1,34 +1,30 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Xcoef (Kdatb)
-C
-C *** PURPOSE -- GENERATE COEFFICIENTS FOR USE IN BROADENING
-C
- use ifwrit_m, only : ktzero
+!
+! *** PURPOSE -- GENERATE COEFFICIENTS FOR USE IN BROADENING
+!
use EndfData_common_m, only : expData
- use fixedi_m, only : numcro
use SammyGridAccess_M
use brdd_common_m, only : Weights
use AllocateFunctions_m
IMPLICIT NONE
-C
+!
type(SammyGridAccess)::grid
real(kind=8),allocatable,dimension(:)::X1, X2, X21
integer::Kdatb
real(kind=8)::e1, e2
integer::I, K, Nn, Nnp2
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
Nn = Kdatb - 3
Nnp2 = Kdatb - 1
-C
-C *** define X21 = Energy(2) - Energy(1)
+!
+! *** define X21 = Energy(2) - Energy(1)
call allocate_real_data(X21, Kdatb)
call allocate_real_data(X2, Kdatb)
call allocate_real_data(X1, Kdatb)
@@ -40,50 +36,50 @@ C *** define X21 = Energy(2) - Energy(1)
end do
-C
-C *** define X2 = X21 ** 2
+!
+! *** define X2 = X21 ** 2
CALL Vsq (X21(1), X2(1), Nnp2)
-C
-C *** define X1 = 1./X21
+!
+! *** define X1 = 1./X21
CALL Vrecip (X21(1), X1(1), Nnp2)
-C
-C *** define Weight(I) = X2(I+2) - X2(I)
+!
+! *** define Weight(I) = X2(I+2) - X2(I)
CALL Vsub (X2(1), X2(3), Weights(1), Nn)
-C
-C *** redefine X2(I) = Weights(I) / X21(I+1) = Weights(I) X1(I+1)
+!
+! *** redefine X2(I) = Weights(I) / X21(I+1) = Weights(I) X1(I+1)
CALL Vmul (Weights(1), X1(2), X2(1), Nn)
-C
-C *** redefine X1 = 5 * X21
+!
+! *** redefine X1 = 5 * X21
CALL Vsmul (X21(1), 5.0D0, X1(1), Nnp2)
-C
-C *** next set W(I) = X21(I-2) + X1(I-1) + X1(I) + X21(I+1)
-C *** + X2(I-2) - X2(I-1)
-C
-C *** here Weights is reused to be Weighting factor
+!
+! *** next set W(I) = X21(I-2) + X1(I-1) + X1(I) + X21(I+1)
+! *** + X2(I-2) - X2(I-1)
+!
+! *** here Weights is reused to be Weighting factor
Weights(1) = X1(1) + X21(2)
- Weights(2) = X1(1) + X1(2) + X21(3)
- * - X2(1)
+ Weights(2) = X1(1) + X1(2) + X21(3) &
+ - X2(1)
DO K=3,NN+1
- Weights(K) = X21(K-2) + X1(K-1) + X1(K) + X21(K+1)
- * + X2(K-2) - X2(K-1)
+ Weights(K) = X21(K-2) + X1(K-1) + X1(K) + X21(K+1) &
+ + X2(K-2) - X2(K-1)
END DO
Weights(Nn+2) = X21(Nn) + X1(Nn+1) + X1(Nn+2) + X2(Nn)
Weights(Kdatb)= X21(Nn+1) + X1(Nn+2)
-C
-C *** Note that value of Weights(I) is now 12 times the quantity
-C *** given in Eq. (IV B 3.8) on page 80 of the SAMMY manual (R3)
-C
+!
+! *** Note that value of Weights(I) is now 12 times the quantity
+! *** given in Eq. (IV B 3.8) on page 80 of the SAMMY manual (R3)
+!
call grid%destroy()
deallocate(X21)
deallocate(X2)
deallocate(X1)
RETURN
END
-C
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Read_Cross_Sections( Npnts)
use ifwrit_m, only : Kksave
implicit none
@@ -92,23 +88,23 @@ C
IF (Kksave.NE.Npnts) THEN
WRITE (21,10200) Kksave, Npnts
WRITE (6,10200) Kksave, Npnts
-10200 FORMAT (' Error in Read_Cross_Sections', /,
- * ' Kksave should equal Npnts but =', 3I10)
+10200 FORMAT (' Error in Read_Cross_Sections', /, &
+ ' Kksave should equal Npnts but =', 3I10)
STOP '[Stop in Read_Cross_Sections in dbd/mdbd2.f #2]'
END IF
-C
+!
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Trans_and_Norm (Parnbk, Iflnbk, Parbgf, Iflbgf, Kndbgf,
- * Bgfmin, Bgfmax, Texbgf, Teabgf,
- * Em, Kkkkkk)
-C
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Trans_and_Norm (Parnbk, Iflnbk, Parbgf, Iflbgf, Kndbgf, &
+ Bgfmin, Bgfmax, Texbgf, Teabgf, &
+ Em, Kkkkkk)
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -119,31 +115,29 @@ C
use normalize_and_background
use convert_to_transmission_m
IMPLICIT None
-C
- real(kind=8)::Parnbk(*), Parbgf(*),
- * Bgfmin(*), Bgfmax(*), Texbgf(*),Teabgf(*)
+!
+ real(kind=8)::Parnbk(*), Parbgf(*), Bgfmin(*), Bgfmax(*), Texbgf(*),Teabgf(*)
integer:: Iflnbk(*), Iflbgf(*), Kndbgf(*)
integer::Kkkkkk
real(kind=8)::Em
real(kind=8)::val
-C
- IF (Ynrmbk .OR. (Kfinit.EQ.0 .AND. Ytrans .AND. Ktruet.EQ.0) )
- * THEN
-C *** transmission?
+!
+ IF (Ynrmbk .OR. (Kfinit.EQ.0 .AND. Ytrans .AND. Ktruet.EQ.0) ) THEN
+! *** transmission?
IF (Kfinit.EQ.0 .AND. Ytrans .AND. Ktruet.EQ.0) THEN
IF (Nonu.EQ.0) THEN
- CALL Transm_sum (calcData, Kkkkkk, 1,
- * numUsedPar, Kvthck, Thick)
+ CALL Transm_sum (calcData, Kkkkkk, 1, &
+ numUsedPar, Kvthck, Thick)
ELSE
CALL Ztrans (calcData, Kkkkkk, 1, -1, Kvthck)
END IF
END IF
-C *** Normalize & add background
- IF (Numnbk.GT.0) CALL Norm (Parnbk, Iflnbk,
- * Em, Kkkkkk, calcData, numUsedPar)
- IF (Numbgf.GT.0) CALL Bgfrpi (Parbgf, Iflbgf, Kndbgf,
- * Bgfmin, Bgfmax, Texbgf, Teabgf, Em,
- * calcData, Kkkkkk, numUsedPar.ne.0)
+! *** Normalize & add background
+ IF (Numnbk.GT.0) CALL Norm (Parnbk, Iflnbk, &
+ Em, Kkkkkk, calcData, numUsedPar)
+ IF (Numbgf.GT.0) CALL Bgfrpi (Parbgf, Iflbgf, Kndbgf, &
+ Bgfmin, Bgfmax, Texbgf, Teabgf, Em, &
+ calcData, Kkkkkk, numUsedPar.ne.0)
END IF
RETURN
END
diff --git a/sammy/src/dbd/mdbd3.f b/sammy/src/dbd/mdbd3.f
deleted file mode 100644
index 827413d7ff680d20d50e4a19e3f255f3314b6cd2..0000000000000000000000000000000000000000
--- a/sammy/src/dbd/mdbd3.f
+++ /dev/null
@@ -1,73 +0,0 @@
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Kountd_Dbd (Elow, Eup)
-C
-C *** Purpose -- FIND Kc AND Iup, ALSO Ipnts
-C
- use brdd_common_m, only : Ipnts, Iup, Kc
- use EndfData_common_m, only : expData
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
- use SammyGridAccess_M
- IMPLICIT none
- type(SammyGridAccess)::grid
- real(kind=8)::Elow, Eup
- real(kind=8)::elowGrid, eupGrid
- integer::Ilow
-
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
- call grid%setToAuxGrid(expData)
-
- Ilow = Kc - 1
- 10 Ilow = Ilow + 1
- elowGrid = grid%getEnergy(Ilow, expData)
- IF (elowGrid.LE.Elow) GO TO 10
- 20 Iup = Iup + 1
- eupGrid = grid%getEnergy(Iup, expData)
- IF (eupGrid.LT.Eup) GO TO 20
- Ilow = Ilow - 2
- IF (Ilow.LT.0) Ilow = 0
- Ipnts = Iup - Ilow
- Kc = Ilow + 1
- Iup = Iup - 1
- call grid%destroy()
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Which_Dbd (EM, Ipnts, Jwhich, Kc)
- use EndfData_common_m, only : expData
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
- use SammyGridAccess_M
- IMPLICIT None
- type(SammyGridAccess)::grid
- integer::Ipnts, Jwhich, Kc
- real(kind=8)::EM
- real(kind=8)::A, Ddd, e1, e2
- integer::I
-
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
- call grid%setToAuxGrid(expData)
-C
- Jwhich = 0
- e1 = grid%getEnergy(Ipnts+Kc-1, expData)
- e2 = grid%getEnergy(kc, expData)
- Ddd = e1 - e2
- DO I=1,Ipnts
- e1 = grid%getEnergy(I+Kc-1, expData)
- A = dABS(e1-EM)
- IF (A.LE.Ddd) Jwhich = I
- IF (A.LE.Ddd) Ddd = A
- END DO
- IF (Jwhich.EQ.0) Jwhich = 1
- Jwhich = Kc + Jwhich - 1
- call grid%destroy()
- RETURN
- END
diff --git a/sammy/src/dex/mdex0.f b/sammy/src/dex/mdex0.f
index 8596313ef5f199dfc3572e9e09f859855b2edf29..85e23b1a8d268a742cb7f866df7e053d3c4ea627 100644
--- a/sammy/src/dex/mdex0.f
+++ b/sammy/src/dex/mdex0.f
@@ -3,10 +3,9 @@ C
SUBROUTINE Samdex_0
C
C use oops_common_m
- use fixedi_m, only : Jwwwww, K2reso,
+ use fixedi_m, only : K2reso,
* Numorr, Numrpi,
* Nudwhi
- use ifwrit_m, only : Jjjdop, Kplotu
use exploc_common_m
use array_sizes_common_m
use oopsch_common_m, only : Nowwww, Segmen
@@ -31,7 +30,6 @@ C
Nowwww = 0
C
CALL Initix
- IF (Kplotu.NE.0) Kplotu = 0
C
Kdatb = getNumAuxGridPoints()
C
@@ -56,9 +54,6 @@ C
deallocate(A_Iwts)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
C
- Jwwwww = 4
-C
- Jjjdop = 0
CALL Write_Commons_Many
RETURN
C
diff --git a/sammy/src/dex/mdex1.f b/sammy/src/dex/mdex1.f
index 02a3827cbf2f6dccc2333c4220c9a3ae392eaeec..c5a35e349965f33043ed219a83522737c59994d1 100644
--- a/sammy/src/dex/mdex1.f
+++ b/sammy/src/dex/mdex1.f
@@ -10,8 +10,8 @@ C *** function in energy between E and E-Dddeee)
C *** [or between E+Dddeee/2 & E-Dddeee/2, if Ndexxx=1]
C
use fixedi_m, only : K2reso, ndexxx, numUsedPar,
- * numcro, Numnbk, Numorr, Numrpi, Numbgf
- use ifwrit_m, only : Kdebug, ktzero, Ndat
+ * Numnbk, Numorr, Numrpi, Numbgf
+ use ifwrit_m, only : Kdebug, Ndat
use fixedr_m, only : Dddeee
use brdd_common_m, only : Ipk, Iup
use mxct27_m
@@ -40,11 +40,9 @@ C
CALL Read_Cross_Sections (nauxMax)
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
- call grid%setToExpGrid(expData)
+ call grid%setToExpGrid(expData)
numEl = grid%getNumEnergies(expData)
- call auxGrid%initialize()
- call auxGrid%setParameters(numcro, ktzero)
+ call auxGrid%initialize()
call auxGrid%setToAuxGrid(expData)
C
IF (K2reso.EQ.1 .AND. (Numorr.GT.0 .OR. Numrpi.GT.0) ) THEN
diff --git a/sammy/src/dop/LealHwangBroadening_M.f90 b/sammy/src/dop/LealHwangBroadening_M.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8fad7a99d01a0b93f61f2dc987bdf3dde3ddbeb2
--- /dev/null
+++ b/sammy/src/dop/LealHwangBroadening_M.f90
@@ -0,0 +1,50 @@
+module LealHwangBroadening_M
+use FortranExtDopplerBroadening_M
+use DopplerBroadening_M
+use DerivativeHandler_M
+use GridData_M
+use, intrinsic :: ISO_C_BINDING
+
+
+implicit none
+type, extends(FortranExtDopplerBroadening) :: LealHwangBroadening
+type(GridData)::coefGrid
+integer::Kjjjjj
+integer::K2pls1
+real(kind=8)::delT
+contains
+procedure, pass(this) :: initialize => LealHwangBroadening_initialize
+procedure, pass(this) :: broaden => LealHwangBroadening_broaden
+procedure, pass(this) :: destroy => LealHwangBroadening_destroy
+end type LealHwangBroadening
+
+contains
+subroutine LealHwangBroadening_initialize(this, hand, list, work)
+ implicit none
+ class(LealHwangBroadening) :: this
+ class(DerivativeHandler)::hand
+ class(GridDataList)::list
+ class(GridDataList)::work
+ call FortranExtDopplerBroadening_initialize(this, hand, list, work)
+ call this%coefGrid%initialize()
+ this%Kjjjjj = 0
+ this%K2pls1 = 0
+ this%delT = 5.0d0
+end subroutine
+
+subroutine LealHwangBroadening_destroy(this)
+ implicit none
+ class(LealHwangBroadening) :: this
+ call FortranExtDopplerBroadening_destroy(this)
+ call this%coefGrid%destroy()
+end subroutine
+
+
+subroutine LealHwangBroadening_broaden(this)
+ class(LealHwangBroadening) :: this
+
+ call FortranExtDopplerBroadening_broaden(this)
+ call this%coefGrid%nullify()
+end subroutine
+
+end module LealHwangBroadening_M
diff --git a/sammy/src/dop/mdop0.f90 b/sammy/src/dop/mdop0.f90
index d88f2235187006ff8a675c1786d0ef4ba06077bd..00b177716f61c86d3d2721c1bae4907c9901f32b 100644
--- a/sammy/src/dop/mdop0.f90
+++ b/sammy/src/dop/mdop0.f90
@@ -1,82 +1,59 @@
!
-module dop_m
+module LealHwangBroadeningImpl_m
+ use LealHwangBroadening_M
+ implicit none
+
+ type, extends(LealHwangBroadening) :: LealHwangBroadeningImpl
contains
-!
- SUBROUTINE Samdop_0
-!
- use over_common_m
- use oops_common_m
- use fixedi_m
- use ifwrit_m
- use exploc_common_m
- use array_sizes_common_m
- use oopsch_common_m
- use cbro_common_m
- use lbro_common_m
- use EndfData_common_m
- use GridData_M
+ procedure, pass(this) :: initialize => LealHwangBroadeningImpl_initialize
+ procedure, pass(this) :: broaden => LealHwangBroadeningImpl_broaden
+ procedure, pass(this) :: destroy => LealHwangBroadeningImpl_destroy
+ end type LealHwangBroadeningImpl
+
+ contains
+ subroutine LealHwangBroadeningImpl_initialize(this, hand, list, work)
+ implicit none
+ class(LealHwangBroadeningImpl) :: this
+ class(DerivativeHandler)::hand
+ class(GridDataList)::list
+ class(GridDataList)::work
+ call LealHwangBroadening_initialize(this, hand, list, work)
+ end subroutine
+
+ subroutine LealHwangBroadeningImpl_destroy(this)
+ implicit none
+ class(LealHwangBroadeningImpl) :: this
+ call LealHwangBroadening_destroy(this)
+ end subroutine
+
+ subroutine LealHwangBroadeningImpl_broaden(this)
+ use exploc_common_m, only : I_Iflmsc
use dop1_m
use dop2_m
- use AllocateFunctions_m
- use rsl7_m
- use mxct27_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-!
- type(GridData)::grid, auxGrid
- type(GridData)::coefGrid
- real(kind=8),allocatable,dimension(:)::A_Icoef
+
+ class(LealHwangBroadeningImpl)::this
+ integer::I2pls1, Mmmmmm
!
WRITE (6,99999)
99999 FORMAT (' *** SAMMY-DOPPL 8 Aug 07 ***')
- Segmen(1) = 'D'
- Segmen(2) = 'O'
- Segmen(3) = 'P'
- Nowwww = 0
-!
-!x CALL Initix
-!
-!
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- N = K2pls1 + 1
- call coefGrid%initialize()
+
+
+ call LealHwangBroadening_broaden(this)
+
! *** Coefgn generates Coefficients Coef for solving heat equation
! *** for performing Doppler broadening
- CALL Coefgn (coefGrid, Kjjjjj, K2pls1, Mmmmmm, I2pls1, 0)
+ CALL Coefgn (this%coefGrid, this%Kjjjjj, Mmmmmm, I2pls1)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- call allocate_real_data(A_Icoef, I2pls1)
- do i = 1, I2pls1
- A_Icoef(i) = coefGrid%getData(i,1)
- end do
- call coefGrid%destroy()
- I = Idimen (0, 0, '0, 0')
-!
-!
- Nv = Ndatb
- Left = Msize - Icoef - 2*I2pls1
- Ldatb = Ndatb
-
- ! ensure we have an auxillary energy grid
- if ( expData%getLength().lt.2) then
- write(0,*)" Missing auxillary grid"
- stop
- end if
!
!
! *** Dopplh performs Doppler broadening operation via Leal-Hwang method
- CALL Dopplh(I_Iflmsc , A_Icoef , &
- Mmmmmm , I2pls1 , Ngb , Nss, Ldatb, &
- calcData, calcDataSelf)
- deallocate(A_Icoef)
+ CALL Dopplh(this, I_Iflmsc , Mmmmmm , I2pls1)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
-!
- Jwwwww = 2
-!
- Jjjdop = 1
- CALL Write_Commons_Many
+
RETURN
!
- END
+ END subroutine
-end module dop_m
+end module LealHwangBroadeningImpl_m
diff --git a/sammy/src/dop/mdop1.f90 b/sammy/src/dop/mdop1.f90
index 783805da256743e47409fca4384e3bdb4960d31f..dfa925814446b17955dfcfdb33ae4edf739a70a9 100644
--- a/sammy/src/dop/mdop1.f90
+++ b/sammy/src/dop/mdop1.f90
@@ -1,65 +1,48 @@
!
-module dop1_m
- use convert_to_transmission_m
+module dop1_m
+ use LealHwangBroadening_M
+ use ifwrit_m, only : Kvtemp
+ use AuxGridHelper_M, only : setAuxGridOffset
+ use DerivativeHandler_M
+ IMPLICIT None
+
+ public Dopplh
contains
!
! ____________________________________________________________________
!
- SUBROUTINE Dopplh (Iflmsc, Coef , &
- Mmmmmm, M2pls1, Ngb , Nss , Ldatb, &
- derivs, derivsSelf)
+ SUBROUTINE Dopplh (calc, Iflmsc, Mmmmmm, M2pls1)
!
! *** Purpose -- Implement Doppler broadening
!
- use oops_common_m
- use fixedi_m
- use ifwrit_m
- use samxxx_common_m
- use oopsch_common_m
- use fixedr_m
- use abro_common_m
- use lbro_common_m
- use hhhhhh_common_m
- use xct2_m
- use mxct27_m
- use EndfData_common_m
- use SammyGridAccess_M
- use AuxGridHelper_M
- use DerivativeHandler_M
- use broad_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- type(SammyGridAccess)::grid
- LOGICAL Need_isotopes
- LOGICAL Another_Process_will_Happen
+ class(LealHwangBroadening)::calc
integer::nauxStart
- type(DerivativeHandler)::derivs, derivsSelf
-!
- DIMENSION Iflmsc(*), Coef(*)
-! DIMENSION Iflmsc(Nummsc), Coef(K2pls1)
-!
+ type(DerivativeHandler)::derivs
+!
+ integer::Iflmsc(*)
+ integer::Mmmmmm, M2pls1, Ldatb
+ real(kind=8)::Cc, Ebm, Coef
+ integer::I, Ii, Imax, Imin, Isox, K
+ integer::Kkkkkk, Kkkmin, Ldatb_M2, M, Mmax, Mmin, Mmm
+ integer::Newmin
+
+! DIMENSION Iflmsc(Nummsc)
!
- Need_Isotopes = Yssmsc
- Another_Process_will_Happen = Yresol.OR.Yssmsc.or.yaverg
!
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
- call grid%setToAuxGrid(expData)
- call setAuxGridOffset(1) ! reset auxiallary grid offset
+ call calc%getData(derivs)
+
call derivs%nullify()
+ Ldatb = calc%getNumEnergyUnbroadened()
!
- K2pls1 = M2pls1
- Nnn = Ngb
+ calc%K2pls1 = M2pls1
Imin = 1
- Imax = Ldatb - K2pls1 + 1
+ Imax = Ldatb - M2pls1 + 1
Mmin = 1
-!
-!
- Newkkk = Kksave
+
+
!
Ldatb_M2 = Ldatb - Mmmmmm*2
- Iw = 0
- IF (Ksindi.NE.0) Iw = 1
- call derivsSelf%nullify()
+ if (calc%hasSelf) call calc%dataSelf%nullify()
!
!
!
@@ -67,30 +50,31 @@ module dop1_m
!
Mmax = Ldatb
!
- CALL Set_Negative_E (derivs, derivsSelf)
+ CALL Set_Negative_E (calc)
!
- DO Iso=1,derivs%getUsedIsotopes()
- Isox = Iso
+ DO Isox=1,derivs%getUsedIsotopes()
Mmm = Mmmmmm
Kkkmin = 0
Kkkkkk = 0
nauxStart = 0
! *** Loop over Energies
+
DO I=1,Imax
Mmm = Mmm + 1
!
- call derivs%reserveColumnsNs(Kkkkkk+1, derivs%getNnnsig(),numUsedPar+1)
- IF (Ksindi.NE.0) THEN
- call derivsSelf%reserveColumnsNs(Kkkkkk+1, derivsSelf%getNnnsig(),numUsedPar+1)
+ call derivs%reserveColumnsNs(Kkkkkk+1, derivs%getNnnsig(),calc%getNumParams()+1)
+ IF (calc%hasSelf) THEN
+ call calc%dataSelf%reserveColumnsNs(Kkkkkk+1, calc%dataSelf%getNnnsig(),calc%getNumParams()+1)
END IF
!
Ii = I
M = I
! *** Do the broadening integration
- DO K=1,K2pls1
- IF (Coef(K).NE.0.0d0.and.m.le.Mmax) THEN
- Cc = Coef(K) * grid%getEnergy(M, expData)
- CALL Multiply_by_Coef (Kkkkkk+1, derivs, derivsSelf, Cc, M, Isox)
+ DO K=1,calc%K2pls1
+ Coef = calc%coefGrid%getData(K,1)
+ IF (Coef.NE.0.0d0.and.m.le.Mmax) THEN
+ Cc = Coef * calc%getEnergyUnbroadened(M)
+ CALL Multiply_by_Coef (calc, Kkkkkk+1, Cc, M, Isox)
END IF
M = M + 1
IF (M.GT.Mmax) GO TO 195
@@ -98,12 +82,12 @@ module dop1_m
!
!
IF (Kkkmin.EQ.0) Kkkmin = Mmm
- Ebm = grid%getEnergy(Mmm, expData)
+ Ebm = calc%getEnergyUnbroadened(Mmm)
Kkkkkk = Kkkkkk + 1
! ****** transform back to cross section (from E*Sigma)
- CALL Transform_to_Cross ( derivs, derivsSelf, Kkkkkk, Ebm, Isox)
+ CALL Transform_to_Cross ( calc, Kkkkkk, Ebm, Isox)
END DO
GO TO 196
@@ -111,19 +95,28 @@ module dop1_m
Imax = I
196 CONTINUE
!
- IF (Ksolve.NE.2 .AND. Kvtemp.GT.0) THEN
+ IF (calc%getNumParams().gt.0 .AND. Kvtemp.GT.0) THEN
! *** generate derivatives wrt temperature
- CALL Temp_Deriv ( derivs, derivsSelf, Imax)
+ CALL Temp_Deriv ( calc, Imax)
END IF
!
END DO
!
- call setAuxGridRowMax(Kkkkkk)
nauxStart = Kkkmin
- call dopplerOption%lealHwang%updateBroadenedOffset(nauxStart)
- call dopplerOption%lealHwang%setLength(Kkkkkk)
-!
- call grid%destroy()
+ ! If the broadenened data are store on the experimental
+ ! grid, the function calc%updateBroadenedOffset
+ ! does not have any effect (as we alwayas make
+ ! sure that all experimental data are calcuated).
+ ! Broadened data are on the experimental
+ ! grid if there is no more broadening
+ call calc%updateBroadenedOffset(nauxStart)
+ call calc%setLength(Kkkkkk)
+!
+ ! this function set the grid offset on the auxillary grid
+ ! regardless of whether the final broadened data
+ ! are on the experimental grid.
+ ! It is used if printing the interpolated cross section
+ ! in SAMMY output
call setAuxGridOffset(nauxStart)
RETURN
!
@@ -132,34 +125,26 @@ module dop1_m
!
! ____________________________________________________________________
!
- SUBROUTINE Set_Negative_E (derivs, derivsSelf)
+ SUBROUTINE Set_Negative_E (calc)
! *** Purpose -- generate the data for negative-velocity points
! *** NOTE -- Integrand requires " sigma(E<0) times (sqrt(-E))**2 " for
! *** which "sigma(E<0)" is negative, and "(sqrt(-E))**2" is
! *** positive. Since we Store E as negative, we'll instead
! *** store "sigma(E<0)" as postive, and use "E" (which is
-! *** negative) instead of "(sqrt(-E))**2" (which is positive).
- use fixedi_m
- use ifwrit_m
- use EndfData_common_m
- use DerivativeHandler_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- type(GridData)::grid
+! *** negative) instead of "(sqrt(-E))**2" (which is positive).
real(kind=8)::ee, val
- integer::j1,j2,ii
- type(DerivativeHandler)::derivs, derivsSelf
-!
- call expData%getGrid(grid, 2) ! we ensured that it exists
-
+ class(LealHwangBroadening)::calc
+ type(DerivativeHandler)::derivs
+ integer::Ipar, Iso, Jj, Ll, N
- ll = grid%getLength()
- if (numcro.gt.1) ll = ll/numcro
+ ll = calc%getNumEnergyUnbroadened()
+ call calc%getData(derivs)
DO Jj=1,ll
- ee = grid%getData((Jj-1)*numcro+1, 1)
+ ee = calc%getEnergyUnbroadened(jj)
if (ee.ge.0.0d0) exit
DO Iso=1,derivs%getUsedIsotopes()
! set negative cross section to positive
- DO Ipar=0,numUsedPar
+ DO Ipar=0,calc%getNumParams()
do N=1, derivs%getNnnsig()
val = derivs%getDataNsOld(Jj, N, Ipar, iso)
if (val.ne.0.0d0) then
@@ -168,11 +153,11 @@ module dop1_m
end if
end do
- IF (Ksindi.NE.0.and.N.eq.1) THEN ! self indicated cross section only has 1 section
- val = derivsSelf%getDataNsOld(Jj, 1, Ipar, iso)
+ IF (calc%hasSelf) THEN ! self indicated cross section only has 1 section
+ val = calc%dataSelf%getDataNsOld(Jj, 1, Ipar, iso)
if (val.ne.0.0d0) then
val = -1.0d0*val
- call derivsSelf%addDataNsOld(Jj, 1, Ipar, iso, val)
+ call calc%dataSelf%addDataNsOld(Jj, 1, Ipar, iso, val)
end if
end if
END DO
@@ -185,35 +170,35 @@ module dop1_m
!
! ____________________________________________________________________
!
- SUBROUTINE Multiply_By_Coef (irow, derivs, derivsSelf, Cc, M, Isox)
- use fixedi_m
- use ifwrit_m
- use DerivativeHandler_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- type(DerivativeHandler)::derivs, derivsSelf
+ SUBROUTINE Multiply_By_Coef (calc, irow, Cc, Mm, Isox)
+ class(LealHwangBroadening)::calc
+ type(DerivativeHandler)::derivs
+ real(kind=8)::Cc
+ integer::Mm, Isox
integer::irow
+ integer::Ipar, N
+ real(kind=8)::val
!
- Mm = M
- Iso = Isox
+ call calc%getData(derivs)
DO N=1,derivs%getNnnsig()
! update cross section (ipar=0) as well as derivatives
- DO Ipar=0,numUsedPar
- val = derivs%getDataNsOld(Mm, n, Ipar, Iso)*Cc
- val = val + derivs%getDataNs(irow, N, Ipar, Iso)
+ DO Ipar=0,calc%getNumParams()
+ val = derivs%getDataNsOld(Mm, n, Ipar, Isox)*Cc
+ val = val + derivs%getDataNs(irow, N, Ipar, Isox)
if (val.eq.0.0d0) cycle
- call derivs%addDataNs(irow, n, Ipar, Iso, val)
+ call derivs%addDataNs(irow, n, Ipar, Isox, val)
end do
END DO
!
- IF (Ksindi.NE.0) THEN
+ IF (calc%hasSelf) THEN
! update cross section (ipar=0) as well as derivatives
- DO N=1,derivsSelf%getNnnsig()
+ DO N=1,calc%dataSelf%getNnnsig()
! update cross section (ipar=0) as well as derivatives
- DO Ipar=0,numUsedPar
- val = derivsSelf%getDataNsOld(Mm, n, Ipar, Iso)*Cc
- val = val + derivsSelf%getDataNs(irow, N, Ipar, Iso)
+ DO Ipar=0,calc%getNumParams()
+ val = calc%dataSelf%getDataNsOld(Mm, n, Ipar, Isox)*Cc
+ val = val +calc%dataSelf%getDataNs(irow, N, Ipar, Isox)
if (val.eq.0.0d0) cycle
- call derivsSelf%addDataNs(irow, n, Ipar, Iso, val)
+ call calc%dataSelf%addDataNs(irow, n, Ipar, Isox, val)
end do
END DO
END IF
@@ -224,14 +209,9 @@ module dop1_m
!
! ____________________________________________________________________
!
- Subroutine Temp_Deriv ( derivs, derivsSelf, Imax)
- use fixedi_m
- use ifwrit_m
- use abro_common_m
- use DerivativeHandler_M
- IMPLICIT None
-!
- type(DerivativeHandler)::derivs, derivsSelf
+ Subroutine Temp_Deriv ( calc, Imax)
+ class(LealHwangBroadening)::calc
+ type(DerivativeHandler)::derivs
integer::Imax
integer::Kvt
real(kind=8)::val1, val2, val3, resVal, Sig0,delt6
@@ -239,7 +219,8 @@ module dop1_m
Sig0 = 0.0d0
Kvt = Kvtemp
- delt6 = delt * 6.0d0
+ delt6 = calc%delT * 6.0d0
+ call calc%getData(derivs)
DO Iso=1,derivs%getUsedIsotopes()
DO N=1,derivs%getNnnsig()
val1 = derivs%getDataNs(1, 1, 0, iso)
@@ -260,20 +241,20 @@ module dop1_m
END DO
END DO
!
- IF (Ksindi.NE.0) THEN
+ IF (calc%hasSelf) THEN
DO Iso=1,derivs%getUsedIsotopes()
- val1 = derivsSelf%getData(1,0,Iso)
- val2 = derivsSelf%getData(2,0,Iso)
+ val1 = calc%dataSelf%getData(1,0,Iso)
+ val2 = calc%dataSelf%getData(2,0,Iso)
resVal = (Sig0 - val1*2.0d0 + val2) / Delt6
- call derivsSelf%addData(1, Kvt, Iso, resVal)
+ call calc%dataSelf%addData(1, Kvt, Iso, resVal)
END DO
DO I=2,Imax-1
DO Iso=1,derivs%getUsedIsotopes()
- val1 = derivsSelf%getData(I-1, 0, Iso)
- val2 = derivsSelf%getData(I, 0, Iso)
- val3 = derivsSelf%getData(I+1, 0, Iso)
+ val1 = calc%dataSelf%getData(I-1, 0, Iso)
+ val2 = calc%dataSelf%getData(I, 0, Iso)
+ val3 = calc%dataSelf%getData(I+1, 0, Iso)
resVal = (val1 - val2*2.0d0 + val3) / Delt6
- call derivsSelf%addData(1, Kvt, Iso, resVal) ! Todo: Is this right? This is what it was
+ call calc%dataSelf%addData(1, Kvt, Iso, resVal) ! Todo: Is this right? This is what it was
END DO
END DO
END IF
@@ -283,17 +264,17 @@ module dop1_m
!
! ____________________________________________________________________
!
- SUBROUTINE Transform_to_Cross ( derivs, derivsSelf, irow, Ebm, Isox)
- use fixedi_m
- use ifwrit_m
- use DerivativeHandler_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- type(DerivativeHandler)::derivs, derivsSelf
+ SUBROUTINE Transform_to_Cross (calc, irow, Ebm, Isox)
+ class(LealHwangBroadening)::calc
+ type(DerivativeHandler)::derivs
+ integer::irow, Isox
+ real(kind=8)::Ebm
real(kind=8)::val
+ integer::Ipar, Iso, N
- Iso = Isox
+ call calc%getData(derivs)
DO N=1,derivs%getNnnsig()
- do ipar = 0, numUsedPar
+ do ipar = 0, calc%getNumParams()
val = derivs%getDataNs(irow, N, Ipar, isox)
if( val.eq.0.0d0) cycle
val = val/Ebm
@@ -301,13 +282,13 @@ module dop1_m
end do
END DO
!
- IF (Ksindi.NE.0) THEN
- DO N=1,derivsSelf%getNnnsig()
- do ipar = 0, numUsedPar
- val = derivsSelf%getDataNs(irow, N, Ipar, isox)
+ IF (calc%hasSelf) THEN
+ DO N=1,calc%dataSelf%getNnnsig()
+ do ipar = 0, calc%getNumParams()
+ val = calc%dataSelf%getDataNs(irow, N, Ipar, isox)
if( val.eq.0.0d0) cycle
val = val/Ebm
- call derivsSelf%addDataNs(irow, N, Ipar, isox, val)
+ call calc%dataSelf%addDataNs(irow, N, Ipar, isox, val)
end do
END DO
END IF
diff --git a/sammy/src/dop/mdop2.f90 b/sammy/src/dop/mdop2.f90
index 290e00f2d4ef8807015e91bdc949ea2ebd32d718..9407a07f2aa59fbc7d463c2b7da48142f5b469ec 100755
--- a/sammy/src/dop/mdop2.f90
+++ b/sammy/src/dop/mdop2.f90
@@ -1,21 +1,28 @@
module dop2_m
use GridData_M
+ implicit none
+
+ public Coefgn
contains
!
!
! __________________________________________________________________
!
- SUBROUTINE Coefgn (Coef, Jjjjjj, J2pls1, Mmmmmm, M2pls1, Kkkxxx)
+ SUBROUTINE Coefgn (Coef, Jjjjjj, Mmmmmm, M2pls1)
!
! *** revised extensively July 1996 to increase speed & accuracy
!
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- type(GridData)::Coef
- DATA Two /2.0d0/, Four /4.0D0/
+ type(GridData)::Coef
+ integer:: Mmmmmm
+ integer::Jjjjjj, M2pls1
+ real(kind=8),parameter::Two=2.0d0, Four=4.0D0
+ real(kind=8)::Ans, C, Cay, Cay2, Fac
+ real(kind=8)::Ratio, Ratio2, tmp, X, Y
+ integer::I, Ii, Itimes, M, Max, Mj, Mm, Mstart, Mstmin, Mstop
+ integer::Mstopx, N, Nj, Np1, Mwhich
!
N = Jjjjjj
- J2pls1 = 2*N + 1
!
Cay = Four
Cay2 = Cay + Two
@@ -93,12 +100,7 @@ module dop2_m
70 CONTINUE
Np1 = Mmmmmm + 1
M2pls1 = Np1 + Mmmmmm
-!
- IF (Kkkxxx.EQ.1) THEN
- WRITE (06,10000) Jjjjjj, Mmmmmm, Mstmin, Mstopx
-10000 FORMAT (' J, M, Mstart, Mstop =', 4I10)
- RETURN
- END IF
+
!
! *** rearrange storage of Coef ... 1 to m+1 now goes to m+1 to 2m+1
C = Coef%getData(Np1, 1)
@@ -134,9 +136,12 @@ module dop2_m
! *** method: directly if N < 128
! *** via asymptotic expAnsion for ln(N) if N > 128
!
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DATA Dln2pi/1.8378770664125945d0/, One /1.0d0/
-! / ln ( 2 pi)
+ real(kind=8)::Cay, Cay2, Ratio, Ratio2, Ans
+ integer::N, J, M
+ real(kind=8),parameter::Dln2pi=1.8378770664125945d0, One=1.0d0
+ ! / ln ( 2 pi)
+ integer::Jj, L, Mj, Mm, Nm, Nn
+ real(kind=8)::X,Y
!
X = dFLOAT(N+3)**2 + 3.0d0*dFLOAT(J)**2
X = 2.0d0*dSQRT(X) - dFLOAT(N+3*J+9)
diff --git a/sammy/src/end/msamvv.f b/sammy/src/end/msamvv.f
index 1f3a0b1613d9cfe4cba812120f1f8937cc36b3e0..1c1030a81bce9f5a46ee8b33719cfd3f93be45a6 100644
--- a/sammy/src/end/msamvv.f
+++ b/sammy/src/end/msamvv.f
@@ -1,6 +1,3 @@
-C
- use cbro_common_m
- END
C
C
C --------------------------------------------------------------
@@ -36,7 +33,6 @@ C
C *** Note that this routine actually performs more useful functions
C *** in file msamww.f, which is used for debugging.
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- I = Idimen (0, 0, '0, 0')
CALL Timer (0)
RETURN
END
@@ -51,7 +47,6 @@ C *** in file msamzz.f, which is used for debugging.
IMPLICIT DOUBLE PRECISION (a-h,o-z)
Ngbinx = Ngbout
Nsgbin = Nsgbou
- I = Idimen (0, 0, '0, 0')
CALL Timer (0)
RETURN
END
diff --git a/sammy/src/end/msamxx.f b/sammy/src/end/msamxx.f
index bfc06b4b1e575f7da2cc7d33e16e257a11454a63..c32d28afda0e2588ccdb4fce3fc528b4fea6550d 100755
--- a/sammy/src/end/msamxx.f
+++ b/sammy/src/end/msamxx.f
@@ -111,7 +111,7 @@ C
ELSE IF (Ix.EQ.2) THEN
C *** For call from end of SAMMAS, or from DOPUSHx or others
Tabsol = Tiniti
-C
+
ELSE
C ELSE IF (Ix.GT.3 .OR. Ix.LT.0)
STOP '[STOP in Timer in end/msamxx.f]'
@@ -123,8 +123,8 @@ C
IF (Ix.NE.3) THEN
C
cq WRITE (21,99999) (Segmen(I),I=1,3), Trel
- WRITE ( line,99999) (Segmen(I),I=1,3), Trel
-99999 FORMAT (40X, 'CPU for SAMMY-', 3A1, ' =', 0PF9.2, ' sec')
+ WRITE ( line,99999) Trel
+99999 FORMAT (40X, 'CPU for this section is ', 0PF9.2, ' sec')
call printStdoutData(line)
C
diff --git a/sammy/src/fgm/FreeGasDopplerBroadening_M.f90 b/sammy/src/fgm/FreeGasDopplerBroadening_M.f90
index f616b6e180e85a37cbf13ef4787d23345da11366..41b7e9b1e32ba459034f1111d7b9d79d6ab3f20b 100644
--- a/sammy/src/fgm/FreeGasDopplerBroadening_M.f90
+++ b/sammy/src/fgm/FreeGasDopplerBroadening_M.f90
@@ -1,24 +1,17 @@
module FreeGasDopplerBroadening_M
use, intrinsic :: ISO_C_BINDING
-use DopplerAndResolutionBroadener_M
+use FortranExtDopplerBroadening_M
+use DopplerBroadening_M
use DerivativeHandler_M
use GridData_M
implicit none
-type, extends(DopplerAndResolutionBroadener) :: FreeGasDopplerBroadening
+type, extends(FortranExtDopplerBroadening) :: FreeGasDopplerBroadening
real(kind=8),allocatable,dimension(:)::velocity
-real(kind=8)::temp
-integer::numPar
-type(DerivativeHandler)::dataSelf
-logical::hasSelf = .false.
contains
procedure, pass(this) :: initialize => FreeGasDopplerBroadening_initialize
procedure, pass(this) :: broaden => FreeGasDopplerBroadening_broaden
-procedure, pass(this) :: addSelfData => FreeGasDopplerBroadening_addSelfData
-procedure, pass(this) :: transferUnbroadenedAll => FreeGasDopplerBroadening_transferUnbroadenedAll
-procedure, pass(this) :: transferUnbroadened => FreeGasDopplerBroadening_transferUnbroadened
-procedure, pass(this) :: transferUnbroadenedSelf => FreeGasDopplerBroadening_transferUnbroadenedSelf
procedure, pass(this) :: destroy => FreeGasDopplerBroadening_destroy
end type FreeGasDopplerBroadening
@@ -29,104 +22,28 @@ subroutine FreeGasDopplerBroadening_initialize(this, hand, list, work)
class(DerivativeHandler)::hand
class(GridDataList)::list
class(GridDataList)::work
- call DopplerAndResolutionBroadener_initialize(this, hand, list, work)
+ call FortranExtDopplerBroadening_initialize(this, hand, list, work)
end subroutine
subroutine FreeGasDopplerBroadening_destroy(this)
implicit none
class(FreeGasDopplerBroadening) :: this
- call DopplerAndResolutionBroadener_destroy(this)
+ call FortranExtDopplerBroadening_destroy(this)
if( allocated(this%velocity)) deallocate(this%velocity)
end subroutine
-subroutine FreeGasDopplerBroadening_addSelfData(this, self, copyData, ipos)
- class(FreeGasDopplerBroadening) :: this
- type(DerivativeHandler)::self
- type(DerivativeHandler)::data
- logical::copyData
- integer:: ipos
-
- integer::iso, jdat, Ii
- real(kind=8)::val
-
- this%dataSelf%instance_ptr=self%instance_ptr
- this%hasSelf = .true.
- if( .not.copyData) return
-
- call this%getData(data)
-
- ! Note this is after the switch, ergo operate on old data
- DO Iso=1,this%dataSelf%getUsedIsotopes()
- do jdat = 1, this%getNumEnergyUnbroadened()
- DO Ii=0,this%numPar
- val = data%getDataNsOld(Jdat, ipos, Ii, Iso)
- if (val.ne.0.0d0) then
- call this%dataSelf%addDataNsOld(Jdat, 1, Ii, Iso, val)
- else
- if (this%dataSelf%getDataNsOld(Jdat, 1, Ii, Iso).ne.0.0d0) then
- call this%dataSelf%addDataNsOld(Jdat, 1, Ii, Iso, val)
- end if
- end if
- end do
- end do
- end do
-end subroutine
-
-subroutine FreeGasDopplerBroadening_transferUnbroadened(this, ipos, iso, iflag)
- class(FreeGasDopplerBroadening) :: this
- integer::ipos, iso, iflag
-
- type(DerivativeHandler)::data
- integer::ipar, n, inew
- real(kind=8)::val
-
- inew = this%getCurrentPos()
- call this%getData(data)
- do ipar = 0, this%numPar
- if (ipar.gt.0.and.iflag.eq.ipar) cycle
- do n = 1, data%getNnnsig()
- val = data%getDataNsOld(ipos, N, ipar, iso)
- if (val.eq.0.0d0) cycle
- call data%addDataNs(inew, N, ipar, Iso, val)
- end do
- end do
-end subroutine
-subroutine FreeGasDopplerBroadening_transferUnbroadenedSelf(this, ipos, iso, iflag)
- class(FreeGasDopplerBroadening) :: this
- integer::ipos, iso, iflag
-
- integer::ipar, n, inew
- real(kind=8)::val
-
- inew = this%getCurrentPos()
- if (this%hasSelf) then
- do ipar = 0, this%numPar
- if (ipar.gt.0.and.iflag.eq.ipar) cycle
- do n = 1, this%dataSelf%getNnnsig()
- val = this%dataSelf%getDataNsOld(ipos, N, ipar, iso)
- if (val.eq.0.0d0) cycle
- call this%dataSelf%addDataNs(inew, N, ipar, Iso, val)
- end do
- end do
- end if
-end subroutine
-subroutine FreeGasDopplerBroadening_transferUnbroadenedAll(this, ipos, iso, iflag, iflagSelf)
- class(FreeGasDopplerBroadening) :: this
- integer::ipos, iso, iflag, iflagSelf
-
- call this%transferUnbroadened(ipos, iso, iflag)
- call this%transferUnbroadenedSelf(ipos, iso, iflagSelf)
-end subroutine
subroutine FreeGasDopplerBroadening_broaden(this)
use AllocateFunctions_m
class(FreeGasDopplerBroadening) :: this
- integer::ndatb, i
+ integer::ndatb, i,current1, current2
real(kind=8)::ener
type(DerivativeHandler)::data
+ call FortranExtDopplerBroadening_broaden(this)
+
ndatb = this%getNumEnergyUnbroadened()
call allocate_real_data(this%velocity, 2*ndatb)
@@ -142,16 +59,7 @@ subroutine FreeGasDopplerBroadening_broaden(this)
this%velocity(I) = dSQRT(ener)
end if
end do
-
- ! reserve the data
- ndatb = this%getNumEnergyBroadened()
- call this%getData(data)
- call data%nullify()
- call data%reserve(ndatb*data%getNnnsig(), this%numPar+1)
- if( this%hasSelf) then
- call this%dataSelf%nullify()
- call this%dataSelf%reserve(ndatb*this%dataSelf%getNnnsig(), this%numPar+1)
- end if
end subroutine
+
end module FreeGasDopplerBroadening_M
diff --git a/sammy/src/fgm/mfgm0.f90 b/sammy/src/fgm/mfgm0.f90
index 58e1c0a1bc1a93cfe9f6814d8bdc0f187c5f9f7e..3e03e28af1d6042fdcc44f4daa3463163243299c 100644
--- a/sammy/src/fgm/mfgm0.f90
+++ b/sammy/src/fgm/mfgm0.f90
@@ -1,105 +1,58 @@
-!
-!
- Subroutine Samfgm_0(broadener)
-!
+module FreeGasDopplerBroadeningImpl_m
+use FreeGasDopplerBroadening_M
+implicit none
+type, extends(FreeGasDopplerBroadening) :: FreeGasDopplerBroadeningImpl
+contains
+procedure, pass(this) :: initialize => FreeGasDopplerBroadeningImpl_initialize
+procedure, pass(this) :: broaden => FreeGasDopplerBroadeningImpl_broaden
+procedure, pass(this) :: destroy => FreeGasDopplerBroadeningImpl_destroy
+end type FreeGasDopplerBroadeningImpl
+
+contains
+subroutine FreeGasDopplerBroadeningImpl_initialize(this, hand, list, work)
+ implicit none
+ class(FreeGasDopplerBroadeningImpl) :: this
+ class(DerivativeHandler)::hand
+ class(GridDataList)::list
+ class(GridDataList)::work
+ call FreeGasDopplerBroadening_initialize(this, hand, list, work)
+end subroutine
+
+subroutine FreeGasDopplerBroadeningImpl_destroy(this)
+ implicit none
+ class(FreeGasDopplerBroadeningImpl) :: this
+ call FreeGasDopplerBroadening_destroy(this)
+end subroutine
+
+subroutine FreeGasDopplerBroadeningImpl_broaden(this)
+
! *** Purpose -- Calculate Doppler broadening using free-gas model with
! *** auxiliary energy- (velocity-) grid of varying spacing
!
- use fixedi_m, only : Jwwwww, K2reso, Kkkdex, &
- Kkkrsl, Ndatd, Nudwhi, &
- Numorr, Numrpi, numcro, Lllmax, numUsedPar
- use ifwrit_m, only : Kaverg, Kcros, Kplotu, Ksolve, Kvers7, &
- Ndatb, Ntgrlq, ktzero, Ksitmp, Ksindi
- use fixedr_m, only : temp
- use exploc_common_m
- use array_sizes_common_m
- use oopsch_common_m, only : Nowwww, Segmen
- use lbro_common_m, only : Debug, Yresol, Yssmsc
- use AllocateFunctions_m
- use rsl7_m
- use mxct27_m
+ use exploc_common_m, only : A_Idpiso, I_Iflmsc
use mfgm1_m
- use SammyLptPrinting_m
- use FreeGasDopplerBroadening_M
- use EndfData_common_m, only : expData
- use GridData_M
+ use SammyLptPrinting_m
IMPLICIT None
!
character(len=80)::line
- type(FreeGasDopplerBroadening)::broadener
- integer::N, Nn, Kdatb, ii
+ class(FreeGasDopplerBroadeningImpl) :: this
!
!
WRITE (line,99999)
99999 FORMAT (' *** SAMMY-FGM 3 Oct 08 ***')
call printStdoutData(line)
- Segmen(1) = 'F'
- Segmen(2) = 'G'
- Segmen(3) = 'M'
- Nowwww = 0
-
- broadener%temp = temp
- broadener%numPar = numUsedPar
-!
- CALL Initix
- IF (Kplotu.NE.0 .AND. Kaverg.NE.2 .AND. Kaverg.NE.3) Kplotu = 0
-!
- Kdatb = Ndatd
- IF (Kdatb.EQ.0) Kdatb = Ndatb
-!
-!
-! *** GUESSTIMATE SIZE OF ARRAY NEEDED FOR SAMFGM
- CALL Estfgm (Kdatb)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! *** One ***
-
- if (Kcros.EQ.8) THEN
- call broadener%addSelfData(calcDataSelf, Ksindi.le.0.and.Ksitmp.GT.0, Lllmax+1)
- END IF
-!
- N = 1
- Nn = 1
- Jwwwww = 2
- IF (Kcros.EQ.8) THEN
- Jwwwww = 6
- END IF
!
- call broadener%broaden()
+ call FreeGasDopplerBroadening_broaden(this)
!
!
! *** Dopfgm PERFORMS DOPPLER BROADENING OPERATION
- CALL Dopfgm( broadener, A_Idpiso , A_Idsiso , I_Iflmsc)
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-!
-!
- CALL Write_Commons_Many
- RETURN
-!
- END
-!
-!
-! __________________________________________________________________
-!
- SUBROUTINE Estfgm (Kdatb)
-!
-! *** purpose -- estimate array size for this segment
+ CALL Dopfgm( this, A_Idpiso , I_Iflmsc, this%Brdlim)
!
+END subroutine
+end module FreeGasDopplerBroadeningImpl_m
- IMPLICIT none
- integer::Kdatb
- integer::I,k,Idimen
- external Idimen
-!
-! *** One
-!x CALL Figure_KWs_1 (Kone)
-!
-!x K = Kone + 2*Kdatb
- K = 2*Kdatb
- K = Idimen (K, 1, 'K, 1')
- I = Idimen (K, -1, 'K, -1')
- I = Idimen (0, 0, '0, 0')
- RETURN
- END
diff --git a/sammy/src/fgm/mfgm1.f90 b/sammy/src/fgm/mfgm1.f90
index 70b0d3e45b09303c910d42abda394279e9f0681d..8b56b51ba88bccb828c47caea3bd64bd91810e5d 100644
--- a/sammy/src/fgm/mfgm1.f90
+++ b/sammy/src/fgm/mfgm1.f90
@@ -1,48 +1,35 @@
module mfgm1_m
+use ifwrit_m, only : Ksitmp, Nolowb, Kvtemp
+use fixedr_m, only : Emax, Emin, Emins, Sitemp, Emaxs
+use EndfData_common_m, only : resparData
+use mfgm4_m
+use FreeGasDopplerBroadening_M
+IMPLICIT none
+
+public Dopfgm
+
contains
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Dopfgm ( broadener, Dopwid, Doswid, Iflmsc)
+ SUBROUTINE Dopfgm ( broadener, Dopwid, Iflmsc, Brdlim)
!
! *** PURPOSE -- FORM DOPPLER-BROADENED CROSS SECTION AND DERIVATIVES
!
- use fixedi_m, only : Ktruet, Lllmax, numUsedPar, &
- numcro
- use ifwrit_m, only : Kcros, Kdebug, Ksindi, ktzero, Kvtemp, &
- Kvthck, ndat, Nolowb, ndat, Nonu, &
- Kfinit, Ksitmp
- use fixedr_m, only : Elowbr, Emax, Emin, Emins, Sitemp, Temp, Thick, Emaxs
- use broad_common_m, only : Brdlim
- use brdd_common_m, only : Ipnts, Iup, Kc
- use lbro_common_m, only : Yresol, Yssmsc, Ytrans
- use EndfData_common_m, only : expData, resparData
- use AuxGridHelper_M, only : setAuxGridOffset, setAuxGridRowMax
- use array_sizes_common_m, only : calcData, calcDataSelf
- use xct2_m
- use mxct27_m
- use SammyGridAccess_M
- use mfgm4_m
- use EndfData_common_m, only : resParData
- use convert_to_transmission_m
- use SumIsoAndConvertToTrans_M
- use FreeGasDopplerBroadening_M
-
- IMPLICIT None
- LOGICAL Need_isotopes
- LOGICAL Another_Process_Will_Happen
-!
- type(FreeGasDopplerBroadening)::broadener
+
+ class(FreeGasDopplerBroadening)::broadener
+ type(DerivativeHandler)::calcData
+ real(kind=8)::Brdlim
real(kind=8)::ee
- real(kind=8):: Dopwid(*), Doswid(*)
+ real(kind=8):: Dopwid(*)
integer:: Iflmsc(*)
real(kind=8)::Zero, A1, A2
real(kind=8)::Ddo, Ddosin, Ddox, Em, Vlimit, Vlow
real(kind=8)::Vlowbr, Vup, Vv, Vslimi, Elow, Ehigh
- integer::Iffy, Iso, Isomax, Iw, Jdat,iiso
+ integer::Iffy, Iso, Isomax, Iw, Jdat,iiso, Iup
integer(C_SIZE_T)::IsoIndex
- integer::Kkkkkk, Kkkmin, Ngtvx, Now,nauxStart
+ integer::Kkkkkk, Ngtvx, Now,nauxStart
integer::nauxMax, insig, Iipar, ii,numEl, iposVel, IflmscKsitmp
@@ -50,17 +37,12 @@ contains
nauxMax = broadener%getNumEnergyUnbroadened()
- numEl = broadener%getNumEnergyBroadened()
+ numEl = broadener%getNumEnergyBroadened()
+ call broadener%getData(calcData)
!
!
! *** FORM DOPPLER-BROADENED CROSS SECTION, STORE IN X5.
! *** ALSO DOPPLER-BROADEN THE PARTIAL DERIVATIVES.
-!
- Need_Isotopes = Yssmsc
- Another_Process_Will_Happen = Yresol.OR.Yssmsc
-
-
-
!
!
Now = 0 ! number of un-broadened points
@@ -69,7 +51,7 @@ contains
IF (Isomax.EQ.0) STOP '[STOP in Dopfgm in fgm/mfgm1.f]'
IflmscKsitmp = 0
- if( Kcros.eq.8) IflmscKsitmp = Iflmsc(Ksitmp)
+ if( broadener%hasSelf) IflmscKsitmp = Iflmsc(Ksitmp)
!
! *** Do separately for each isotope (nuclide), since Doppler-width is
@@ -78,7 +60,7 @@ contains
iiso = isoIndex ! convert c_size_t to fortran integer
iso = IsoIndex
if (isomax.gt.0) iso = calcData%getRealIsotopeIndex(IsoIndex)
- if (Iso.le.0) GO TO 80 ! not included in the calculation
+ if (Iso.le.0) cycle ! not included in the calculation
! iso = index of isotope in resParData (or if summed the summed isotope
! iiso and IsoIndex, index of iso in calcData (potentially different if doing scattering with threshold reactions)
@@ -94,7 +76,7 @@ contains
END IF
! -------------------------------
Iffy = 0
- Kc = 1
+ broadener%Kc = 1
Iup = 0
!
! *** "Ddo" is the broadening width in sqrt(E)-space, so integration
@@ -102,15 +84,17 @@ contains
Ddo = Dopwid(Iso)
Vlimit = Brdlim*Ddo
IF (Ksitmp.GT.0) THEN
- Ddosin = Doswid(Iso)
+ ! adjust factor for SiTemp
+ Ddosin = dSQRT(broadener%getTemperature())
+ Ddosin = Dopwid(Iso)/Ddosin
+ Ddosin = Ddosin * dsqrt(broadener%SiTemp)
Vslimi = Brdlim*Ddosin
ELSE
Ddosin = Zero
Vslimi = Zero
END IF
- Vlowbr = dSQRT(Elowbr)
+ Vlowbr = dSQRT(broadener%Elowbr)
!
- Kkkmin = 0
Kkkkkk = 0
nauxStart = 0
!
@@ -127,7 +111,7 @@ contains
10001 FORMAT (' *** on data point number', I10)
!
Em = broadener%getEnergyBroadened(Jdat) ! desired energy
- iposVel = broadener%getEmInUnbroadened(Em, iposVel) ! find position (iposVel) in un-broadened grid and get the velocity
+
! convert Em to velocity
if (Em.lt.0.0d0) then
@@ -141,31 +125,36 @@ contains
IF (Em.LT.Emins) THEN
! These points are the very low-energy limit,
! of very little interest, ergo copy as is
+ iposVel = broadener%getEmInUnbroadened(Em, iposVel) ! find position (iposVel) in un-broadened grid and get the velocity
IF (broadener%getEnergyUnbroadened(iposVel+1).GE.Emin) THEN
Now = Now + 1
- call broadener%transferUnbroadenedAll(iposVel, iiso, Kvtemp, IflmscKsitmp)
- GO TO 40
+ call broadener%transferUnbroadenedAll(iposVel, iiso, Kvtemp, IflmscKsitmp)
+ Kkkkkk = Kkkkkk + 1
+ cycle
ELSE
nauxStart = iposVel
- go to 70
+ cycle
END IF
ELSE IF (Em.GT.Emaxs) THEN
! These points are the very high-energy limit,
! of very little interest, ergo copy as is
ee = 0.0
+ iposVel = broadener%getEmInUnbroadened(Em, iposVel) ! find position (iposVel) in un-broadened grid and get the velocity
if (iposVel.gt.1) ee = broadener%getEnergyUnbroadened(iposVel-1)
IF (ee.LE.Emax) THEN
Now = Now + 1
- call broadener%transferUnbroadenedAll(iposVel, iiso, Kvtemp, IflmscKsitmp)
- GO TO 40
+ call broadener%transferUnbroadenedAll(iposVel, iiso, Kvtemp, IflmscKsitmp)
+ Kkkkkk = Kkkkkk + 1
+ cycle
ELSE
- GO TO 80
+ exit ! don't need to broaden at higher energies
END IF
END IF
!
!
!
! ********* regular Doppler for most cross sections
+ broadener%rowData = 0.0d0
Vup = Vv + Vlimit
IF (Vup.GT.broadener%velocity(nauxMax)) Vup = broadener%velocity(nauxMax)
Ehigh = Vup * Vup
@@ -177,19 +166,22 @@ contains
!
! *** find how many and which points are in integral for Jdat
call broadener%calcIntegralSpan(Elow, Ehigh)
- Kc = broadener%getIntegralStart()
- Ipnts = broadener%getIntegralSpan()
-!
- IF ((Nolowb.EQ.0 .OR. Vlowbr.LE.Vv) .AND. Ipnts.GT.2) THEN
-! *** Doppler-broaden
- CALL Xdofgm (broadener%velocity, calcData, &
- broadener%velocity(nauxMax+1:2*nauxMax), Em, Vv, Ddo, &
- Temp, Iffy, Kvtemp, iiso, Ngtvx, &
+ broadener%Kc = broadener%getIntegralStart()
+ broadener%Ipnts = broadener%getIntegralSpan()
+!
+ IF ((Nolowb.EQ.0 .OR. Vlowbr.LE.Vv) .AND. broadener%Ipnts.GT.2) THEN
+! *** Doppler-broaden
+ broadener%rowData = 0.0d0
+ CALL Xdofgm (broadener, broadener%velocity, calcData, &
+ broadener%velocity(nauxMax+1:2*nauxMax), Em, Vv, Ddo, &
+ broadener%getTemperature(), Iffy, Kvtemp, iiso, Ngtvx, &
Kkkkkk+1)
+ call broadener%copyRowData(calcData, iso)
ELSE
! *** IF too few points, do not broaden
Now = Now + 1
- call broadener%transferUnbroadened(iposVel, iiso, Kvtemp)
+ iposVel = broadener%getEmInUnbroadened(Em, iposVel) ! find position (iposVel) in un-broadened grid and get the velocity
+ call broadener%transferUnbroadenedBroad(calcData, iposVel, iiso, Kvtemp)
END IF
!
Ddox = Ddo
@@ -206,47 +198,43 @@ contains
Elow = Vlow * Vlow
if (Vlow.lt.0.0d0) Elow = -1.0d0 * Elow
call broadener%calcIntegralSpan(Elow, Ehigh)
- Kc = broadener%getIntegralStart()
- Ipnts = broadener%getIntegralSpan()
+ broadener%Kc = broadener%getIntegralStart()
+ broadener%Ipnts = broadener%getIntegralSpan()
END IF
!
! ********* broaden self-indication transmission separately
- IF (Kcros.EQ.8) THEN
- IF ((Nolowb.EQ.0.OR.Vlowbr.LE.Vv) .AND. Ipnts.GT.2) THEN
- CALL Xdofgm (broadener%velocity, calcDataSelf, &
- broadener%velocity(nauxMax+1:2*nauxMax), Em, Vv, Ddox, &
- Sitemp, Iffy, Iflmsc(Ksitmp), iiso, Ngtvx, &
+ IF (broadener%hasSelf) THEN
+ IF ((Nolowb.EQ.0.OR.Vlowbr.LE.Vv) .AND. broadener%Ipnts.GT.2) THEN
+ broadener%rowData = 0.0d0
+ CALL Xdofgm (broadener, broadener%velocity, broadener%dataSelf, &
+ broadener%velocity(nauxMax+1:2*nauxMax), Em, Vv, Ddox, &
+ Sitemp, Iffy, Iflmsc(Ksitmp), iiso, Ngtvx, &
Kkkkkk+1)
- ELSE
- call broadener%transferUnbroadenedSelf(iposVel, iiso, IflmscKsitmp)
+ call broadener%copyRowData(broadener%dataSelf, iso)
+ ELSE
+ iposVel = broadener%getEmInUnbroadened(Em, iposVel) ! find position (iposVel) in un-broadened grid and get the velocity
+ call broadener%transferUnbroadenedBroad(broadener%dataSelf, iposVel, iiso, IflmscKsitmp)
END IF
END IF
-!
- 40 CONTINUE
+
Kkkkkk = Kkkkkk + 1
- IF (Kkkmin.EQ.0) Kkkmin = Jdat
+
!
- 70 CONTINUE
END DO ! end loop over data
-!
- 80 CONTINUE
+
END DO ! *** end of do-loop on isotopes (nuclides)
!
!
nauxStart = nauxStart + 1
call broadener%updateBroadenedOffset(nauxStart)
call broadener%setLength(Kkkkkk)
- call setAuxGridRowMax(Kkkkkk)
IF (Iffy.EQ.0) WRITE (21,99998)
99998 FORMAT (/' ** NOTE -- NO DOPPLER BROADENING ACTUALLY OCCURED **')
IF (Now.NE.0) WRITE (21,99997) Now, Kkkkkk*Isomax
- IF (Now.NE.0 .AND. Kdebug.NE.0) WRITE (06,99997) Now,Kkkkkk*Isomax
+ IF (Now.NE.0 .AND. broadener%debugOutput) WRITE (06,99997) Now,Kkkkkk*Isomax
99997 FORMAT (' No Doppler broadening occured', I8,' times of a possible', I8)
-!
-
- call setAuxGridOffset(nauxStart)
RETURN
!
END
diff --git a/sammy/src/fgm/mfgm2.f90 b/sammy/src/fgm/mfgm2.f90
index 24b497c3d2d44e69e4fad4ab40fcacbd68e3933e..1057b85a6cbba63dca0424e48e1052c82671c955 100644
--- a/sammy/src/fgm/mfgm2.f90
+++ b/sammy/src/fgm/mfgm2.f90
@@ -1,4 +1,7 @@
module fgm2_m
+ use FreeGasDopplerBroadening_M
+ use abcexp_m
+ use abcerf_m
IMPLICIT None
real(kind=8)::Xm1, X00, Y00, Em1, E00, Z, W
integer::Im1, I00
@@ -19,16 +22,13 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Modsmp (Vv, Velcty, Wts, Ddo)
+ SUBROUTINE Modsmp (calc, Vv, Velcty, Wts, Ddo)
!
! *** Form the Gaussian Doppler weights via Simpson's rule, sort of, and
! *** normalize them
+!
!
- use brdd_common_m, only : Ipnts, Kc
- use abcexp_m
- use abcerf_m
- use AuxGridHelper_M, only : getNumAuxGridPoints
-!
+ class(FreeGasDopplerBroadening)::calc
Real(kind=8):: Velcty(*), Wts(*)
real(kind=8)::Vv, Ddo
real(kind=8)::Xm1, X00, Y00, Em1, E00, Z, W
@@ -36,18 +36,18 @@ module fgm2_m
real(kind=8)::Qq, S
integer::I, Itype, Kca, Kcmin, N, NN, nauxMax
!
- nauxMax = getNumAuxGridPoints()
- Kcmin = Kc - 1
+ nauxMax = calc%getNumEnergyUnbroadened()
+ Kcmin = calc%Kc - 1
IF (Kcmin.LT.1) THEN
Kcmin = 1
- WRITE (6,10000) Kcmin, Ipnts
-10000 FORMAT ('Kcmin & Ipnts in Modsmp=',2i5)
+ WRITE (6,10000) Kcmin, calc%Ipnts
+10000 FORMAT ('Kcmin & calc%Ipnts in Modsmp=',2i5)
END IF
Kca = Kcmin
!
- I00 = Kca - Kc + 1
+ I00 = Kca - calc%Kc + 1
IF (I00.LE.0) I00 = 1
- X00 = (Velcty(I00+Kc-1)-Vv)/Ddo
+ X00 = (Velcty(I00+calc%Kc-1)-Vv)/Ddo
E00 = X00**2
IF (E00.GT.Expmax) THEN
E00 = Zero
@@ -55,24 +55,24 @@ module fgm2_m
E00 = dEXP(-E00)
END IF
Wts(I00) = Zero
- CALL Resets (Vv, Velcty, Ddo, Kc)
+ CALL Resets (calc, Vv, Velcty, Ddo, calc%Kc)
!
!
Itype = 0
IF (X00.gt.Zero) Itype = 1
!
- IF (Im1+Kc.LE.1) THEN
-! *** Here for [Im1+Kc] < 1 so only I00 contributes
- CALL Resets (Vv, Velcty, Ddo, Kc)
- IF (Im1.EQ.Ipnts) GO TO 20
- IF (I00+Kc-1.LE.nauxMax) GO TO 10
+ IF (Im1+calc%Kc.LE.1) THEN
+! *** Here for [Im1+calc%Kc] < 1 so only I00 contributes
+ CALL Resets (calc, Vv, Velcty, Ddo, calc%Kc)
+ IF (Im1.EQ.calc%Ipnts) GO TO 20
+ IF (I00+calc%Kc-1.LE.nauxMax) GO TO 10
GO TO 20
END IF
!
!
10 CONTINUE
-! *** Here for normal case, 0 < Im1+Kc-1 < I00+Kc-1 < nauxMax
-! *** and 0 < Im1 < I00 < Ipnts+1
+! *** Here for normal case, 0 < Im1+calc%Kc-1 < I00+calc%Kc-1 < nauxMax
+! *** and 0 < Im1 < I00 < calc%Ipnts+1
IF (X00.GT.Zero) Itype = 1
IF (Itype.EQ.0) THEN
Qq = Abcerf (X00, Y00, A, B, C, N)
@@ -87,19 +87,19 @@ module fgm2_m
Wts(Im1) = Em1 * Y00 * (One + Two*X00*B + Bb) + Wts(Im1)
Wts(I00) = Em1 * Y00 * (One - Two*Xm1*B - Bb)
END IF
- CALL Resets (Vv, Velcty, Ddo, Kc)
- IF (Im1.EQ.Ipnts) GO TO 20
- IF (I00+Kc-1.LE.nauxMax) GO TO 10
+ CALL Resets (calc, Vv, Velcty, Ddo, calc%Kc)
+ IF (Im1.EQ.calc%Ipnts) GO TO 20
+ IF (I00+calc%Kc-1.LE.nauxMax) GO TO 10
!
!
20 CONTINUE
S = Zero
- DO I=1,Ipnts
+ DO I=1,calc%Ipnts
S = S + Wts(I)
END DO
S = One/S
- DO I=1,Ipnts
- Wts(I) = Wts(I)*S * Velcty(I+Kc-1)**2
+ DO I=1,calc%Ipnts
+ Wts(I) = Wts(I)*S * Velcty(I+calc%Kc-1)**2
END DO
!
RETURN
@@ -108,7 +108,8 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Resets (Vv, Velcty, Ddo, Kc)
+ SUBROUTINE Resets (calc, Vv, Velcty, Ddo, Kc)
+ class(FreeGasDopplerBroadening)::calc
real(kind=8)::Velcty(*), Vv, Ddo
integer::Kc
!
@@ -136,32 +137,31 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Modfpl (Vv, Velcty, Wts, Ddo)
+ SUBROUTINE Modfpl (calc, Vv, Velcty, Wts, Ddo)
!
! *** form the Doppler weights via modified four-point Legrange rule
!
- use brdd_common_m, only : Ipnts, Kc
- use AuxGridHelper_M, only : getNumAuxGridPoints
-!
+
+ class(FreeGasDopplerBroadening)::calc
real(kind=8):: Velcty(*), Wts(*), Vv, Ddo
integer::I,Iq, Iz, nauxMax
real(kind=8)::S
!
- CALL Zero_Array (Wts, Ipnts)
- nauxMax = getNumAuxGridPoints()
+ CALL Zero_Array (Wts, calc%Ipnts)
+ nauxMax = calc%getNumEnergyUnbroadened()
!
- IF (Kc.EQ.1) CALL Start1 (Vv, Velcty, Wts, Ddo)
- IF (Kc.EQ.2) CALL Start2 (Vv, Velcty, Wts, Ddo)
- IF (Kc.EQ.3) CALL Start3 (Vv, Velcty, Wts, Ddo)
- IF (Kc.GE.4) CALL Start4 (Vv, Velcty, Wts, Ddo)
+ IF (calc%Kc.EQ.1) CALL Start1 (calc, Vv, Velcty, Wts, Ddo)
+ IF (calc%Kc.EQ.2) CALL Start2 (calc, Vv, Velcty, Wts, Ddo)
+ IF (calc%Kc.EQ.3) CALL Start3 (calc, Vv, Velcty, Wts, Ddo)
+ IF (calc%Kc.GE.4) CALL Start4 (calc, Vv, Velcty, Wts, Ddo)
!
!
- IF (Ip1.LE.Ipnts) THEN
+ IF (Ip1.LE.calc%Ipnts) THEN
20 CONTINUE
- CALL Wtabcd (Wts)
- IF (Im1.LT.Ipnts) THEN
- CALL Reset (Velcty, Vv, Ddo, Kc)
- IF (Ip1.GT.Ipnts) GO TO 30
+ CALL Wtabcd (calc, Wts)
+ IF (Im1.LT.calc%Ipnts) THEN
+ CALL Reset (calc, Velcty, Vv, Ddo, calc%Kc)
+ IF (Ip1.GT.calc%Ipnts) GO TO 30
GO TO 20
END IF
END IF
@@ -169,39 +169,39 @@ module fgm2_m
30 CONTINUE
!
IF (Em1.NE.Zero) THEN
- Iq = Ipnts + Kc + 2
- IF (Iq.LE.nauxMax ) CALL Quit4 (Vv, Velcty, Wts, Ddo, Kc)
- IF (Iq.EQ.nauxMax+1) CALL Quit3 (Vv, Velcty, Wts, Ddo, Kc)
- IF (Iq.EQ.nauxMax+2) CALL Quit2 (Vv, Velcty, Wts, Ddo, Kc)
- IF (Iq.EQ.nauxMax+3) CALL Quit1 (Wts)
+ Iq = calc%Ipnts + calc%Kc + 2
+ IF (Iq.LE.nauxMax ) CALL Quit4 (calc, Vv, Velcty, Wts, Ddo, calc%Kc)
+ IF (Iq.EQ.nauxMax+1) CALL Quit3 (calc, Vv, Velcty, Wts, Ddo, calc%Kc)
+ IF (Iq.EQ.nauxMax+2) CALL Quit2 (calc, Vv, Velcty, Wts, Ddo, calc%Kc)
+ IF (Iq.EQ.nauxMax+3) CALL Quit1 (calc, Wts)
END IF
!
!
Iz = 0
S = Zero
- DO I=1,Ipnts
+ DO I=1,calc%Ipnts
S = S + Wts(I)
IF (Wts(I).NE.Zero) Iz = 1
END DO
IF (S.EQ.Zero) THEN
IF (Iz.EQ.1) THEN
- WRITE (6,10000) Ipnts, Kc, Im1, Ip1, Iq, nauxMax
-10000 FORMAT (' Sum of weights is Zero! Ipnts,Kc=',10I5)
- WRITE (6,10010) (Wts(I),I=1,Ipnts)
+ WRITE (6,10000) calc%Ipnts, calc%Kc, Im1, Ip1, Iq, nauxMax
+10000 FORMAT (' Sum of weights is Zero! calc%Ipnts,Kc=',10I5)
+ WRITE (6,10010) (Wts(I),I=1,calc%Ipnts)
10010 FORMAT ('Wts=',7F10.6, /, (4x,7F10.6))
ELSE IF (Iz.EQ.0) THEN
- WRITE (6,10020) Ipnts, Kc, Im1, Ip1, Iq, nauxMax
-10020 FORMAT (' Weights are all Zero! Ipnts,Kc=',10I5)
+ WRITE (6,10020) calc%Ipnts, calc%Kc, Im1, Ip1, Iq, nauxMax
+10020 FORMAT (' Weights are all Zero! calc%Ipnts,Kc=',10I5)
END IF
WRITE (6,10100) Ddo
10100 FORMAT ('Ddo =', 1p6g14.6)
- WRITE (6,10200) (Velcty(I+Kc-1),I=1,Ipnts)
+ WRITE (6,10200) (Velcty(I+calc%Kc-1),I=1,calc%Ipnts)
10200 FORMAT ('Velcty=', 1p5g14.6)
STOP '[STOP in Modfpl in fgm/mfgm2.f]'
END IF
S = One/S
- DO I=1,Ipnts
- Wts(I) = Wts(I)*S * Velcty(I+Kc-1)**2
+ DO I=1,calc%Ipnts
+ Wts(I) = Wts(I)*S * Velcty(I+calc%Kc-1)**2
END DO
!
RETURN
@@ -210,7 +210,8 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Reset (Velcty, Vv, Ddo, Kc)
+ SUBROUTINE Reset (calc, Velcty, Vv, Ddo, Kc)
+ class(FreeGasDopplerBroadening)::calc
real(kind=8)::Velcty(*), Vv, Ddo
integer::Kc
@@ -255,12 +256,10 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Wtxxxd (Wts)
+ SUBROUTINE Wtxxxd (calc, Wts)
! *** integral from (Im1 to I00) but Ip1=1 so only Ip1 contributes,
! *** even though Im2, Im1, and I00 are defined (Kc>3)
- use abcexp_m
- use abcerf_m
-
+ class(FreeGasDopplerBroadening)::calc
real(kind=8)::Wts(*)
real(kind=8)::A, Aa, B, Bb, C, Cc, D, Dd, Qq
integer::N, Nn
@@ -292,12 +291,10 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Wtxxcd (Wts)
+ SUBROUTINE Wtxxcd (calc, Wts)
! *** Integral from (Im1 to I00) but Ip1=2 so only I00 and Ip1
! *** contribute, even though Im2 and Im1 are defined (Kc>2)
- use abcexp_m
- use abcerf_m
-
+ class(FreeGasDopplerBroadening)::calc
real(kind=8):: Wts(*)
real(kind=8)::A, Aa, B, Bb, C, Cc, D, Dd, E, Qq
integer::N, Nn
@@ -337,11 +334,10 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Wtxbcd (Wts)
+ SUBROUTINE Wtxbcd (calc, Wts)
! *** Integral from (Im1 to I00) but Ip1=3 so Im2 does not
! *** contribute, even though Im2 is defined (Kc>1)
- use abcexp_m
- use abcerf_m
+ class(FreeGasDopplerBroadening)::calc
real(kind=8):: Wts(*)
real(kind=8)::A, Aa, B, Bb, C, Cc, D, Dd, E, Qq
integer::N, Nn
@@ -387,12 +383,10 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Wtabcd (Wts)
+ SUBROUTINE Wtabcd (calc, Wts)
! *** Integral from (Im1 to I00) where all terms contribute (Kc>3,
-! *** Kc<Kdatb-2, Ip1=<Ipnts)
- use abcexp_m
- use abcerf_m
-
+! *** Kc<Kdatb-2, Ip1=<calc%Ipnts)
+ class(FreeGasDopplerBroadening)::calc
real(kind=8)::Wts(*)
real(kind=8)::A, Aa, B, Bb, C, Cc, D, Dd, E, Qq
integer::N, Nn
@@ -442,13 +436,12 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Wtabcx (Wts)
+ SUBROUTINE Wtabcx (calc, Wts)
! *** Integral from (Im1 to I00) but Im2=Ipnts-2 so Ip1 does not
! *** contribute, even though Ip1=Ipnts+1 is defined
! *** (Kc+Ipnts < Kdatb)
- use abcexp_m
- use abcerf_m
+ class(FreeGasDopplerBroadening)::calc
real(kind=8)::Wts(*)
real(kind=8)::A, Aa, B, Bb, C, Cc, D, Dd, E, Qq
integer::N, Nn
@@ -494,13 +487,11 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Wtabxx (Wts)
+ SUBROUTINE Wtabxx (calc, Wts)
! *** integral from (Im1 to I00) but Im2=Ipnts-1 so I00 & Ip1 DO not
! *** contribute, even though I00=Ipnts+1 & Ip1=Ipnts+2 are defined
! *** (Kc+Ipnts+1 < Kdatb)
- use abcexp_m
- use abcerf_m
-
+ class(FreeGasDopplerBroadening)::calc
real(kind=8)::Wts(*)
real(kind=8)::A, Aa, B, Bb, C, Cc, D, Dd, E, Qq
integer::N, Nn
@@ -539,13 +530,11 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Wtaxxx (Wts)
+ SUBROUTINE Wtaxxx (calc, Wts)
! *** Integral from (Im1 to I00) but Im2=Ipnts so only Im2 contributes
! *** even though Im1=Ipnts+1, I00=Ipnts+2, & Ip1=Ipnts+3 are defined
! *** (Kc+Ipnts+2 < Kdatb)
- use abcexp_m
- use abcerf_m
-
+ class(FreeGasDopplerBroadening)::calc
real(kind=8)::Wts(*)
real(kind=8)::A, Aa, B, Bb, C, Cc, D, Dd, E, Qq
integer::N, Nn
@@ -577,12 +566,11 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Start4 (Vv, Velcty, Wts, Ddo)
+ SUBROUTINE Start4 (calc, Vv, Velcty, Wts, Ddo)
!
! *** Kc-3 is defined (Kc>3) so can calculate all integrals
!
- use brdd_common_m, only : Kc
-!
+ class(FreeGasDopplerBroadening)::calc
real(kind=8):: Velcty(*), Wts(*), Ddo, Vv
!
@@ -591,10 +579,10 @@ module fgm2_m
I00 = Im1 + 1
Ip1 = I00 + 1
!
- Xm2 = (Velcty(Im2+Kc-1)-Vv)/Ddo
- Xm1 = (Velcty(Im1+Kc-1)-Vv)/Ddo
- X00 = (Velcty(I00+Kc-1)-Vv)/Ddo
- Xp1 = (Velcty(Ip1+Kc-1)-Vv)/Ddo
+ Xm2 = (Velcty(Im2+calc%Kc-1)-Vv)/Ddo
+ Xm1 = (Velcty(Im1+calc%Kc-1)-Vv)/Ddo
+ X00 = (Velcty(I00+calc%Kc-1)-Vv)/Ddo
+ Xp1 = (Velcty(Ip1+calc%Kc-1)-Vv)/Ddo
!
Ym1 = Xm1 - Xm2
Y00 = X00 - Xm1
@@ -626,25 +614,24 @@ module fgm2_m
!
Itype = 0
!
- CALL Wtxxxd (Wts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
- CALL Wtxxcd (Wts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
- CALL Wtxbcd (Wts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
+ CALL Wtxxxd (calc, Wts)
+ CALL Reset (calc, Velcty, Vv, Ddo, calc%Kc)
+ CALL Wtxxcd (calc, Wts)
+ CALL Reset (calc, Velcty, Vv, Ddo, calc%Kc)
+ CALL Wtxbcd (calc, Wts)
+ CALL Reset (calc, Velcty, Vv, Ddo, calc%Kc)
RETURN
END SUBROUTINE Start4
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Start3 (Vv, Velcty, Wts, Ddo)
+ SUBROUTINE Start3 (calc, Vv, Velcty, Wts, Ddo)
!
! *** Kc-3 is not defined (Kc=3) so can calculate all integrals but
! *** need to treat first One differently
!
- use brdd_common_m, only : Kc
-!
+ class(FreeGasDopplerBroadening)::calc
real(kind=8):: Velcty(*), Wts(*), Vv, Ddo
!
@@ -653,9 +640,9 @@ module fgm2_m
I00 = Im1 + 1
Ip1 = I00 + 1
!
- Xm1 = (Velcty(Im1+Kc-1)-Vv)/Ddo
- X00 = (Velcty(I00+Kc-1)-Vv)/Ddo
- Xp1 = (Velcty(Ip1+Kc-1)-Vv)/Ddo
+ Xm1 = (Velcty(Im1+calc%Kc-1)-Vv)/Ddo
+ X00 = (Velcty(I00+calc%Kc-1)-Vv)/Ddo
+ Xp1 = (Velcty(Ip1+calc%Kc-1)-Vv)/Ddo
!
Y00 = X00 - Xm1
Yp1 = Xp1 - X00
@@ -684,25 +671,25 @@ module fgm2_m
!
Itype = 0
!
- CALL WtZxxd (Wts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
- CALL Wtxxcd (Wts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
- CALL Wtxbcd (Wts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
+ CALL WtZxxd (calc, Wts)
+ CALL Reset (calc, Velcty, Vv, Ddo, calc%Kc)
+ CALL Wtxxcd (calc, Wts)
+ CALL Reset (calc, Velcty, Vv, Ddo, calc%Kc)
+ CALL Wtxbcd (calc, Wts)
+ CALL Reset (calc, Velcty, Vv, Ddo, calc%Kc)
RETURN
END SUBROUTINE Start3
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Start2 (Vv, Velcty, Wts, Ddo)
+ SUBROUTINE Start2 (calc, Vv, Velcty, Wts, Ddo)
!
! *** Kc-2 is not defined (Kc=2) so cannot calculate the first integral;
! *** also, need to treat second integral differently
!
- use brdd_common_m, only : Kc, Ipnts
!
+ class(FreeGasDopplerBroadening)::calc
real(kind=8):: Velcty(*), Wts(*), Vv, Ddo
!
Im2 = -2
@@ -710,8 +697,8 @@ module fgm2_m
I00 = Im1 + 1
Ip1 = I00 + 1
!
- X00 = (Velcty(I00+Kc-1)-Vv)/Ddo
- Xp1 = (Velcty(Ip1+Kc-1)-Vv)/Ddo
+ X00 = (Velcty(I00+calc%Kc-1)-Vv)/Ddo
+ Xp1 = (Velcty(Ip1+calc%Kc-1)-Vv)/Ddo
!
Yp1 = Xp1 - X00
Rp1 = One + Two*Xp1*X00
@@ -724,24 +711,23 @@ module fgm2_m
!
Itype = 0
!
- CALL Reset (Velcty, Vv, Ddo, Kc)
- CALL WtZxcd (Wts, Ipnts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
- CALL Wtxbcd (Wts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
+ CALL Reset (calc, Velcty, Vv, Ddo, calc%Kc)
+ CALL WtZxcd (calc, Wts, calc%Ipnts)
+ CALL Reset (calc, Velcty, Vv, Ddo, calc%Kc)
+ CALL Wtxbcd (calc, Wts)
+ CALL Reset (calc, Velcty, Vv, Ddo, calc%Kc)
RETURN
END SUBROUTINE Start2
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Start1 (Vv, Velcty, Wts, Ddo)
+ SUBROUTINE Start1 (calc, Vv, Velcty, Wts, Ddo)
!
! *** Kc-2 is not defined (Kc=2) so cannot calculate the first or
! *** second integrals; also, need to treat third integral differently
!
- use brdd_common_m, only : Kc, Ipnts
-!
+ class(FreeGasDopplerBroadening)::calc
real(kind=8):: Velcty(*), Wts(*), Vv, Ddo
@@ -750,26 +736,24 @@ module fgm2_m
I00 = Im1 + 1
Ip1 = I00 + 1
!
- Xp1 = (Velcty(Ip1+Kc-1)-Vv)/Ddo
+ Xp1 = (Velcty(Ip1+calc%Kc-1)-Vv)/Ddo
Itype = 0
!
- CALL Reset (Velcty, Vv, Ddo, Kc)
- CALL Reset (Velcty, Vv, Ddo, Kc)
- CALL WtZbcd (Wts, Ipnts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
+ CALL Reset (calc, Velcty, Vv, Ddo, calc%Kc)
+ CALL Reset (calc, Velcty, Vv, Ddo, calc%Kc)
+ CALL WtZbcd (calc, Wts, calc%Ipnts)
+ CALL Reset (calc, Velcty, Vv, Ddo, calc%Kc)
RETURN
END SUBROUTINE Start1
!
!
! --------------------------------------------------------------
!
- SUBROUTINE WtZxxd (Wts)
+ SUBROUTINE WtZxxd (calc, Wts)
! *** Integral from (Im1 to I00) but Ip1=1 so no other terms contribute;
! *** Also Im2 is not defined (Kc<4)
- use abcexp_m
- use abcerf_m
-
real(kind=8):: Wts(*)
+ class(FreeGasDopplerBroadening)::calc
real(kind=8)::A, Aa, B, Bb, C, Cc, D, Dd, Qq
integer::N, Nn
!
@@ -800,13 +784,11 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE WtZxcd (Wts, Ipnts)
+ SUBROUTINE WtZxcd (calc, Wts, Ipnts)
! *** Integral from (Im1 to I00) but Ip1=2 so Im2 & Im1 do not contribute;
! *** Also Im2 is not defined (Kc<4)
- use abcexp_m
- use abcerf_m
-
real(kind=8):: Wts(*)
+ class(FreeGasDopplerBroadening)::calc
integer::Ipnts
real(kind=8)::A, Aa, B, Bb, C, Cc, D, Dd, E, Qq
integer::N, Nn
@@ -848,13 +830,12 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE WtZbcd (Wts, Ipnts)
+ SUBROUTINE WtZbcd (calc, Wts, Ipnts)
! *** integral from (Im1 to I00) but Ip1=3 so Im2 does not contribute;
! *** Also Im2 is not defined (Kc<4)
- use abcexp_m
- use abcerf_m
real(kind=8):: Wts(*)
+ class(FreeGasDopplerBroadening)::calc
integer::Ipnts
real(kind=8)::A, Aa, B, Bb, C, Cc, D, Dd, E, Qq
integer::N, Nn
@@ -901,14 +882,12 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE WtabcZ (Wts)
+ SUBROUTINE WtabcZ (calc, Wts)
! *** Integral from (Im1 to I00) but Im2=Ipnts-2 so Ip1 does not
! *** contribute, also Ip1=Ipnts+1 is not defined
! *** (Kc+[Ipnts+1]-1 = Kdatb+1)
- use abcexp_m
- use abcerf_m
-
real(kind=8):: Wts(*)
+ class(FreeGasDopplerBroadening)::calc
real(kind=8)::A, Aa, B, Bb, C, Cc, D, Dd, E, Qq
integer::N, Nn
@@ -949,14 +928,13 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE WtabxZ (Wts)
+ SUBROUTINE WtabxZ (calc, Wts)
! *** Integral from (Im1 to I00) but Im2=Ipnts-1 so Ip1 & I00 do not
! *** contribute, also Ip1=Ipnts+2 is not defined
! *** (Kc+[Ipnts+2]-1 = Kdatb+1)
- use abcexp_m
- use abcerf_m
real(kind=8):: Wts(*)
+ class(FreeGasDopplerBroadening)::calc
real(kind=8)::A, Aa, B, Bb, C, Cc, D, Dd, E, Qq
integer::N, Nn
@@ -992,14 +970,12 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE WtaxxZ (Wts)
+ SUBROUTINE WtaxxZ (calc, Wts)
! *** Integral from (Im1 to I00) but Im2=Ipnts so Im1, Ip1, & I00 do not
! *** contribute, also Ip1=Ipnts+3 is not defined
! *** (Kc+[Ipnts+3]-1 = Kdatb+1)
- use abcexp_m
- use abcerf_m
-
real(kind=8):: Wts(*)
+ class(FreeGasDopplerBroadening)::calc
real(kind=8)::A, Aa, B, Bb, C, Cc, D, Dd, E, Qq
integer::N, Nn
@@ -1030,21 +1006,22 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Quit4 (Vv, Velcty, Wts, Ddo, Kc)
+ SUBROUTINE Quit4 (calc, Vv, Velcty, Wts, Ddo, Kc)
!
! *** (Ipnts+3) is defined (Kc+Ipnts+2<Kdatb) so can calculate all
! *** integrals
!
+ class(FreeGasDopplerBroadening)::calc
real(kind=8):: Velcty(*), Wts(*), Vv, Ddo
integer::kc
- CALL Wtabcx (Wts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
+ CALL Wtabcx (calc, Wts)
+ CALL Reset (calc, Velcty, Vv, Ddo, Kc)
IF (Em1.NE.Zero) THEN
- CALL Wtabxx (Wts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
+ CALL Wtabxx (calc, Wts)
+ CALL Reset (calc, Velcty, Vv, Ddo, Kc)
IF (Em1.NE.Zero) THEN
- CALL Wtaxxx (Wts)
+ CALL Wtaxxx (calc, Wts)
END IF
END IF
RETURN
@@ -1053,21 +1030,22 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Quit3 (Vv, Velcty, Wts, Ddo, Kc)
+ SUBROUTINE Quit3 (calc, Vv, Velcty, Wts, Ddo, Kc)
!
! *** (Ipnts+3) is not defined (Kc+Ipnts+2=Kdatb) but Ipnts+2 is, so can
! *** calculate all integrals but must do last one differently
!
+ class(FreeGasDopplerBroadening)::calc
real(kind=8):: Velcty(*), Wts(*), Vv, Ddo
integer::Kc
- CALL Wtabcx (Wts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
+ CALL Wtabcx (calc, Wts)
+ CALL Reset (calc, Velcty, Vv, Ddo, Kc)
IF (Em1.NE.Zero) THEN
- CALL Wtabxx (Wts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
+ CALL Wtabxx (calc, Wts)
+ CALL Reset (calc, Velcty, Vv, Ddo, Kc)
IF (Em1.NE.Zero) THEN
- CALL WtaxxZ (Wts)
+ CALL WtaxxZ (calc, Wts)
END IF
END IF
RETURN
@@ -1076,19 +1054,20 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Quit2 (Vv, Velcty, Wts, Ddo, Kc)
+ SUBROUTINE Quit2 (calc, Vv, Velcty, Wts, Ddo, Kc)
!
! *** (Ipnts+2) is not defined (Kc+Ipnts+1=Kdatb) but Ipnts+1 is, so
! *** cannot calculate last integral and must do second-to-last one
! *** differently
!
+ class(FreeGasDopplerBroadening)::calc
real(kind=8)::Velcty(*), Wts(*), Vv, Ddo
integer::Kc
- CALL Wtabcx (Wts)
- CALL Reset (Velcty, Vv, Ddo, Kc)
+ CALL Wtabcx (calc, Wts)
+ CALL Reset (calc, Velcty, Vv, Ddo, Kc)
IF (Em1.NE.Zero) THEN
- CALL WtabxZ (Wts)
+ CALL WtabxZ (calc, Wts)
END IF
RETURN
END SUBROUTINE Quit2
@@ -1096,15 +1075,15 @@ module fgm2_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Quit1 (Wts)
+ SUBROUTINE Quit1 (calc, Wts)
!
! *** (Ipnts+1) is not defined (Kc+Ipnts=Kdatb) but Ipnts is, so
! *** cannot calculate last two integrals and must do third-to-last
! *** differently
!
- IMPLICIT None
+ class(FreeGasDopplerBroadening)::calc
real(kind=8):: Wts(*)
- CALL WtabcZ (Wts)
+ CALL WtabcZ (calc, Wts)
RETURN
END SUBROUTINE Quit1
end module fgm2_m
diff --git a/sammy/src/fgm/mfgm3.f90 b/sammy/src/fgm/mfgm3.f90
deleted file mode 100644
index 820e769681a67b52690fb36d8e878d77ce36bdfc..0000000000000000000000000000000000000000
--- a/sammy/src/fgm/mfgm3.f90
+++ /dev/null
@@ -1,63 +0,0 @@
-module mfgm3_m
- implicit none
- contains
-!
-!
-! --------------------------------------------------------------
-!
- SUBROUTINE Stetd (derivsOld, derivsNew, Irow, Now, &
- Ktempx, Isox, Jdat, Locate)
-!
-! *** purpose -- COPY DATA AND DERIVATIVES, CUZ THERE ARE TOO FEW
-! *** POINTS TO BROADEN
-!
- use fixedi_m, only : numUsedPar
- use DerivativeHandler_M
-!
- integer:: Isox, Jdat, Locate, Ktempx, Now, irow
- integer::Ii, N, nsigMax
- type(DerivativeHandler)::derivsOld, derivsNew
- real(kind=8)::Zero,val
- DATA Zero /0.0d0/
-!
- NOW = NOW + 1
- if (Locate.eq.0) then
- if (derivsNew%getNnnsig().ne.derivsOld%getNnnsig()) then
- Write (6,10000) Locate, &
- derivsOld%getNnnsig(), &
- derivsNew%getNnnsig()
-10000 FORMAT (' Error in Stetd, Locate.ne.0 but na.ne.nb',3i6)
-
- end if
- end if
- IF (Locate.NE.0) THEN
- ! update cross section (ipar=0) as well as derivatives
- DO Ii=0,numUsedPar
- val = derivsOld%getDataNsOld(Jdat, Locate, Ii, Isox)
- if (val.eq.0.0d0) cycle
- call derivsNew%addDataNs(irow, 1, Ii, Isox, val)
- end do
- else
- DO N=1,derivsOld%getNnnsig()
- ! update cross section (ipar=0) as well as derivatives
- DO Ii=0,numUsedPar
- val = derivsOld%getDataNsOld(Jdat, N, Ii, Isox)
- if (val.eq.0.0d0) cycle
- call derivsNew%addDataNs(irow, N, Ii, Isox, val)
- End do
- END DO
- end if
-!
- IF (numUsedPar.gt.0 .and. Ktempx.gt.0) THEN
- IF (Locate.NE.0) THEN
- call derivsNew%addDataNs(irow, 1, Ktempx, Isox, 0.0d0)
- ELSE
- do N = 1, derivsOld%getNnnsig()
- call derivsNew%addDataNs(irow, N, Ktempx, Isox, 0.0d0)
- END DO
- END IF
- END IF
-!
- RETURN
- END SUBROUTINE Stetd
-end module mfgm3_m
diff --git a/sammy/src/fgm/mfgm4.f90 b/sammy/src/fgm/mfgm4.f90
index a248f1376d4e27f80826127cb1db118747ea1c4f..dcc552064f1e24be61b0dea5151aec627dea0af8 100644
--- a/sammy/src/fgm/mfgm4.f90
+++ b/sammy/src/fgm/mfgm4.f90
@@ -1,34 +1,36 @@
module mfgm4_m
+ use fgm2_m
+ use DerivativeHandler_M
+ use FreeGasDopplerBroadening_M
+ use, intrinsic :: ISO_C_BINDING
+ IMPLICIT None
+
+
+ public Xdofgm
contains
!
!
! --------------------------------------------------------------
!
- SUBROUTINE Xdofgm (Velcty, derivs, &
+ SUBROUTINE Xdofgm (calc, Velcty, derivs, &
Wts, Em, Vv, Ddo, Tempx, Iffy, Ktempx, Isox, &
Ngtvx, irow)
!
! *** PERFORM INTEGRATION FOR DOPPLER-BROADENING FROM POINT NUMBER
-! *** Kc TO POINT NUMBER Iup
-!
- use fixedi_m, only : numUsedPar
- use ifwrit_m, only : Kdebug
- use brdd_common_m, only : Ipnts, Kc
- use fgm2_m
- use DerivativeHandler_M
- use, intrinsic :: ISO_C_BINDING
- IMPLICIT None
+! *** calc%Kc TO POINT NUMBER Iup
+!
integer::Iffy, Ktempx, Isox, Ngtvx
real(kind=8)::Velcty(*), Wts(*), Em, Vv, Ddo, Tempx
type(DerivativeHandler)::derivs
+ class(FreeGasDopplerBroadening)::calc
real(kind=8)::Sigpls(100), Sigmns(100), Derdop(100)
real(kind=8)::Zero, One
real(kind=8)::Del, Derdp1, Derdp2, Sigt, W, val
real(kind=8)::Sigma
integer::I, Ipar, Iso, Ix, K, Ks, N, Ikc, Ipos, irow
- logical(C_BOOL)::accu
+
DATA Zero /0.0d0/, One /1.0d0/
IF (derivs%getNnnsig().GT.100) STOP '[STOP in Xdofgm in fgm/mfgm4.f]'
!
@@ -37,11 +39,11 @@ module mfgm4_m
Iso = Isox
!
Del = 0.02D0
- IF (numUsedPar.gt.0.AND. Ktempx.GT.0 .AND. Em.NE.Zero) THEN
+ IF (calc%getNumParams().gt.0.AND. Ktempx.GT.0 .AND. Em.NE.Zero) THEN
W = Ddo*(One+Del)
- CALL Funfgm (W, Vv, Velcty, Wts, Sigpls, Isox, derivs)
+ CALL Funfgm (calc, W, Vv, Velcty, Wts, Sigpls, Isox, derivs)
W = Ddo*(One-Del)
- CALL Funfgm (W, Vv, Velcty, Wts, Sigmns, Isox, derivs)
+ CALL Funfgm (calc, W, Vv, Velcty, Wts, Sigmns, Isox, derivs)
!
DO I=1,derivs%getNnnsig()
Sigpls(I) = Sigpls(I)/dABS(Em)
@@ -51,44 +53,40 @@ module mfgm4_m
END IF
!
!
- IF (Ipnts.LE.3) THEN
+ IF (calc%Ipnts.LE.3) THEN
! *** modified Simpson rule -- see manual for details
- CALL Modsmp (Vv, Velcty, Wts, Ddo)
- ELSE IF (Ipnts.GT.3) THEN
+ CALL Modsmp (calc, Vv, Velcty, Wts, Ddo)
+ ELSE IF (calc%Ipnts.GT.3) THEN
! *** modified 4-point Lagrange -- see manual for details
- CALL Modfpl (Vv, Velcty, Wts, Ddo)
+ CALL Modfpl (calc, Vv, Velcty, Wts, Ddo)
END IF
!
!
- accu = .true.
- call derivs%setAccumulate(accu)
- DO Ipar=0,numUsedPar
+
+ DO Ipar=0,calc%getNumParams()
DO N=1,derivs%getNnnsig()
val = 0.0d0
- DO I=1,Ipnts
+ DO I=1,calc%Ipnts
IF (Wts(I).NE.Zero) THEN
- Ikc = I + Kc - 1
+ Ikc = I + calc%Kc - 1
! update cross section (ipar=0) as well as derivatives
val = val + Wts(I)*derivs%getDataNsOld(Ikc, N, Ipar, Iso)
END if
END Do
- if (val.eq.0.0d0) cycle
- call derivs%addDataNs(irow, N, Ipar, Iso, val)
+ calc%rowData(N, Ipar) = calc%rowData(N, Ipar) + val
end do
END DO
- Sigt = derivs%getDataNs(irow, 1, 0, Iso)
+ Sigt = calc%rowData(1, 0)
- accu = .false.
- call derivs%setAccumulate(accu)
- Sigma = derivs%getDataNs(irow, 1, 0, Iso)
+ Sigma = calc%rowData(1, 0)
IF (Ngtvx.EQ.1 .AND. Sigma.LT.Zero) THEN
IF (Sigma.GT.-1.E-15) THEN
Sigma = Zero
ELSE
Ix = 0
- DO I=1,Ipnts-2
- Ikc = Kc + I - 1
+ DO I=1,calc%Ipnts-2
+ Ikc = calc%Kc + I - 1
IF (derivs%getDataNsOld(Ikc, 1, 0, Iso).GT.Zero) Ix = Ix + 1
END DO
IF (Ix.EQ.0) THEN
@@ -100,14 +98,14 @@ module mfgm4_m
' at Energy =', 0PF30.15)
END IF
END IF
- call derivs%addDataNs(irow, 1, 0, Iso, Sigma)
+ calc%rowData(1, 0) = Sigma
ELSE IF (Ngtvx.EQ.0 .AND. Sigma.GT.Zero) THEN
IF (Sigma.LT.1.E-15) THEN
Sigma = Zero
ELSE
Ix = 0
- DO I=1,Ipnts-2
- Ikc = Kc + I - 1
+ DO I=1,calc%Ipnts-2
+ Ikc = calc%Kc + I - 1
IF (derivs%getDataNsOld(Ikc-1, 1, 0, Iso).LT.Zero) Ix = Ix + 1
END DO
IF (Ix.EQ.0) THEN
@@ -119,12 +117,12 @@ module mfgm4_m
1PG14.6, ' at Energy =', 0PF30.15)
END IF
END IF
- call derivs%addDataNs(irow, 1, 0, Iso, Sigma)
+ calc%rowData(1, 0) = Sigma
END IF
!
Do N=1, derivs%getNnnsig()
- do Ipar = 0, numUsedPar
- val = derivs%getDataNs(irow, N, Ipar, Iso)
+ do Ipar = 0, calc%getNumParams()
+ val = calc%rowData(N, Ipar)
if(val.eq.0.0d0) cycle
if (EM.LT.ZERO) then
val = -val/Em
@@ -133,22 +131,22 @@ module mfgm4_m
else
val = val/Em
end if
- call derivs%addDataNs(irow, N, Ipar, Iso, val)
+ calc%rowData(N, Ipar) = val
end do
END DO
!
!
!
- IF (Ktempx.LE.0 .OR. numUsedPar.le.0) THEN
+ IF (Ktempx.LE.0 .OR. calc%getNumParams().le.0) THEN
GO TO 200
ELSE
K = Ktempx
DO N=1,derivs%getNnnsig()
val = Derdop(N)*Ddo*0.5d0/Tempx
- call derivs%addDataNs(irow, N, K, Iso, val)
+ calc%rowData(N, K) = val
! Derdop already has 1/Em built in
END DO
- IF (Kdebug.EQ.0) RETURN
+ IF (.not.calc%debugOutput) RETURN
IF (Em.EQ.Zero) RETURN
!
! *** Here for debug info only
@@ -176,33 +174,30 @@ module mfgm4_m
!
! --------------------------------------------------------------
!
- SUBROUTINE Funfgm (Ddo, Vv, Velcty, Wts, Sum, Isox, derivs)
+ SUBROUTINE Funfgm (calc, Ddo, Vv, Velcty, Wts, Sum, Isox, derivs)
!
- use brdd_common_m, only : Ipnts, Kc
- use fgm2_m
- use DerivativeHandler_M
- IMPLICIT None
real(kind=8)::Velcty(*), Wts(*), Sum(*)
real(kind=8)::Ddo, Vv
integer::Isox, Nb
real(kind=8)::Zero
integer::I, Ikc, N
type(DerivativeHandler)::derivs
+ class(FreeGasDopplerBroadening)::calc
DATA Zero /0.0d0/
!
! *** modified Simpson rule -- see manual for details
- IF (Ipnts.LE.3) CALL Modsmp (Vv, Velcty, Wts, Ddo)
+ IF (calc%Ipnts.LE.3) CALL Modsmp (calc, Vv, Velcty, Wts, Ddo)
!
! *** modified 4-point Lagrange -- see manual for details
- IF (Ipnts.GT.3) CALL Modfpl (Vv, Velcty, Wts, Ddo)
+ IF (calc%Ipnts.GT.3) CALL Modfpl (calc, Vv, Velcty, Wts, Ddo)
!
DO N=1,derivs%getNnnsig()
Sum(N) = Zero
END DO
- DO I=1,Ipnts
- Ikc = I + Kc - 1
+ DO I=1,calc%Ipnts
+ Ikc = I + calc%Kc - 1
IF (Wts(I).NE.Zero) THEN
DO N=1,derivs%getNnnsig()
Sum(N) = Sum(N) + Wts(I)*derivs%getDataNsOld(Ikc, N, 0, Isox)
diff --git a/sammy/src/fin/mfin0.f90 b/sammy/src/fin/mfin0.f90
index 94cf6c9fb8b518b47178f40a500ec31236d4237f..bab45d6e20340f49d1a9542ae2da81cc55d442de 100644
--- a/sammy/src/fin/mfin0.f90
+++ b/sammy/src/fin/mfin0.f90
@@ -60,7 +60,6 @@ module fin
END IF
!
!
- IF (Kplotu.NE.0) Kplotu = 0
IF (Kgodf .NE.0) THEN
! - - - - - - - - - - - - - - - - - - - - - - - - - - - <
CALL Vodf
@@ -98,7 +97,7 @@ module fin
A_Itempy = 1.0d0 ! conversion factor from U to P, usually 1, except for resonance parameters
CALL Convrt ( A_Iprbrd , I_Iflbrd , A_Isiabn , &
A_Iechan , &
- A_Idpiso , A_Idsiso , &
+ A_Idpiso , &
A_Iprdet , I_Ifldet , &
A_Ipolar , A_Iprmsc , I_Iflmsc , I_Irdmsc , A_Iprpmc , &
I_Iflpmc , A_Iprorr , I_Iflorr , A_Iprrpi , I_Iflrpi , &
diff --git a/sammy/src/fin/mfin1.f90 b/sammy/src/fin/mfin1.f90
index a38e246da141df323e75f89c0a44aa0229dc0b03..f69fd3c93fdbfa5d56002be905fed433dd319496 100644
--- a/sammy/src/fin/mfin1.f90
+++ b/sammy/src/fin/mfin1.f90
@@ -61,7 +61,7 @@ module fin1
! --------------------------------------------------------------
!
SUBROUTINE Convrt ( Parbrd, Iflbrd, Siabnd, &
- Echan , Dopwid, Doswid, &
+ Echan , Dopwid, &
Pardet, Ifldet, &
Polar , Parmsc, Iflmsc, Iradms, Parpmc, Iflpmc, &
Parorr, Iflorr, Parrpi, Iflrpi, Parudr, Ifludr, &
@@ -81,7 +81,7 @@ module fin1
!
DIMENSION Parbrd(*), Iflbrd(*), Siabnd(*), &
Echan(Ntotc,*), &
- Dopwid(*), Doswid(*), &
+ Dopwid(*), &
Pardet(*), Ifldet(*), &
Polar(2,*), Parmsc(*), Iflmsc(*), Iradms(*), &
Parpmc(4,*), Iflpmc(4,*), &
@@ -93,7 +93,7 @@ module fin1
!
! DIMENSION Parbrd(Numbrd), Iflbrd(Numbrd), Ntot(Ngroup),
! * Echan(Ntotc,Ngroup),
-! * Dopwid(Numiso), Doswid(Numiso),
+! * Dopwid(Numiso),
! * Pardet(Numdet), Ifldet(Numdet),
! * Polar(2,Nres), Parmsc(Nummsc), Iflmsc(Nummsc), Iradms(Ngroup),
! * Parpmc(4,Numpmc), Iflpmc(4,Numpmc),
@@ -151,8 +151,7 @@ module fin1
IF (Nvp.EQ.Nvpall) RETURN
!
IF (Nvpmsc.NE.0) THEN
- CALL Cnvmsc (Siabnd, Doswid, &
- Parmsc, Iflmsc, Iradms, Tempy, Ipar)
+ CALL Cnvmsc (Siabnd, Parmsc, Iflmsc, Iradms, Tempy, Ipar)
END IF
CALL Update (Ipar, Kpar, Nvp, Nfpmsc, Nvpmsc)
IF (Nvp.EQ.Nvpall) RETURN
@@ -952,6 +951,10 @@ module fin1
Dopwid(1) = Dopple
END IF
Temp = val
+ if (associated(dopplerInfo%broadener)) then
+ call dopplerInfo%broadener%setTemperature(temp)
+ dopplerInfo%wantBroaden = .true.
+ end if
ELSE IF (I.EQ.3) THEN
Thick = val
ELSE IF (I.EQ.4) THEN
@@ -975,7 +978,7 @@ module fin1
!
! --------------------------------------------------------------
!
- SUBROUTINE Cnvmsc (Siabnd, Doswid, &
+ SUBROUTINE Cnvmsc (Siabnd, &
Parmsc, Iflmsc, Iradms,Tempy, Ipar)
!
! *** PURPOSE -- Convert from updated U-Parameters to updated P-Parameters
@@ -993,13 +996,12 @@ module fin1
use RMatResonanceParam_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
- DIMENSION Siabnd(*), Doswid(*), &
- Parmsc(*), Iflmsc(*), Iradms(*), Tempy(*)
+ DIMENSION Siabnd(*), Parmsc(*), Iflmsc(*), Iradms(*), Tempy(*)
type(SammyResonanceInfo)::resInfo
type(SammySpinGroupInfo)::spinInfo
type(RMatResonance)::resonance, resonanceRed
!
-! DIMENSION Siabnd(Numiso), Doswid(Numiso),
+! DIMENSION Siabnd(Numiso),
! * Parmsc(Nummsc), Iflmsc(Nummsc), Iradms(Ngroup),
! * U(Nvpall), Tempy(Nvpall)
DATA Zero /0.0d0/, One /1.0d0/
@@ -1063,17 +1065,8 @@ module fin1
Tzero = Parmsc(I)
Elzero = Parmsc(I+1)
Tttzzz = Sm2*Dist*Elzero
- ELSE IF (Ksitmp.EQ.I) THEN
- Aa = dSQRT(Parmsc(Ksitmp)/Sitemp)
- Dosind = Dosind*Aa
- Sitemp = Parmsc(Ksitmp)
- IF (Numiso.NE.0) THEN
- DO Iso=1,Numiso
- Doswid(Iso) = Aa*Doswid(Iso)
- END DO
- ELSE
- Doswid(1) = Dosind
- END IF
+ ELSE IF (Ksitmp.EQ.I) THEN
+ Sitemp = Parmsc(Ksitmp)
ELSE IF (Ksithc.EQ.I) THEN
Sithck = Parmsc(Ksithc)
ELSE IF (Ksindi.EQ.I) THEN
diff --git a/sammy/src/grp/mgrp2.f b/sammy/src/grp/mgrp2.f
index 57e62c80222bcab050b83fc1f04f62b0dae6ca39..b938effe6116a713960b12057023120b16d44fac 100755
--- a/sammy/src/grp/mgrp2.f
+++ b/sammy/src/grp/mgrp2.f
@@ -8,15 +8,12 @@ C *** Purpose -- Find highest Kmn such that Energy(Kmn).LE.Emn
C *** lowest Kmx such that Energy(Kmx).GE.Emx
C on auxillary grid
C
- use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+ use EndfData_common_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
type(SammyGridAccess)::grid
C
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
Ilow = Kc - 1
@@ -85,7 +82,6 @@ C
DIMENSION Ebonda(*), Bondar(*), Fintgr(2,Ngbxxx,*)
C
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
Kbonda = 0
diff --git a/sammy/src/grp/mgrp3.f b/sammy/src/grp/mgrp3.f
index 61871a93938710d1105d6926dcada4e47eada921..018b34d8efe53e28b6a901bde7d1519d1d239fe4 100644
--- a/sammy/src/grp/mgrp3.f
+++ b/sammy/src/grp/mgrp3.f
@@ -45,7 +45,6 @@ C *** are within energy range specified. If not, testee
C *** issues warning, and redefines limits (also redefines
C *** Ndatq, if needed).
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
elow = grid%getEnergy(1, expData)
ehigh = grid%getEnergy(Kdatb, expData)
diff --git a/sammy/src/grp/mgrp4.f b/sammy/src/grp/mgrp4.f
index da5a56c1ed2b9f99c673afdf7d074c55e8be71c5..940912cd63019d0a03288907c03ee7a44f7bfaeb 100755
--- a/sammy/src/grp/mgrp4.f
+++ b/sammy/src/grp/mgrp4.f
@@ -11,16 +11,13 @@ C *** Note -- Integral is from Emn to Emx, where
C *** Energb(Jlow-1) < Emn =< Energb(Jlow ) and
C *** Energb(Jup ) =< Emx < Energb(Jup+1)
C
- use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+ use EndfData_common_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
type(SammyGridAccess)::grid
DIMENSION Wts(*), Weight(*)
C
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
CALL Zero_Array (Wts, Kdatb)
J = Kmx - Kmn + 1
diff --git a/sammy/src/inp/minp01.f b/sammy/src/inp/minp01.f
index 7a41d383518847e0da4b5254e2a386b4ea877d05..810b6fa56dc56c82522e22aa0151e1f8c6f989dd 100644
--- a/sammy/src/inp/minp01.f
+++ b/sammy/src/inp/minp01.f
@@ -272,11 +272,13 @@ C
use ifwrit_m
use exploc_common_m
use broad_common_m
- use EndfData_common_m
+ use EndfData_common_m
use Qiso_m
use par1_m
+ use GridData_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Nvp(15), Nfp(15)
+ type(GridData)::grid
call resParData%cleanIsotopes()
@@ -300,14 +302,21 @@ C
C *** three
Ncrsss = Ntotc + 1
N = (Ncrsss+1)/2
- call make_I_Ifcros(Ncrsss)
+ call make_I_Ifcros(Ncrsss)
+ if (expData%getLength().eq.0) then
+ call grid%initialize()
+ call expData%addGrid(grid)
+ if (Nangle.gt.0) then
+ call grid%setNumPerEnergy(Nangle)
+ end if
+ ! one point per energy is the default
+
+ numcro = grid%getNumPerEnergy()
+ end if
IF (Nangle.GT.0) THEN
- N = Nangle
- Numcro = N
+ N = Nangle
call make_A_Iangle(N)
call make_A_Idangl(N)
- ELSE
- Numcro = 1
END IF
C
C *** four
@@ -337,7 +346,6 @@ C *** needed here, because Nnniso=1 is used if Numiso=0
call make_A_Ispiso(N)
call make_I_Ixciso(N)
call make_A_Idpiso(N)
- call make_A_Idsiso(N)
M = Ngroup
DO J=1,N
amass = 0.0d0
diff --git a/sammy/src/inp/minp04.F b/sammy/src/inp/minp04.F
index 2e68ef8e7595d33ed16525aae7ab1a629d9b9bb3..f5e6ce80e8ece5a0c384a5d0acf53f8400cf6bd1 100644
--- a/sammy/src/inp/minp04.F
+++ b/sammy/src/inp/minp04.F
@@ -192,6 +192,7 @@ C
use namfil_common_m
use lbro_common_m
use Observable_common_m
+ use broad_common_m, only : dopplerInfo
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
#ifdef COMPILE_WITH_SAMINT
@@ -480,6 +481,7 @@ C *** Leal-Hwang Doppler broadening (-213,214)(1)
C *** Gaussian approx for Doppler (-215,216,217,218)(0)
C *** Crystal lattice model of Dopp (-219,220)(3)
Kkkdop = 2
+ dopplerInfo%bType = 2
C
C *** DO NOT BROADEN THE LOW-ENERGY DATA POINTS (-221)
Nolowb = 0
diff --git a/sammy/src/inp/minp05.F b/sammy/src/inp/minp05.F
index 0d359ec3a9cd35316c0c58b595aeefba1211b382..8f2f5464d8bfeb0fbbfa0d259b7dd2d482195757 100644
--- a/sammy/src/inp/minp05.F
+++ b/sammy/src/inp/minp05.F
@@ -16,7 +16,7 @@ C
use lbro_common_m
use misccc_common_m
use Observable_common_m
-
+ use broad_common_m, only : dopplerInfo
use mdf5_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
@@ -355,13 +355,17 @@ C ************************************************************
C
ELSE IF (Number.EQ.211 .OR. Number.EQ.212) THEN
Kkkdop = 2
+ dopplerInfo%bType = 2
ELSE IF (Number.EQ.213 .OR. Number.EQ.214) THEN
Kkkdop = 1
+ dopplerInfo%bType = 1
ELSE IF (Number.EQ.215 .OR. Number.EQ.216 .OR. Number.EQ.217
* .OR. Number.EQ.218) THEN
Kkkdop = 0
+ dopplerInfo%bType = 0
ELSE IF (Number.EQ.219 .OR. Number.EQ.220) THEN
Kkkdop = 3
+ dopplerInfo%bType = 3
ELSE IF (Number.EQ.221) THEN
Nolowb = 1
C
diff --git a/sammy/src/inp/minp06.f b/sammy/src/inp/minp06.f
index 0e9c8fcf3a4de82d79938a033dc3d515aee21012..9b2d716627b87ac2886813a2499f2bb23f371aa3 100644
--- a/sammy/src/inp/minp06.f
+++ b/sammy/src/inp/minp06.f
@@ -178,6 +178,91 @@ C *** CARD SET 2
C
RETURN
END
+
+ subroutine setup_broadening
+ use broad_common_m
+ use FreeGasDopplerBroadening_M
+ use DopplerAndResolutionBroadener_M
+ use GridData_M
+ use EndfData_common_m, only : expData
+ use array_sizes_common_m, only : calcData, calcDataInit,
+ * calcDataSelf, calcDataSelfInit
+ implicit none
+ integer::bTypeOld
+
+ ! make sure we delete the ones we don't need
+ bTypeOld = -1
+ if (associated(dopplerInfo%highEnergyFreeGas)) then
+ bTypeOld = 0
+ else if (associated(dopplerInfo%lealHwang)) then
+ bTypeOld = 1
+ else if (associated(dopplerInfo%freeGas)) then
+ bTypeOld = 2
+ else if(associated(dopplerInfo%crystalLattice)) then
+ bTypeOld = 3
+ end if
+ if (bTypeOld.eq.dopplerInfo%bType) return ! all set
+
+ if (bTypeOld.ne.-1) then
+ call dopplerInfo%broadener%destroy()
+ if (bTypeOld.eq.0) then
+ deallocate(dopplerInfo%highEnergyFreeGas)
+ else if (bTypeOld.eq.1) then
+ deallocate(dopplerInfo%lealHwang)
+ else if (bTypeOld.eq.2) then
+ deallocate(dopplerInfo%freeGas)
+ else if (bTypeOld.eq.3) then
+ deallocate(dopplerInfo%crystalLattice)
+ end if
+ end if
+
+ ! and set up the correct broadening option
+ if (.not.calcDataInit) then
+ calcDataInit = .true.
+ call calcData%initialize()
+ end if
+ if (.not.calcDataSelfInit) then
+ calcDataSelfInit = .true.
+ call calcDataSelf%initialize()
+ end if
+ if (.not.workArrayInit) then
+ call workArray%initialize()
+ workArrayInit = .true.
+ end if
+ IF (dopplerInfo%bType.EQ.0) then
+ allocate(dopplerInfo%highEnergyFreeGas)
+ dopplerInfo%broadener => dopplerInfo%highEnergyFreeGas
+ call dopplerInfo%broadener%initialize(calcData,
+ * expData, workArray)
+ dopplerInfo%highEnergyFreeGas%dataSelf%instance_ptr =
+ * calcDataSelf%instance_ptr
+ dopplerInfo%highEnergyFreeGas%Brdlim = Brdlim
+ else IF (dopplerInfo%bType.EQ.1) then
+ allocate(dopplerInfo%lealHwang)
+ dopplerInfo%broadener => dopplerInfo%lealHwang
+ call dopplerInfo%broadener%initialize(calcData,
+ * expData, workArray)
+ dopplerInfo%lealHwang%dataSelf%instance_ptr =
+ * calcDataSelf%instance_ptr
+ else IF ( dopplerInfo%bType.EQ.2) then
+ allocate(dopplerInfo%freeGas)
+ dopplerInfo%broadener => dopplerInfo%freeGas
+ call dopplerInfo%broadener%initialize(calcData,
+ * expData, workArray)
+ dopplerInfo%freeGas%dataSelf%instance_ptr =
+ * calcDataSelf%instance_ptr
+ dopplerInfo%freeGas%Brdlim = Brdlim
+ else IF ( dopplerInfo%bType.EQ.3) then
+ allocate(dopplerInfo%crystalLattice)
+ dopplerInfo%broadener => dopplerInfo%crystalLattice
+ call dopplerInfo%broadener%initialize(calcData,
+ * expData, workArray)
+ dopplerInfo%crystalLattice%dataSelf%instance_ptr =
+ * calcDataSelf%instance_ptr
+ else
+ STOP 'Invalid doppler broadening option in inp/minp6.f'
+ end if
+ end subroutine
C
C
C --------------------------------------------------------------
@@ -193,13 +278,23 @@ C
use broad_common_m
use constn_common_m
use Wdsint_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ use broad_common_m
+ IMPLICIT None
C
C DIMENSION Parbrd(Numbrd), Iflbrd(Numbrd), Bcf(Ncf), Cf2(Ncf), Cf(Ncf)
- DIMENSION Parbrd(*), Iflbrd(*), Bcf(*), Cf2(*)
+ real(kind=8)::Parbrd(*), Bcf(*), Cf2(*)
+ integer::Iflbrd(*)
+ real(kind=8)::Eeemin, Aw, Deltab
real(kind=8),allocatable,dimension(:)::Cf
+ real(kind=8)::Elowbr, Delttt
C
- DATA Zero /0.0d0/
+ real(kind=8),parameter::Zero=0.0d0
+ real(kind=8)::A, B, Ao2x, Ax, Dist1, Do2x, E1, Gaussian, Xm
+ integer::I, Iwrong, Kz
+
+ ! set up broadening
+ Brdlim = 5.0d0
+ call setup_broadening
C
C
C *** CARD SET 5
@@ -291,9 +386,11 @@ C
Ao2 = Zero
Bo2 = Zero
Co2 = Zero
+ dopplerInfo%wantBroaden = .false.
C
IF (Temp.NE.Zero .AND. Aw.NE.Zero) THEN
Dopple = dSQRT(Boltzm*Aneutr*Temp/Aw)
+ dopplerInfo%wantBroaden = .true.
END IF
C
C
@@ -339,12 +436,11 @@ C
C *** Check Emin against 5*Doppler width
E1 = Eeemin
C
- IF (Kkkdop.EQ.0) THEN
+ IF (dopplerInfo%bType.EQ.0) THEN
C IF (using HEGA = High-Energy-Gaussian-Approximation to free gas
C model) then cannot broaden low energy points
- Xm = Zero
- Brdlim = 5.0d0
-C *** changed from 4.0d0 June 1997
+ Xm = Zero
+C *** Brdlim changed from 4.0d0 to 5.0d0 June 1997
IF (Dopple.NE.Zero) Xm = (2.0d0*Brdlim*Dopple)**2
IF (Maxwel.NE.1 .AND. Nolowb.EQ.0 .AND. E1.LT.Xm) THEN
WRITE (06,11100) Xm
@@ -353,9 +449,24 @@ C *** changed from 4.0d0 June 1997
* 1X, 'using the Gaussian approximation.', /,
* ' Therefore SAMMY will switch to the Free Gas Model.',
* /, /, ' Min energy for DBD = ', 1p4e14.6)
- Kkkdop = 2
+
+ if (dopplerInfo%bType.ne.2) then
+ Kkkdop = 2
+ dopplerInfo%bType = 2
+ call setup_broadening
+ end if
END IF
END IF
+
+ if (dopplerInfo%bType.eq.0) then
+ dopplerInfo%highEnergyFreeGas%Elowbr = Elowbr
+ else if( dopplerInfo%bType.eq.2) then
+ dopplerInfo%freeGas%Elowbr = Elowbr
+ end if
+ call dopplerInfo%broadener%setTemperature(temp)
+ if (associated(dopplerInfo%lealHwang) ) then
+ dopplerInfo%lealHwang%delT = Delttt
+ end if
C
C SET STARTING VALUE FOR EST IN SHFTGE ROUTINE
C
@@ -398,6 +509,7 @@ C *** stuff on CARD SET 5
Co2 = Zero
Do2 = Zero
Dopple = Zero
+ dopplerInfo%wantBroaden = .false.
Nobrd = 1
RETURN
END
diff --git a/sammy/src/int/mint0.f b/sammy/src/int/mint0.f
index a913c86b17a711fadddcfd1ea3bd8bb5ec1f88bc..148df684ebb8d13f5ca2ce873ebd42947c9f7879 100644
--- a/sammy/src/int/mint0.f
+++ b/sammy/src/int/mint0.f
@@ -1,6 +1,6 @@
C
C
- SUBROUTINE Samint_0(debugOut, haveMultScatter)
+ SUBROUTINE Samint_0(debugOut, haveMultScatter, Jwwwww, Jjjdop)
C
C *** Purpose -- Print cross sections etc
C
@@ -20,6 +20,7 @@ C
CHARACTER*10 Sss
character(len=80)::line
logical::debugOut, haveMultScatter
+ integer::Jwwwww, Jjjdop
C
C
WRITE (line, 99999)
@@ -34,17 +35,17 @@ C
C
C *** GUESSTIMATE SIZE OF ARRAY NEEDED FOR SAMINT
CALL Estint (Nblmax, Iv, debugOut, haveMultScatter)
- I = Idimen (Istarting, -1, 'Istarting, -1')
+ I = Idimen (Istarting, -1, 'Istarting, -1')
C
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
IF (Jjjdop.EQ.1) THEN
C (intermediate results, using Leal-Hwang Energy grid)
- CALL Leal_Hwang (Nblmax, debugOut)
+ CALL Leal_Hwang (Nblmax, debugOut, Jwwwww)
C
ELSE IF (debugOut) THEN
C (intermediate results, using regular auxiliary grid)
- CALL Intermediate (Iv)
+ CALL Intermediate (Iv, Jwwwww)
C
ELSE
C (final results, no more broadening or anything else needed)
diff --git a/sammy/src/int/mint0a.f b/sammy/src/int/mint0a.f
index e49d64d7955eea657eebbe759187e94979a001e7..46ff6dff88588b9671e445a48ae23250f6d6c97b 100644
--- a/sammy/src/int/mint0a.f
+++ b/sammy/src/int/mint0a.f
@@ -2,7 +2,7 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Intermediate (Iv)
+ SUBROUTINE Intermediate (Iv, Jwwwww)
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -22,6 +22,7 @@ C
use AuxGridHelper_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
type(GridData)::grid
+ integer::Jwwwww
type(SammyGridAccess)::gridAccess
integer,allocatable,dimension(:)::I_Jjjder, I_Jjjpar
real(kind=8),allocatable,dimension(:)::A_Idum
@@ -34,7 +35,6 @@ C - - - - - - - - - - - - - >
! get SAMMY Aux grid. Reuse experimental grid if it doesn't exi
call gridAccess%initialize()
- call gridAccess%setParameters(numcro, ktzero)
call gridAccess%setToAuxGrid(expData)
C
C *** Read the cross sections etc
@@ -153,8 +153,7 @@ C
C
Nnn= Ndat
N = Ndat
- call gridAccess%initialize()
- call gridAccess%setParameters(numcro, ktzero)
+ call gridAccess%initialize()
call gridAccess%setToExpGrid(expData)
IF (Ktheor.NE.0) CALL Outthr (7, gridAccess,
diff --git a/sammy/src/int/mint1.f b/sammy/src/int/mint1.f
index 1ec72cbf68190bd31a71faa0094327866be208bf..46ba0fb6e73eb68f4fa183bb455a80dbc4e186b1 100644
--- a/sammy/src/int/mint1.f
+++ b/sammy/src/int/mint1.f
@@ -26,11 +26,9 @@ C
C
Kkknew = Jgbmax
- call auxGrid%initialize()
- call auxGrid%setParameters(numcro, ktzero)
+ call auxGrid%initialize()
call auxGrid%setToAuxGrid(expData)
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToExpGrid(expData)
C
IF (Kkknew.LT.1) THEN
diff --git a/sammy/src/int/mint2.f90 b/sammy/src/int/mint2.f90
index fc4ec8f58630e77dbdb053ff7555c55ea6d87fda..323ef8fc236204cb7ca4887764d7c49a2f04afab 100644
--- a/sammy/src/int/mint2.f90
+++ b/sammy/src/int/mint2.f90
@@ -430,9 +430,7 @@ module mint2_m
! --------------------------------------------------------------
!
SUBROUTINE Wascii (derivs, Ndat)
- use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+ use EndfData_common_m
use DerivativeHandler_M
use SammyGridAccess_m
! *** Write theoretical values into ascii file SAMTHE.DAT
@@ -444,7 +442,6 @@ module mint2_m
!
CALL Newopn (59, File, 0)
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToExpGrid(expData)
DO J=1,Ndat
WRITE (59,10000) grid%getEnergy(J, expData), &
@@ -651,9 +648,7 @@ module mint2_m
! which we need to set the values for SammyGridAccess.
!
use modf3_M
- use EndfData_common_m
- use ifwrit_m, only : ktzero
- use fixedi_m, only : numcro
+ use EndfData_common_m
use SammyGridAccess_M
use DerivativeHandler_M
@@ -672,7 +667,6 @@ module mint2_m
integer::Ipos,iso, NumSect, ii, niso
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
niso = derivs%getUsedIsotopes()
if( old) niso = derivs%getUsedIsotopesOld()
diff --git a/sammy/src/int/mint3.f b/sammy/src/int/mint3.f
index 07323c3a85907d5e485c30380e366c16d9a0a8d3..c87f92567ec8f2d80c73ef970be174ba9c856df0 100644
--- a/sammy/src/int/mint3.f
+++ b/sammy/src/int/mint3.f
@@ -25,13 +25,11 @@ C
type(GridData)::grid
type(SammyGridAccess)::gridAccess
DIMENSION Dum(*), Block(*)
-C DIMENSION Data(Ndat*Numcro)
Data Zero /0.0d0/, One /1.0d0/
C
Nsect = 0
Input = 0
call gridAccess%initialize()
- call gridAccess%setParameters(numcro, ktzero)
call gridAccess%setToExpGrid(expData)
IF (Nblock.LT.Ndat) WRITE (6,10010) Nblock, Ndat
10010 FORMAT (' Possible problem with ODF file; Nblock,Ndat=', 2I8)
@@ -255,8 +253,6 @@ C
SUBROUTINE Undo (Data, Ndat)
use fixedr_m
use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
type(SammyGridAccess)::grid
@@ -264,7 +260,6 @@ C
Data Zero /0.0d0/, One /1.0d0/
C
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToExpGrid(expData)
DO I=1,Ndat
@@ -292,9 +287,7 @@ C Unfortunately this value can be different from the numcro set in fixedi_m,
C which we need to set the values for SammyGridAccess.
C
use modf3_M
- use EndfData_common_m
- use ifwrit_m, only : ktzero
- use fixedi_m, only : numcro
+ use EndfData_common_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Th(NumSect,Ndatb), Dum(*)
@@ -302,8 +295,7 @@ C
type(SammyGridAccess)::grid
procedure (arrayFunc), pointer :: f_ptr => auxEArray
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
C
cx Input = 0
diff --git a/sammy/src/int/mint6.f b/sammy/src/int/mint6.f
index 168293743e542fe98f038d6d0a66157b299ce603..40754578ea55aaaefccacfaa802950003c830905 100644
--- a/sammy/src/int/mint6.f
+++ b/sammy/src/int/mint6.f
@@ -2,7 +2,7 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Leal_Hwang (Nblmax, debugOutput)
+ SUBROUTINE Leal_Hwang (Nblmax, debugOutput, Jwwwww)
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -24,14 +24,14 @@ C
use SammyFlowControl_M, only : fitOption
IMPLICIT DOUBLE PRECISION (a-h,o-z)
logical::debugOutput
+ integer::Jwwwww
type(SammyGridAccess)::gridAccess
integer,allocatable,dimension(:)::I_Jjjder, I_Jjjpar
integer::nauxStart
real(kind=8),allocatable,dimension(:)::A_Idum, A_Iblock
C
C *** Here when using Leal-Hwang so need to interpolate to present results
- call gridAccess%initialize()
- call gridAccess%setParameters(numcro, ktzero)
+ call gridAccess%initialize()
call gridAccess%setToExpGrid(expData)
C
C *** Read the cross sections etc
diff --git a/sammy/src/mas/mmas1.f90 b/sammy/src/mas/mmas1.f90
index 2f0540913070ed703296136ea503d6926572bd98..b57a97f6229e330549f4443a8be23e0ea5fcba06 100644
--- a/sammy/src/mas/mmas1.f90
+++ b/sammy/src/mas/mmas1.f90
@@ -556,6 +556,7 @@ contains
use misccc_common_m
use ntyp_common_m
use mdf5_m
+ use broad_common_m, only : dopplerInfo
IMPLICIT DOUBLE PRECISION (a-h,o-z)
CHARACTER*1 Kt, Kc, Ktotal, Ktran
DATA Kt /'T'/, Kc /'C'/
@@ -588,6 +589,7 @@ contains
Mxwrec = 0
Kaddcr = 0
Kkkdop = 2
+ dopplerInfo%bType = 2
Kresol = 0
Ntgrlq = 0
Kidcxx = 0
@@ -613,7 +615,7 @@ contains
use zzzzz_common_m
use misccc_common_m
use ntyp_common_m
-
+ use broad_common_m, only : dopplerInfo
use mdf5_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
@@ -787,6 +789,7 @@ contains
!
ELSE IF (Number.EQ.219 .OR. Number.EQ.220) THEN
Kkkdop = 3
+ dopplerInfo%bType = 3
! *** Use CLM for Doppler broadening
!
!
diff --git a/sammy/src/mas/mmas4.f b/sammy/src/mas/mmas4.f
index 732d7fdc174dbe0a44d2fbbfde52b3d60da68744..6984d66ac07a06ca60f7a07c10b401f4e20d2984 100644
--- a/sammy/src/mas/mmas4.f
+++ b/sammy/src/mas/mmas4.f
@@ -92,6 +92,7 @@ C
use eees_common_m
use namfil_common_m
use mssccc_common_m
+ use broad_common_m, only : dopplerInfo
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
Odfmul = 1.00d0
@@ -262,7 +263,7 @@ C *** # 14 (ENDF/B File 3)
70 CONTINUE
END IF
C
- IF (Kkkdop.EQ.3) THEN
+ IF (dopplerInfo%bType.EQ.3) THEN
C ************************************************************** File 13
WRITE (6,11600)
11600 FORMAT (' What is name of Crystal-Lattice Model file? ')
diff --git a/sammy/src/mso/mmso0.f b/sammy/src/mso/mmso0.f
index 48574d90bf0e61af0e06083cc11ef3b6019bac40..1fd1aed0c283e69f2146c275fd624fa26ae5b20d 100644
--- a/sammy/src/mso/mmso0.f
+++ b/sammy/src/mso/mmso0.f
@@ -9,11 +9,11 @@ C *** "Version 7.0.0 for multiple scattering" or "V7".
C *** This version is faster but probably not as accurate
C *** as subsequent versions.
C
- use fixedi_m, only : Jtheta, Jwwwww, K2reso, Kkkdex,
+ use fixedi_m, only : Jtheta, K2reso, Kkkdex,
* Kkkrsl, Ktheta,
- * Ntheta, Nudwhi, Numcro, Numrpi, Numorr,
+ * Ntheta, Nudwhi, Numrpi, Numorr,
* Numder
- use ifwrit_m, only : Jjjdop, Kssmsc
+ use ifwrit_m, only : Kssmsc
use exploc_common_m
use array_sizes_common_m
use oopsch_common_m, only : Nowwww, Segmen
@@ -216,8 +216,6 @@ C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
C
C
- Jwwwww = 8
- Numcro = 1
Numder = 1
C
call multScat%setNumThetaNearOne( jkn1 )
@@ -226,7 +224,6 @@ C
Ktheta = jkn2 ! remove
call multScat%setNumTheta(jkn3 )
Ntheta = jkn3 ! remove
- Jjjdop = 0
CALL Write_Commons_Many
RETURN
END
diff --git a/sammy/src/mso/mmso2.f b/sammy/src/mso/mmso2.f
index 78c4aaf3abca41e71bff030570f0472f72227108..69defe1f6f5171912f252fe3b03df57630b31a2c 100644
--- a/sammy/src/mso/mmso2.f
+++ b/sammy/src/mso/mmso2.f
@@ -15,10 +15,10 @@ C *** Ssssds generates the [approximation to] the self-shielded,
C *** single-scattered, and double(plus)-scattered capture yield.
C
use fixedi_m, only : Ntepnt, Nxtptv, Nxtptw, Jtheta,
- * Kssmpr, Ntheta, Numbgf, numcro,
+ * Kssmpr, Ntheta, Numbgf,
* Numiso, Numnbk, numUsedPar
use ifwrit_m, only : Nnpar, Kbrd, Kksave, Ksindi, Ksitmp,
- * Ksolve, Kssdbl, Kssmsc, ktzero, Kwssms, Ndat
+ * Ksolve, Kssdbl, Kssmsc, Kwssms, Ndat
use samxxx_common_m, only : Sam15x
use fixedr_m, only : Aaawww, Sensin
use lbro_common_m, only : Debug, Yaverg, Yresol, Yselfi
@@ -73,7 +73,6 @@ C
DATA Zero /0.0d0/, One /1.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
niso = calcData%getUsedIsotopesOld()
C
diff --git a/sammy/src/mso/mmso4.f b/sammy/src/mso/mmso4.f
index e0b8eb30eb5a5fd813876d6a55a4502fdaf74a8d..53b76a6b110906ac58a037256c367d862845561b 100755
--- a/sammy/src/mso/mmso4.f
+++ b/sammy/src/mso/mmso4.f
@@ -20,8 +20,7 @@ C
type(SammyGridAccess)::grid
DATA Zero /0.0d0/, One /1.0d0/
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
C
IF (Idone.EQ.3 .AND. Ientrp.EQ.0) RETURN
@@ -155,8 +154,7 @@ C
* Dy2ccc(Nx,*)
DATA Zero /0.0d0/, One /1.0d0/
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
C
IF (Ientrp.NE.0) THEN
diff --git a/sammy/src/mxw/mmxw5.f b/sammy/src/mxw/mmxw5.f
index a9763475e8b7f2afbc9e4db9b5a4385d6b8932b5..766230df3f5e944ccbcb0adaf5cd4234b21f868b 100644
--- a/sammy/src/mxw/mmxw5.f
+++ b/sammy/src/mxw/mmxw5.f
@@ -39,7 +39,6 @@ C
DATA Etherm /0.00253d0/, Zero /0.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
niso = calcData%getUsedIsotopes()
C
diff --git a/sammy/src/new/mnew0.f b/sammy/src/new/mnew0.f
index 403e9a099f7be4124483f86fb87624d52f03e7f2..61aae11da9d5a53878035f1cebbec1943c38a3cf 100644
--- a/sammy/src/new/mnew0.f
+++ b/sammy/src/new/mnew0.f
@@ -48,7 +48,7 @@ C
C *** Generate proper Zke, radii, Zeta
CALL Fxradi (
* A_Idpiso ,
- * A_Idsiso , A_Izke , A_Izeta )
+ * A_Izke , A_Izeta )
C
call allocate_real_data(A_Iderpp, Nfpall)
idum_size = Ntotc * resParData%getNumResonances()
diff --git a/sammy/src/npv/mnpv7.f b/sammy/src/npv/mnpv7.f
index fb51363fbc98cca65fd4a512ced4e3ac0de6e262..8507dae7237b975912aabd82abdbfefe2baab1c2 100644
--- a/sammy/src/npv/mnpv7.f
+++ b/sammy/src/npv/mnpv7.f
@@ -23,18 +23,15 @@ C
RETURN
END
- real(kind=8) function getDerivative(idat, ncro, iipar
- * ) result(gg)
- use fixedi_m, only : Numcro, numUsedPar
+ real(kind=8) function getDerivative(idat, iipar) result(gg)
+ use fixedi_m, only : numUsedPar
use array_sizes_common_m, only : calcData
implicit none
- integer::idat, ncro, iipar
- integer::ipos
+ integer::idat, iipar
gg = 0.0d0
- if (iipar.le.numUsedPar) then
- ipos = (Idat-1)*Numcro + ncro
- gg = calcData%getData(Ipos, iipar, 1)
+ if (iipar.le.numUsedPar) then
+ gg = calcData%getData(Idat, iipar, 1)
end if
end function getDerivative
C
@@ -54,21 +51,16 @@ C
C
integer::ipup
integer:: Kdat
- integer::Ipar, Ii, I, K, Iffy, keep
+ integer::Ipar, I, K, Iffy, keep
integer::ipos
real(kind=8)::gg, getDerivative
- kdat = resultData%getLength()
- if (Numcro.gt.1) kdat = kdat/Numcro
+ kdat = resultData%getLength()
IF (Ksolve.NE.2) THEN
DO Ipar=1,covData%getNumTotalParam()
- Ii = 1
DO I=1,Kdat
- DO K=1,Numcro
- call resultData%addData(Ii,
- * Ipar + derivStart, 0.0d0)
- Ii = Ii + 1
- END Do
+ call resultData%addData(I,
+ * Ipar + derivStart, 0.0d0)
End do
End do
@@ -76,22 +68,18 @@ C
DO Ipar=1,covData%getNumTotalParam()
IF (covData%contributes(Ipar))THEN
keep = covData%getCovIndex(Ipar)
- Ii = 0
DO I=1,Kdat
- DO K=1,Numcro
- Ii = Ii + 1
- gg = getDerivative(i, k, ipar)
+ gg = getDerivative(i, ipar)
- ipos = 0
- IF (Keep.LE.Nvpthe) THEN ! derivatives start right after derivStart
- ipos = keep + derivStart
- else if (covData%isPupedParameter(ipar)) THEN
- ipos = keep + derivStart + nimplgiven ! pup'ed derivatives start after implicit derivatives
- end if
- if (ipos.gt.0) then
- call resultData%addData(Ii, ipos, gg)
- end if
- End do
+ ipos = 0
+ IF (Keep.LE.Nvpthe) THEN ! derivatives start right after derivStart
+ ipos = keep + derivStart
+ else if (covData%isPupedParameter(ipar)) THEN
+ ipos = keep + derivStart + nimplgiven ! pup'ed derivatives start after implicit derivatives
+ end if
+ if (ipos.gt.0) then
+ call resultData%addData(I, ipos, gg)
+ end if
End do
END IF
END DO
@@ -103,15 +91,11 @@ C
IF (Keep.LE.Nvpthe) THEN
C These are not part of IDC so not needed at Ksolve=2
ELSE IF (covData%isPupedParameter(Ipar)) THEN
- Ii = 0
DO I=1,Kdat
- DO K=1,Numcro
- Ii = Ii + 1
- gg = getDerivative(i, k, Ipar)
+ gg = getDerivative(i, Ipar)
- ipos = keep + derivStart + nimplgiven ! pup'ed derivatives start after implicit derivatives
- call resultData%addData(Ii, ipos, gg)
- End do
+ ipos = keep + derivStart + nimplgiven ! pup'ed derivatives start after implicit derivatives
+ call resultData%addData(I, ipos, gg)
End do
END IF
END IF
diff --git a/sammy/src/npv/mnpv9.f b/sammy/src/npv/mnpv9.f
index 13f87bf56415f493483b50d0dc3486e69be67b64..3c92e91b90076f3e584403b8a6f6c407a70e9fa5 100644
--- a/sammy/src/npv/mnpv9.f
+++ b/sammy/src/npv/mnpv9.f
@@ -8,7 +8,7 @@ C *** Purpose -- Create the arrays Th, G, X, in lowest possible storage
C *** location so that other needed arrays will not wipe out
C *** the storage
C
- use fixedi_m, only : Numcro, Nvpdtp
+ use fixedi_m, only : Nvpdtp
use ifwrit_m, only : Ksolve, Ntgrlq
use exploc_common_m
use samxxx_common_m, only : Sam30x
diff --git a/sammy/src/ntg/mntg0.f b/sammy/src/ntg/mntg0.f
index fd6bf690580c5b3733b1eeba6782bd095eac7a4d..1c3780ac5f0a81b92c626be179c452f9023a6e0e 100644
--- a/sammy/src/ntg/mntg0.f
+++ b/sammy/src/ntg/mntg0.f
@@ -8,7 +8,7 @@ C *** factor, and resonance integral
C
use brdd_common_m, only : Weights
use fixedi_m, only : Kywywy, Numiso, Nvpall
- use ifwrit_m, only : Kplotu, Ksolve, Nfissl
+ use ifwrit_m, only : Ksolve, Nfissl
use exploc_common_m
use array_sizes_common_m
use oopsch_common_m, only : Nowwww, Segmen
@@ -49,7 +49,6 @@ C
Nowwww = 0
C
CALL Initix
- IF (Kplotu.NE.0) Kplotu = 0
C
Kdatb = getNumAuxGridPoints()
Many = 5
diff --git a/sammy/src/ntg/mntg2.f b/sammy/src/ntg/mntg2.f
index 6930c5eda8348b1cc39b6f68ce535f6457734165..8cdfe32297e24491409e8f200290d4656a5bc81d 100644
--- a/sammy/src/ntg/mntg2.f
+++ b/sammy/src/ntg/mntg2.f
@@ -63,11 +63,7 @@ C
Iup = 1
CALL Read_Cross_Sections (Kdatb)
C
-C *** Plotun generates ODF & ASCII file of unaveraged cross sections
IF (Kdatb.NE.Ipnts) STOP '[STOP in Genint in ntg/mntg2.f]'
- IF (Kplotu.EQ.1) Then
- CALL Plotun_d (calcData, Dum, Kdatb, 1, .true.)
- end if
C
C *** initialize
call calcData%nullify()
diff --git a/sammy/src/ntg/mntg3.f b/sammy/src/ntg/mntg3.f
index 06b781ab5cdbdac03bed080306a14395b4ffd2f2..ac82586efd4f522aac884bee199fc67591b3a9fb 100644
--- a/sammy/src/ntg/mntg3.f
+++ b/sammy/src/ntg/mntg3.f
@@ -4,8 +4,7 @@ C --------------------------------------------------------------
C
SUBROUTINE Therml (Kdatb, Numntg, Iso, Kountr)
use fixedi_m
- use EndfData_common_m
- use ifwrit_m, only : ktzero
+ use EndfData_common_m
use SammyGridAccess_M
use array_sizes_common_m, only : calcData
IMPLICIT DOUBLE PRECISION (a-h,o-z)
@@ -13,8 +12,7 @@ C
real(kind=8)::val1, val2
DATA Etherm /0.0253d0/
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
C
C *** J = 1 thermal cross section
diff --git a/sammy/src/ntg/mntg4.f b/sammy/src/ntg/mntg4.f
index b75b70ecb765c871a10934bb87d7525cc1543e1b..f5b56f3c2242697dc8e6f5ede527ed860871b54c 100644
--- a/sammy/src/ntg/mntg4.f
+++ b/sammy/src/ntg/mntg4.f
@@ -33,7 +33,6 @@ C
Aaold = Zero
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
C
C *** figure which energy is just below E1=.00001 eV and E2=3 eV
@@ -387,7 +386,6 @@ C
end if
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
C
C *** figure which energy is just below E1=.00001 eV and E2=3 eV
diff --git a/sammy/src/ntg/mntg6.f b/sammy/src/ntg/mntg6.f
index 2d18fd379e6a328d226b41e80a7bb0241c369ce6..f7b3e2758733c208f41c7f5b8574026bbb491b5c 100644
--- a/sammy/src/ntg/mntg6.f
+++ b/sammy/src/ntg/mntg6.f
@@ -29,7 +29,6 @@ C * Const(2,Numntg)
C
Ipnts = Kdatb
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
C
C *** figure which energies are just below bEgin and Equit
diff --git a/sammy/src/ntg/mntg7.f b/sammy/src/ntg/mntg7.f
index f6cca137ebe7ef2e0b14aa62352d535febfd0ba8..6abded2b3ec14a927680463f3b3e5412b814350e 100644
--- a/sammy/src/ntg/mntg7.f
+++ b/sammy/src/ntg/mntg7.f
@@ -31,7 +31,6 @@ C
C
Ipnts = Kdatb
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
C
C *** figure which energies are just below bEgin and Equit
diff --git a/sammy/src/ntg/mntg8.f b/sammy/src/ntg/mntg8.f
index d4c24fcd46ad83f1359f3bc8c15f5a0398c8168b..400034a01488dab675ceb6e67c7a4d3b33d465da 100644
--- a/sammy/src/ntg/mntg8.f
+++ b/sammy/src/ntg/mntg8.f
@@ -32,7 +32,6 @@ C
Tosp = Two/Sqrtpi
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
C
C *** figure which energy is just below bEgin=1e-5 eV
diff --git a/sammy/src/ntg/mntga.f b/sammy/src/ntg/mntga.f
index 437baa190c55e20dd8ceb8c1f346fe277c3c240d..5119c15e0f010c6e30e025b2e995afbddc051893 100644
--- a/sammy/src/ntg/mntga.f
+++ b/sammy/src/ntg/mntga.f
@@ -34,7 +34,6 @@ C
CALL Findpr (Nflux, Kflux)
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
Ipnts = Kdatb
diff --git a/sammy/src/odf/modf3.f90 b/sammy/src/odf/modf3.f90
index 7bd8851a2c251a94d9746cebf6b08545c259ccb6..f809916d3e075d945b8c4e585e41308fb850795e 100755
--- a/sammy/src/odf/modf3.f90
+++ b/sammy/src/odf/modf3.f90
@@ -449,15 +449,12 @@ contains
!!
real(kind=8) function auxEArray (i) result(data)
use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
use SammyGridAccess_M
implicit none
type(SammyGridAccess)::grid
integer, intent (in) :: i
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
data = grid%getEnergy(i, expData)
diff --git a/sammy/src/old/mold0.f b/sammy/src/old/mold0.f
index c6db795e65fc2483bfd4c0e3c21040c531b9b0ee..32a047c528b277f08380fefb81de820e446363a2 100644
--- a/sammy/src/old/mold0.f
+++ b/sammy/src/old/mold0.f
@@ -94,8 +94,7 @@ C *** Put quantum numbers into PARameter file
END IF
C *** Fix the miscellaneous parameters
- IF (Nummsc.GT.0) CALL Fxxmsc (A_Isiabn , A_Idsiso ,
- * A_Iprmsc )
+ IF (Nummsc.GT.0) CALL Fxxmsc (A_Isiabn , A_Iprmsc )
C
C *** Multiply the initial uncertainty by an Energy (and spin-group)-
C *** dependent multiplier, if applicable
@@ -111,7 +110,7 @@ C
C *** Generate proper Zke, Zkte, Zkfe, Zeta
CALL Fxradi (
* A_Idpiso ,
- * A_Idsiso , A_Izke , A_Izeta )
+ * A_Izke , A_Izeta )
C *** Generate associated flags
CALL Ifxrad
C
diff --git a/sammy/src/old/mold1.f b/sammy/src/old/mold1.f
index cfc7639be1f94bd50e3547f87b6c817d31e525c5..0674bd40c4d7c1c8376a7816239f6f1ffba705e3 100644
--- a/sammy/src/old/mold1.f
+++ b/sammy/src/old/mold1.f
@@ -2,7 +2,7 @@ C
C
C --------------------------------------------------------------
C
- SUBROUTINE Fxradi (Dopwid,Doswid, Zke, Zeta)
+ SUBROUTINE Fxradi (Dopwid, Zke, Zeta)
C
C *** Purpose -- Fix the following parameters:
C *** Zke , where k = Zke * sqrt(E)
@@ -21,7 +21,7 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
DIMENSION
- * Dopwid(*), Doswid(*),
+ * Dopwid(*),
* Zke(Ntotc,*), Zeta(Ntotc,*)
C
type(SammySpinGroupInfo)::spinInfo
@@ -70,21 +70,15 @@ C
& dSQRT(Boltzm*A_Mass_Small*Temp/
& resParData%getMassForIsotope(Iso))
IF (Dopple.LT.Dopwid(Iso)) Dopple = Dopwid(Iso)
- END DO
- END IF
- IF (Sitemp.NE.Zero) THEN
- DO Iso=1,Numiso
- Doswid(Iso) =
- & dSQRT(Boltzm*Sitemp*A_Mass_Small/
- & resParData%getMassForIsotope(Iso))
- IF (Dosind.LT.Doswid(Iso)) Dosind = Doswid(Iso)
+ if (associated(dopplerInfo%broadener)) then
+ dopplerInfo%wantBroaden = .true.
+ end if
END DO
END IF
C
ELSE
C *** here Numiso.EQ.0
Dopwid(1) = Dopple
- Doswid(1) = Dosind
DO Kgroup=1,resParData%getNumSpinGroups()
call resParData%getSpinGroupInfo(spinInfo, Kgroup)
Ntotnn = spinInfo%getNumChannels()
diff --git a/sammy/src/old/mold2.f b/sammy/src/old/mold2.f
index 99d43368aba9de782e0abe801caf2aba7ffeb244..f98d047dc0a0053bb4f1cbd243f8b126f877b317 100644
--- a/sammy/src/old/mold2.f
+++ b/sammy/src/old/mold2.f
@@ -835,7 +835,7 @@ C
C
C _____________________________________________________________
C
- SUBROUTINE Fxxmsc (Siabnd, Doswid, Parmsc)
+ SUBROUTINE Fxxmsc (Siabnd, Parmsc)
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -844,7 +844,7 @@ C
use EndfData_common_m
use SammySpinGroupInfo_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Siabnd(*), Doswid(*), Parmsc(*)
+ DIMENSION Siabnd(*), Parmsc(*)
type(SammySpinGroupInfo)::spinInfo
C
DO 200 I=1,Nummsc
@@ -864,17 +864,8 @@ C
Tzero = Parmsc(I)
Elzero = Parmsc(I+1)
Tttzzz = Sm2*Dist*Elzero
- ELSE IF (Ksitmp.EQ.I) THEN
- Aa = dSQRT(Parmsc(Ksitmp)/Sitemp)
- Dosind = Dosind*Aa
- Sitemp = Parmsc(Ksitmp)
- IF (Numiso.GT.0) THEN
- DO Iso=1,Numiso
- Doswid(Iso) = Doswid(Iso)*Aa
- END DO
- ELSE
- Doswid(1) = Dosind
- END IF
+ ELSE IF (Ksitmp.EQ.I) THEN
+ Sitemp = Parmsc(Ksitmp)
ELSE IF (Ksithc.EQ.I) THEN
Sithck = Parmsc(Ksithc)
ELSE IF (Ksindi.EQ.I) THEN
diff --git a/sammy/src/orr/morr0.f90 b/sammy/src/orr/morr0.f90
index b6b30253a801a03632513b421fadb05096c9ee93..46184e551863f49dcafce3695276144eda9904ab 100644
--- a/sammy/src/orr/morr0.f90
+++ b/sammy/src/orr/morr0.f90
@@ -7,8 +7,7 @@ module orr_m
!
! *** Purpose -- ORR resolution function calculation
!
- use fixedi_m, only : Jwwwww, Numorr, numcro
- use ifwrit_m, only : Jjjdop, Kplotu, ktzero
+ use fixedi_m, only : Numorr, numUsedPar
use fixedr_m, only : Dist
use EndfData_common_m, only : expData
use DopplerAndResolutionBroadener_M
@@ -27,6 +26,7 @@ module orr_m
type(GridDataList)::work
type(DopplerAndResolutionBroadener)::broadener
integer::N, Idimen, nauxMax, ii
+ logical(C_BOOL)::moreBroadening
external Idimen
!
!
@@ -41,20 +41,10 @@ module orr_m
call work%initialize()
call broadener%initialize(calcData, expData, work)
- call broadener%setNumPerEnergy(max(1,numcro))
- ii = 1
- if ( ktzero.ne.0) then
- if (numcro.gt.1) then
- ii = 3
- else
- ii = 2
- end if
- end if
- call broadener%setUnbroadenedGrid(2, ii)
- call broadener%setBroadenedGrid(1, ii) ! always finish on experinental grid
+ moreBroadening = .false.
+ call broadener%setupBroadener(moreBroadening, numUsedPar) ! always finish on experinental grid
!
CALL Initix
- IF (Kplotu.NE.0) Kplotu = 0
nauxMax = getNumAuxGridPoints()
!
! *** GUESSTIMATE SIZE OF ARRAY NEEDED FOR SAMORR
@@ -84,9 +74,6 @@ module orr_m
call work%destroy()
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
!
- Jwwwww = 4
-!
- Jjjdop = 0
CALL Write_Commons_Many
RETURN
!
diff --git a/sammy/src/orr/morr1.f90 b/sammy/src/orr/morr1.f90
index 9258a87adef1665608e8d6ff4ecc8b696db062ff..65248a400667b9bfdd09acc27201343b2e187717 100644
--- a/sammy/src/orr/morr1.f90
+++ b/sammy/src/orr/morr1.f90
@@ -11,7 +11,7 @@ module orr1_m
! *** Purpose -- Form Resolution-broadened cross section and derivatives
!
use fixedi_m, only : Numbgf, Numnbk, Numorr, numUsedPar
- use ifwrit_m, only : Jjjdop, Kdebug
+ use ifwrit_m, only : Kdebug
use brdd_common_m, only : Ipk, Ipnts, Iup, Kc
use DopplerAndResolutionBroadener_M
use mxct27_m
@@ -43,8 +43,6 @@ module orr1_m
call allocate_real_data(Sigmns, Numorr)
call allocate_real_data(Sigpls, Numorr)
!
- call derivs%nullify()
- call derivs%reserve(nexp*derivs%getNnnsig(), numUsedPar+1)
!
! *** initialize limits
Kc = 2
@@ -72,7 +70,7 @@ module orr1_m
IF (Ipnts.LE.5) THEN
!
! ********* no integration possible
- IF (Jjjdop.NE.1) THEN
+ IF (dopplerInfo%bType.ne.1) THEN
Now = Now + 1
do Ipar = 0, numUsedPar
do ns = 1, derivs%getNnnsig()
@@ -143,7 +141,6 @@ module orr1_m
real(kind=8)::A, B, Ddeell, Der1, Der2, P, Sigt
integer::Kwarn
integer::I, Ii, Ipar, Ks, Ksol, N
- logical(C_BOOL)::accu
!
DATA Kwarn /0/, Zero /0.0d0/, One /1.0d0/
!
@@ -175,8 +172,6 @@ module orr1_m
!
!
Sigt = Zero
- accu = .true.
- call derivs%setAccumulate(accu)
DO N=1,derivs%getNnnsig()
do ipar = 0,numUsedPar
val = 0.0d0
@@ -189,8 +184,6 @@ module orr1_m
call derivs%addDataNs(irow, N, Ipar, 1, val)
END DO
END DO
- accu = .false.
- call derivs%setAccumulate(accu)
!
IF (numUsedPar.EQ.0) RETURN
!
diff --git a/sammy/src/ort/mort.f b/sammy/src/ort/mort.f
index a476439cb6b59ce3841fbc4f3fceeb99aa96f983..95214c7393966c5481173d4b25d4818e3ca2e7e7 100644
--- a/sammy/src/ort/mort.f
+++ b/sammy/src/ort/mort.f
@@ -35,8 +35,7 @@ C
C
use over_common_m, only : Kount, Nsize
use oops_common_m, only : Jmsize, Kmsize, Kount_Initial, Msize
- use fixedi_m, only : Iu32, Kwatta, Nmdets, Numorr, numcro
- use ifwrit_m, only : ktzero
+ use fixedi_m, only : Iu32, Kwatta, Nmdets, Numorr, numUsedPar
use fixedr_m, only : Dist
use oopsch_common_m, only : Segmen
use namfil_common_m, only : Dblank, Dignor, Dignor, Fblank,
@@ -56,9 +55,10 @@ C
real(kind=8),allocatable,dimension(:)::A_It, A_Iweigh, A_Iwts
integer,allocatable,dimension(:)::I_Iflorr
real(Kind=8)::Aw, Dt, Elow, Em, Eup
- integer::I, Idimen, Itime, Kpnts, Min, Mndets, N, ii
+ integer::I, Idimen, Itime, Kpnts, Min, Mndets, N
type(DopplerAndResolutionBroadener)::broadener
type(GridDataList)::work
+ logical(C_BOOL)::moreBroadening
external Idimen
@@ -141,18 +141,9 @@ C
call work%initialize()
call broadener%initialize(calcData, expData, work)
- call broadener%setNumPerEnergy(max(1,numcro))
- ii = 1
- if ( ktzero.ne.0) then
- if (numcro.gt.1) then
- ii = 3
- else
- ii = 2
- end if
- end if
- call broadener%setUnbroadenedGrid(2, ii)
- call broadener%setBroadenedGrid(1, ii) ! always finish on experimental grid
-
+ moreBroadening = .false.
+ call broadener%setupBroadener(moreBroadening, numUsedPar)
+
CALL Orresb (broadener, A_Iweigh, A_Iwts, Dist)
CALL Showwe (A_It , A_Iwts, Dt, Ipnts)
CALL Showwt (A_It , A_Iwts, Dt, Kpnts)
diff --git a/sammy/src/ort/mort1.f b/sammy/src/ort/mort1.f
index 52ef439542028516d8c5c178e0c1366b6878aa45..6af6aacef4ea09dd58b3b34cb48faedbab691213 100755
--- a/sammy/src/ort/mort1.f
+++ b/sammy/src/ort/mort1.f
@@ -60,9 +60,7 @@ C --------------------------------------------------------------
C
SUBROUTINE Showwe (Tt, Wts, Dt, Ipnts)
use modf3_M
- use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+ use EndfData_common_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
CHARACTER*17 Xxxxxx, Xxxxxy
@@ -80,8 +78,7 @@ C un-normalize !
Wts(I) = Wts(I)/Dt
END DO
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
C
Nsn = 3
diff --git a/sammy/src/par/mpar0.f90 b/sammy/src/par/mpar0.f90
index b60a3970ea1ee531c0dba1720d2cbfa59d80581e..9b3598e0b26b27a6021aa2bb5b8159908d0c470a 100644
--- a/sammy/src/par/mpar0.f90
+++ b/sammy/src/par/mpar0.f90
@@ -43,6 +43,7 @@ module par_m
use par16_m
use par17_m
use par19_m
+ use broad_common_m, only : dopplerInfo
IMPLICIT NONE
integer,allocatable,dimension(:)::I_tmp
real(kind=8),allocatable,dimension(:)::A_Ixtptw, A_Ixtplw, &
@@ -279,7 +280,10 @@ module par_m
!
!xxxxxxxxxxxxxxxxxxxxxxx
Kenbbb = 0
- IF (Kkkdop.NE.2 .AND. Kkkdop.NE.3 .AND. Ksitmp.GT.0) Kkkdop = 2
+ IF (dopplerInfo%bType.NE.2 .AND. dopplerInfo%bType.NE.3 .AND. Ksitmp.GT.0) then
+ Kkkdop = 2
+ dopplerInfo%bType = 2
+ end if
CALL Write_Commons_Few
RETURN
END
diff --git a/sammy/src/par/mpar04.f90 b/sammy/src/par/mpar04.f90
index 234c2ba4291280e226eb17444c11ad272a728e67..5532bed7e9d3dfc2a85f7d209db7f0fdf818c068 100644
--- a/sammy/src/par/mpar04.f90
+++ b/sammy/src/par/mpar04.f90
@@ -359,7 +359,9 @@ module par4_m
Sitemp = A
Sithck = C
Dopple = dSQRT(Boltzm* Temp*Aneutr/Aaawww)
- Dosind = dSQRT(Boltzm*Sitemp*Aneutr/Aaawww)
+ if (associated(dopplerInfo%broadener)) then
+ dopplerInfo%wantBroaden = .true.
+ end if
N = N + 2
!
ELSE IF (Xx.EQ.Effici) THEN
diff --git a/sammy/src/ref/mref0.f b/sammy/src/ref/mref0.f
index b5b66c7e8b9d4a51b4b1cdc9759f24e8390319aa..0f71702eed6dcfa0cfe4ea7f86a2133a9bd5c92e 100644
--- a/sammy/src/ref/mref0.f
+++ b/sammy/src/ref/mref0.f
@@ -66,7 +66,6 @@ C *** read Energy from 50 & Data, Uncertainty from 44
C
use EndfData_common_m
use SammyGridAccess_M
- use fixedi_m, only : numcro
use ifwrit_m, only : Kdatv
IMPLICIT NONE
type(GridData)::grid
diff --git a/sammy/src/ref/mref2.f b/sammy/src/ref/mref2.f
index a184a0406f71d6494d6569c4435d7cea28f4832a..19d39c460327e085b2945d73c72d428f67d8a775 100644
--- a/sammy/src/ref/mref2.f
+++ b/sammy/src/ref/mref2.f
@@ -12,13 +12,11 @@ C
use samxxx_common_m
use fixedr_m
use EndfData_common_m
- use fixedi_m, only : numcro
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (A-h,o-z)
type(SammyGridAccess)::grid
DIMENSION Data(*), dData(*)
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToExpGrid(expData)
Jcros = Kcros
Jtrans = Ktrans
diff --git a/sammy/src/ref/mrfs2.f b/sammy/src/ref/mrfs2.f
index 16ac0d71eafc6bf9e906fab088d39279dc305279..fbe40f02cb75af6d7793f4e54e8322d5adb719ec 100644
--- a/sammy/src/ref/mrfs2.f
+++ b/sammy/src/ref/mrfs2.f
@@ -91,8 +91,10 @@ C
use exploc_common_m
use broad_common_m
use aaarfs_common_m
- use EndfData_common_m, only : radFitFlags
+ use GridData_M
+ use EndfData_common_m, only : radFitFlags, expData
IMPLICIT DOUBLE PRECISION (A-h,o-z)
+ type(GridData)::grid
C
call make_A_Iprbrd(Numbrd)
call make_I_Iflbrd(Numbrd)
@@ -107,9 +109,19 @@ C
C *** three
N = Nangle
IF (N.EQ.0) N = 1
- Numcro = N
call make_A_Iangle(N)
call make_A_Idangl(N)
+
+ if (expData%getLength().eq.0) then
+ call grid%initialize()
+ call expData%addGrid(grid)
+ if (Nangle.gt.0) then
+ call grid%setNumPerEnergy(Nangle)
+ end if
+ ! one point per energy is the default
+
+ numcro = grid%getNumPerEnergy()
+ end if
C
C *** four
N = Ncf
diff --git a/sammy/src/ref/mrfs3.f b/sammy/src/ref/mrfs3.f
index 9e38e3fd47999b9f0e4360ea66f4fc87f9034724..f7d10bb00060d71e6851933f812831801368073c 100644
--- a/sammy/src/ref/mrfs3.f
+++ b/sammy/src/ref/mrfs3.f
@@ -79,8 +79,6 @@ C *** CARD SET 5 Broadening information
Deltal = 0.0d0
Deltae = 0.0d0
Delta6 = 0.0d0
- Delttt = 0.0d0
- Elowbr = 0.0d0
C
C *** CARD SET 6 (IF IT'S PRESENT)
Deltab = 1.0d0
diff --git a/sammy/src/ref/mwrt1.f b/sammy/src/ref/mwrt1.f
index 65228f4db35bcc95d0127c017f18a119f9c73cee..8d55753221594499c8ab7d67b11f136db17d8d00 100644
--- a/sammy/src/ref/mwrt1.f
+++ b/sammy/src/ref/mwrt1.f
@@ -41,6 +41,7 @@ C
type(RMatParticlePair)::pair
type(RMatChannelParams)::channel
type(SammyChannelInfo)::channelInfo
+ real(kind=8)::Elowbr, Delttt
C
OPEN (UNIT=11, FILE='SAMMY.INP', STATUS='unknown',
* FORM='formatted')
@@ -76,9 +77,22 @@ C *** Card Set 4.5 Energies at which to plot resolution fUnction
10450 FORMAT (8F10.3)
C
C *** CARD SET 5 Broadening information
- IF (Ib.EQ.1) WRITE (11,10500) Temp, Dist, Deltal, Deltae, Deltag,
+ Delttt = 0.0d0
+ IF (Ib.EQ.1) then
+ Elowbr = 0
+ if (associated(dopplerInfo%freeGas)) then
+ Elowbr = dopplerInfo%freeGas%Elowbr
+ else if (
+ * associated(dopplerInfo%highEnergyFreeGas)) then
+ Elowbr = dopplerInfo%highEnergyFreeGas%Elowbr
+ else if (
+ * associated(dopplerInfo%lealHwang)) then
+ Delttt = dopplerInfo%lealHwang%DelT
+ end if
+ WRITE (11,10500) Temp, Dist, Deltal, Deltae, Deltag,
* Delttt, Elowbr
10500 FORMAT (8F10.5)
+ end if
C
C *** CARD SET 6 (IF IT'S PRESENT)
IF (Ncf.GT.0) THEN
@@ -184,15 +198,12 @@ C
C --------------------------------------------------------------
C
SUBROUTINE Wrtdat (Data, Unc, Ndat)
- use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+ use EndfData_common_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (A-h,o-z)
type(SammyGridAccess)::grid
DIMENSION Data(*), Unc(*)
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToExpGrid(expData)
OPEN (UNIT=10, FILE='SAMMY.DAT', STATUS='unknown',
* FORM='formatted')
diff --git a/sammy/src/rpi/mrpi0.f90 b/sammy/src/rpi/mrpi0.f90
index de14a75318b375e7ea9aed2213f9168fdd9a72e3..97692cc8e3695ce7fec2b38ace57bc5eceea13a9 100644
--- a/sammy/src/rpi/mrpi0.f90
+++ b/sammy/src/rpi/mrpi0.f90
@@ -6,8 +6,7 @@ module rpi_m
!
SUBROUTINE Samrpi_0
!
- use fixedi_m, only : Jwwwww, Medrpi, Mmmrpi
- use ifwrit_m, only : Jjjdop, Kplotu
+ use fixedi_m, only : Medrpi, Mmmrpi
use exploc_common_m
use array_sizes_common_m
use oopsch_common_m, only : Nowwww, Segmen
@@ -33,7 +32,6 @@ module rpi_m
Nowwww = 0
!
CALL Initix
- IF (Kplotu.NE.0) Kplotu = 0
!
nauxMax = getNumAuxGridPoints()
!
@@ -80,9 +78,6 @@ module rpi_m
deallocate(A_Ixxxrp)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
!
- Jwwwww = 4
-!
- Jjjdop = 0
CALL Write_Commons_Many
RETURN
!
diff --git a/sammy/src/rpi/mrpi1.f90 b/sammy/src/rpi/mrpi1.f90
index aabe3b426350b0197f527991a84c9d24e89f2738..541cb85252d5ba7c850138bd9ad60a1c2914db44 100644
--- a/sammy/src/rpi/mrpi1.f90
+++ b/sammy/src/rpi/mrpi1.f90
@@ -11,8 +11,8 @@ module rpi1_m
! *** using RPI resolution function
!
use fixedi_m, only : numUsedPar, &
- Nfprpi, Nnnrpi, numcro, Numnbk, Numbgf
- use ifwrit_m, only : Jjjdop, Kdebug, Ksolve, ktzero
+ Nfprpi, Nnnrpi, Numnbk, Numbgf
+ use ifwrit_m, only : Kdebug, Ksolve
use brdd_common_m, only : Ipk, Ipnts, Iup, Kc
use rpijnk_common_m
use rpires_common_m
@@ -43,7 +43,6 @@ module rpi1_m
type(DerivativeHandler)::derivs
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToExpGrid(expData)
numEl = grid%getNumEnergies(expData)
@@ -85,7 +84,7 @@ module rpi1_m
IF (Ipnts.LE.5) THEN
!
! ********* No integration possible
- IF (Jjjdop.NE.1) THEN
+ IF (dopplerInfo%bType.ne.1) THEN
Now = Now + 1
do Ipar = 0, numUsedPar
do ns = 1, derivs%getNnnsig()
diff --git a/sammy/src/rpi/mrpi5.f90 b/sammy/src/rpi/mrpi5.f90
index 639db56d55fa65746e0cf2a272506716e97d3bbe..9b24f35bcde60b5c1936def19390f39da87fa272 100644
--- a/sammy/src/rpi/mrpi5.f90
+++ b/sammy/src/rpi/mrpi5.f90
@@ -9,8 +9,6 @@ module rpi5_m
!
! *** PURPOSE -- form the resolution-broadening function
!
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
use rpires_common_m
@@ -29,7 +27,6 @@ module rpi5_m
logical debug
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
debug=.false.
@@ -123,8 +120,8 @@ module rpi5_m
! *** November 16, 1999 -- Mods to fix subtle, obscure bug uncovered by
! *** Greg Leinweber in Troy, NY
!
- use fixedi_m, only : numcro, Lother, Mmmrpi
- use ifwrit_m, only : ktzero, Itdchi
+ use fixedi_m, only : Lother, Mmmrpi
+ use ifwrit_m, only : Itdchi
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
@@ -160,7 +157,6 @@ module rpi5_m
CALL Zero_Array (Wts, Ipnts)
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
Aw = Aaa/Www
diff --git a/sammy/src/rpi/mrpi6.f90 b/sammy/src/rpi/mrpi6.f90
index 85a67cc9f31584b09eb2e05ecff2852125af24b1..f8771cffb47a5f503505676ccde892f52260f60b 100644
--- a/sammy/src/rpi/mrpi6.f90
+++ b/sammy/src/rpi/mrpi6.f90
@@ -11,8 +11,8 @@ module rpi6_m
! *** PURPOSE -- Form the weights for resolution broadening when
! *** only the RPI target-detector function is used
!
- use fixedi_m, only : numcro, Lother
- use ifwrit_m, only : ktzero, Itdchi
+ use fixedi_m, only : Lother
+ use ifwrit_m, only : Itdchi
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
@@ -35,7 +35,6 @@ module rpi6_m
DATA Zero /0.0d0/, Half /0.5d0/, Two /2.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
Timeij_Old = 0.0d0
@@ -309,8 +308,6 @@ module rpi6_m
! *** PURPOSE -- Form the weights for resolution broadening when
! *** only the electron burst is included (Gaussian)
!
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
@@ -334,7 +331,6 @@ module rpi6_m
CALL Zero_Array (Wts, Ipnts)
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
Allmax = Zero
@@ -374,9 +370,7 @@ module rpi6_m
!
! *** PURPOSE -- Form the weights for resolution broadening when
! *** only the channel widths contribute
-!
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+!
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
@@ -394,7 +388,6 @@ module rpi6_m
DATA Zero /0.0d0/, Half /0.5d0/, One/ 1.0d0/, Two /2.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
!
@@ -471,8 +464,6 @@ module rpi6_m
! *** the (Gaussian) electron burst and the (square) channel
! *** widths are included
!
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
@@ -491,7 +482,6 @@ module rpi6_m
!
DATA Zero /0.0d0/, Two /2.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
!
@@ -542,8 +532,8 @@ module rpi6_m
! *** the (Gaussian) electron burst and the (chi squared
! *** plus exponential) target-detector are included
!
- use fixedi_m, only : numcro, Lother
- use ifwrit_m, only : ktzero, Itdchi
+ use fixedi_m, only : Lother
+ use ifwrit_m, only : Itdchi
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
@@ -565,7 +555,6 @@ module rpi6_m
DATA Zero /0.0d0/, Half /0.5d0/, Two /2.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
!
@@ -694,8 +683,8 @@ module rpi6_m
! *** the (square) channel width and the (chi squared
! *** plus exponential) target-detector are included
!
- use fixedi_m, only : numcro, Lother
- use ifwrit_m, only : ktzero, Itdchi
+ use fixedi_m, only : Lother
+ use ifwrit_m, only : Itdchi
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
@@ -717,7 +706,6 @@ module rpi6_m
DATA Small /0.5d0/, Zero /0.0d0/, One/1.0d0/, Two /2.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
!
diff --git a/sammy/src/rpi/mrpi8.f90 b/sammy/src/rpi/mrpi8.f90
index a55807b0c6d276c9343a0bce6112c9d134f7ee51..eea10bb7b44f49a94888134f8fead5cb5f4d30bd 100644
--- a/sammy/src/rpi/mrpi8.f90
+++ b/sammy/src/rpi/mrpi8.f90
@@ -42,8 +42,8 @@ module rpi8_m
! *** broadening when using (Gaussian) burst, RPI resolution,
! *** and (square) channel width
!
- use fixedi_m, only : numcro, Lother, Mmmrpi
- use ifwrit_m, only : ktzero, Itdchi
+ use fixedi_m, only : Lother, Mmmrpi
+ use ifwrit_m, only : Itdchi
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
@@ -79,8 +79,7 @@ module rpi8_m
END IF
! *** initialize
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
!
diff --git a/sammy/src/rpi/mrpi9.f90 b/sammy/src/rpi/mrpi9.f90
index 5324428eb74f219662704913fa6be21783f5a13a..0f635618ad07397841ed435106fb05706e98304d 100644
--- a/sammy/src/rpi/mrpi9.f90
+++ b/sammy/src/rpi/mrpi9.f90
@@ -11,8 +11,8 @@ module rpi9_m
! *** broadening parameters when only the RPI target-detector
! *** function is used
!
- use fixedi_m, only : numcro, Lother, Mmmrpi
- use ifwrit_m, only : ktzero, Itdchi
+ use fixedi_m, only : Lother, Mmmrpi
+ use ifwrit_m, only : Itdchi
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m, only : Time, Ac6x, A7x
@@ -44,7 +44,6 @@ module rpi9_m
IF (Kstop.EQ.0) STOP '[ STOP - Onlytd_Der is not yet working in mrpi9.f]'
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
! *** initialize
@@ -291,8 +290,6 @@ module rpi9_m
! *** PURPOSE -- Form the derivatives of the weights for resolution
! *** broadening when only the electron burst is included
!
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
@@ -312,7 +309,6 @@ module rpi9_m
! *** initialize
CALL Zero_Array (Wtsx, Ipnts)
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
Summax = Zero
@@ -338,8 +334,6 @@ module rpi9_m
! *** PURPOSE -- Form the derivatives of the weights for resolution
! *** broadening when only the channel widths contribute
!
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
@@ -361,7 +355,6 @@ module rpi9_m
IF (Kstop.EQ.0) STOP '[STOP -- Onlych_Der not yet ready in mrpi9.f]'
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
! *** initialize
@@ -436,8 +429,6 @@ module rpi9_m
! *** the (Gaussian) electron burst and the (square) channel
! *** widths are included
!
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
@@ -462,7 +453,6 @@ module rpi9_m
!
CALL Zero_Array (Wtsx, Ipnts)
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
DO Ie=1,Ipnts
eIe = grid%getEnergy(Ie+Kc-1, expData)
@@ -514,8 +504,8 @@ module rpi9_m
! *** the (Gaussian) electron burst and the (chi squared
! *** plus exponential) target-detector are included
!
- use fixedi_m, only : numcro, Lother
- use ifwrit_m, only : ktzero, Itdchi
+ use fixedi_m, only : Lother
+ use ifwrit_m, only : Itdchi
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
@@ -541,8 +531,7 @@ module rpi9_m
!
IF (Kstop.EQ.0) STOP '[Stop -- Ebantd_Der not yet ready rpi/mpri9.f]'
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
!
! *** initialize
@@ -669,8 +658,7 @@ module rpi9_m
! *** the (square) channel width and the (chi squared
! *** plus exponential) target-detector are included
!
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero, Itdchi
+ use ifwrit_m, only : Itdchi
use fixedr_m, only : Ttoe
use brdd_common_m, only : Ipnts, Kc
use rpijnk_common_m
@@ -695,7 +683,6 @@ module rpi9_m
!
IF (Kstop.EQ.0) STOP '[Stop -- Chantd_Der not yet ready rpi/mrpi9.f]'
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
! *** initialize
diff --git a/sammy/src/rpt/mrpt1.f b/sammy/src/rpt/mrpt1.f
index 5b687cfa829a3d1de9e033c4bd0c81f2cdd5ba47..4612a4af644fee20af063eb1d48a8975e8bc48f5 100644
--- a/sammy/src/rpt/mrpt1.f
+++ b/sammy/src/rpt/mrpt1.f
@@ -81,9 +81,7 @@ C
use rpires_common_m
use rpirrr_common_m
use modf3_M
- use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+ use EndfData_common_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
@@ -102,8 +100,7 @@ C un-normalize !
Wts(I) = Wts(I)*Wwnorm
END DO
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
C
C normalize for comparison to components of resolution function
diff --git a/sammy/src/rsl/mrsl0.f90 b/sammy/src/rsl/mrsl0.f90
index 92a89a0a2f407df54dfe162f69369fc465a52b4b..eaca6b2f2944c2475797de77db07e13bb2269c76 100644
--- a/sammy/src/rsl/mrsl0.f90
+++ b/sammy/src/rsl/mrsl0.f90
@@ -5,9 +5,8 @@ module rsl_m
!
SUBROUTINE Samrsl_0
!
- use fixedi_m, only : Jwwwww, K2reso, Kkkdex, Nudwhi, numcro, &
+ use fixedi_m, only : K2reso, Kkkdex, Nudwhi, &
Numorr, Numrpi
- use ifwrit_m, only : ktzero, Jjjdop, Kplotu
use exploc_common_m
use array_sizes_common_m
use oopsch_common_m, only : Nowwww, Segmen
@@ -36,7 +35,6 @@ module rsl_m
Segmen(3) = 'L'
Nowwww = 0
!
- IF (Kplotu.NE.0) Kplotu = 0
Kdatb = getNumAuxGridPoints()
!
! *** GUESSTIMATE SIZE OF ARRAY NEEDED FOR SAMRSL
@@ -44,11 +42,9 @@ module rsl_m
!
!
- call eGrid%initialize()
- call eGrid%setParameters(numcro, ktzero)
+ call eGrid%initialize()
call eGrid%setToExpGrid(expData)
- call auxGrid%initialize()
- call auxGrid%setParameters(numcro, ktzero)
+ call auxGrid%initialize()
call auxGrid%setToAuxGrid(expData)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
@@ -72,9 +68,6 @@ module rsl_m
deallocate(A_Iwts)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
!
- Jwwwww = 4
-!
- Jjjdop = 0
CALL Write_Commons_Many
call eGrid%destroy()
diff --git a/sammy/src/rsl/mrsl1.f90 b/sammy/src/rsl/mrsl1.f90
index 3e86a34123320bdd31d43e936679e5e9a067d1f1..935ed0959deb7396d8480f04e928f63023b17e64 100644
--- a/sammy/src/rsl/mrsl1.f90
+++ b/sammy/src/rsl/mrsl1.f90
@@ -15,9 +15,9 @@ module rsl1_m
! *** derivatives
!
use fixedi_m, only : K2reso,Numbgf, Numnbk, numUsedPar
- use ifwrit_m, only : Jjjdop, Kdebug, Kjdele, Kjdell, Ksolve, Ndat
+ use ifwrit_m, only : Kdebug, Kjdele, Kjdell, Ksolve, Ndat
use fixedr_m
- use broad_common_m, only : Bo2, Co2, Dell00, Deltae,Dell00, Dele00, Dele11, Dele22, Dell11, deltal
+ use broad_common_m, only : Bo2, Co2, Dell00, Deltae,Dell00, Dele00, Dele11, Dele22, Dell11, deltal, dopplerInfo
use brdd_common_m, only : Ipk, Ipnts, Iup, Kc
use constn_common_m, only : Sm2
use Wdsint_m, only : Wdsint
@@ -112,7 +112,7 @@ module rsl1_m
!
IF (Ipnts.LE.5) THEN
! ********* No integration is possible
- IF (Jjjdop.NE.1) THEN
+ IF (dopplerInfo%bType.ne.1) THEN
Now = Now + 1
do Ipar = 0, numUsedPar
do ns = 1, derivs%getNnnsig()
diff --git a/sammy/src/rsl/mrsl3.f90 b/sammy/src/rsl/mrsl3.f90
index 0b35486a87f542183018fa6bc46ddbfcf0781d96..d087536522ace3a3457898f4ef50b6cc25645afc 100644
--- a/sammy/src/rsl/mrsl3.f90
+++ b/sammy/src/rsl/mrsl3.f90
@@ -9,8 +9,7 @@ module rsl3_m
! *** interpolate to get (un-resolution-broadened) result, when energy
! *** grid Energb is from Leal-Hwang evenly-spaced-in-velocity
!
- use fixedi_m, only : numcro,numUsedPar
- use ifwrit_m, only : ktzero
+ use fixedi_m, only : numUsedPar
use abro_common_m, only : Delv
use EndfData_common_m, only : expData
use AuxGridHelper_M, only : getNumAuxGridPoints
@@ -28,8 +27,7 @@ module rsl3_m
integer::I1, I2, I3, Ipar, N, nauxMax
DATA half /0.5d0/
!
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
nauxMax = getNumAuxGridPoints()
diff --git a/sammy/src/rsl/mrsl6.f90 b/sammy/src/rsl/mrsl6.f90
index ee9621e6342a20f5c49cded80ef0cb95252cb326..3f9fa630dfc3e4ba643e57b447411e6356cf9c60 100644
--- a/sammy/src/rsl/mrsl6.f90
+++ b/sammy/src/rsl/mrsl6.f90
@@ -11,9 +11,7 @@ module rsl6_m
!
use brdd_common_m, only : Ipk, Ipke, Ipnts, Kc, Iup
use EndfData_common_m, only : expData
- use AuxGridHelper_M, only : getNumAuxGridPoints
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+ use AuxGridHelper_M, only : getNumAuxGridPoints
use SammyGridAccess_M
type(SammyGridAccess)::grid
@@ -22,7 +20,6 @@ module rsl6_m
integer::Ilow, nauxMax
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
nauxMax = getNumAuxGridPoints()
diff --git a/sammy/src/rst/mrst0.f90 b/sammy/src/rst/mrst0.f90
index e1979ca2bef1cb8190cd0ed19def464681d8a856..4c367a4a8d91bf43062bedba1a057e1f5346372d 100644
--- a/sammy/src/rst/mrst0.f90
+++ b/sammy/src/rst/mrst0.f90
@@ -4,8 +4,7 @@ module rst_m
!
SUBROUTINE Samrst_0
!
- use fixedi_m, only : Jwwwww
- use ifwrit_m, only : Jjjdop, Kplotu, Ndatb
+ use ifwrit_m, only : Ndatb
use exploc_common_m
use oopsch_common_m, only : Nowwww, Segmen
use rst1_m
@@ -23,7 +22,6 @@ module rst_m
Nowwww = 0
!
CALL Initil
- IF (Kplotu.NE.0) Kplotu = 0
!
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
@@ -40,8 +38,6 @@ module rst_m
deallocate(A_IWts)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
!
- Jwwwww = 4
- Jjjdop = 0
CALL Write_Commons_Few
RETURN
!
diff --git a/sammy/src/rst/mrst1.f90 b/sammy/src/rst/mrst1.f90
index a62bf6f7ccaa2314ba3096bad3c30f31708eade3..c461794119086c3c63692268f41f0611fb853b34 100644
--- a/sammy/src/rst/mrst1.f90
+++ b/sammy/src/rst/mrst1.f90
@@ -108,8 +108,7 @@ module rst1_m
! *** GAUSSIAN+EXPONENTIAL resolution function, AND
! *** NORMALIZE THEM
!
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero, Kexpsh
+ use ifwrit_m, only : Kexpsh
use broad_common_m, only : Iesopr
use brdd_common_m, only : Ipnts, Ipke, Kc
use EndfData_common_m, only : expData
@@ -131,7 +130,6 @@ module rst1_m
DATA Zero /0.0d0/, Half /0.5d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
!
diff --git a/sammy/src/salmon/DerivativeList.cpp b/sammy/src/salmon/DerivativeList.cpp
index 55128e0734bace2492f102973c24983893f37066..2b8f467d0484dfdeb9cd4ecdd95beec2cffae8e8 100644
--- a/sammy/src/salmon/DerivativeList.cpp
+++ b/sammy/src/salmon/DerivativeList.cpp
@@ -200,9 +200,7 @@ namespace sammy {
void DerivativeList::addSharedColumn(int col, int iso){
- if (isSharedColumn(col)) {
- int ourCol = realColIndices[col];
- if (ourCol < 0) ourCol = -1*ourCol - 1;
+ if (isSharedColumn(col)) {
// The function allows a reset because in legacy SAMMY the
// isotope index was not always set to the correct isotope.
// Therefore the C++ setup get's a chance to reset the
diff --git a/sammy/src/salmon/GridData.cpp b/sammy/src/salmon/GridData.cpp
index 9fb512cf35003c765ee5b9fdc822012fe1e0cf2a..299d2f81fd5e171f8a4fab8786fb8a6e9995cd37 100644
--- a/sammy/src/salmon/GridData.cpp
+++ b/sammy/src/salmon/GridData.cpp
@@ -7,7 +7,8 @@ namespace sammy{
rowOffset(orig.rowOffset),
rowMax(orig.rowMax),
notSetReturnsZero(orig.notSetReturnsZero),
- accumulate(orig.accumulate){
+ accumulate(orig.accumulate),
+ numPerEner(orig.numPerEner){
if (orig.implicitParCov != nullptr){
implicitParCov = std::make_unique<endf::ResonanceCovariance>(*(orig.implicitParCov));
diff --git a/sammy/src/salmon/GridData.h b/sammy/src/salmon/GridData.h
index cc9ed05249742fb8a5bb4e7f4d2a833d4a99354b..f25064159532f5a387759165fa6e79a592591b16 100644
--- a/sammy/src/salmon/GridData.h
+++ b/sammy/src/salmon/GridData.h
@@ -31,7 +31,7 @@ namespace sammy{
*/
class GridData {
public:
- GridData():dataIndex(-1), rowOffset(0), rowMax(0), notSetReturnsZero(false),accumulate(false){}
+ GridData():dataIndex(-1), rowOffset(0), rowMax(0), notSetReturnsZero(false),accumulate(false), numPerEner(1){}
GridData(const GridData & orig);
virtual ~GridData(){}
@@ -170,6 +170,20 @@ namespace sammy{
*/
void reserve(int maxRow, int maxCol);
void reserveColumn(int row, int maxCol);
+
+ /**
+ * Get the number of points per energy
+ *
+ * @return the points per energy
+ */
+ int getNumPerEnergy() const{ return numPerEner;}
+
+ /**
+ * Set the number of points per energy
+ *
+ * @param n the points per energy
+ */
+ void setNumPerEnergy(int n) { numPerEner = n;}
protected:
std::vector< std::vector<double> > data;
@@ -182,6 +196,8 @@ namespace sammy{
bool notSetReturnsZero;
bool accumulate;
+ int numPerEner;
+
// arrays for the implicit data covariance
// covariance for the implicit parameters
diff --git a/sammy/src/salmon/SammyGridAccess.cpp b/sammy/src/salmon/SammyGridAccess.cpp
index d60bb719edce92a8d5ef4281abbd9ff4a5777f6f..8063b925c817bb8e4c83c0cc5c63d3df17d02dc4 100644
--- a/sammy/src/salmon/SammyGridAccess.cpp
+++ b/sammy/src/salmon/SammyGridAccess.cpp
@@ -2,12 +2,6 @@
#include <exception>
namespace sammy {
- void SammyGridAccess::setParameters(int numcro, int ktzero){
- this->numcro = numcro;
- this->ktzero = ktzero;
- if (this->numcro == 0) this->numcro = 1;
- }
-
void SammyGridAccess::setToExpGrid(const GridDataList & list){
gridIndex = list.getExpGridIndex();
@@ -32,6 +26,7 @@ namespace sammy {
int SammyGridAccess::getNumEnergies(const GridDataList & list) const{
const std::unique_ptr<GridData> & grid = getGrid(list);
+ int numcro = grid->getNumPerEnergy();
int ll = grid->getLength();
ll /= numcro;
@@ -47,14 +42,11 @@ namespace sammy {
double SammyGridAccess::getEnergy(int index, const GridDataList & list) const{
const std::unique_ptr<GridData> & grid = getGrid(list);
+ int numcro = grid->getNumPerEnergy();
- int ipos = 0;
- if (gridIndex == list.getExpGridIndex() || list.getLength() == 1){
- if (ktzero != 0){
- if( numcro > 1) ipos = 2;
- else ipos = 1;
- }
- }
+ int ipos = grid->getDataColumn() - 1;
+ if (numcro > 1) ipos--;
+ if (ipos < 0) ipos = 0;
int jj = index;
if( useOffsets) jj += grid->getRowOffset();
@@ -69,6 +61,7 @@ namespace sammy {
int jj = index;
if( useOffsets) jj += grid->getRowOffset();
+ int numcro = grid->getNumPerEnergy();
jj *= numcro;
return grid->getData(jj, 0);
diff --git a/sammy/src/salmon/SammyGridAccess.h b/sammy/src/salmon/SammyGridAccess.h
index add19dcd97a67c93c4c22213d9ed6551ba556e46..dd384589406c95873c81623237a83d6da5e2908e 100644
--- a/sammy/src/salmon/SammyGridAccess.h
+++ b/sammy/src/salmon/SammyGridAccess.h
@@ -26,17 +26,10 @@ namespace sammy{
class SammyGridAccess
{
public:
- SammyGridAccess():numcro(1),ktzero(0),gridIndex(0),useOffsets(true){}
+ SammyGridAccess():gridIndex(0),useOffsets(true){}
+ SammyGridAccess(const SammyGridAccess & orig) = delete;
virtual ~SammyGridAccess(){}
- /**
- * Set the values for numcro and ktzero.
- * See class description for more info.
- *
- * @param numcro number of angles on the angle grid for each energy
- * @param ktzero do we have an energy calibration applied
- */
- void setParameters(int numcro, int ktzero);
/**
* Indicate that this access is for the experimental grid
@@ -87,10 +80,6 @@ namespace sammy{
private:
const std::unique_ptr<GridData> & getGrid( const GridDataList & list) const;
- int numcro; // number of angles
-
- int ktzero; // did we correct to time-of-flight
-
int gridIndex;
bool useOffsets;
diff --git a/sammy/src/salmon/interface/cix/GridData.cpp2f.xml b/sammy/src/salmon/interface/cix/GridData.cpp2f.xml
index 8fbc81c4ce1bd4566942e8fa82a7d7cdc19ac673..1e484fa6512b485d03c506488e25da49c821fdc5 100644
--- a/sammy/src/salmon/interface/cix/GridData.cpp2f.xml
+++ b/sammy/src/salmon/interface/cix/GridData.cpp2f.xml
@@ -33,6 +33,11 @@
<param name="col" type="int"/>
</method>
+ <method name="getNumPerEnergy" return_type="int"/>
+ <method name="setNumPerEnergy">
+ <param name="n" type="int"/>
+ </method>
+
<method name="addImplicitDerivs">
<param name="grid" type="GridData*"/>
</method>
diff --git a/sammy/src/salmon/interface/cix/SammyGridAccess.cpp2f.xml b/sammy/src/salmon/interface/cix/SammyGridAccess.cpp2f.xml
index e25c6e7a3edb4c19ec757d346f151075e9231538..3d4f8da2c848a0de9c05d5d4802158a691f84f1f 100644
--- a/sammy/src/salmon/interface/cix/SammyGridAccess.cpp2f.xml
+++ b/sammy/src/salmon/interface/cix/SammyGridAccess.cpp2f.xml
@@ -3,10 +3,6 @@
<using_namespace name="sammy"/>
<class name="SammyGridAccess">
- <method name="setParameters">
- <param name="numcro" type="int"/>
- <param name="ktzero" type="int"/>
- </method>
<method name="setToExpGrid">
<param name="list" type="GridDataList"/>
</method>
diff --git a/sammy/src/salmon/interface/cpp/GridDataInterface.cpp b/sammy/src/salmon/interface/cpp/GridDataInterface.cpp
index 9877ebd19a84170f01bd91f70f02d9d753b8d241..389eaa5721de9f89c252cea3b0bfa9716e80b60b 100644
--- a/sammy/src/salmon/interface/cpp/GridDataInterface.cpp
+++ b/sammy/src/salmon/interface/cpp/GridDataInterface.cpp
@@ -69,6 +69,16 @@ void GridData_reserve(void * GridData_ptr,int * row,int * col)
((GridData*)GridData_ptr)->reserve(*row,*col);
}
+int GridData_getNumPerEnergy(void * GridData_ptr)
+{
+ return ((GridData*)GridData_ptr)->getNumPerEnergy();
+}
+
+void GridData_setNumPerEnergy(void * GridData_ptr,int * n)
+{
+ ((GridData*)GridData_ptr)->setNumPerEnergy(*n);
+}
+
void GridData_addImplicitDerivs(void * GridData_ptr,GridData* grid)
{
std::unique_ptr<GridData> gridPtr(grid);
diff --git a/sammy/src/salmon/interface/cpp/GridDataInterface.h b/sammy/src/salmon/interface/cpp/GridDataInterface.h
index fb679a93e204f9b8b30b9f871441ea3d62e532d5..491caa7aa17aba9bca9ff56d9dffad9bcc2aebf0 100644
--- a/sammy/src/salmon/interface/cpp/GridDataInterface.h
+++ b/sammy/src/salmon/interface/cpp/GridDataInterface.h
@@ -26,6 +26,8 @@ void GridData_setRowMax(void * GridData_ptr,int * offset);
void GridData_clearGrid(void * GridData_ptr);
void GridData_nullify(void * GridData_ptr);
void GridData_reserve(void * GridData_ptr,int * row,int * col);
+int GridData_getNumPerEnergy(void * GridData_ptr);
+void GridData_setNumPerEnergy(void * GridData_ptr,int * n);
void GridData_addImplicitDerivs(void * GridData_ptr,GridData* grid);
void* GridData_getImplicitDerivs(void * GridData_ptr);
void GridData_addImplicitParCov(void * GridData_ptr,endf::ResonanceCovariance* cov);
diff --git a/sammy/src/salmon/interface/cpp/SammyGridAccessInterface.cpp b/sammy/src/salmon/interface/cpp/SammyGridAccessInterface.cpp
index a51df1dde85994b25fa17d091e011b35099f1088..0998a3ef5c982b16abab85661d147e9f066dc2ea 100644
--- a/sammy/src/salmon/interface/cpp/SammyGridAccessInterface.cpp
+++ b/sammy/src/salmon/interface/cpp/SammyGridAccessInterface.cpp
@@ -9,11 +9,6 @@
#include <string.h>
#include "SammyGridAccessInterface.h"
using namespace sammy;
-void SammyGridAccess_setParameters(void * SammyGridAccess_ptr,int * numcro,int * ktzero)
-{
- ((SammyGridAccess*)SammyGridAccess_ptr)->setParameters(*numcro,*ktzero);
-}
-
void SammyGridAccess_setToExpGrid(void * SammyGridAccess_ptr,GridDataList * list)
{
((SammyGridAccess*)SammyGridAccess_ptr)->setToExpGrid(*list);
diff --git a/sammy/src/salmon/interface/cpp/SammyGridAccessInterface.h b/sammy/src/salmon/interface/cpp/SammyGridAccessInterface.h
index ab7e97b3350cd00258151d8c5e4a36b432cc4f7a..7c00bfe95aa15901c1902eef0c655f6182d3913a 100644
--- a/sammy/src/salmon/interface/cpp/SammyGridAccessInterface.h
+++ b/sammy/src/salmon/interface/cpp/SammyGridAccessInterface.h
@@ -13,7 +13,6 @@ using namespace sammy;
#ifdef __cplusplus
extern "C" {
#endif
-void SammyGridAccess_setParameters(void * SammyGridAccess_ptr,int * numcro,int * ktzero);
void SammyGridAccess_setToExpGrid(void * SammyGridAccess_ptr,GridDataList * list);
void SammyGridAccess_setToAuxGrid(void * SammyGridAccess_ptr,GridDataList * list);
double SammyGridAccess_getEnergy(void * SammyGridAccess_ptr,int * index,GridDataList * list);
diff --git a/sammy/src/salmon/interface/fortran/GridData_I.f90 b/sammy/src/salmon/interface/fortran/GridData_I.f90
index 5630fa4a8b29e668574984734fb6fded66621d3d..0f8a1b98aab75b121f498b33f9a6b36ae0bc9a57 100644
--- a/sammy/src/salmon/interface/fortran/GridData_I.f90
+++ b/sammy/src/salmon/interface/fortran/GridData_I.f90
@@ -79,6 +79,18 @@ subroutine f_GridData_reserve(GridData_ptr, row,col ) BIND(C,name="GridData_rese
integer(C_INT) :: row;
integer(C_INT) :: col;
end subroutine
+integer(C_INT) function f_GridData_getNumPerEnergy(GridData_ptr ) BIND(C,name="GridData_getNumPerEnergy")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: GridData_ptr;
+end function
+subroutine f_GridData_setNumPerEnergy(GridData_ptr, n ) BIND(C,name="GridData_setNumPerEnergy")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: GridData_ptr;
+ integer(C_INT) :: n;
+end subroutine
+
subroutine f_GridData_addImplicitDerivs(GridData_ptr, grid ) BIND(C,name="GridData_addImplicitDerivs")
use,intrinsic :: ISO_C_BINDING
implicit none
diff --git a/sammy/src/salmon/interface/fortran/GridData_M.f90 b/sammy/src/salmon/interface/fortran/GridData_M.f90
index ad964fe6613e4f877f960db3344c0b45e7c88a71..feb75c5de470f92e8ce80b67185858d0762c47ce 100644
--- a/sammy/src/salmon/interface/fortran/GridData_M.f90
+++ b/sammy/src/salmon/interface/fortran/GridData_M.f90
@@ -25,6 +25,8 @@ type GridData
procedure, pass(this) :: clearGrid => GridData_clearGrid
procedure, pass(this) :: nullify => GridData_nullify
procedure, pass(this) :: reserve => GridData_reserve
+ procedure, pass(this) :: getNumPerEnergy => GridData_getNumPerEnergy
+ procedure, pass(this) :: setNumPerEnergy => GridData_setNumPerEnergy
procedure, pass(this) :: addImplicitDerivs => GridData_addImplicitDerivs
procedure, pass(this) :: getImplicitDerivs => GridData_getImplicitDerivs
procedure, pass(this) :: addImplicitParCov => GridData_addImplicitParCov
@@ -124,6 +126,18 @@ subroutine GridData_reserve(this, row, col)
integer(C_INT)::col
call f_GridData_reserve(this%instance_ptr, row,col)
end subroutine
+function GridData_getNumPerEnergy(this) result(result2Return)
+ implicit none
+ class(GridData)::this
+ integer(C_INT):: result2Return
+ result2Return=f_GridData_getNumPerEnergy(this%instance_ptr)
+end function
+subroutine GridData_setNumPerEnergy(this, n)
+ implicit none
+ class(GridData)::this
+ integer(C_INT)::n
+ call f_GridData_setNumPerEnergy(this%instance_ptr, n)
+end subroutine
subroutine GridData_addImplicitDerivs(this, grid)
implicit none
class(GridData)::this
diff --git a/sammy/src/salmon/interface/fortran/SammyGridAccess_I.f90 b/sammy/src/salmon/interface/fortran/SammyGridAccess_I.f90
index 346c298f63468cf03ad2f7f46f813b4a21c487ec..ba50151750f9a67a7cf217d0e0ef3ae342555ea8 100644
--- a/sammy/src/salmon/interface/fortran/SammyGridAccess_I.f90
+++ b/sammy/src/salmon/interface/fortran/SammyGridAccess_I.f90
@@ -9,13 +9,6 @@
module SammyGridAccess_I
use, intrinsic :: ISO_C_BINDING
interface
-subroutine f_SammyGridAccess_setParameters(SammyGridAccess_ptr, numcro,ktzero ) BIND(C,name="SammyGridAccess_setParameters")
- use,intrinsic :: ISO_C_BINDING
- implicit none
- type(C_PTR), value :: SammyGridAccess_ptr;
- integer(C_INT) :: numcro;
- integer(C_INT) :: ktzero;
-end subroutine
subroutine f_SammyGridAccess_setToExpGrid(SammyGridAccess_ptr, list ) BIND(C,name="SammyGridAccess_setToExpGrid")
use,intrinsic :: ISO_C_BINDING
implicit none
diff --git a/sammy/src/salmon/interface/fortran/SammyGridAccess_M.f90 b/sammy/src/salmon/interface/fortran/SammyGridAccess_M.f90
index 9b9ad4778f02fbf2ec546b6d97355476040aab37..8518ab3088633f096f65177ada8f5036790bd4da 100644
--- a/sammy/src/salmon/interface/fortran/SammyGridAccess_M.f90
+++ b/sammy/src/salmon/interface/fortran/SammyGridAccess_M.f90
@@ -13,7 +13,6 @@ use GridData_M
type SammyGridAccess
type(C_PTR) :: instance_ptr=C_NULL_PTR
contains
- procedure, pass(this) :: setParameters => SammyGridAccess_setParameters
procedure, pass(this) :: setToExpGrid => SammyGridAccess_setToExpGrid
procedure, pass(this) :: setToAuxGrid => SammyGridAccess_setToAuxGrid
procedure, pass(this) :: getEnergy => SammyGridAccess_getEnergy
@@ -24,13 +23,6 @@ type SammyGridAccess
procedure, pass(this) :: destroy => SammyGridAccess_destroy
end type SammyGridAccess
contains
-subroutine SammyGridAccess_setParameters(this, numcro, ktzero)
- implicit none
- class(SammyGridAccess)::this
- integer(C_INT)::numcro
- integer(C_INT)::ktzero
- call f_SammyGridAccess_setParameters(this%instance_ptr, numcro,ktzero)
-end subroutine
subroutine SammyGridAccess_setToExpGrid(this, list)
implicit none
class(SammyGridAccess)::this
diff --git a/sammy/src/salmon/tests/SammyGridAccessTest.cpp b/sammy/src/salmon/tests/SammyGridAccessTest.cpp
index 3c5819684ab1bd95da751d5b0be2076eeb650f91..9f0809f287a7d1ecd6ec806f7de56a46e8f4a949 100644
--- a/sammy/src/salmon/tests/SammyGridAccessTest.cpp
+++ b/sammy/src/salmon/tests/SammyGridAccessTest.cpp
@@ -3,13 +3,23 @@
#include "../GridData.h"
#include "../SammyGridAccess.h"
-void addTestData(sammy::GridDataList & list, int numcro = 1, bool addSecond = true){
+void addTestData(sammy::GridDataList & list, int numcro = 1, int ktzero = 0, bool addSecond = true){
std::unique_ptr<sammy::GridData> grid = std::make_unique<sammy::GridData>();
int ipos = 0;
+ int idat;
int nn = numcro;
if (nn == 0) nn = 1;
+ grid->setNumPerEnergy(nn);
+ grid->setDataIndex(1);
+ if (ktzero > 0) {
+ grid->setDataIndex(2);
+ }
+ if ( numcro > 1){
+ grid->setDataIndex( grid->getDataColumn()+1);
+ }
+
for (int i = 0; i < 10; i++){
double e = i + 1;
for ( int j = 0; j < nn; j++){
@@ -17,23 +27,31 @@ void addTestData(sammy::GridDataList & list, int numcro = 1, bool addSecond = tr
double data = e+ cro + 0.2;
grid->addData(ipos,0, e);
- if ( numcro > 1){
- grid->addData(ipos, 1 , cro + e);
- grid->addData(ipos, 2 , e + 0.1);
- grid->addData(ipos, 3 , data + e);
+ idat = 1;
+
+ if (ktzero > 0) {
+ grid->addData(ipos, idat , e + 0.1);
+ idat++;
}
- else{
- grid->addData(ipos, 1 , e + 0.1);
- grid->addData(ipos, 2 , data + e);
+ if ( numcro > 1){
+ grid->addData(ipos, idat , cro + e);
+ idat++;
}
+ grid->addData(ipos, idat , data + e);
+
ipos++;
+
}
}
list.addGrid(grid);
if (!addSecond) return;
- grid = std::make_unique<sammy::GridData>();
+ grid = std::make_unique<sammy::GridData>();
+ grid->setNumPerEnergy(nn);
+ grid->setDataIndex(1);
+ if (nn > 1) grid->setDataIndex(2);
+
ipos = 0;
for (int i = 0; i < 20; i++){
double e = i + 10;
@@ -43,12 +61,10 @@ void addTestData(sammy::GridDataList & list, int numcro = 1, bool addSecond = tr
grid->addData(ipos,0, e);
if ( numcro > 1){
grid->addData(ipos, 1 , cro + e);
- grid->addData(ipos, 2 , e + 0.1);
- grid->addData(ipos, 3 , data + e);
+ grid->addData(ipos, 2 , data + e);
}
else{
- grid->addData(ipos, 1 , e + 0.1);
- grid->addData(ipos, 2 , data + e);
+ grid->addData(ipos, 1 , data + e);
}
ipos++;
}
@@ -56,7 +72,7 @@ void addTestData(sammy::GridDataList & list, int numcro = 1, bool addSecond = tr
list.addGrid(grid);
}
-void testFirstGrid(sammy::SammyGridAccess & access, sammy::GridDataList & list, int ktzero){
+void testFirstGrid(sammy::SammyGridAccess & access, sammy::GridDataList & list, int ktzero){
ASSERT_EQ(10, access.getNumEnergies(list));
for (int i = 0; i < 10; i++){
double e = i + 1;
@@ -71,17 +87,11 @@ void testFirstGrid(sammy::SammyGridAccess & access, sammy::GridDataList & list,
}
}
-void testSecondGrid(sammy::SammyGridAccess & access, sammy::GridDataList & list, int ktzero){
- ASSERT_EQ(20, access.getNumEnergies(list));
+void testSecondGrid(sammy::SammyGridAccess & access, sammy::GridDataList & list){
+ ASSERT_EQ(20, access.getNumEnergies(list));
for (int i = 0; i < 20; i++){
double e = i + 10;
- if (ktzero == 0){
- ASSERT_NEAR(e, access.getEnergy(i, list), 1e-3);
- }
- else{
- ASSERT_NEAR(e + 0.1, access.getEnergy(i, list), 1e-3);
- }
-
+ ASSERT_NEAR(e, access.getEnergy(i, list), 1e-3);
ASSERT_NEAR(e, access.getOrigEnergy(i, list), 1e-3);
}
}
@@ -101,28 +111,23 @@ void testFirstGridOff(sammy::SammyGridAccess & access, sammy::GridDataList & lis
}
}
-void testSecondGridOff(sammy::SammyGridAccess & access, sammy::GridDataList & list, int ktzero){
+void testSecondGridOff(sammy::SammyGridAccess & access, sammy::GridDataList & list){
ASSERT_EQ(10, access.getNumEnergies(list));
for (int i = 0; i < 10; i++){
double e = i + 20;
- if (ktzero == 0){
- ASSERT_NEAR(e, access.getEnergy(i, list), 1e-3);
- }
- else{
- ASSERT_NEAR(e + 0.1, access.getEnergy(i, list), 1e-3);
- }
-
+ ASSERT_NEAR(e, access.getEnergy(i, list), 1e-3);
ASSERT_NEAR(e, access.getOrigEnergy(i, list), 1e-3);
}
}
TEST(GridAcccesTest, twoGridsNoOffsetLimits){
for ( int numcro = 0; numcro < 5; numcro++){
- sammy::GridDataList list;
- addTestData(list, numcro);
for (int ktzero = 0; ktzero <= 1; ktzero++){
+ sammy::GridDataList list;
+ addTestData(list, numcro, ktzero);
+
list.setExpGridIndex(0);
list.getGrid(0)->setRowOffset(2);
list.getGrid(0)->setRowMax(4);
@@ -130,75 +135,73 @@ TEST(GridAcccesTest, twoGridsNoOffsetLimits){
list.getGrid(1)->setRowOffset(3);
list.getGrid(1)->setRowMax(12);
- sammy::SammyGridAccess access;
- access.setParameters(numcro, ktzero);
+ sammy::SammyGridAccess access;
access.setToExpGrid(list);
access.setUseOffset(false);
testFirstGrid(access, list, ktzero);
list.setExpGridIndex(1);
access.setToExpGrid(list);
- testSecondGrid(access, list, ktzero);
+ testSecondGrid(access, list);
list.setExpGridIndex(0);
list.setAuxGridIndex(1);
access.setToAuxGrid(list);
- testSecondGrid(access, list, 0);
+ testSecondGrid(access, list);
list.setExpGridIndex(1);
list.setAuxGridIndex(0);
access.setToAuxGrid(list);
- testFirstGrid(access, list, 0);
+ testFirstGrid(access, list, ktzero);
}
}
}
TEST(GridAcccesTest, twoGridsNoOffset){
for ( int numcro = 0; numcro < 5; numcro++){
- sammy::GridDataList list;
-
- addTestData(list, numcro);
for (int ktzero = 0; ktzero <= 1; ktzero++){
+ sammy::GridDataList list;
+ addTestData(list, numcro, ktzero);
+
list.setExpGridIndex(0);
list.setAuxGridIndex(1);
- sammy::SammyGridAccess access;
- access.setParameters(numcro, ktzero);
+ sammy::SammyGridAccess access;
access.setToExpGrid(list);
testFirstGrid(access, list, ktzero);
list.setExpGridIndex(1);
access.setToExpGrid(list);
- testSecondGrid(access, list, ktzero);
+ testSecondGrid(access, list);
+
list.setExpGridIndex(0);
list.setAuxGridIndex(1);
access.setToAuxGrid(list);
- testSecondGrid(access, list, 0);
+ testSecondGrid(access, list);
list.setExpGridIndex(1);
list.setAuxGridIndex(0);
access.setToAuxGrid(list);
- testFirstGrid(access, list, 0);
+ testFirstGrid(access, list, ktzero);
}
}
}
TEST(GridAcccesTest, twoGridsOffset){
for ( int numcro = 0; numcro < 5; numcro++){
- sammy::GridDataList list;
-
- addTestData(list, numcro);
- list.getGrid(0)->setRowOffset(5);
- list.getGrid(1)->setRowOffset(10);
for (int ktzero = 0; ktzero <= 1; ktzero++){
+ sammy::GridDataList list;
+ addTestData(list, numcro, ktzero);
+ list.getGrid(0)->setRowOffset(5);
+ list.getGrid(1)->setRowOffset(10);
+
list.setExpGridIndex(0);
list.setAuxGridIndex(1);
sammy::SammyGridAccess access;
- access.setParameters(numcro, ktzero);
access.setToExpGrid(list);
testFirstGridOff(access, list, ktzero);
@@ -210,7 +213,7 @@ TEST(GridAcccesTest, twoGridsOffset){
list.setExpGridIndex(1);
access.setToExpGrid(list);
- testSecondGridOff(access, list, ktzero);
+ testSecondGridOff(access, list);
list.getGrid(1)->setRowMax(15);
ASSERT_EQ(6, access.getNumEnergies(list));
@@ -222,28 +225,26 @@ TEST(GridAcccesTest, twoGridsOffset){
list.setExpGridIndex(0);
list.setAuxGridIndex(1);
access.setToAuxGrid(list);
- testSecondGridOff(access, list, 0);
+ testSecondGridOff(access, list);
list.setExpGridIndex(1);
list.setAuxGridIndex(0);
access.setToAuxGrid(list);
- testFirstGridOff(access, list, 0);
+ testFirstGridOff(access, list, ktzero);
}
}
}
TEST(GridAcccesTest, oneGridsNoOffset){
for ( int numcro = 0; numcro < 5; numcro++){
- sammy::GridDataList list;
-
- addTestData(list, numcro, false);
-
for (int ktzero = 0; ktzero <= 1; ktzero++){
+ sammy::GridDataList list;
+ addTestData(list, numcro, ktzero, false);
+
list.setExpGridIndex(0);
list.setAuxGridIndex(1);
- sammy::SammyGridAccess access;
- access.setParameters(numcro, ktzero);
+ sammy::SammyGridAccess access;
access.setToExpGrid(list);
testFirstGrid(access, list, ktzero);
@@ -266,11 +267,12 @@ TEST(GridAcccesTest, oneGridsNoOffset){
TEST(GridAcccesTest, oneGridsNoOffsetLimits){
for ( int numcro = 0; numcro < 5; numcro++){
- sammy::GridDataList list;
-
- addTestData(list, numcro, false);
for (int ktzero = 0; ktzero <= 1; ktzero++){
+ sammy::GridDataList list;
+
+ addTestData(list, numcro, ktzero, false);
+
list.setExpGridIndex(0);
list.getGrid(0)->setRowOffset(2);
list.getGrid(0)->setRowMax(4);
@@ -278,7 +280,6 @@ TEST(GridAcccesTest, oneGridsNoOffsetLimits){
sammy::SammyGridAccess access;
access.setUseOffset(false);
- access.setParameters(numcro, ktzero);
access.setToExpGrid(list);
testFirstGrid(access, list, ktzero);
@@ -301,17 +302,17 @@ TEST(GridAcccesTest, oneGridsNoOffsetLimits){
TEST(GridAcccesTest, oneGridsOffset){
for ( int numcro = 0; numcro < 5; numcro++){
- sammy::GridDataList list;
-
- addTestData(list, numcro, false);
- list.getGrid(0)->setRowOffset(5);
for (int ktzero = 0; ktzero <= 1; ktzero++){
+ sammy::GridDataList list;
+
+ addTestData(list, numcro, ktzero, false);
+ list.getGrid(0)->setRowOffset(5);
+
list.setExpGridIndex(0);
list.setAuxGridIndex(1);
- sammy::SammyGridAccess access;
- access.setParameters(numcro, ktzero);
+ sammy::SammyGridAccess access;
access.setToExpGrid(list);
testFirstGridOff(access, list, ktzero);
diff --git a/sammy/src/sammy/CMakeLists.txt b/sammy/src/sammy/CMakeLists.txt
index 01e57b697d3383059ef9757e7219ee6c2ad698dc..bfb4d77a732b69e18e698c24434f6df2d5c6a54f 100644
--- a/sammy/src/sammy/CMakeLists.txt
+++ b/sammy/src/sammy/CMakeLists.txt
@@ -50,16 +50,17 @@ APPEND_SET(SAMMY_SOURCES
../clm/dopush3.f
../clm/dopush4.f
- ../clm/mclm0.f
- ../clm/mclm1.f
- ../clm/mclm2.f
- ../clm/mclm3.f
- ../clm/mclm4.f
- ../clm/mclm5.f
- ../clm/mclm6.f
- ../clm/mclm7.f
- ../clm/mclm8.f
+ ../clm/mclm0.f90
+ ../clm/mclm1.f90
+ ../clm/mclm2.f90
+ ../clm/mclm3.f90
+ ../clm/mclm4.f90
+ ../clm/mclm5.f90
+ ../clm/mclm6.f90
+ ../clm/mclm7.f90
+ ../clm/mclm8.f90
../clm/mclm8a.f90
+ ../clm/CrystalLatticeBroadening_M.f90
../clq/mclq0.f90
../clq/ArtificalCross_M.f90
@@ -91,10 +92,10 @@ APPEND_SET(SAMMY_SOURCES
../dat/mdata.f90
../dat/mdatb.f90
- ../dbd/mdbd0.f
- ../dbd/mdbd1.f
- ../dbd/mdbd2.f
- ../dbd/mdbd3.f
+ ../dbd/mdbd0.f90
+ ../dbd/mdbd1.f90
+ ../dbd/mdbd2.f90
+ ../dbd/HighEnergyFreeGas_m.f90
../dex/mdex0.f
../dex/mdex1.f
@@ -102,6 +103,7 @@ APPEND_SET(SAMMY_SOURCES
../dop/mdop0.f90
../dop/mdop1.f90
../dop/mdop2.f90
+ ../dop/LealHwangBroadening_M.f90
../end/mend0.f
../end/mend1.f
@@ -139,7 +141,6 @@ APPEND_SET(SAMMY_SOURCES
../fgm/mfgm0.f90
../fgm/mfgm1.f90
../fgm/mfgm2.f90
- ../fgm/mfgm3.f90
../fgm/mfgm4.f90
../fgm/FreeGasDopplerBroadening_M.f90
@@ -547,7 +548,6 @@ APPEND_SET(SAMMY_SOURCES
../blk/Mssccc_common.f90
../blk/Endfaa_common.f90
../blk/Brdd_common.f90
- ../blk/Clm_common.f90
../blk/Abro_common.f90
../blk/Rpijnk_common.f90
../blk/Rpires_common.f90
diff --git a/sammy/src/smc/msmc1.f b/sammy/src/smc/msmc1.f
index 04ea8814f1f5f10b845765d56f831ab6fa634d64..ec126b5480a9ae0a937339cacdf1db56136bd301 100755
--- a/sammy/src/smc/msmc1.f
+++ b/sammy/src/smc/msmc1.f
@@ -4,9 +4,7 @@ C -------------------------------------------------------------------
C
SUBROUTINE Sigmax_smc (Ee, Ec, Et, Amux, Yield, Y0, Total,
* Captur, Ccclll, Poly, Dmu, Sssxxx, Sxxxxx, Xxxsss)
- use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+ use EndfData_common_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INCLUDE 'msmc3.f'
@@ -23,8 +21,7 @@ C
I3 = 1
I4 = 1
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToExpGrid(expData)
C
C *** Initialize random-number-generators
@@ -565,9 +562,7 @@ C
C -------------------------------------------------------------------
C
SUBROUTINE Output (Yield, Y0, Total, Captur)
- use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+ use EndfData_common_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CHARACTER*50 Filees, Filexs, Title
@@ -577,7 +572,6 @@ C
DIMENSION Yield(*), Y0(*), Total(*), Captur(*)
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToExpGrid(expData)
C
DO I=1,I2
diff --git a/sammy/src/ssm/mssm00.f90 b/sammy/src/ssm/mssm00.f90
index e4222a62f662e9a508dd6ebd0b6054100f6533e4..ea3aff41dc7eabbc55e1f765043996e4be9cf253 100644
--- a/sammy/src/ssm/mssm00.f90
+++ b/sammy/src/ssm/mssm00.f90
@@ -14,10 +14,9 @@ module ssm_m
! (tr039|tr119|tr085|tr066|tr171|tr160|tr060|tr118|tr057|tr064|
! tr090|tr052|tr078|tr076|tr095|tr188|tr046|tr099|tr189|tr045)
!
- use fixedi_m, only : Jtheta, Jwwwww, K2reso, Kkkdex, Kkkrsl, &
- Ktheta, Ntheta, Nudwhi, Numcro, &
+ use fixedi_m, only : Jtheta, K2reso, Kkkdex, Kkkrsl, &
+ Ktheta, Ntheta, Nudwhi, &
Numder, Numorr, Numrpi
- use ifwrit_m, only : Jjjdop
use exploc_common_m, only : I_Ixciso
use oopsch_common_m, only : Nowwww, Segmen
use logic_ssm_common_m
@@ -37,6 +36,7 @@ module ssm_m
real(8):: Delthe
integer(4):: Jthhhh, Kdatb, Kphi, Kthhhh, M1, M2, M3, M4, Maxx, Mx, Nd, &
Ndbl, Nf, Ng, Nh, Nnx, Nthhhh, Nx
+ type(GridData)::grid
!
!
WRITE (6,99999)
@@ -114,9 +114,7 @@ module ssm_m
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
!
-!
- Jwwwww = 8
- Numcro = 1
+!
Numder = 1
call multScat%setNumTheta( Nthhhh )
@@ -125,7 +123,6 @@ module ssm_m
Ktheta = Kthhhh ! remove
call multScat%setNumThetaNearOne( Jthhhh )
Jtheta = Jthhhh ! remove
- Jjjdop = 0
CALL Write_Commons_Many
RETURN
end subroutine Samssm_0
diff --git a/sammy/src/ssm/mssm01.f90 b/sammy/src/ssm/mssm01.f90
index fb21bed0f0a28a6123f59496c30fdd5504969174..cb6f5e776fdaa6d445b3ea1d0611524ee8df4204 100644
--- a/sammy/src/ssm/mssm01.f90
+++ b/sammy/src/ssm/mssm01.f90
@@ -274,7 +274,7 @@ module ssm_1_m
!
! *** Purpose -- Find next cross section, store values in appropriate places
!
- use fixedi_m, only : numUsedPar, Lllmax, numcro
+ use fixedi_m, only : numUsedPar, Lllmax
use ifwrit_m
use EndfData_common_m
use SammyGridAccess_M
@@ -296,7 +296,6 @@ module ssm_1_m
Istop = 0
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
diff --git a/sammy/src/ssm/mssm03.f90 b/sammy/src/ssm/mssm03.f90
index 86f393a50d17697c38ff321935c6cf5bbc674917..882ef8e34233745d2abc5d9044e26af149c32de9 100644
--- a/sammy/src/ssm/mssm03.f90
+++ b/sammy/src/ssm/mssm03.f90
@@ -46,7 +46,6 @@ module ssm_3_m
DATA Zero /0.0d0/, One /1.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
Itimes = 1
@@ -183,7 +182,6 @@ module ssm_3_m
DATA Zero /0.0d0/, One /1.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
Itimes = 1
@@ -360,7 +358,6 @@ module ssm_3_m
DATA Zero /0.0d0/, One /1.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
@@ -540,7 +537,6 @@ module ssm_3_m
DATA Zero /0.0d0/, One /1.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
Itimes = 1
@@ -724,7 +720,6 @@ module ssm_3_m
DATA Zero /0.0d0/, One /1.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
Itimes = 1
diff --git a/sammy/src/ssm/mssm04.f90 b/sammy/src/ssm/mssm04.f90
index c3b6da90d5b124ef26130a6a9a43f36e430396ca..85a718dfbf068da0ebd20ab3ce95047683363994 100644
--- a/sammy/src/ssm/mssm04.f90
+++ b/sammy/src/ssm/mssm04.f90
@@ -55,7 +55,6 @@ module ssm_4_m
DATA Zero /0.0d0/, One /1.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
Itimes = 1
@@ -252,7 +251,6 @@ module ssm_4_m
DATA Zero /0.0d0/, One /1.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
Itimes = 1
@@ -451,7 +449,6 @@ module ssm_4_m
DATA Zero /0.0d0/, One /1.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
Itimes = 1
@@ -653,7 +650,6 @@ module ssm_4_m
DATA Zero /0.0d0/, One /1.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
Itimes = 1
diff --git a/sammy/src/ssm/mssm05.f90 b/sammy/src/ssm/mssm05.f90
index c19742da2268eef678415f612eb39ced2baaa603..35f23444dc1e41b5600804361698efc73f0e84f2 100644
--- a/sammy/src/ssm/mssm05.f90
+++ b/sammy/src/ssm/mssm05.f90
@@ -67,7 +67,6 @@ module ssm_5_m
srcfile = "mssm05.f"
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
!
@@ -385,7 +384,6 @@ module ssm_5_m
srcfile = "mssm05.f"
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
!
diff --git a/sammy/src/ssm/mssm06.f90 b/sammy/src/ssm/mssm06.f90
index 4ae785d8a42391d2215f5440c2c040763da77c3c..f6c6d875529e95bc1515ac76d26bc4537672930d 100644
--- a/sammy/src/ssm/mssm06.f90
+++ b/sammy/src/ssm/mssm06.f90
@@ -70,7 +70,6 @@ module ssm_6_m
srcfile = "mssm06.f"
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
!
@@ -379,7 +378,6 @@ module ssm_6_m
srcfile = "mssm06.f"
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
!
diff --git a/sammy/src/ssm/mssm07.f90 b/sammy/src/ssm/mssm07.f90
index 5a7681cbd21c368d350f7e68d7adf3b59ededc3f..8779855e3b6264e5c4b56cb809c0232e1a58f17b 100644
--- a/sammy/src/ssm/mssm07.f90
+++ b/sammy/src/ssm/mssm07.f90
@@ -72,7 +72,6 @@ module ssm_7_m
srcfile = "mssm07.f"
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
Not_Quad = 0
@@ -437,7 +436,6 @@ module ssm_7_m
srcfile = "mssm07.f"
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
!
diff --git a/sammy/src/ssm/mssm08.f90 b/sammy/src/ssm/mssm08.f90
index 6835284089f12c7faee24a1a5201dab412410a24..d184f0f9ad883cb4bd9729d8624d34c3f89369ed 100644
--- a/sammy/src/ssm/mssm08.f90
+++ b/sammy/src/ssm/mssm08.f90
@@ -75,7 +75,6 @@ module ssm_8_m
srcfile = "mssm08.f"
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
Non_Quad = 0 ! make sure it is initialized
@@ -416,7 +415,6 @@ module ssm_8_m
srcfile = "mssm08.f"
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
!
diff --git a/sammy/src/ssm/mssm09.f90 b/sammy/src/ssm/mssm09.f90
index 9a00d98b3da3b05aaa534a5b2dc8b374925a6640..05071700ca628e77f819cb5cff909636957eb797 100644
--- a/sammy/src/ssm/mssm09.f90
+++ b/sammy/src/ssm/mssm09.f90
@@ -12,9 +12,7 @@ module ssm_9_m
! *** I2=grid Number just below E2
!
use mdat9_m
- use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+ use EndfData_common_m
use SammyGridAccess_M
IMPLICIT none
@@ -30,7 +28,6 @@ module ssm_9_m
DATA One /1.0d0/
!
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
E = grid%getEnergy(Iie, expData)
@@ -74,7 +71,6 @@ module ssm_9_m
DATA Zero /0.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
IF (Ientrp.NE.0) THEN
@@ -168,7 +164,6 @@ module ssm_9_m
DATA Zero /0.0d0/, Half /0.5d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
Not_Quad = 0
@@ -352,9 +347,7 @@ module ssm_9_m
! *** Purpose -- Choose the next value of E' to be included in the
! *** grid for integrating over mu
!
- use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+ use EndfData_common_m
use SammyGridAccess_M
IMPLICIT none
@@ -368,7 +361,6 @@ module ssm_9_m
type(SammyGridAccess)::grid
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
J2 = 0
@@ -451,9 +443,7 @@ module ssm_9_m
SUBROUTINE Talk (Kadd, Maxx, Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, &
J1, J3, Csx, Epx, Ggx, Emind, Emins, Eminr, Totsig, &
Ns, Niniso, Nnpar, N, Iso, Kwhich)
- use EndfData_common_m
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
+ use EndfData_common_m
use SammyGridAccess_M
IMPLICIT none
@@ -469,7 +459,6 @@ module ssm_9_m
DIMENSION Csx(*), Epx(*), Ggx(*), Totsig(*)
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
WRITE (6,10100) Kadd, Maxx, Kwhich
diff --git a/sammy/src/ssm/mssm18.f90 b/sammy/src/ssm/mssm18.f90
index 20e9f45d674977a4de7dec81fc4df4919e235e17..d366b380b4db16e8ffd76471da471698a473b995 100644
--- a/sammy/src/ssm/mssm18.f90
+++ b/sammy/src/ssm/mssm18.f90
@@ -189,7 +189,6 @@ module ssm_18_m
DATA Zero /0.0d0/, One /1.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
!
Y2dddd = Zero
@@ -298,7 +297,6 @@ module ssm_18_m
SUBROUTINE Reorder_Energy (derivs,Kdatmn, Kdatmx, Kkkdat)
use fixedi_m
use EndfData_common_m
- use ifwrit_m, only : ktzero
use SammyGridAccess_M
use DerivativeHandler_M
implicit none
@@ -310,11 +308,9 @@ module ssm_18_m
DATA Thous /1000.0d0/
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToExpGrid(expData)
maxExp = grid%getNumEnergies(expData)
call auxGrid%initialize()
- call auxGrid%setParameters(numcro, ktzero)
call auxGrid%setToAuxGrid(expData)
Jj = 1
diff --git a/sammy/src/the/SumIsoAndConvertToTrans_M.f90 b/sammy/src/the/SumIsoAndConvertToTrans_M.f90
index c700e32bc7fbb8e4d6edc2037c0899441acbb1bc..bf13ae39b3b9b46d1a1680d6cd1fd196bb78c84e 100644
--- a/sammy/src/the/SumIsoAndConvertToTrans_M.f90
+++ b/sammy/src/the/SumIsoAndConvertToTrans_M.f90
@@ -14,6 +14,7 @@ module SumIsoAndConvertToTrans_M
procedure, pass(this) :: destroy => SumIsoAndConvertToTrans_destroy
procedure, pass(this) :: sumAndConvert => SumIsoAndConvertToTrans_sumAndConvert
procedure, pass(this) :: normalize => SumIsoAndConvertToTrans_normalize
+ procedure, pass(this) :: angPostProcessing => SumIsoAndConvertToTrans_angPostProcessing
end type
contains
subroutine SumIsoAndConvertToTrans_initialize(this, broad, datSelf, hasSelf)
@@ -119,6 +120,7 @@ contains
real(kind=8)::em
length = this%broadener%getLength()
+ call this%broadener%getData(crossData)
IF ( this%Another_Process_Will_Happen) THEN
jj = 0
if (this%haveSelf) jj = 1
@@ -127,7 +129,6 @@ contains
return
END IF
- call this%broadener%getData(crossData)
Iwarn = 0
do Jj = 1, this%broadener%getNumEnergyBroadened()
if (jj.gt.length) exit
@@ -165,4 +166,31 @@ contains
END IF
end subroutine
+ subroutine SumIsoAndConvertToTrans_angPostProcessing(this, numPar)
+ use exploc_common_m, only : A_Iprnbk, I_Iflnbk
+ use mxct27_m, only : Write_Cross_Sections
+ use fixedi_m, only : Numnbk
+ use lbro_common_m, only : Ynrmbk
+ use normalize_and_background
+ use AuxGridHelper_M
+ class(SumIsoAndConvertToTrans)::this
+ integer::numPar
+
+ integer::iso, Jdat, bStart
+ type(DerivativeHandler)::crossData
+ real(kind=8)::em
+
+ call this%broadener%getData(crossData)
+ IF (.NOT. this%Another_Process_Will_Happen.or. &
+ .NOT. this%Need_Isotopes) THEN
+ call crossData%sumOverIsotopes(numPar+1)
+ END IF
+
+ if (.not.this%Another_Process_Will_Happen.and.Numnbk.gt.0.and.Ynrmbk) then
+ do Jdat = 1, this%broadener%getNumEnergyBroadened()
+ em = this%broadener%getEnergyBroadened(Jdat)
+ CALL Norm (A_Iprnbk , I_Iflnbk, Em, Jdat, crossData, numPar)
+ end do
+ end if
+ end subroutine SumIsoAndConvertToTrans_angPostProcessing
end module SumIsoAndConvertToTrans_M
diff --git a/sammy/src/the/mthe0.f90 b/sammy/src/the/mthe0.f90
index c3fb39413df1ed0ae21d4e79f19df1abc0a8c621..238866a228386b753254912239997059d49ac5c5 100644
--- a/sammy/src/the/mthe0.f90
+++ b/sammy/src/the/mthe0.f90
@@ -7,11 +7,11 @@ module mthe0_M
!
SUBROUTINE Samthe_0
!
- use fixedi_m, only : K2reso, Nangle, Nres, Numiso, numcro, jwwwww
+ use fixedi_m, only : K2reso, Nangle, Nres, Numiso
use ifwrit_m, only : Kdata, Kdecpl, Kfake, Kkkclq, Krmatx, &
Ksolve, Ndatb, Ndat, &
Ilzero, Itzero, Kcros, Kssmsc, &
- kwcoul, Kkkdop, Kpoten, ktzero, &
+ kwcoul, Kpoten, &
Ksindi, Kfake, Ks_Res
use exploc_common_m
use oopsch_common_m, only : Nowwww, Segmen
@@ -99,11 +99,9 @@ module mthe0_M
call zeroKCalc%driver%calcData%setNnsig(nnnsig)
! set up the energy grid on which the data are calculated
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
- call userGrid%initialize()
- call userGrid%setParameters(numcro, ktzero)
+ call userGrid%initialize()
call userGrid%setToExpGrid(expData)
call setAuxGridOffset(1) ! reset starting point for auxillary grid
call setAuxGridRowMax(0)
@@ -169,8 +167,7 @@ module mthe0_M
call Odfpcs ( Ngroup, zeroKCalc%driver%crossPerSpin)
end if
call zeroKCalc%writeMCData() ! save data for MC and set some SAMMY globals
- CALL Write_Commons_Many
- IF (Ksindi.GT.0 .and. Kcros.EQ.8) jwwwww = 5
+ CALL Write_Commons_Many
call grid%destroy()
call userGrid%destroy()
RETURN
@@ -189,10 +186,10 @@ module mthe0_M
calcDataInit, calcDataSelfInit
use fixedi_m, only : Numiso, Ktruet, Kaddcr,lllmax, Kshift, Kaptur, Kpolar
use ifwrit_m, only : Ilzero, Itzero, Kcros, Knocor, Kpoten, Krmatx, Ksolve, &
- Kssmsc, kwcoul, Maxwel, Knocor, Kkkdop, Kkclqx, Kkkclq, &
+ Kssmsc, kwcoul, Maxwel, Knocor, Kkclqx, Kkkclq, &
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 lbro_common_m, only : Yaverg, Ydoppr, Yresol, Yssmsc, Ytrans, debug
use namfil_common_m, only : Faddcr
implicit none
logical::wantDeriv, wantSelfIndicate, doResShift
@@ -272,7 +269,7 @@ module mthe0_M
end if
! do we need to do anything else after 0k reconstruction
- zeroKCalc%moreCorrections = Ydoppr.OR.Yresol.OR.Yangle.OR.Yssmsc.OR.Yaverg.OR. Maxwel.EQ.1 .OR. Knocor.EQ.1
+ zeroKCalc%moreCorrections = Ydoppr.OR.Yresol.OR.Kcros.eq.7.or.Kcros.eq.11.OR.Yssmsc.OR.Yaverg.OR. Maxwel.EQ.1 .OR. Knocor.EQ.1
! artifical grid
if (Kartgd.EQ.1) then
diff --git a/sammy/src/the/mthe1.f90 b/sammy/src/the/mthe1.f90
index e94ccacaa4444418a86a33bc1d2e905ed9c60ebf..5977807a144cadcec02018527a3b8fc897795f2f 100644
--- a/sammy/src/the/mthe1.f90
+++ b/sammy/src/the/mthe1.f90
@@ -8,9 +8,8 @@ module mthe1_m
!
! *** PURPOSE -- GENERATE Nnpar, and Difmax
!
- use fixedi_m, only : Numcro
use fixedr_m, only : Emax, Emin
- use ifwrit_m, only : Kdecpl, Kscut, Ksolve, ktzero, Ndat
+ use ifwrit_m, only : Kdecpl, Kscut, Ksolve, Ndat
use broad_common_m, only : Dopple, Iesopr
use EndfData_common_m
use SammyResonanceInfo_M
@@ -38,8 +37,7 @@ module mthe1_m
DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/, Three /3.0d0/
!
!
- call gridAccess%initialize()
- call gridAccess%setParameters(numcro, ktzero)
+ call gridAccess%initialize()
call gridAccess%setToExpGrid(expData)
call covData%clearIrrelevant()
@@ -477,12 +475,12 @@ module mthe1_m
!
SUBROUTINE Setthe(Nnnsig, Nnniso)
!
- use fixedi_m, only : Jcros, Kjjjjj, Lllmax, &
+ use fixedi_m, only : Jcros, Lllmax, &
Numcro, Numder, Numiso, &
Jtrans
use ifwrit_m, only : Kaverg, Kdebug, Kfinit, Kkkclq, Kcros, &
Krmatx, Ksolve, Kssmsc, Ktrans, MIKE, Nfissl
- use broad_common_m, only : Dopple
+ use broad_common_m, only : dopplerInfo
IMPLICIT None
integer::Nnnsig, Nnniso
real(kind=8)::zero
@@ -529,7 +527,7 @@ module mthe1_m
END IF
!
IF (Nnnsig.EQ.1 .AND. (Kssmsc.EQ.-1 .OR. Kssmsc.EQ.0) .AND. &
- Kaverg.NE.2 .AND. (Dopple.EQ.Zero .AND. Kjjjjj.EQ.0)) THEN
+ Kaverg.NE.2 .AND. .not.dopplerInfo%wantBroaden) THEN
! *** If we can add up isotopes in XCT rather than waiting for ANG or
! *** FGM or SSM...
! *** ie for anything other than self-shielding, multiple-scattering,
@@ -551,7 +549,7 @@ module mthe1_m
IF (Kssmsc.EQ.-2) THEN
! *** for self-shielding but not multiple-scattering (if no Doppler)
Nnnsig = 2
- IF (Dopple.EQ.Zero .AND. Kjjjjj.EQ.0) Nnniso = 1
+ IF (.not.dopplerInfo%wantBroaden) Nnniso = 1
END IF
IF (Kaverg.EQ.2) THEN
! *** for Bondarenko group averages
@@ -589,13 +587,13 @@ module mthe1_m
!
SUBROUTINE Orgniz
!
- use fixedi_m, only : Jcros, Jtrans, Kjjjjj, Kkkdex, Kkkrsl, &
+ use fixedi_m, only : Jcros, Jtrans, Kkkdex, Kkkrsl, &
Ktruet, Nudwhi, Numbgf, Numnbk, Numorr, &
Numrpi
use ifwrit_m, only : Kaverg, Kdebug, Kssmsc, Ntgrlq
use fixedr_m, only : Dddeee
- use broad_common_m, only : Ao2, Bo2, Co2, Dopple, Ncf
- use lbro_common_m, only : Debug, Yangle, Yaverg, Ydoppr, Ynrmbk, &
+ use broad_common_m, only : Ao2, Bo2, Co2, Ncf, dopplerInfo
+ use lbro_common_m, only : Debug, Yaverg, Ydoppr, Ynrmbk, &
Yresol, Yselfi, Yssmsc, Ytotrs, Ytrans
IMPLICIT None
@@ -614,14 +612,12 @@ module mthe1_m
Yresol = False
Ytotrs = False
Ynrmbk = False
- Yangle = False
Yssmsc = False
Yselfi = False
Yaverg = False
!
-! *** IF (WANT DOPPLER BROADENING) ydoppr = True
- IF (Dopple.NE.Zero) Ydoppr = True
- IF (Kjjjjj.NE.0 ) Ydoppr = True
+! *** IF (WANT DOPPLER BROADENING) ydoppr = True
+ IF (dopplerInfo%wantBroaden) Ydoppr = True
!
! *** if (this is transmission) ytrans = True
IF (Jcros.EQ.1 .AND. Jtrans.EQ.1) Ytrans = True
@@ -653,9 +649,6 @@ module mthe1_m
IF (Jcros.EQ.1 .AND. Jtrans.NE.1 .AND. Yresol) Ytotrs = True
END IF
!
-! *** if (this is angle-differential cross section) Yangle = True
- IF (Jcros.EQ.7 .OR. Jcros.EQ.11) Yangle = True
-!
! *** if (normalization and/or background) Ynrmbk = True
IF (Numnbk.GT.0) Ynrmbk = True
IF (Numbgf.GT.0) Ynrmbk = True
diff --git a/sammy/src/udr/mudr0.f b/sammy/src/udr/mudr0.f
index d7498467c6277d3f89afd77ca8aa9df4930323c9..aa0e71d230cb60488ead1ba6ffb5ab34cd02df9a 100644
--- a/sammy/src/udr/mudr0.f
+++ b/sammy/src/udr/mudr0.f
@@ -5,9 +5,7 @@ C
SUBROUTINE Samudr_0
C
use oops_common_m, only : Msize
- use fixedi_m, only : Jwwwww,
- * Nudmax, Nudtim, Nudwhi, Numudr
- use ifwrit_m, only : Jjjdop, Kplotu
+ use fixedi_m, only : Nudmax, Nudtim, Nudwhi, Numudr
use exploc_common_m
use array_sizes_common_m
use oopsch_common_m, only : Nowwww, Segmen
@@ -38,7 +36,6 @@ C
Nowwww = 0
C
CALL Initix
- IF (Kplotu.NE.0) Kplotu = 0
Kdatb = getNumAuxGridPoints()
C
C *** GUESSTIMATE SIZE OF ARRAY NEEDED FOR Samudr
@@ -82,9 +79,6 @@ C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
C
- Jwwwww = 4
-C
- Jjjdop = 0
CALL Write_Commons_Many
RETURN
END
diff --git a/sammy/src/udr/mudr1.f b/sammy/src/udr/mudr1.f
index 8fe30aaf5e4361440b0fd3d1b2fbedaa39ce11a4..68d3e784d55a1202180b9377de39a3f4ccfec52c 100644
--- a/sammy/src/udr/mudr1.f
+++ b/sammy/src/udr/mudr1.f
@@ -11,9 +11,9 @@ C *** AND DERIVATIVES
C
use fixedi_m, only : Nudeng, Nudtim,
* Numbgf, Numbgf,
- * Numnbk, Nudwhi, numcro, Ntepnt,
+ * Numnbk, Nudwhi, Ntepnt,
* numUsedPar
- use ifwrit_m, only : ktzero, Jjjdop, Kdebug
+ use ifwrit_m, only : Kdebug
use brdd_common_m, only : Ipk, Ipnts, Kc, Iup
use mxct27_m
use rsl3_m
@@ -38,8 +38,7 @@ C
integer::I, Ienpk, Igbpk, Itime, J, Jcro, nauxMax
integer::Jwhich, Minudr, Mndets, Now, numEl, Ipar, ns
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToExpGrid(expData)
numEl = grid%getNumEnergies(expData)
@@ -81,7 +80,7 @@ C
cx call timer_debug('d',0)
C
C ********* no integration possible
- IF (Jjjdop.NE.1) THEN
+ IF (dopplerInfo%bType.ne.1) THEN
Now = Now + 1
do Ipar = 0, numUsedPar
do ns = 1, calcData%getNnnsig()
diff --git a/sammy/src/udr/mudr4.f b/sammy/src/udr/mudr4.f
index bb5d491f7ba32ccbd4fd037bb77101d203bddf05..a45b273275311f6f56ee1bdb59dfe3bb5b7511d4 100644
--- a/sammy/src/udr/mudr4.f
+++ b/sammy/src/udr/mudr4.f
@@ -10,13 +10,12 @@ C *** grid plus all the grid-points of the
C *** user-defined functions
C *** Output -- Array UdT_x of Dimension NudT_x
C
- use fixedi_m, only : Nudtim, Nudmax, Nudwhi, numcro, Numudr
+ use fixedi_m, only : Nudtim, Nudmax, Nudwhi, Numudr
use fixedr_m, only : Dist
use brdd_common_m, only : Ipnts, Kc
use constn_common_m, only : Sm2
use EndfData_common_m, only : expData
use AuxGridHelper_M, only : getNumAuxGridPoints
- use ifwrit_m, only : ktzero
use SammyGridAccess_M
use rsl6_m
use Udreso_m, only : Ccc, Tlow, Tup, Www
@@ -33,8 +32,7 @@ C
DATA Zero /0.0d0/, Half /0.5d0/, Four /4.0d0/
C
T0 = Sm2*Dist/Dsqrt(Em)
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToAuxGrid(expData)
C *** First, find max & min t needed for broadening
Tmin = T0
diff --git a/sammy/src/xct/mxct0.f90 b/sammy/src/xct/mxct0.f90
index e7011c0d1c97408a4430cc953fc6f97c3bb22ad1..3a007cb9a5e272686b731e9db5886ac48a8c7cb5 100644
--- a/sammy/src/xct/mxct0.f90
+++ b/sammy/src/xct/mxct0.f90
@@ -56,8 +56,6 @@ module xct_m
! --------------------------------------------------------------
!
SUBROUTINE Newdat (derivs)
- use fixedi_m, only : numcro
- use ifwrit_m, only : ktzero
use SammyGridAccess_M
use EndfData_common_m
use DerivativeHandler_M
@@ -69,7 +67,6 @@ module xct_m
!
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
numEl = grid%getNumEnergies(expData)
X = 0.010
diff --git a/sammy/src/xct/mxct27.f90 b/sammy/src/xct/mxct27.f90
index 74bfab950d837142c909edbc4f7ef69c9c385503..e13a483822a2ca7bfa522213614de1b3384b8a03 100644
--- a/sammy/src/xct/mxct27.f90
+++ b/sammy/src/xct/mxct27.f90
@@ -36,8 +36,8 @@ module mxct27_m
!
SUBROUTINE Write_Cross_Sections (derivs, &
Kkkkkk, Kkkmin, If_W_Selfin, derivsSelf)
- use fixedi_m, only : Montec, Ndasig, numcro, numUsedPar
- use ifwrit_m, only : Kksave, Kmsave, ktzero
+ use fixedi_m, only : Montec, Ndasig, numUsedPar
+ use ifwrit_m, only : Kksave, Kmsave
use cbro_common_m, only : Filein, Filout
use SammyGridAccess_M
use EndfData_common_m, only : expData
@@ -51,8 +51,7 @@ module mxct27_m
!
optional derivsSelf
IF (Montec.EQ.1) THEN
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
+ call grid%initialize()
call grid%setToExpGrid(expData)
niso = derivs%getUsedIsotopes()
! *** Here to write files for use in Monte Carlo simulations
diff --git a/sammy/src/xxx/mxxx4.f90 b/sammy/src/xxx/mxxx4.f90
index afbe4e24547fd6c4f5d7559d801a6ad0fb8746fd..1ee7e2694b766ed53b03bbe1a908f0b8e20c64fc 100644
--- a/sammy/src/xxx/mxxx4.f90
+++ b/sammy/src/xxx/mxxx4.f90
@@ -60,7 +60,6 @@ module xxx4
! *** Pi90 = 28.647, Pi180=57.296
!
call grid%initialize()
- call grid%setParameters(numcro, ktzero)
call grid%setToExpGrid(expData)
e1 = grid%getEnergy(1, expData)
numEl = grid%getNumEnergies(expData)