From 884523efc56b4f0c8a2bf6e664b4855e8a91b878 Mon Sep 17 00:00:00 2001
From: Brown <2mx@ornl.gov>
Date: Fri, 14 Feb 2020 11:15:56 -0500
Subject: [PATCH] Moved ssm folder from f77 to f90
Change ssm from f77 to f90, and implement capture
yield corrections into the new C++ code.
---
docs/glossary.md | 5 +
docs/tex/figures/rmatrix_exit_channel.pdf | Bin 0 -> 22742 bytes
docs/tex/figures/rmatrix_inc_channel.pdf | Bin 0 -> 15335 bytes
docs/tex/figures/rmatrix_interior_region.pdf | Bin 0 -> 37043 bytes
docs/tex/sammy_main.tex | 1 -
docs/tex/scattering-theory.tex | 63 +-
sammy/PackagesList.cmake | 1 +
sammy/script/options_sammy_packages.cmake | 1 +
sammy/src/blk/CapYCorrections_common.f90 | 12 +
sammy/src/blk/Logic_ssm_common.f90 | 23 +-
sammy/src/convolution/CMakeLists.txt | 17 +-
sammy/src/convolution/CapYieldCorrections.cpp | 134 +++
sammy/src/convolution/CapYieldCorrections.h | 59 +-
.../src/convolution/cmake/Dependencies.cmake | 8 +
.../cix/CapYieldCorrections.cpp2f.xml | 24 +
.../cpp/CapYieldCorrectionsInterface.cpp | 31 +
.../cpp/CapYieldCorrectionsInterface.h | 23 +
.../fortran/CapYieldCorrections_I.f90 | 43 +
.../fortran/CapYieldCorrections_M.f90 | 52 ++
sammy/src/convolution/tests/CMakeLists.txt | 3 +
.../tests/CapYieldCorrectionsTest.cpp | 359 ++++++++
sammy/src/mso/mmso0.f | 1 +
sammy/src/mso/mmso2.f | 3 +
sammy/src/mso/mmso5.f | 1 +
sammy/src/sam/msam.F | 1 +
sammy/src/sam012/CMakeLists.txt | 2 +-
sammy/src/sammy/CMakeLists.txt | 49 +-
sammy/src/sammy/cmake/Dependencies.cmake | 2 +-
sammy/src/ssm/{m012.f => m012.f90} | 43 +-
sammy/src/ssm/{mssm00.f => mssm00.f90} | 208 ++---
sammy/src/ssm/{mssm01.f => mssm01.f90} | 240 +++---
sammy/src/ssm/mssm02.f | 316 -------
sammy/src/ssm/mssm02.f90 | 129 +++
sammy/src/ssm/{mssm03.f => mssm03.f90} | 782 ++++++++---------
sammy/src/ssm/{mssm04.f => mssm04.f90} | 789 +++++++++---------
sammy/src/ssm/{mssm05.f => mssm05.f90} | 504 ++++++-----
sammy/src/ssm/{mssm06.f => mssm06.f90} | 530 ++++++------
sammy/src/ssm/{mssm07.f => mssm07.f90} | 581 +++++++------
sammy/src/ssm/{mssm08.f => mssm08.f90} | 588 +++++++------
sammy/src/ssm/{mssm09.f => mssm09.f90} | 315 +++----
sammy/src/ssm/{mssm10.f => mssm10.f90} | 182 ++--
sammy/src/ssm/{mssm11.f => mssm11.f90} | 352 ++++----
sammy/src/ssm/{mssm12.f => mssm12.f90} | 231 ++---
sammy/src/ssm/{mssm13.f => mssm13.f90} | 258 +++---
sammy/src/ssm/{mssm14.f => mssm14.f90} | 533 ++++++------
sammy/src/ssm/{mssm15.f => mssm15.f90} | 110 +--
sammy/src/ssm/{mssm16.f => mssm16.f90} | 300 +++----
sammy/src/ssm/{mssm17.f => mssm17.f90} | 238 +++---
sammy/src/ssm/{mssm18.f => mssm18.f90} | 246 +++---
sammy/src/ssm/mssm19.f | 160 ----
sammy/src/ssm/mssm19.f90 | 158 ++++
sammy/src/ssm/{mssm20.f => mssm20.f90} | 320 ++++---
sammy/src/ssm/{mssm21.f => mssm21.f90} | 230 ++---
sammy/src/ssm/mssm21a.f | 146 ----
sammy/src/ssm/{mssm22.f => mssm22.f90} | 64 +-
sammy/src/ssm/ssm_utils.f90 | 203 +++++
56 files changed, 5195 insertions(+), 4479 deletions(-)
create mode 100644 docs/tex/figures/rmatrix_exit_channel.pdf
create mode 100644 docs/tex/figures/rmatrix_inc_channel.pdf
create mode 100644 docs/tex/figures/rmatrix_interior_region.pdf
create mode 100644 sammy/src/blk/CapYCorrections_common.f90
create mode 100644 sammy/src/convolution/CapYieldCorrections.cpp
create mode 100644 sammy/src/convolution/cmake/Dependencies.cmake
create mode 100644 sammy/src/convolution/interface/cix/CapYieldCorrections.cpp2f.xml
create mode 100644 sammy/src/convolution/interface/cpp/CapYieldCorrectionsInterface.cpp
create mode 100644 sammy/src/convolution/interface/cpp/CapYieldCorrectionsInterface.h
create mode 100644 sammy/src/convolution/interface/fortran/CapYieldCorrections_I.f90
create mode 100644 sammy/src/convolution/interface/fortran/CapYieldCorrections_M.f90
create mode 100644 sammy/src/convolution/tests/CMakeLists.txt
create mode 100644 sammy/src/convolution/tests/CapYieldCorrectionsTest.cpp
rename sammy/src/ssm/{m012.f => m012.f90} (85%)
rename sammy/src/ssm/{mssm00.f => mssm00.f90} (75%)
rename sammy/src/ssm/{mssm01.f => mssm01.f90} (74%)
delete mode 100644 sammy/src/ssm/mssm02.f
create mode 100644 sammy/src/ssm/mssm02.f90
rename sammy/src/ssm/{mssm03.f => mssm03.f90} (54%)
rename sammy/src/ssm/{mssm04.f => mssm04.f90} (51%)
rename sammy/src/ssm/{mssm05.f => mssm05.f90} (55%)
rename sammy/src/ssm/{mssm06.f => mssm06.f90} (53%)
rename sammy/src/ssm/{mssm07.f => mssm07.f90} (52%)
rename sammy/src/ssm/{mssm08.f => mssm08.f90} (52%)
rename sammy/src/ssm/{mssm09.f => mssm09.f90} (72%)
rename sammy/src/ssm/{mssm10.f => mssm10.f90} (55%)
rename sammy/src/ssm/{mssm11.f => mssm11.f90} (53%)
rename sammy/src/ssm/{mssm12.f => mssm12.f90} (62%)
rename sammy/src/ssm/{mssm13.f => mssm13.f90} (52%)
rename sammy/src/ssm/{mssm14.f => mssm14.f90} (55%)
rename sammy/src/ssm/{mssm15.f => mssm15.f90} (56%)
rename sammy/src/ssm/{mssm16.f => mssm16.f90} (55%)
rename sammy/src/ssm/{mssm17.f => mssm17.f90} (53%)
rename sammy/src/ssm/{mssm18.f => mssm18.f90} (68%)
delete mode 100644 sammy/src/ssm/mssm19.f
create mode 100644 sammy/src/ssm/mssm19.f90
rename sammy/src/ssm/{mssm20.f => mssm20.f90} (59%)
rename sammy/src/ssm/{mssm21.f => mssm21.f90} (53%)
delete mode 100644 sammy/src/ssm/mssm21a.f
rename sammy/src/ssm/{mssm22.f => mssm22.f90} (63%)
create mode 100644 sammy/src/ssm/ssm_utils.f90
diff --git a/docs/glossary.md b/docs/glossary.md
index fcfb58129..b04a1f2d5 100644
--- a/docs/glossary.md
+++ b/docs/glossary.md
@@ -16,6 +16,7 @@
- 1: Don't calc yields or pieces of Y2 just store arrays for Y1
- 2: Em $`>`$ Emaxr so quit
- 3: Em $`<`$ Eminr but still need to calc pieces of Y2
+- **Jtheta**: Number of integration points in scattering angle theta near $`cos(\theta)=1`$ (ssm/mso/par/inp)
- **Ksolve**: Whether to solve Bayes eqtns
- 0: true
- 1:
@@ -29,6 +30,7 @@
- **Kssmsc**: Whether to include self-shielding
- 0: false
- $`>`$ 0: options
+- **Ktheta**: Number of integration points in scattering angle theta near $`cos(\theta)=0`$
- **Kthet2**: $`\theta=90^\circ`$
- **Kvers7**: Multiple-scattering corrections use the current version (-132,138)
- **Kvthck**: Vary sample thickness set in *PAR* file (sometimes updated to index of covariance matrix)
@@ -57,6 +59,9 @@
- **Nnpar**: Number of parameters
- **Noyzer**: Calculate Y0 (-248)
- 0: true
+- **Ntheta**: Number of integration points in scattering angle theta (ssm/mso/par/inp)
+- **Nxtptv**: Number of interpolation points in $`sigma`$
+- **Nxtptw**: Number of interpolation points in $`\sigma '`$
- **Sigxxx**: Final observable from mult. scat. module
- **Sthick**: Sample thickness **[cm]**
- **Totsig**: Total cross section (summed over iso)
diff --git a/docs/tex/figures/rmatrix_exit_channel.pdf b/docs/tex/figures/rmatrix_exit_channel.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..994f0b824a09502213ddd5b26e1d9f6b69e8cf97
GIT binary patch
literal 22742
zcma%i1ymi&wk_@w++pJu+}+*X-3jh)L4vz`aCdjt;2H={a3{EYNY1(Uy!Y<^?`MqE
z>RMghRn@Fs(sOQ7d0|l+23jT<(*E7c-J_zboT>gn7-j%Hz}C<bhMOBeCv9S5=41|F
zc~dC@=tM27oJ<_vq?Lh_iLi;0t+5G!mlwv-$-%_H8paK{L3PXqMc_mGnHsY#j<8wl
zo;T@MFT4pULQ1>{Dj^QE!-mv7L8+@LA*&P=rXlIFuI-{~SLq%~N1@!#xdIId<;>pg
zbujPD@_ob9O`7q8w(UirciZdBs!gjyeR{iVADWI!dBI*5m&;9FPl&Sd<-`42Vuy#i
z{x-YV0|-@B1P#WX_cV9Ma=9|g+{pLSiv~G2B<K)qiSRhi-5p3_muZSMgmc3{$ToW5
z#xg_G-7j6+SrdZ_khvFeYcq#y&yb&B>OJoEFXF#h)~%Ii^J>j<Ve3tgAyvVyrudpu
z@^sO^+^KZyWvt^*_}P^@+{BV_qKmvJZG?r}K#J6pq;Z&9idJL@<y*7W*{R^QY84+}
zMJz|qtl|v`e@ocV2u#CqKH@U13wh~1U24H){4q11aM}{<BOGZ8ld3aUj0!UZ;6?Pj
z#Fv<$NR@*U{m>i54HFGX?S6hkiLnX`d}|qs8q^`RoOUpp;V>#OOw1<|529eN(E)Ke
zN*nIMT{0X+XATos(gKm$PUou!c@)-dzOjIQqR2gjOo8=lMvFK{W*WQ9^Ak2-J$`e8
zS;cVpMh<o#5<9j5$m@gIMv~uL%Iz2?`A@^V*yxmXKD2fK*YFVV9iI^`QA89wP_|=~
z!c%<4YX&+q^qv>g%Vf&lC<~fo&^(^&Sf5g=kuWjI6OfmGOGt#EKA{Or?sFy(l84d&
zD%4?>j9)&);I*?>*ue=PWj`>43^u?J8w@(lI-#7uFwN{+p#WYZmX>0Khho~efDki$
ztz@5dqv_PLP1SK!<^<s~O=Fyd4<hDkE>9Ce9(a4st0GF?E<k|;!5Va&=5{|S=n=dY
zNtDr+h)(&$mYsU%5X$}M)1B}{aU#vqtHAf%NCmg!5U+%Na`HF`GVE)zOTn)N$}7^!
zFjA^;Wxu-2a5cFL#!1DiNev?pxC?0vm&Kv_5GtbZj;lK*4e8WHW(^tk((KqrqJ(5+
z$-3cyr`Rjtvn^SL`%idGAv{~>lzBd!2>)^oy3If~vEqa3Z6>hOO{MPA$V?FtH-*D%
z!!Rd|OxgA6Z&~SvAA+Qnn7{6y09$GfL21%hX9#w$!^itcBBWzC-W=NTq3_7{SwoZ!
z#>B?>uUG5s=>3g+e+}OyJ2U(H$@fFXf4r>9?sg^sI(Y-L->rj*jT3<B&x@;Q;%Mva
zU}WM5VEv;IvbAw~JMRd1f7##OY#9?{3j;x0H-HxXn}U&%9l*fKq672xa{o2Y`*nXi
z1$hTsBPA0jfY#e&!lD2=WfM0ifDV98$kxi%LCMa*$OQ22JA@n=0BpZ+&&&JfGu~$W
ztyWfM1aQ2oVd#{VnE?z8zlXdXvj7<0ccb{`Qr^AFUlTLDZ{hEm|8hqRf2~^fZGUtE
z?>@=q%^?BkgiTy5j7${81pjwem6_zKth9_CGTFh_F@;P7Aic)+fCkKPiKBrjgi83y
zg9HbXxd?-cq9ReM8Y_1Li-iywiJ-!M4lrDVzWg9R*rOmUvil?A6ZBaH%hg)i^N_~+
z@?O*8ve}vUVk?mRQvg`6lRB^;bFMn-=~0h1GRj#0EePfZU<7sG?oCruFtIyfkh!N0
zp48N0@xi*AQ(8acwv~@v@??$+ufDNFY(gXuKrkZntlU0i7`q?|N_7KRjIUs$*NK#j
z!3>P(xzJzBiMIQztZs^aQn!tyB$MsrVrxubwKHc$w8^ifk#6QifaPkZkZzdec|n?V
zC`+UP?cP$%&faB61JR?V>W%M_<ywU@ilAbhhF*dIK_&Eav^yY#-*cE}0l5{L?Sz4a
zN*ER*Ev8uP?hl(jT+}Ju8!}KQ^vP^~ag(0Bu7``F$MCDNO%een)v!)Ak3FftJvq@>
z_-TIMwY-k+qx8%(?D42_L3TWuB@mINv2Jx-PS=4BbVH(<j#t;2r~*`P4Z**=SuS@5
z0J;PRs$a{v!Vk96jqBfnBZmz?KDKfM&i+J8z0dZT9bh}!70hv)I(GV~%2kNL=T9tw
z#$+P0TUb;mB|JV3hmbsJ{CxZ2b-SCx;@e2y$BgW5jEkUs6@~o-=)h3(wjgeQ^%z=X
zm_Xn8O<zn_a!4$n%ulH1&U!%JK^*eU5|G2TJU~Lkpd>bY9w6RFS|1o-hCAEMD`Kl0
zqZvJ3_8tgewZm*Sr3HwTe%`=E8#|DG{fL#f9%$7Af*b?slmo-;PfHK-Q6C=HkI4>n
z4FDAAC;kC636xeG#DX8JR)BX22u6Tm3E1Vcr5(_mzsD4qYyhhrgf^I3H@qDzoSzs!
zOmL4BJ@A^p1ysQK2ehvOr7`IFh^c}LA8<6G+=T?>*-=3UghFFJ#PQ!xkriW7eJ;%v
zlIOW5cEWCj()s+5133j?hIj_{4n#@;nKgi40&4VIuI9pp66+n?5Ozb$fW+ut*_3QX
z=S67h#n{9-2l^PK*BcMTKMVyrEvgQMb0I7kqfP>hMEEI|C?BLmBrOIZAEzZ!Jl1{(
z6e1+oAO#bB5NkU`BVyA~)nLI;l72qLC`DBo<0q@>2PXgffC9t$nnHE*ay}PmR;2Vu
zntoONXnn2f<QmW=gJUjSgrRP%EnGXFW=w5H8<tA2Cd9>vHov1j_)W44w|1&E)UyD@
z9>;S-FTze3UtC}O^=N{@F7g;?O|VY^h=fT15-Sqr57<z9P|tx#z03;!#d1zW!5`fF
zwGAn2qLu{OC2+}P<54AoNiY;iC{yeGl_e~RbjWzfItb%OIE}>|Fg5sf<tj<C0eYl}
zaeVR#6lAD!lDHy*%d#AjE&T5M?m`8M@WnQB>ZK{InVNDP!rqeJbYk&L$ydqSBNg#w
zv7Zu;l08Y~5*CwPll5q`$@K_*C0`1knn4tL_<NN6^Qu*IMK|kvd4eQF(!M4delbil
z3^n|`#WJ8k+8*a0*Muxr!hcXbLs~$HEjU}?KGR$;Q_uO`<U2i{7+e11Z2ZB%HNk$z
zHM9w-iPkQ~F77V&Zr!LNL@&Mm9g`wfK}38+TSW8~^Us#a?a39^Dhu7$cFM$iDjO=V
zM508~MBv2eQfU?2dDQvLQtMK=IeJSnO9RVg%g1@zvdGDzN!P5&Og-k;ou`n)>ef(?
z<_F7PeTO`U@z`nDo!D5|D%i=)gDhBSHfbYiyJ>sOL-ppGunl0EyPA6qy7Y;ur{l_|
zq;=sOxfPWsMKsgA`9I2dDvXNj)Xnl_>n2ci;%K$l1e&y)lw1Ynr0CS?^r{rja(NZ9
zE3)&u#JaS6N4uv0-}S=<(tC<?!*aU}vJCPzjfhKQ%ciOFH1oIy*^L_Q!!CHYwaBVN
zGbQ3AB1dGDmgd%!^;;+FC*eN*G$&&&V`&@uTD_{FQ7*cW!_mh*?3L%9eoqa{6RsYf
ziT(p!@8iiwC7Pp;1R9hY;Of@(ht&^#-}}=(=@@wr1zT<#)lC%s_}NfVLbLADb>hvH
zrc?a`y-l`l@&@6C=#lJ^0g@-gEu;hCcFD<wqAk#S9_eU*vw7koVjGg&le}hDqG&x+
zV}f!5ej*PR4&xkSjt0|V+J3Vc*CCeHm^MPs%`SINWhHT2^XOq*W-)TlrQf>$#}d!-
zbMqrLq7-7RSolyvQT!hEB&_b2<SMmTwW_ALTf;NUvm#zj-ca61UX)Ik&N6ShJA-GC
zXP1W`SBvL+4~vg-VC-P!(EBj?V4`5Eki4*r(8%D<V0}HnJ#7I5bTfJ++H>e2f=@y&
zLEO+Ra5`uYj+nF`najzJ-J4b1eB4~YXbeS!h5FmXqlagP#lj=erO;hPN5lq1=EY=0
zJVla4q>|M?YSitBMrcL=3VF~8aL_zSTpUVnXMRY9Y#(pIY@gCHX(!bke|KouEg74v
zjM3}Su&2VuA;4Sz@EVHJTe2%%d9Bytx(l`#-xl&1w>L<=7kQy`XYv#amK<0cI4zvq
zuM=t{Q7M5Yu?-?8(6HfLt9R+YQ<4yqkVnZ>GF|e`BC!6hepZmwAgr2Nhlz*0gRYM`
zk6x&C)MEZr1?4OMbgVRmqlRf)O4N(=FYySHbkffnuyvNTYi435*`o^MNI$Q4(spdd
z@J6mi9(`C$SzMjXI$d6ZpL$qMKOs~EEmUf+w8*;Z^t5jN>O6|J23U(PpO1--MVjEO
z+k~ynDdZ?rcj}who&6jXY!Ou0?4X&@La-XJLbE#gVOm#VxsptzJN?UWY%6R_j&wEd
zXkEiw?f%F3P2fpK!A-%V>xK)I>*|k#)+_Z?Lk->KsmcwVirw+cua`}2YR8?b23q#|
zh!)Yt(e;eQwH=aGmSXcohxv#8*wJY}I}SaYPBOm_tt@t}Tl>xeM}iJO^5Uc7w)+m>
z%73a5upTg2-7N2$Jo<Xr+GXae=PP_7ei1t<79>_M)En(Q&o#HmR?L>b+8Y@+ShH<E
zWc$4FOUM(Y>_DC=ujLMmosi>VYv_*PEDMf%**(m=^nm<1`=)V9GfXpgVRa$2F`w1K
zQ`&R=z;8AaZvu~oFa6c)I^rfZt!~szYBF{LEhC*H+tue%a4_g1JQO2@Q_YFDwSH$N
zv$DE!ZOlKpO8270p=71w@ku4Q%&d|_hs!(DyW=GIIdTENEh|ay*vI0a;mo?@z^?8&
zX}cn-6Wn|6LFbWf?WWaxH|jML2Q(bw;gq)1^Hq11=fHdIc^a|=QI~JrgZ<h3+30xt
zD>;lDRaPlq#q<2#qG?IT^>NOk{$$-3v*_SvA-dPZ`zpCU@X3-%YSDVpL$M06$%y-i
zA09Q=1LtEA$+O!*U6e14w~5nb**>n19cG3j{pX*ik5c(0*NQti9u{t__l);<W?e1L
z3X8(l$~yUO{GW3ljjo4c502&T<Px(Z`CPrApDx|VtWAHe-v(Yi{?By$cN+RT31?+s
z{5xNL&v@T;Z^^NQkdUB(qlq!#cMhuv(D{4JKU3O&C+&{^w>11cvvz*Vo*4jiQWnOJ
zZ+Z8hJXz<TY4YE-!F%TY=bl0aP6k%CW`8OI$G=K}e<arbvvl~Kqthul8#?{2B$OST
zP5#{KeH(vHs*B1h3Mf;*Ey%&b#6i}?RbGik(ALUWM)^;QFKpsy<X~avWa|LK@K>!N
zV)OQ)z{2KjAu<L=ini7UHviU$S~xg537H!>02tpM5}mZcKYMBx#!lvM+l67Jr+=$2
z{;~9bRwI8__`bS-&;4gDvIf>~MZy1b#a0GpZ%^iJ=J)Fb-wGfYEgA+6MgR>P13iF^
zp7E_DVPt$OZ6w|vrG=4zjhU6n+uxT?z|rWvx?+F7@_p9#4h_@WD(Qp_?8Hqh%*>qt
zEF6q5bV^Pp)~fGUsQ;y9W`4Uwz{TwM-T?0#dwVKw|LDCh<n23)$=lR_7f*ki&2Pnj
zFNN6O?*3N5{i%!?01WhR|Ni&#r$Y0SoAUg;uICvO6Eul&FDZ#|3KJF?QXKsz89SJ%
zL#i-}z921Q-+(m0Uq3eVgS@<dDMdf5Lbz%fVo#gMg>kjDVZ)&1bNg<rn0!tnp4CxN
zqv8}|yTDJcvt_2$a=8@(9<#NMg*DI2UzHt`x_e3WRk|yJl=Z1#?#a48=0qJF@%=Fy
zoOIf#$`WegC@h9+8+X-)j*M&owP49r+Fc)YCshERnp$aT+s>Tu?h@44Th6TD4pv9=
zCyN6|6GAZ()O}JY&$4}MUe2@5&^`~KhlizwWm;P|Exth?&0(u7<mU7O+ncSOrFyf#
zzlg$}q%|A@d!s1m2_k<+E21k&u^~iZrf#7y|B!wYAJ95&8!%G$x-ylb>cvROA<^nv
zPpEB3(S@_x#_V$9dL@lW{)*5zGPAbdZU3_f5+9)WV6=EBQW!FMgV`}S*tWMKX-XBL
z&5s1g|LOk|65Id7Iqe7VC}4^Fugq3Wpj^OtL&B`N@vsyiVD9p)Ak%dXCsQsUI^Fi&
z!n#N+TyDc8S`r0cHm5KffVqIdL$b>7;%Qb;ymev%W>8TEw*(J>8$pMFf|TvCPgL#0
zdigOd#el%qx`f0bWMc^!N$g=RnL8pHy}Rx8W7fz!m$|BJkP}hEZ8!I|gzstQfvmet
z`9Y(AQXms(8T^oZVTV9xsK7c<+^~M}4tx6<@L>ADg#*hYOgZ{(?nNXT*yD;rJU7K+
z-O3y$N?Num%bq%8$bDC1)XwN%;xtJOo&k3Q;;Y7UL!kfsQ<#K91mBg&p~O=$lp!BQ
zT{HgIw;1P`;<HS(aCd^w5QrO)5fk2i&^~g2VHAB%f5MFJ<AU5(gk!KMEE>BDlO5zH
z<9kNNCLhHS?YvL~@iV=dm%t|zLEgBSCbFHRK<&hs3TSr`!NI(zI8)L?CX^Y>pdKbl
zLUOWvCPGJKMH%t*1U=zHGS{RC6g~Y1!7ZkYkxBa1$?6D8`K<MsP!Eh8VDD~TKq@C%
zP|8{evVCaPy_Y2bXN#To*))86=B()ak@Crh>e&aTYfqCi*A*Ch3i22wTQn}DlvLLq
zR&|nw-J%JQq(whZcma6ghT=oq0^|OIE@%O+oC9?Z!s3U;13B&Z0pkm?A>YEJk9pt>
zOff&w2DmiFT%cPbn<CTYFNRL`87oHvEa7T6B6SF)ejj06zbep~Mc_M5zdXe5cM0&$
zEQ78A5T#l3Y&FF)3bofRu31S@r&5e=biz@Wz=2Zr0hATOBo2k#!8X(t3ifG&#uU{P
z42KJhkrRos9qf%6x&jIXC-{HF*eC#Y3!pi4cEkz;$i+~5q>vU&W9?-=xEJr{CXs(K
zQosrSu8#Z_YFFKD^m7Irhbnsnr|eg3tR&LK8tfV_l+i$mcwJ<dHGZc2Q17ZL2gPFJ
z>Sic=-N5}TVOBga_Nd7y=?oIYu_$F_GE{9o$(aH1PDO{v4e}9)iOra8KnQ6*4P)Wl
z!kDBRkeR<^tq6=M7r0Vlz_M)5T>b`kk-mo_f4COG6tvTyM@{J&0*7~avS}+iD7$tK
z;`=%3f~_51yP+<#(1@&4iKFm5b1P+o>z-jkkG0EcleKPW)f^$cDP4v&d}ziTTB}h@
z8vhi@=M*E1Q}mm{)f`B}j4_^3gO+2t`vS<Pf|eR%@K+>RL*iFZh8IZuL78FE^!pHV
zrF(+}5sD6=q7S32CDx+Llnt~AX>$+qgV78g_H9B3iD?Eci0mLx%Qp3PJ}FfRR#bdo
zNkY}U!T|(ZawDqLd|#j<xamiUx?$&lVEBd!5?JLf5Q`z%!JuA%Uy+c<2G^sdCF&C4
z&TsG0YF`k1L%JfLX^w3TeL+#u$S#s_=hNqg)=BWX@eoc3bKv*E9)M6x_h=$2!n;1t
z1kJz(0`<Mnd`D=9+n|O0guxtrJ^v+cn#>2(dgF)w_x>u-1yCHnqgeiQH?C@Qbx3V$
zt?xNHpydz?!%2x#l@O}H2Fo)r*5Gz%=fw4aJ<~)Sy&F)UiQ%HEcYX_c_TD(+@s;0~
zynV?*cgDmuunQy=OKB3+0@en{#8uhQr}#YykP)29xgPlITSNM+*5ixz^wuO^|Ixgu
zXZ~p3)Do{Y2kY>!Hg~RlU0M%s4bIDt^RuM)CfJwlsjc9>*?b>?f2z7l$_cd!u>0Ii
z1Fap`4Gw|<r46u?_#^zgNul3*{%`7JlHcO(tOF43ooi1Q?2FEfuku55uP^FL-Z??y
zdlU3Z@g!F8-fZ&0yeb^LH+OF%{yB{8Vpm<f&7VizGW||52g@8dX;av$7hWF)5m=@h
zdAat(cOrcTy8^3JL>eG4fAHD@1WlePAZ`C7dbdgtx$qt6&*X4f^lrUzf5Zl~R2ID+
zlr>T{=9{uPGq?u@LQefM&>gSdBL|q?4ZCM{IJ*#h19>V5<QqS%enb%xcjSfzm|Wh@
zTSNSQp2GdDfyxp+XO?_#E+3G&ivvm&81H*_Ae9o0FF%hUlJTWH#r+Zbms0ON{WmpT
z>TiKa*7ZIp8tJ}gJDD5*yt${x9#|cQ8I;D40UME>d*j@%kC@}P07Z!2dFz29ys6{<
zh>de`1Pt~;skcUZ!_L2tl;gJmM@Zgz>w&+k<Nk;ZJBfb}`nqw~vGXN>7$%B>{cGGG
zvGGOny|?kErsDW5V4{luH3$N-%b%yG$}BI2v?zvVo$!+jAzNz<F;^`0x8c<L;Rs1%
zaV*9HOf03qb_!u1RDj%N44tg82tsXN)JKI_8lyXhJ8g(;8mH2J|Kcv8>$VR@7=}MW
zQ__(hy@b_6#m7F_GZ4`UdIf!{1G@N0XhZ&WOd!EUxa^YCb|K}l)1uKDR26g)2*n?o
z9}#CaGmJb>i628A8WmK8AAbYP0SFBfR9+Nf?OSjmxx19;Wh(9@aKfl=+^&np8tK?4
z6ArDU#9Aj$v4#9j<@oOk@z|9T*5wlL3;C*Z`K_N6eZLvjBkA&9M6IQ?8W|l{;3#2O
zOILhP(QIXCFg7|Yz)_-GPB{#ytew<gfFp?A^{#DSp*TqR*cH2rq@hbWW~fnGi`y4Q
zT#~TbCo6i)#Bhp&)JCvn-rotfb@0VI>_p@SZ24l)+$dV)Sncbt=`S7VhVK2mXoed7
zyhvY}4e35pxUcCNKTfRW(c7k-5I<V3c-~N@n|94Lj+uuqxr|o!G|u06X@z^YS8%Lx
z^U;pNT}Z7+KiX&+v=;!@X6Qe<t2>w>9{rMSbb5&{U@|`VSnKpti*rbe(~&0Ah$fR&
zYR`P^JU>@rA)io!QsQ%5T->;XB(mJs{7s$*BwPOr7oJrsmO!jYgb36UtqZ7$m<3UZ
z3{v~juT!vIWcVniE>{-c=@q_}9Z705EHovQCKrEKbB@AiHD3eywnJg^eaf=5lJ1*c
zyheq|yvir%D|9fAJ85f2_l7W;vC_o(&dZ!6>Un(8DRNRLIwx1bb+``3+&<o7nX#(V
zn*E0F*H4x-Ev5!J={0Qu#TH)F?Q@VGDK^a3BMZSv;2xn2D@j~+@Flh_Oqlr*&RNov
zQyK@!stK?BNO6(5mrssbKRM<%DmBhzYEEjFywF#S!@n6Yc$6JYEwv2I9Mm~&3HReL
ziG8|NSp;YHW`;<TFSW-%niKKYJ>6vT-tF*8A`I|fE2llZn8!ZR(81i%;36r4bQzX`
zvJjK)i^^E98{4ddYvUH`KXJ&{nE-eBk?5l5-h?NzTB!J4S=W5lIaemR{y=gG3aiV>
zesHq-z&M%p#$eXucyDE=zvZPsW)1OsM*7W}1x>;Fr@Kw6qXJFzldPJF#jW!o+)i{r
z{*TT|7NwPTVHHmch;VG3QZff2sia2i+LD405j>jR?{H!*-*u=FJF4}x%$ycEN82ni
zt9Yk6CRP;jOMWdp;L7awbiC|lC1Olja|tb;XuM1se|P9h9oo1Y+wL4{nAyL<(WZv4
zOoT{YKT6i_L=(N42WyQlW>#;cpuN59`CNS{w0xs)5!_&%B<+uNGak82w=w@piJd_(
zr-)miNu_TrW*}h@Ivv!{)*76{K{K7$Vjs-&2!5mdbu8?slNco-_>09=;_L0LOH0K)
zV&iLn+;^0y?@Zp*qm!?@dpN|FlX{=^UNrB*aK1Jcc4PuAPj!-I(+{mB$m<pZlqm&`
z1YJ5!Wv0x%plwwLwW2S42BrqTQ}Sh#l0id~vED^~0-OA#4>EegQq2U$+BXk-cU*%c
z8(<~#sHt8q0u=n@e<CfWjZF$PWR}oyf2a8XZHH(g6on*Z4i}3rvoTo{S?eoo1(baI
zxq1AS9LV1q>sK9jJ=UZ5wPS+725W2NkI`D=qmFCl9SE<3=THW>@5b$LTW#k|%m^nT
zl-ZRzk2SvG-{n2<o}V8ul*8mKf6crY*8hlp_;f7Fo3>(CcA%C~pM5a8zAS&iUSX8J
z^cpI9*F}JD_+;|zP+CB9EwAX`8R9S^r8W!i#Kto|qaM{M$rphrfwggS5Pf7TkK)l*
z62e1mnSk>vlf5=db(-gzJ3S{bferEnxlIG{=xkH!iPa+j-qa-uNP7F%y%UlQIU>#1
zrk=3OlF?>ho*S_aoR_N-uq;;pUp5akCwX-094l2jX%vG_=`W2hp0yiF>qOssz+9-u
z4A89D2q@PE)HG2{6iK6Wg=y+Ddh64&`d{F_at{_(my~BDUk!LsulMMo-BPhp;n<t9
zPFG<u1Vx(Zs(w3Mvbn+cM67GjUB&Dpw^w9XW4xTU(u}yU8A|mK67^1jz!U--Q&0IZ
z>@(P^&iDAGi|jCQETQXY>{^RnJ*qBFz-2Tq^;|yssx9P3kuK^LDnjFnH{+GQ7u&_M
zS7r*4Wxt^P=Y7=ZaL`dN6FDo%V}b{C@8p-SFa9sNKBzA<lp!!B*i1Tdz^(XZr#2p7
zx_Y^vuSp%N6&u5T^!o&m*P1QkzkLk$8*rmqr=dl<4b!8NzM$etSTs7Q5i{bcF=~}V
zJS<}9Bz0o4F7P~1@BpDcb$1J|m1Ir-W(2Dag>P%JvJ`);a>Jo^NAv<4OI?YC)Bnpb
zguR445q|Ws(79%y#?z?7BeoL)$#(uVSbdfvyl^wNFsm{jO&!a+KB`h^oK1hiR&Yma
z$A?_>{3E-sNY`LHZtmm(iIi!H6%@|5uxdH8I{H$ePiC&wkV{6#lgB7GEM{Lwvh{lR
zE_d0p+wMMj@x6-Ag`4$<8+I*K8B;hWK$Q2AC-RUn7NnbzbvPcLAM8Q+aGvW&3=IyT
zAEEPTb%|HaWzXu(BObl-|14GZbLPO{a0YcYoWI_X?ubNdMohh7@D5-x?)8u|Gt!_<
z??bO4Fe<bi(B|vMA9!I_op3CNd<<WDTsm9g9e)vU3G^P9W%#I@HKy~$4M}gXYESMW
z`L2wc3?kfWv)c<j9DV#Ca*Oo>Z16nmPSC3YP9d1GWfZPJq(yAGqWvqbs%$EijHC2o
z+Uz&il%_Ei^PNd|oU04U^GS^l_tA3x*RU^~bi$&;+>dn0D@%*l5Yz?H%Rs94tjBzX
za<O7p?pTj{<@sVu%r1y41K?{JjWxW7Uv;*yZh*T|Px)`;a=P-2+Y@E<weCflvDd!c
z&gfM$KE%@LolEXNv(Ki^(LHG3c=vT0yUs8~koJpBIo#mOm}zNnRP1aI3!Ib_P{XB<
zl+n)$YTG8`Eb5v-zT&L+L~Z`CD#CrnD-Ug5VlQv<X^hF*R@g<}B`u$UF+QMBUvyy7
zif*|7ptdjZ!nt6>c4<XhyX9kSi*cC`rl2Q%qCEI>)BW~SlJtQUj_PCL@VNCCGqw{`
z(7QGzK9zksaj((v>KWH5IV4@W$b#%6*J;}&<eiHvs}DTF1k+abf>{1-gZ3u%BSlwB
z$ej6;c};c$wPAeICf9^*c#Dx^`?nuI`xI8q73s6w90~Nh!!{^>F6n26P}?SJ@8~o<
zV0<0Xw#qU$Erc&LRjMfYu56lSnr4n|R-0ZcZBZz2H~RSYrTr3TmtmJ|=M>B&FplUY
z@W`ymjenK4*D&h*3$%KCUQln>?(0VOCg>^Q+EDh-^ps!<zPa@&f~il}sSnKF>L1a$
zusm5B$#3eGqLy@OzST6Un{PDC`f_)?I^7-&Evtcs*gbm$b)aztd3I}h`}1nO!rZfJ
zcd2D#aSb;bMaW|F`*eIhI_zMli#D(UZSHlyHyM{?;FJ(!5F*IwO3v!VZc7q$3c^|!
zv+Hz>O=Tljb%w2Mko!tzR~fv8u+bASImn?A$VT0BX;<VOnKkVi3URleM0rKxn_N;O
zMv17Fs?yA-GOM@r@d4*%@8I4avgan@UZVOYExR!OXUGLc7hds?3GYIufgl#X?!IGL
zZv!jBN{dCMs!N8KIia;>|9ds&xyAX3vWv-z)>WoYrWbIx1+zsmnT+l;{X~m_y#Y@b
z+q4s7&QZ=gODZcV(-<bvqocT~42E~rxd#jNge8=pAxX(K#>qtNM8SE*M8xMEgwo=U
znvZJ*^G?kLg=XF131vi-27*}AEO8eDD`7u&RBPYxNZGE=crL_g%o|eCew6n{P&uM=
zE#|T6X$QLI8p9J%;iCG*p{V9yLW+jgh9_3sIlkbaVnjG!q*DIr<UD8;7FPXsL%<}e
zHc21|e2&MQey(S#J~pb+hSdQ*9){q+(bZ8>asabIA<7{;X}3GqjyR*U(6qu-w_7dC
zx(N~%mRYrNu11)6TYyt9O+Gb$dfX&UWTu#!87{;|tqt~p^K`#vCQjZ*vM#U1LV+Je
z=6rK@=Bh`lGII5NaokabeTewcdhgaW96|3V%sl<+ezVMc>re0rF4h$rHz<fr&>;si
zk>Wg%IoA#48flCGre3ySWCG<Um0_$_$@w_Ef~bY4GC_92JWl3P9oy&#?A??3=qZZq
z?+OHVODuAY#7oLP3b%HL#X4PVV`Zi~OG@ff)-utPrnfQmfpKvjoihQcQMVE@X*inB
zC(8%Mq7hMJEOZOgifFN5xR}FEdFH9Icv3}13pL<aQ8Q`w*sA6uCb<Y@E9OJWjNf+Z
zIp?C{17}a!AMS%_WJ1yFX2YaKi)z>>Xz3$aGN)PENh1hs%VDLkWJwG&NRO0YVHbX#
z`-r8h1a+sA%!ApfPo4B;tegyLbaV_!Ny$&MPQvydQPGS<#ViKh(%>_CJWO0inA3Z(
zW*=~Px()m9K60O?-4(&oP~INXeM@5)Up!n;AMDz<3B6TY<S4yB68+^Ih%D96`Vyeo
zzMdjKj`M(=##;UnP}@>dpL=0N=vjk|LBswjKoTILlyR53D`|6DLt;QVie9K{zA$BS
z!N@*rBS$jY#Z@fEXM;;R(9(z8H??{n%D-*!iHWvY?}M&nNO9#*P_Wt}-TpqNlR!2r
zo1T=t<%n!K3e9{8eCz|g8Htg&P-iJTG>5&31eX>zRUIoB!p5^Ee6i-Uo3=(6Q*>Jt
z#wQkWSL<q&qj`!=gw7db=q>=}=A0-eQ)<JV(?tQ3PO4ZGj_KzN2%d3yG7gq9C8=bO
zV5Yc48{rt*mXItOmf~wUBurrS@K<j*K(B4S(wKv3Tm$<7GpS+hB4p&iq&j>j0rRG2
zSnP(G11lJFU54%sD%|!}&@`bBScKlHHP5B$)!uf<NBEbeVg43_u!;2zfgQ%9T_zY<
z+$nKO%SuqbddzS|ctZG0yxBUu8~x}?VzIZ+WMGIK3`ds5#9;He^O0;Gj`LR92!bsF
zxMccT{%wk4VnIR``%uozzxLCU*_F%k^3;sKL`1O?oRVLVoJ{LA^JtYd6Mvas9$jrl
zwWm69sjj$c?XddvBY>Z-^K+@z5hxP(RC18yXHl5*+6R6^=+UQ`&v58O42eFPmDhFQ
zxm$_wq?=faa34B+8-vV|Pw(A;`f&i1V;5EOAhr=q?MCBC+s%1t3EKe>sWL-B8+maw
zqxPa267!2@KPMZqD6*L3xfdT)E^v?d8QjAl!{DVqre)a3xqhEL8AIc&2<x2HMak@a
zW%)%2<HE4UyEc%?mwMTbHA*NN@EokWbGvk2<X|&`J@*28;C_*jM;_I?I~^)AJ~1AZ
zv09>3Sd+XowX~_=o|l2XyX_B(;wYLQ$+(rIHSWKMZIrRT9`T|#A{xAx;ntOEr=MeJ
zV=dwBqv3XPh(=Sk*Ql+fq^6FoyUbnm@(LV{A;t9{0JnFr;~fBDWn!TJ8x?uylKl;e
z{2L1b{J&u=0R;(76=`Y#2MYtM|0{m=o2B-KrrE04Sp4R?GQN}Je)C}eMy=ifpnri@
z@6gWQm=%DPl?}kc!U|wyV~1gS8}=pvY>bQm);Gf2yZ&$auKy>t^?Q!L_wyIujqxvz
z-2cYE)rlRm?4$o6a{B;7Gb>Vk+}?vJDcK#)TfBl;T~LEGR~wTU^xEk<#~egEv1RTQ
zGEKp?DA!P@U}|eH123|yWd`zXmc={{4}KxEJ!bIGt<I@%XdxVK(=?Shvf+qaBS~=d
z7%!G1SfmpF+uSs0b_aw|Ppd#B@1zW;Mdh0Bv^cFKX{jXk;q+<CFS-+PMyY9MYxyR7
z4dP#}+eQ~83`ofLlj0tX%#W%{=0EtqDwk5xB}>LIy-MEGO#f;s6VXkKP+ZX=9sTMD
zQh*?~0FO%1z*l3F3p7u2gaDI3g?fY!GiBN5;Rj-@R7Q--?^v0Y10-2agUUaPiHFMX
z>@j%O{zSC)<gN684U&}5Nq!Q2Yl!#5cS<hnHs%h(B`gNwf7;aVXZ!xV8Q<`_zd48h
z*{1$8zWAR_={K;*{9kZI);Crq4HMg&NxVaJ4D>9l|5sp<gP!Fdz#`)tFY@2OA`IIb
zu=;OcQQE}dH@Nz4iGPEPEDRj~02!It-g^H68Gldy8}9s#GQzx><R8xE-<$uf`0obz
z7mxH`C?nI`UjA1)xU-VCw3Z4g->rAU61JA47B8o{nj4F1>L&|o4HHmNv0P62FQ9ne
zBdMhBYBvIkduYb_3pHTM?5$c$Qc^kcH0F>31AU#yB+&&>KBwd;aeat?HZqm;yjX42
zx<))3^WMv>TEG9{czT4$hXF#`4#(ZyQ>jmvkB%jv@F2Z+C1-Yh2IM9tMzNH&K<Gd7
z!#_Bp3(mw|Ozo9lbUozqWg_cy)00y1o+~&c<6U(`YYW#Bn&eQpWP<B!m);B7^X<*e
z^{=AsT`cr<9E2ZR;lHkz_o!OstPz06O-MdOC_2J!1jPe@A+eW|Y8gHtIsZ)VOl|7;
z_2^H2cKK2;Zo~|<*7Ea5?~YgB?VuZX?3^ECM2$w1BZHiR070-NeE;@^0Q~ArHFM(}
za$2*)M@R4gLnh%M-t+BB)XE;r??cOjXHc%dVN;cZxN!ms#A-~3=<=J&$~k^qn3$U2
zJAkeF87V}MB~a^g!YAp3{Fo&PP%M(7sgat`p?CV7ApZ5}*3g|$ASB~Y+J?zcIQr;6
z)xT|+N?V~|5E7s%AeWm?S#}$;Vn=-asMRE?8QF7S2g@a)fR?FOH0A^ro)F8mZtFTl
zaJA0$bh@aQ$>rrw?e;WC#UY?6!4{fj{kVjIubXGz+W5j*h6Mh>=F6-bx}7DBM}FLQ
z1p_m~L@kLl_agRZw&y1@?;EnL*)De-3N)&27zF9YmLIYqJvn=haH8Q>@z!z1Kd9P9
zS8bwKwyBIzLrEw}yb&&i<5xrk({F;xn3R5b2|(*8S)h8I?7WOD|C}|_1H<+>Oczi0
ztXQhEb<G(pQLyhykj=2d>X0td<w2)+zf9m=FNj@OJd`0dRWka9&>C|x+~DrY%w;Uc
zpsR{N6`Kjayz56f&oE-yI6@20j@PXPSFXmnz!qe@vqiGl@qqNay+jyScSk;w6xVi_
z*HfyB!#DL5xF|JDyh672!hDG$J1JW=wVWKa7&p<Adw9ruyo`BM4(@5%O{HliKv*=y
zkW^qwR3mrUGi-G}zDC1rYU4Gvc#_Xx&w0PH{CzDJWdy3}*{kf+?LPI0b0Gi1_7?{v
zKBZfMp<4Uscy4TB_g*vMoX|*4fi?BsYTtociy8`h&Qqf-sO>;AG1;V7yPEx3xFB?F
zYMYO@w<}2M+?~z7hPFs*ZVcD_ednZ_B*SLBC8wA^z_DShRgOp(GQ&dZ9V+R4*n14M
zBU@i|G|R>gsHPo0J5r^Os3v=E40P+aP#p~;#nBB@*B=!BP_A~0uB$QiOwiWR$jHx&
zz<UwuRSL*xH3?LA;)LyV*Odu259DUOA}z_YjZyG;2_c;ry>LoJoh{#K>X)M{dL;*0
z{?eNS#_2aI>U)$2>}hf*UwzeCnl*6~k~Z}V5n#nS`X7Ap-^7?V=lGlc{_ci;6U6`a
zNB`deUQ$t1N=1cQ*}~ey@r|YOn|AUSRpk$tLq-|qw-@|}Q)m2(R{oEG|F0ju{O5rG
z#>n{-@Zab@?*X5koddx1_WwP&v%LlO_u&5CXJ%&pef(bn{XZEye+T-%C^P?ip#Ns`
znf^oInNJu`VF;Aal@duHYC%|kE+5qis9%S0Qdmud<HiY>%Z&1&0m8ZmL{-S~5;xld
z*y!4Gz9s@QW*N`q>;QFP*5qJVJHT4GSs|^Y#*s*<S?6cBkx@u!spJO}f-mDeboHG3
zC3_+4o>yrdHD;RLcq_~nbQ9iJ!>lo=&N69`UZ(|)RX>Ik3iey4+1U)<0{z~dHZBUQ
zAW>IkKH0arBh<%<EDdGFh4}+z*v5x-1$X%CzHb^k&S<2&E^6VW6n-%YICvLGP{3nf
zZ~$PA81}G%`KzQ?2vETB?uc)P<X0#kKnlYp0bq5Ko-a12YEkoRW%3wj(}IV5Xs84>
zAJ=_j)3v?KXAr@iLNot^Mg7ebVq|CdSAhHH51jsOQ2#K5--hvrJ@o%!M{j}fJ=(*t
zzK6uWXhZ-l8Wv`@cTNx+fPtC*otMM(-+4qdZ{z<a5^=m)(!YpAj0~(W|Bm->hV>Ty
z|0j`%>A%GI_Y~n@F`j|xZSH@@`2Wr%V*Hz>_K)9qy+!o@#w228db{cWW{Mpi?q13&
zwRV|~HfN7<r?RcHO<X@R1Dyl`o<%|qbxt6G{7~W0A0(C(mWg551DgGS&FlufO~Ho1
zaR<eUmeWKcqhKe#;6!cHQe6#VMecv$&E|iYZ^2XOI(uHbeg5_Eb55glLRF=x^t9zb
z%lnt$R1cXxz3EHsS|Z?;(N$lS-q$*tPG`{?QvO7v-r=Iw>4z#r&POe;`BsqwkDo_C
zg-1yrk9A@y`@qMklk|mJWn=IIq>_H=q*t2J_He(JqFsrdrw-MesxNq+3_qRIE_jc5
zCeujIMq3WGTkakP5xdPm=g{0+@btBox!iY@L;`&#=J;@25ajz7z7ZsI^n(pkpaI;{
zECBt?Z51FnS<jQBmcq2E`BY2yR>*;E#EV{>Bi|CPuB$B<ot9SM`@Gl#4v@!^r#=SU
zr~50eu1^bzpTncC^0FIs5oebvA3%&h56f;|VSA!264t7rj9OhlJ)(FLD$ojgLwI5j
z>c`Qa^r8;s`^i{+a54NIa$q7YXc+^48a*JHPx5nf+97M0K*b@D7+Ir*G`dc}1LTsw
zKbRaDp((<hdwPmqvA9?g;|2pY(M!I{B)U&SI)P^*%kRml>iIrTs#Cm{93c*G6pzY-
zq#-m*Jc1@M?z-Pc&LXsBEt2V4Uo$k+A9|Bl8g&awZmggM%5|i`Fwi-ra0+DxKN!wv
zW~9_SbS`*<@WPLsqLU~K3GHMHq(-h?0u^kU7Gi+0MnX9QX)@HQ%1!#IZdjN1enO)4
zWT#5*l<R&+VsmFC-ukS5+S<Cy#<Tq7f;G3I!Xd9(L4a*0G9nGrJ=ME=q81g!r^lt%
z`&fePt?F8aX^e&DI^caE@lJ)Y=pU07C-&(9i$$yBWDSDGIqI-Nf^iLk+Z(kDgF7--
z|0tvoOomlx?3N_dNU>SPJP&!`$=<6S$i?987b?Ke%PCF0^IcXs43S=8X9E^sSlY*o
z5zoKgw+HSe3s^h`g93)n&4DOFaUQc&kotx00oy`w*v&sUGSx$<1I$L`<RJclux@^L
zDBAZO2mTj?CW3%)v+*!HNe5%S#6-?!Y|iFHj)CJ;HIaD=9y2o}Jcq!V1&CWse5}xA
z0vtiYW`knm;(6radBNg&?BaRW;(6SnUBhDa%qR7I7AH6Op<+C$nn_v-H4An<3yM-^
zV>RqJ=54={5wJ8PX3#XdjWl7c#+3Z|P*$Y6QDH5Aw~Qoy9Ma*)Y3K_z!;WC|0C7Qe
zL?d35E0C5S{8yo1N7b}(CJt>FlHhA}TnZi#VvgjJM+}Z6Pa=kKPYlyP2aZRCSE}ee
ziKbl?xn-jY%!oozwhU|5_z^b0G;Mu^F5V!H1uh2M8sN(*<M!!3BBOcQ3+yn|!l4^o
z5zy;J-V;On5`HC+y&Gfjq}Yr$ylD%3b;#HPrr1j-#JTGq8sRjL7t<ZXkk1yV6h%Fa
zEbmFJ>h;<kj-aOBJ5ejV6;2|PwB1mm1L<1jCHU&F7H2-TNo^~v$t!~@d7wL9maAMT
zhFoCMoDvr3%RHeA<Kuo4C+tM0Dw1&xK{6p-H=KIj1gIcY@IhvB{%Vb9IvUuF!6fq4
zkj2yvQ=)Tl*5ec^c22l9)JzI?VAB4a@Rj6(`Sjp(BMBk&g$@Y<9_l)hT$t@xen@{4
zl?~eZIr+$V;9YWYMy9Z4dB>7VL>1bLaDM;u7OYq^JIdBofkXyBIj;^jS~gV$a&~uR
zZlK#o59x2AxA7+8?OYQ1eQKeI4{~8$)N*l;B=L7ZHYd8q&o`G$=F)K>93*QSRmg0Y
zry>3D1@ZmP8J985r8IKdQLuzd778oE_MNY)HAVG88E8C%K?s@beU=xD+EHn^sAe1Z
zMfqmw%JyALno-2${m|1SyWzM5Jd}e^;D*Fe7;(6ULRul}(W^0%wrIp?YN2`0M*V`v
znd;=hv3Onz_r>|{UZl|WqPzAUSjEFQDUITJDraRk#iwfDl;=xFm5r41lv_$;MvH38
zDlF^17cZ1GST<;upwB78TY54&Yf|m_3|BH=NmJTU44W|Rnt(z1BeMjBR$tkBz+xY1
zZAeIev@xovch(eYXIxEFF5ui!*<5HY^>*0<BIG+Gs<`O6pW>Xvcs11oNYpEt4WRi$
zAU8D%9$iCVAP*g=&V?Pk{T^hC$Hrx-A~I8KN>jw9^V_$pv~=5}Ln8JkY`gLb$9auU
zG_gMmUm>oCBY9*t34AIE!rFIW%!bY^GZ(O4y<ODW12Ghrbt*2}Ejl?e#r9P_q{<JV
ze)QH=P7srbHw|*SaY3^>6E0(>MttluC0Q9|l4XtlxNThQcx7BGnhIAjj7}nS<%bnF
zJtnYYyyU|{E<{;$K((`(<6+GH>xVqytV;1&(g9dpmTJJE`Yb;S2<|t}H1W&)xZ8T}
zk}MQ>;XHB0u$(f-ZfubN|6&!<=x5*)xxAIxeHSdedtjX`QP-mBA75T5VPBgpVR2r%
z%))3g7x*<-xFF}Irsls`ZM5{Y*Qzd%j1h0!xDb%q+@SCG>eyT75LUu6^Xp_%TU8Pc
zRM_`9Roaxep@pgYmXyy8C5o5!_Wxoybk#ZIr2<+ej{Z7i+6Pry+*zEJcRqIx9kFDE
zEznXK{a}B}LrlTMs%2-RW@Ul$a$yDk^3YpT*x6Yo=F@$}TVADs64jDKL<VmXW`_w_
zK;8cFP#J9J_H90emf`S_#lWghfg^QmFNMti%ShiT5F7uYkhB@SHzPNLvw%G*Sa6ki
zrYS4;DtGTs%4gUfwSGuP1BfRS$s9!8K}G6gVrR?-ADOur*z|6R!aNN-eq>nzE-zsJ
zIh1q!C&+}N7hrS`D6;N6V-V4WJVKZz{cNCMbfn_ok#mM9rYLj!aus2oi~xyhEFaLx
zzVsOXI}@wYEg3kXD}y4UP-437g{BcJ2c5%%x%3i8J6ozC1v{j65$=3B^T7*M(1~&m
zD3#_xlXI=D-j0QCTy>Zu14M2y2gO$q&{YtE+3K&LgZ!|AXM12o?J?hzJ*a+RQ1qjT
z=AwJ*LErZF#gKfSo5WUH$;Ds!+3S4{#Vt_3qw~{*OEH`f%qSNpsgDpdP;CR%@cW4U
zcQLl9uB|L8eeP3pgmS<14K+LRn;)RQe(box+w|gKiUL#;5vx52I_(C{2-{E6tB$Cq
z#01$vh?`nl0QdZugjn<)T{e!1;6PrH(66lEC2b5&Oq;`F`lJrWs!I@Uo0NADj}b&i
zN@Yq~CYwQa<T~PYF!v6iyh939XDD1F-6}7^?E+O8U_J5Qfp`-{nJVkyO?!~xa8>i9
zZ37`UN!`$R0|>tgu4hRd4x{Zbw`K4QyVPNz*-~|4`Y<_LAFeAB6uv}JBNBy}@{><A
zVBNQ&xoq%8_spKdU7A2SZ)#=C2W_Lqjg2_(;9qiG61hiuiS;>QK}^!kBC1oiWqN-+
zMx%x53#)kZf7!S`EG$U30`ya8-Jwi#8!%>Dl^A_2!z1jM2hr!a8GgRqMdvINIiwyt
z>KwdC+9zN$qNjtYS>)NX_Vt-AThi3~custvNdqwIbZy~0fCQMhYFRg}J7M;!rJSY8
zrLsf3Q>;!5cPlBhB27i1I|x?vU(U#u!UWo|i@6`q{MzhqgeZpCHm!H2u<mdwHyqi+
zk?*1??9tG@j!7gf6*|4}>PA3n16GA?$R9_LE~)Ngo+2{}U`q2j>H|bAXex?$oM<`_
zv)5<L_V>mIFV#~j3|5vEZkRn~=%LxD8RZ{H!=S@-2Qo)J6FrsPOD{^@_XqUa)$J~x
zH@od-&$l+)f?s1`3J;YW6+22El@JRNwl&;Ye-+Jnme3hz>KAjEuEs;k8DPrs(@1ur
zac($xC2dnK`^9x(JzQu%A)gA+p7nWmen~rLY=`g-p}WYu<r4gow*LjqnFuj^x)xt;
zq%F~|NG&EYKf0Va-M&j}#Cj)rXVEzM>6lc)Ap`E~&N|sy-0TiB>74Wlb9&TQqjQV=
zZ%&jta<*SxXCM!NA5guqS+;o|2%jT-ddADs29{J^=se-{X!Xo|4G8LdYpVjay^>(7
zV2aRKMam2-wgd(Y24=%-6BTx?Ocd`!B}+yX!BtL5#Z;=w6c4%Yf_Jufd1G1_K$c|g
zkZ;i>6u~v<R--1Ljf+0S5hm?>q)5K-duot{D<X!+O^&E~(9Fk8)^wu$Viflrc`jZo
z%L$dvVe9E2rVKPA5<Tlt(91yyB&$_1-$I#T2vZV-I3i=?_xl*)unC@0(Ja-BC+LLl
z9o<fpz(6yxYa$1IOU-NGSUvPsM)Y*+e#M@vu-#|A;d%h}2Db&Qb<aY`3o^T9-Nb$>
z=3k6|JSZBznA|r`q8>NRuH%Dgu}k?TM3V*LUNR~1;nXmEv+CH=gKNyB#Vc~BYD!G$
z+TbvUYs7=w4!^!JL?Y#*|7&24F=8jsF(KVoawr8DA9bNDHO50ScwzrET;p9QmStMz
zxUT7M{lX!!bSMXP6w4#^e!SAUqHP@f7&Tx=Bv|K;Gcp9hY9V|?_H(%!$FlYEueq(U
zEe7dR@Q5*F5j1ChpnY<+dmAV>$QpewnGuB?y_x2DAj6L&o#(y+B#e=G08i9xYMmX9
zJFJXAwPokxrs%$K3{6_NZW*WBAU;^weTCYTAOq48ekMf_sg$g7pxg7XIY%cDEU7MB
zT{f?c-Y!M>;~LmO*p70blaZ5iAkAb6%yr!;@@I5z(jQY{Nu<zC`B?*3)!5cr7#{ha
z5*!|R_U6$GdAshQ6&)}%mty8cQSsFJUv7G=c&U#?w7yrmVY<Lc4G&zLBP>Ha8nkbq
zL@<BUhFDPuNGA+=PV}a9l7wd}lyYv^w){FDTRM7KI}=x96efm&77Q!8ySE!0;E&rS
zcWvsqs*y@tMBHanr#ViRCr~wOIY(6>sGq=Z@NsH&JACh^KWMf4?n0y;e}5o&jezC4
z-+O89Nhz&4`u0d<PL6^!U;EluUeZGH0GX8G(K4s7cnSmdZi_q}q?06-r2%EEi3PmX
z>w>Ull`PqH*aS4`+2?p8yd{bGek*?nBb=>DXNKU&f{Ka+l+)TM$3C~Q_ya^e=f}fp
zR96U9gb!vkv9NPkW%%7(aG*8}S!m{A15BVxXdwo<>SqCNk8>01@hfL%R8$f1gZKXK
z_8Xh(>SX?+?rF`n43%+37c`OEHu~wdId;{)o-=S)9=#9X{@@*soZICXLth4H3^JN1
zPqlpqe+i*M4yD+QMc3FYL>r_<quk!wUJSU(oIEM$HDyOn%?BCj>tS1-9@q|+H09-g
zDZ|7VN}g<rTbt|Uk7&Bq-VFZ)0`LFE<-X40u6@{^s+q_h9*v92mlaYSU*zjx+K66k
z0oCb{$pYrOb}e7Yro3nL4Wp#OrPrES#idUZh4JW%hJ}rtwaCzp8*wjb*hc1p)>F_I
z)D~n(JL^kyg0Lf2!Tnes@N%y*?EK`6bd09wXQ+<7$b561URLuXqMXEDWEl7SmoGfU
zP4|=;pY;Krg+lPS9;leZZgak#{mi2`2R_0OEKIX*F}6ZX^PpynuC8)3s{|iZIrAgE
z(2am6xyw;0t!UQcvv%o99P)Udq}S}+gwqemt5xWjFb2ya9$cn79x@|{A*%;`#}ZFD
zp!r)MUyR_0X3pE0?2+T@fh6Uj&~0CSI_Yh#B5=*3iNouG2TxJu2ImJkOABr@ic5HV
z;)3Rin)nt<HS3QGZ1FY4p^m0HL_Ly4ytIMma+IGg1M(#!ODUQ@=sB*gGV#K<)%&~-
z3*7rUOBQx+bnG05*buLLQ40}6Pt$ebeu#gNODZ}utC*dhm|8ffdw6W%>tV?QKRUBT
zxJ!HVeDI7fk+}ll{Xd1Ac{o&W8^@zk4XK2zMV4%%S<Q^KvNa+!BD*n6*0GGWELoy#
z*&~FMH6i;_60(gcOLodONZH1cBJa`f{r%pzdavs}*ZJps&wZZfzMtzk*Llu$KIco$
z*f}UijoK)R$ozu6gh-aH>Ew4B8@p|6cp+ccNgTnlueC34FWaE3qyEgXy2>TTw6Ww@
z=dwz2GVKNKR8fT#_h3m+>Jm_{Y^RDc3e{D$b;>mt6;Crb#Fhk(2=vcP^4}gw6n!nj
zNRLB|5)<c`T&M2}`+y&$vv+gNeLuF(0hco@^CXY1p8Ng|luXfGRhnJje9)srlHkel
zjDi^TF<K$}LDs=u*E}Th+As6tD8WU+_i$%y_Nn1lB!n!kSDxRuoX+?WR{flD_Wa%D
zQyFLaEgU-Q^$*UzV84bF65S4eZQL4s!th=O2dgBweMV1PAdu~I&XU-k?|B)Hw_*uR
z!M=KK?u_ggVv|@Q@AAFI1p+k7uPh5sh(o%APf!)vn0$JEWYa7=t?1PcD#DREq1N>M
z`v@&x!G4zxGAti-ZfIdTdl7^_qKH3g-df$S6y;PT{dJfjtDjx4tv7{@_VVevR1GZr
zoW7nR!AZA#;Ea`~TiJET_HM3aiTUETD{4Lmnc`D##tw?+>lr4qJU@g?D%G;ft<?$g
zZ?cSJ_opR(%8j+g#U0jdic(Qa5FECt%!_A)PD@^u=pt4Qi`2fP5=*l*k|XSli7!V-
zNJ26>V4Sggu=_aEvb5j`|Fc6W2V8EtBaI`nuxN*^<jv&b=1&n-ujEyZuK71SD<MQb
zySXM2{J6WQT{k}o*0|t?zWSp*HcZ1<)!R_oWq#H)#E=~Hp+=!$|4=yDo%!tBZK~mu
zR_5D7D6_Afd{CRWk1}<Ji4_^XdbxYNJz46-x4FGhVRcnXJ(ty7`nJ2-5A|3omsE%J
z<=U|zX*@S=)vB{3devGAj1CuOi_`9|(;^OKHam;F;E{P}57Q5+>{6dQzhpIZXYWV|
zB|<YaLy#vQZo|ijJ2a?COyyd&4p&3MsPpaA^^id6oY8FkJbLrimagClvx&Q`Iiu&r
z7A_Ui_!5$_u?{g-6fWQ=pAZFhmUgXy(Kf>cSIpg{bgTLV*IRfl4b`Il@zz#ICc8;R
zpigb5cuklo&V*vEf2z^m?~p@YgR;J9+MNk(cYcscT-QXSL3BW4bChfg`vJ1>AQu*A
zL9R)aF$j>s(wY3g;YFf+RD^%e7aoAI0;RllCkUrbzrKQkftuT=?M`}6bw`V=1jSb#
z6mv4T7Qon|c3)}}Y$vtE`OG$E$M8t^1L&g?S^hzLe~LHdM-`4?)I_yrIdmpBWuR4r
zzxwfM;a3MgMVJ)jKFt-bt`5-1Hah1dx;Q%n2Kmk8&-I$57MfQGC)F%{$z5wa(OF_U
zgvY{>^5UVvAfB9AjyP!w{>bfYbI)-U|7Pat-Y2%a17Y+H=6<sQ9c~HkmJ5QS`fDZr
zQR~6)TzwM0=@>RFCfqT9ZcLBdPb+@XI%=72ojk2Lg`Vn-a1icyESp#L5r4DvK56cu
zg%wj)inxMC&YOp6nU6H?H7YCc<j$+bEqyM1yOPxnCKr6Qbg|7dZtwTBDnQMkN2m@5
zwqeFdxoCXT!;|T61|W@K<*i572(GF=i#rY*ULz-i4y4rGsO)+rpDSrs4w_jKotutT
ztM3%(c8pH;jR&7Epn<Zmc5>up3U?iAymdJ9NBU$sG7y$9-O8(@+<h9<p^lbfzMWB;
z08<#cRZh)PbzHO2U6wZr=M2E&&X{+&i%$uqqFgJm`<32Z>(H5ylkh`}Sxtj)7!{_x
z%U{*)n1J3cS9|UeQRz(G|3XYEy(m`-7knXY`$S8ZYCol|jnWfx;YQ9*JN;7E^PI~W
zre;yD#jn(_F!@!t8%#;6bF1-ouvllSw`Lh3A5eN?FFV;MWv;o1^^;d+B>LxAf~b$D
zLvdN<_K2^F=i}MSh-oV>vYhoa>4_7U9s2#!Ja|8HYhII*ouZ$IH{Uz(bxaByB6}EW
z8-~=jquTB3)ctnMCNF+Zu`n(uR$8)_MM|;5mbsMgOoBy_L|=nx1EwsF7CuvBa5z&k
zm-qDwH=TRmR{Ue`A};>1mD1~bByBhw@qT-BHn6tX;^*<39oRjcR<CFVQc64Tdy6hE
zyaoCB{fNl;;I&XXx9Q8MJC$~1Yhrx7Q*gY{y>jxf@NL~ZxSRBt=cgt9g|)pm3Pmh0
zX1|PS?@TnJm0|W$YXUi!d0Yq$3g14=dty8=8ytLW^>m&z{Wu|9$Jl6qs5W5*t^LLM
zXxXV)L|?o?bjt7yYHkf*-x8H`&U|L$X8dBHRoLgrlc){7v9(Pb7vUDx7U|HB7rTq&
zWAZxs3*@s_wrL(mmeC4XWdS0#{Ux7b=dbPDBN>!zj_8<rdf9|e+&p`sFQuN$k$(O=
zBG^QH;p7D}TfoKO(vaFHHXo=SldEe-hlImO09xbHJ2rIQNc{Tg0KTi%cj~Um5olEp
zlHoF`W!K6%FX@_6N9&86N*zjPzG-nY!L(eaDK3-56@-Zg6h_T1O}_AAeS9ZXha)U{
zgTSE9+Ez5Bd;5fU4TtxG!{(Q?1PtZf)umJ>g)@546xmY6#~ob;$|89lQRI8{-n+-~
z^5YM`J&1^$FdIlK(Uu2=&f;m7MrqxT<(^E-PL|cQm&LZ3<s_`G%VKMlYcKKkgN&$j
zPMWxL?e|m`fzM^x+d)0H?&&Kg>1mNW@&UeTvm8UCqG|6_77?YRLmrY1r$a9nY#i{@
zW=%0S<RJ0#jMq}!5ezdwj31K0e2k<f>yV-g)-1;dY1xAj*D;+ofjM$#Pi$&dvYw(;
z*c8&BU3JyuPeweVwRgH=#_!Iy>NO|KEE-4K7W2?+3O9OBRKy3%4*15wOx5H%B2Qoc
zl2^pxPn63{ON~BR+V`d}1wyNLa5LzPpq282a4iS;*#l`7BnV1xE<g7v--ii1Rv80i
zi_sfTqMP=@L)XY3Ll3|)V6FPuDx7c5_QI?$Qcm{d6{URtrXMz4S;$a$eZgkM;3<0&
zlR`kEg@?X?c0p0E-f<h&hir^f$*<-ac)Y}fBnuv8446^eYcn#g;Y|6X`iAVikvz@3
zO*H2YmG3HMj<(6@&EEL=;Y;^29iHmEJ;!5xwSo{l04y~l_3i0<-5JD-g^DGQ9uZ@#
zrMvCN(ZiYTvW^>5_^~n!TFs=)TP&P)X6Kk=pPuX1TjYFX1<`m^N3$6lg*~xY$vJ);
zoQz{m)x92GYLV~Ja7+d-ya4JTZjDsKfj`BrLQLy!Epz!#d1-Qz(2gJHGni6BDa!X%
zI!!A+*LjzT-drvFF8a*L86r>o+VTRWM5?R0-Lp)tv_pPk@MH)%T_!eJm)NROi|LNl
z^i71Qn{c^^XeJJo9T#BXC##ApJ(1wp=n|Sf6(w;}fBFtv8|z-}f|$H_?JoWS91+Yt
z)~jCxKMlJnuRgyT^Ucn)i+1t4udc0kxTk9N`9j<QI<hZyps{mOl=#fmQp~<st6FG+
z+jBXoEdx|uWDY^Pj}TZB?b=u>$W@co1FwhLnh7(C&X4fAkOGm@V4g9V&L=YY&kI(Q
zqj;Y=N`cJPNXd2v-0?$mPKArUcgOTe26HzTWszHgFI-432W`(KsHR0erWX744({=h
zjI0bP#P6ugt9;0Q_wt>ts{E?P#pA8Ta4?it@Z&zX8r3YW>tY0voFw+8$w5$KTf8yH
zP>rK&&Fk)z$e3MQ8#s_-%|4DCO1=+YkPjb^jzf2G@gaC+KHXKsCZ37!Pl*#2#Q1*M
zSMMAR_0k%My5AKv#Zl*=ACu((GJ8*BHEH;8UdM`Sq?+o}V;Yn>CL!O<HSS(Sqn<kQ
z@<!7r`9nHqt;lQNqxUqdfR}N{1B90^SgVGDf)`GL)AiR^O~dwth0&&IE-ne7Pc=Q(
zMo!;PT)HVIVst2$!-^ranLsx(dF;sW{e4){lf0+h#*p;~hbp~fLHcpNlO3i+!2zU?
zhZk+#zu=?->ciDOKCWS|+RcwDTd$O_q-V=sJ63yarFCd;Rm7cpWZP7Qtco5NLz?MV
z3DG1s(HCzJXS5F<(|oBz;xJ>ZJc!#W8NonWl#qxsPIzbhY*^izx13M?+tSUrJb3Ko
z<FA)qHI8q%0}rBz5n&fTO53J{UVMt?i~3WZRI)8*LD3+y;|jM=pop9{#d1@+E)v03
z{}y$mkc$a*u_W$ubHD1=eX!-Sa#ViTrgP%-+-E-0BpLLyFN7QOoxXA|xp2+4w5%zq
zzDIk@h@iq7V_yAv<><PvN7&9|h?mZFu~Kt632fMbH!dzA)$_bO&(&%+=bkp2M|vNu
zzm=W!b}uFtnZ@$jbj45|6fw&_KyX9z$I1zb8AyLvJp`;@4)cA1L;MxGKP>jldi#^M
zr@2%rzT14|zkC)9j?sD{HCndFALC;oEQ?n?p?%TP&$+DQb60_}M%bItQp=tYwysYu
z)|blW5}t_%EFnB5o6U?#ZS?6uePi^nDKf9ba;UGonKSbC8)lKM%k6IyIgam$FS|7~
zMbY}W;jeq{OB+`aS6<u8>PyX=jwu%A;+wBBi>|JjmAm;3y9sZfP20Jg{6Cn0zbR4_
z8u1VE2m2fO6LZ89v~dFZ)~;k*Clc`8UK)y!mJu)!yWno?09d)8)!`5r#6(;`*B$Tb
zc0&MgK>TT@=;bE<H(&tY#YA_B6)_cA7!VABK`~G?5`u&pK_F*<{h!EPuJdoS1#nfg
zawh=xsy|b?0uX<ItEwB2gUYVA;m<Y!QOn8dzmNapiQ?sIO$0#%;84)61IS;SfD94|
zM+y)H{?cI3T|VXKDFM>IH3$SF15h`++kZ4TMg}P1R}H8FAO(NZFaX!`n+Amd9L#ST
z9J7no{B|vH_?rfWU=V-i_dnub7#RSb`L#U+1oKB7P@v%7<KP&`A8`l>fbRa@9t{0^
zeh>t57o7N|Um)jQaN<`Diu_|-pin3P{r(a6$GAYDD9j&y!2TR(C>)9WqhB}_4a}%t
zbAcn_f5xGAtz>?QgF#Wq-|Gc5)bH&9a|mEd{<+r86%TmTxc>AC#@XHg<|zQOTyb&&
z%!>YvPGLzzC&0PrCt8A40lbUk(F7|r1dqX^kk$wcMh1n!5G{!q0s)1GK`bqaL`Bg5
b5BUq3Cc6Q*;LnK<++i{Zkcfz?wi@VPnPph@
literal 0
HcmV?d00001
diff --git a/docs/tex/figures/rmatrix_inc_channel.pdf b/docs/tex/figures/rmatrix_inc_channel.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..9279f8b6e3a1d294487891bba7485c7c7c6da76f
GIT binary patch
literal 15335
zcmajG1za4-_P>q0yE8Zh9o&Pv26uON5AJTkA-GGBU;%==1q%?|3GSNwhwSFw-Mzo}
z-TA<D_vz}cs_t{9zo+XdDkU)qMj#U#0#)D6#m@KA%lA`#0|@K@7J!4XH3C0BfLYGW
z-on)qzyUJ70WeEg*}9rJgO;{Nu4ZCpCJv@%06{?n7guL9BRd37@M=|Ahh-L|&PNT$
z1Ctw)Dk<dxU%fh62XW-1x+Bvn+9*?@wB8>-%EFhazf*~t0Ol<spYHC;BwGR{9dB4@
z-tTYRD&E0#ty_1{q~8kdEKa(UpPuAS*o}^Kf7Enn_i3@|)aSch%pZM?gDX`z*R^)S
z=C-%)xkt+xPOu&i?Ve*Yxcy17iV9_!AXUs+B03E)EIDt#x@bfis5AhUjrSEepW<M1
zRC@Qonjz3e8`{E%$s34H)!i6eX=NPk+!lN~)un?Bn99pBNV(lPd<Fx5knh45^d)M8
zdbW1Ew+bL-(d%6p-aMxo3}1@6wkr_^`Zs@9nYl3;<`bu!V8p^wejgP%T7tlfiW~yW
z%f_V*k{hq0nDlD6uQCiXl$<@HkNa>}<&MlCNXX#3VyrI86X6o(Gh`Q8jKpz2qr%L{
zi9V?6Qd*Xt%YtvhZdyC7J(qyU_!u>(+WUn=mTr-&8GG!rzB1gBKGLEU2V_kIPARqy
zHli7u?FKPSJC-4Szb=H#4Q|W`^@Z4RSA_-v@T*uz$QJn`!w2zt3rJI=P9-xB2>P#m
z9U~*^ZdrsF7L9s2DH6+hs4N1r;P0vLe~!$Bw2YbSEOn%m=46l7iq1!?;SYtj#%f!P
z6_hClFQVsj`7MJLhg9fGPDQvkv{*J9zA-H|UF)+)Z<4SRF7U%d7|1w<nzOelQ21Cv
z>+URO{_)||&=hHo!sudn+k^yquHjW#Gul_E%<9wCqEiYZSNDwu4nd+h<C)jZ>&3gy
z9IFM7WQI}@^T;%VD{DxT-?;q28SUN#BAD5m{^@C;wHF6{@yeGaCkxlh&X-lzzxb}I
zm!lbgS;@%a*SE8oy(@t24?lim=HlSyY+~jD;QYfN>R|5*+V28*@qLh^%bS^68HqS}
z0(4kF23A&X0FaYS4*}%sf7bJI-0v7sa&|CLF>?jzfGQJ{05GeXdAb7h0L-EewhqoJ
zjz%VCfR|7bbpZmnew|)W5EMe78h@EpRapT%FJ=U0RaJHX5cs>ue=7t2wO4;eB=FC!
zD1iFJEc_Cd_Mn&qFpHVFTbY=>kres&Xw7-&p{lZo6F%9&)iH%Z4xqXs@P-F`;giCK
zQjU}kP=W{xp>`L8mcT-%Q#V!p3@#Z?ZX%9_7#w800Dpm|G|;UqCcd*0V*`I$&2hP!
z`8=q#wz${4uxN4Wx6lTr^b`cu<EjZBz@D#(b@IJi7Xx#&?-l|N4ID)i{PTvnIh5p`
z7{u&Thd@R~nbbhT%?VS0Y5OummlCzh{7?TxaxPIy7%&9!IZpn!)VMnkDJl*9_^dyn
zMy^unSi^v<IQj4eRpeWJwYE2<yY%hD>1ov4`2<=M_@CHwW7?HgGpRNTW1#YN)2Y@i
z3VmVCI#i`I!FFzGXJ+oQ<-l05G7QG{sPk<jS;evNPa-cMz~EB)cs@C!MBnpR=7M>a
zSZqf@MM@i&pf99b?d%VkKb$wH+#3VwQ+nk$B0S|LuNsl!Sa1Vs9o~t9Q)$^{SSB7<
z6CEFG&F@;?cP*}wyj6J?81jBpJEuOH%oUEw)mpPXs$%ZI0lT5p&LVE;OjQGGw1W}a
z*{D)H1%O>ZgEg*ZUy_8`>L>MWBGDj5A064cfalpT(eHCT<^?&7bcONUW{jRZs`HiL
zz7C|2#%41U-zh0Akrf*oLqbWLG=08B`?>X*$7+1ImmxdvGwyllzMArW3VcYUWqT-p
zpk@M-DME<<+=f3MCk-tA+Z-D#OE&{Bzfc~f7HQZa2LUiq3P?)(*WM6*-*wP{2t%Ep
zEUOc1UE*22f9ySwBI-ujZ^#LgtL)w&#hW@)6)@lzu7%ikLtrGpy1qwX4`gD2U@$}`
z3Se`DTm^uI1W2JlzJp|vg0K>Tsuvdg3WgvI{0i<KZ0!g(8|Xa+r4YpF2%`(7@fq0>
z5h*}Y2qCOnmIZt@&<ZZ-3=O+LxFP|k2sJ}w9*s~N&P!BSi5m;DUo<iSElKEpin<K%
zRd7YVsFJ`Hg)2cDoL=z5d)O%eJIph<UkG|S#EcR0SFn!(i*<ZNaFRWv>tdeR*|4~u
zmp5cua0F4BdvG@h&%hW$4SJH{gofZCrzJGu2+zet5;Q5n(aCHQ$%`P$#WNF7iU?a{
zr4pUCAz{MvjneUO2JpASwPH4m)s5zjWmx9YP14onaCbS)(bxj-gNlvkK9p$ERK0eG
z=S0tnW$aToj5pM&OZx!%)#!+i2xagy{w9&*+ZH@sR(p;bsAklKnD&70y~rEX=boQl
ztzw-9p?15R8T*oTBKQ;eldQ#)4s_8Zz-vR<1fi0>15nyhs-h9V?ZG{Vp!cvV2bL+i
zl82#r_30YZeTe%i{7IUKS|J%rI*bzc4JBPhW1y<EHMt(O0Cfjh@-VNdq%)qDkiKFK
zWgftQ3N`7qQVK0KmZA)ixX7Xck4&qOmynle@f+ka`&rG3^tK#r#SSq)89!#pWVW=+
zw5{Rl<jO>w)bD9NREjAJX&z|?OnEd0Wd1TgN}gIEl)HtxRRRm^)bk}a8hZpnrNuJ~
zQjH^wGmRsSgEu+)m8m`@1tv9PD3%Ky)P12UCL<7;Dfar((kS1^yJWV+LM+Ku^f;4z
z(0@g`-*E+RMrEe6L%Tz?L$K2@@&=}d#qf^p4SsP<a!h+n{3ZKt>*UttGH0!o{?AWz
zsrRq!U-_nzr<$jNr^Z*vsX5GH&E-_sRVdD~SW{aYSua{Y&M{TSPL@u3<WA-ou>ahC
z3O}rCi}Y@Ju)gj+6gW&K$Ry|_z$Z{6NMj%1z|XYL9M0Uy++!bXwA4myg3{j6-fPll
zNzFJJQ#Ge*h~~+!t~oAcoE9uvsT8O-DQnQQC{$>ez|>1((%}+r)@@et5K)w6)?_xQ
zRX)uZRL-l;E9#Q$((xbpJOx-Xj26!7F3XR~?=s3YD%>!ks7S1wepRSl$Tz@k^3f^k
zTyRT=x-K$DI!QWqSYGAp?5e6^+hpS;lFhCqHG3sT`(Q!cH!ZCyiTU?Dz5GMIg<e_r
z^oRn{n$bBpD>w!W#|$cr-x)}?=(M0U?HUj39(tGhGHvus{076Uw@ex)N>+B8s>>PI
z+`Eqb_%ikCR&d%C+9z*NZpa_0AAzs};hy0gD7Rl--D%rH{N~WV?{BnBoX2dz()iGP
zn2|1B%h8&kn?Rl@L`1?p!<}WsbDnnEXd!Y=WHM!nG4OQEpH*8<-O~R4FebkcyXW3#
z*SGRjVDY)-ksehRHBmBpFr_qkk6;o}KO(JGBT=KaIqBB;)cUkkkXJBLFjf$=)4j9O
zkNM8%8RFUfVdZk+Z0}*=Q4xw8stSG|p$JL>N*z`Zkrf^T+6}6=8@#(ch?Mz@0j2IN
z4ur^)sCy_sJO`2<_Ja!^69an{^^sSLn&(?j4=6@saWT=pcB%NGFGG^iu{g3g9umWn
z{o-?y^5Q<?Y2vbJnhaVE+Y&L_F@O>Q98yATA4+%U^4l*fvf*1tn+RJcOl-RE8jhBn
zn|8`aCu<T6y0x5Mkr0v+uc7^n#Ox{Gk*m2fX!Y2ET1ajWe@xmNpx=u<*Sj-&N`y)a
zsSlYJOY75%G?A{6#+KfKP!w)jcdIwJ2;44DNk}QAV=JF7AGZo=ylb2hp)!i9qt{~-
zpy^=lWiMnAZ5y$gJ5j?d5SmVuqjk|TZ%>c=A$KhmLzzVttcBQMUB7A}X_hylJchn|
zwVk<bKT14&IsEvR!<@sz&7#x&N7z$0$B7L}b?AJJ?sBVwhhBHv#&zfScsqcd)Z*Ew
z#AvJ;;hKHa>a6m6<+@Ho%ZAh40g+Y_<&6%;2^|#Mep_tY;}!FUYU|}Ra{cLR<I&Bi
zO+~72N#EDB{50-Y#%@B6JBn|LA3fIH;XJ;r9JF0(W*BSfFHY60>s9ZJT@+k2w`&}A
zsvGGz8KPRno5nY?meqI2)LKi<l^zxy1`@<)?sgpdG#}?I4K6Qqt=aj{fX71i!wQmM
z5q<I>x>d5N7Pjj*`nFNkJNdofu&v9&-@sq&Sn51+QZiJsc(5nlZH{ktfvb!wg|jC%
zY2d?_)1bri`n9MJX61nrTVd-R6gL^q`R3pq>1i$!|DsovU&R5<bKcFzDeWlj{P}P5
zkspgVt$gHs)(!$@a)>908DD4p^u3C?$;fONv5=iioWRb`;>q)Pdm%CqdLA8#8_uiY
zD%jSz{UxWSu4Z*KFs)Yqyw$mUx#RIkEv?d`hDVRjFUPOrIP5ugo}@kZox#yttAnOf
zyN(0LhUa%%)p4EBetQpkkIbt#ZGJm(KXV8nqhTISm^yua>VFeB@LPSJhAl_ce?8{S
z{cQPca<o-IgP`~-x8im6^W5End3ndx(fb9%$%Y7v_^=jH=AWtewTivaljW225{(jv
zlGT!vG50Ym-XE^|&qia?X0}4R=ze^>O`WdHd+YJoVPQPncV;vFJ>#{^YFQ`G!~Bii
zp6UMfjEB`}Nomw-W#{Xgz~}r&ldHkRgCoT|#nimm*B-v`PZyrlcILZlw;`90|0}_N
z$<SZIn-j?TTO7Zr+!q^25KD`SiWs?=nF4-k*f#*Z-(_Cp>u&-5U!m^u|0TU&)U+E&
zF#`e2vR0-pAg%qPi9zRk$v^+p<iNisu78|U)X3Gy*1_VBEWqVY`Tv(AUc~m_Tk%Vm
zGpo26yZ*`^RGr<-{y5c3H~!curmZL`r$n!6WoPE1VCM10!OqBDNrh3w!PZn7RGpQH
zyeh&keJ^I_V&ZJ&=<47M0REXlt2(IJTm8zLfq$kR5?0PGuA-Jk&Hy%$l9x03bAuh!
zQw=LqS4$VrW#r=G2C#B~5)sgnjhhF+4f=msa)Po2c6Rn(_P<?;zosX@6NW!>kAKbK
z^%BReds)yzPQ9Z9K8CNyX63=e<QGBt?xVUrg2gqW1Zm^cJD)9k6cy23v4lH#NRHJ+
z`CWeFCM@?vEwrb4<B$W-8oT#CG|stRfl-!KeUN@9lZ3YxA${2^ij}>Fw7ddK`5b%{
zt5?oL(VTz8uc8B*qPq=q#qW4o*J^Ure-yxkQQ1aKA&~2H@MOaUhrQTliS)oZf!Okc
zTF`<yM9h(aIq}NU^djfoRBLisRBH`NxOODlPwn>TjjskYqh@+kKnJ<%ih3xKF)A8g
zFp>QejG6$n%a5`xFd}1>M=M}th9s*HWV>!8Z=poa?2|lTL(b|ac>FPohYlK>RrX!r
zT0}bi1(meF@wWOUlKN@0e}{$GicI-God36@vvRZj#|eKYr7tPpAD;8#HGgr1U#_8G
zWcQM+{ktdqdf8&(g22iBN6sknD=TH>VCMobvaxUhfb1+l0FZ@^6_jxP;eEpP7Pe*p
zMo@WS7n7HymzxLVOD_$0*<fS^aw0H`8aYatSy@=R0ysHY0n93{W_IeJP+->l)5^}q
z13KK@;+F>k*g?U|EN|rb#}<$cRQIn=fL;fgu_6Gue?{V7qUy!)JF0$r->($+_xq%m
z7PGR0>if4BN*&%_zN+FM&&n&7eLTG7JuEs_4o)bG-~*3xP=?39z@tHsF;ELp8cCYP
z53y22AmBN|SbQ4<ClYtWBh4|l!J*=f+l+DQb^0c3w#r?IZUL1WPj#EqMy%X*`n-Dk
ze0?IHqoTGq>poGgvZr3^(_el08H_NXdx$5x{axTik*#D3mxWq0jWVY#<kV44mu>f^
z*rGntdnSFy(aifu=aFTw5=6v3w{iKDjaQprLNya<F}GoV_Vlk*V(z4bMz}a=@mfUW
zIzx<3^y^iI4}_zBIMVvk<f$L@dJk*!!i;_wd0Lt<pc9QCji0<0_Ujx=NF@edML0{h
zy7wKfYLDN07z7;J04uN_`wB?#(d-&<Zl3$<=!UUW+$K70vlf~@OvQ^aJ{y0dmio&j
zPSMDZI6H+ZcRb+BR-b~=kDhku`Ix!zWIm5S-gg()0(-FBGdm&h0rfL?o&BqQUJ*y*
z>Aa%+BR_`pBU2-klE?G|64NQ=+F8Vb<%W>ogLBevOuUJc0k<DIArqzYu_TFz^4B#_
z>Us*Z(PYP&eBWJ9t0X{@tMlW!l+dMEm^3wsW_-C2+ZED(yOBX4;Da+^QgEboL$pn;
zO*}-beCL)e;1OY~;jl1Ocmd=6inBs0YDNY2OEdx_hZVO7O^I1LUOM{8pcq-ySyfV2
zsAF0Zy^v<C6}bS_u^BB3^>tb}VzD`tViat@;5qVnc9}K$UewB_UI8EiWttf$`nupS
z+f%scv2SZLPwd9~C+xGU&ClA0+uOV&+=s`<tk;$$I$8d6PjZ(H<039Di{3^ZQ8lIC
z@j2Koc=>uK*fQW>TktKubx(rFTx9r|Qf<+r(3Y25RI5TJ?3n`(-!qv3sE1G=r)D+s
zlc&y#AJMD$tc8$W_SqU5hgM1Ty;fj7#H7p6?%*f0U4qxoa6ajwjx;4~>3CRxs)0sT
zx?{0I?%>D*C<AbG6^;_Ebf^dP&f0Y!gyLO*5Zpc-G-Hddr4DDMdc}t?@}{t=!I3fQ
z?~_H_uujDGHxpb*TW7Aub4t`aGOgtrp`N51=@Xo!+ORCsbl=XXyq$r3J0sC$RldgF
z>tKDBRsZy9T63sRLYgRP5Bn|zLPHimqeM2N#NRwqaGc#Q#mbv;#?_|8N~^?5zoeXF
z#x<MwJ<{?~5|UX7y;;c<tBOPhokB8d=J)aUd<x0=Bz!e792OBy+UPbo=&AjgmwlLx
zXqj}vRxuHgU061*uG|rn0Xu+AtBA`KZ_IHjjH>Q>DIEIi3?<4lcl-|pE?;%DtIA*!
z*>=Zqx3+IT?8=GJn2dLcUFlY}8t@Cp(MXU>8gD{;7!X4-iN9T^1=8*aB<j;r#goSk
z$i$meK7aV)$4z#Dq=kf7_uvts0eJgrmpE>F1?T`@Kx4AXQn1$diE9%rUKHK{Nox>R
zP<URb;mhSK!N5#YXZj>ZJ5#DSU&Ku_Q3@vUvF{EFRgnx)*el)Pxv2WZZ&5<9zv0<T
zY_ipg>I=%@MePgrVJj7-h<+$A&X%(p<Aac7hNxxrHe&dM8cmMk4a-_eDYhNuMVPoi
zKz|@v6w6U7Tof1ih*oY~Opn%$ZrU2re%+%?ZWU>YJBf>o+to7x`)RAcp{0av+)2cE
zGkl1MoANE-Ci;}VD!l(z<`jMHd|<dS{cf)==phkTww9B0&n5IV2Hi(d-yK>F3pw9b
z+BitOKHR9D%}eo}O_#6iXqfTg@ish{;PrSJw|$YW+c@X&4qbOyN!(tltkLmXUr2<f
z9q4(&Cn%W`dN+wzot*?6-fHS<u<Psg@}NeKX1VlHaia&t?sCOr?s=Y~^F?d-A8c&t
z9!!N%RG~S1KCm1nb9z<dWNh4cUd-25f^oz{9fv$fm$#kn*oAk#8|n7dK*%|&X}sDP
zSw{3#n<P@|DtX*l99Fo=_pb!Nh|Trn5pjy~4YtTgl~IK$LLt%B?nW(w{Cmv?jRsLR
zd6i<i`IuRx8B-ewg7|^_CM(7z%4+4x1?wj3>i5OkQ@ooOT2|bz!-=dBC9MNRg@<)$
zCn<#BQY`6Wf^#On$nRHibxX@JSX;<9S~=S_GJM5a7^<GWFjP^UVJ)mqOUP?VF0ouA
zvdlb=)XzMM#(XY1P)@CVCuS!<#a=ugJEq(QU2QC*lRfmQf5l2!M{imAN<F{*RDP@F
z;>2fp8Q#4MBfGL<W$xoEo3i{LUEnz~W)^;DkAu&C@AkfR$Lt5oCodOtja$a!T*PEg
zuVRg79AzxJr`YFbkzY$5n8z(G$6>r)!LZu7?lV}6v!%f1tjDWNv_q84w&T<qTb$Z8
zr?+)OAoNZg9|}7GN3WkI6yCPg^rx^8Wu&>2Nj-UQT*h}Ss#I~7YEAm)4k`&xJt#`b
z&jA|Zi1CskF-5p|tYPH6#KbHi3WY3s(9K7E9Xx#RUd~YdL!WvsVSDKW9W3X4A7|;H
zZ;1d8!2KZk)7q=?%IBXXboG|bj8@iG-{(Z^e2Ak0O-jwQQjMkOOC{EF++&J9+<r#0
zjX(5jQVy=gsi<5LmZhSzjLIx=bV)AUDKp->{<MUrMo|fa**sXc;ODah1Rv5b#-&it
z3X{6$xaY_YX%9n92$|a@OM1Mi!yR1Z6RS6D!X9*&#F^V7m83sEK#@3XZ+9T}4%o71
zsMW=fX~89<0>_RsL<77b-576k2sL!vsZOs!Je*GzuIkn2$vU)19|(@1%UMCS0=u9|
zpD=pxb<Flvb7Q-MaY&kE<+HaZF}h6ggg8S!|ICn%@H0SUKWqWG0QD%%AyJJRiBoR`
z*)oLXil`9LYh@W&+fDNtmbBYnDDugp?n^HVPA;_xu$~0m=xd0bFP?VDdkE^!7GEbV
z3kEyiVIIFn+A^Zxhhgq*Pl&ndw@o_KLn3!EDt#3vFxkI!JB)OJc@KTBcMri&K8gpu
z*Xu)><BEv<bq(QjqFeZTqP-TpxANaw=4I01qYW94Ler$)Ju$O%Q{TnFs8zFI5CGqH
z0nj$Ey}F)0Jz3zzu_1|Kf9%9330y&=@tYkz+_qB+c57Hy_C&~~@V+1$HC^6;Mhj4$
z0+(H9x#}i#B%ov5hB_|!zHi_tU(5od!H)T^NAFD56Kwe;bWIp5?lb&81q2<H8KuaH
zMR@HBP&3x)EkX?s5}Q(-e}Lk;&L$;~DK{N;ENusha}YAzN`;78D$<20UR%b8z5Y5R
zDtA=dP=Pak-5$=~A#JbFPvXk@U>aZI_(zqQJl1_6nl6A&38vXQCfmf`?Etug3*NK$
zoCJ;~<1EBD#_M$uZr(Kf;I-XZXLLwt$hpUhMVa5kCh7?nF>O(O)UIm|zju4=%w2R1
z=MDMyW;`m3sN^FLE=63dKrB1u3~oSsqVKQ<d^}@}I~;f$mP|OTIMln%wXJr6(<&G2
z3WS-gonfnrSQ!+=yn)vU6`sSHTbreUT}v6<;Dv)}gJ^LKk;&d**S&^lL8ihN=Xoa4
z4^lbvxPxHYg!48Qi%eZ7>{*PX8s8=(IxxGyCYIN+B#diJSye=3F)U|@cl!XlxFwPZ
zfVT;`4V?_7uW$psPxQ;I>7MA8R2pz^6|zr(Jwvp`TKewU7-6r8{90IV6%}=3KU_Kf
zwC9mF-{njryIaGNgu^kT%n3)`mzYwnLaED_gl$N-KINPE2?gws@&)yM$Wv-|>8pwo
zt;UovE9~n099L{VtTlrf+yjlV31`iOYSZPfz#9l3Sr$Z($|U8-(25TgOmmQjlCwS>
zJek1EMbD@%Z^qN5!QjsBhi>R#RFoeIH=`UEa;>tfWUt9cyE`sm@8d5dFBYQYSsIBD
zYv_nQjL<xUu&q1cwKpVu)7F`^!ZW)Fy&VmnAV?(WP6ypOqu!nIeuDN7_TS_>H4}+=
zhZlitM-ID&9z~o+UzzGy%#~<XlvPDW=+vPz)Ul1btznvWaYEtb9CVexyGBEr)UeG!
zH7i2Q9*j~*ab8`B?24`@ds=`xMYAvb!0!jnxJB^*|D5!8oS`a6{4354oDa-vrZsba
z^SlrKbq*o6zG-j{2o`GYYRT5AhwyXgbBGlVb4J%lZo1E{64lakcN~nFr5p}6rgkX0
z<clqFY*FlCVC{&nH#^CkD#&d@AJ0~V-4Vc{jpJ%UrMEpAql@cU<SmRYuop!%R0Qr3
zM){_ho*Sc&gxd8{u1y&_5J~W5z`tRlKd{_9AQ02fCNqi%kS4^b=HMi0!L~yBn!=~R
z)qX~r3-0kld*5&%xs9Bke&AFkck`)E^qMCtl96*{4;s@a_HgPW)AaBW*A<c<qyu2J
zdj&>G%C#l$CV9C`Xd#LC3Nhs_%@tx4$Goog>uIPhcaM1?wqgj;J^f}l>>|V+VteZ9
zV7(S+9>qPPt4hX6i9%a)RX=iC-0BS+d{XFH9!u0wKWae7wi-V?L`o2@dQ#e4Oi7}4
zfr#u)14dhrE#~2n!GVNvNic1i(-msjB0PKi33YAZ+EMYPR!mc(=^g&T`}U3TZbfM<
zJ4;?4Fo9Wr%M(+pI<@_PL1}@3celOW-N{E(ci9~h>h=CK6qfJKz#eExM+D<YpA0Y~
z<;-D+_2)FKxxC=tB0Qf_Kf*5^H=G^L4ODhG;;y({EB5Gm$1oTQYf8vW$71z}m{Y2d
z**TU!VGzqoO#7qM;PZQ48#pui>{@@BV|o|<V_VRZsAJSK#=)U4rxV^o8kRlZBC?nI
z9<_y3{k?<DAm#!3o1oHZ%PUEn>B~>StNOtt_bOK^G(++%LhVK{q}Vt4%y!DhVaLH3
zGEPXoLLYm;@hCh)C<(Ca1MJGWV-xy+^!%V}lx|Wfm6}s4r0>Pfzo<{zEa*|DK$O@<
zMcqXn9Un%y^V8CgPtQoqeV4iE&XY{+o;7Ezz>1ITougi;4j+SoM{>^L>RqsyqfEBU
zWiBVk{Mc4k@EsOAM;TR}<0+lyaO1cw;fg{5o@ehTY4)2Sm9`0KhFqDlG18OBJO1e(
z-gz_%C5qO)PaW5t?uxEL!(8<D$1<xSUbVP{p5!N?*SWL@S7HUol{hzIyx%Xwll6l;
zCp5Se^Ij8qU&D+Mu;9Agzq`iJz*c6R#V+6P=R?9|0%jgo#*3-=e#L4x3Y1#-W;t5)
zQOYlKVLA6Tzs%w8ow;OSxQTEm^kIq-=yhqC1pYt+ZB%7ob?)khpTP1aPWlQy`^5G5
zapoe9nci1PN^9iJmTTpOC6|-a=&w8jAzA)X@+Ja!C0^Vvij(Gwt_wvUNgL%aFG!Y_
zKcL#mLL%n~Aah@F&SE*?u5aI6-M_(z&fJSW%bdvKSI()OZ?4-bQJ9sqR>aa?@H8ne
z|Dt@)P$a=Gpt9t<YU!3)+fgalu>dYmZG%!Im77AUauI&3T?KD-L!A-MDlvn~cB%9Q
zJ~K(>t5;3=bsIN)UZR7ost8-=R(D3@y(8HU(HMPrF3%3Fo9`0*$EXQ$4u+`1LtY;S
zY)uDY<)pG#hUZ@1Ob`_-TxUD+Hf>?nv*4rR>tgmq3&->_ZJnc%!QGbnB+ZEO#IG>+
zG>cPYFT!i1X4pE-a8SvyNE;iC8g8N>Qd$>Ao7y;-x@{T6xa6#5Qv_J}7-8OkOB^>Q
zt2}fTQY!AGAg?LcaGhS|-;->w^&}9@nH&6M)5*RW>WQLt`hmLb1@Ap$YA{oDV3#YU
zxR+4QDSxj_C%gwC-b!Xii`%r&^nraup3sFomQJ;?FJq>*!7zUu4;$jHRGq=gUbj$O
zMb$c@l+5~oC^_KRyVk?9@TrTSf2Y=q9@=ls))Id@YJEx!b0#j#U-ifIRg6HD6~Y7l
z61$nVV*C%uMwlx@0Rdz|MNvfyMGf6mmgT(<ciwUJm`7rh^>7clAre~`AF8dU!|aY*
zQbLO$j^Byc)yCUq%+e<^CYLr7_xm7DzN51PBC#Lx+ARA#OWE)pf+wVCkJxxoS)89i
zJb1HT;my5zvXZ0<Kt@ngdX;iP^r=wk5JOH=(oi9r`j7#^z~LinLP(yt%ce*Wx!*!?
zfZLMTN*I*K30gA_9gYG|*d8j$qwhpyczaYEot<cqdKH-Xc(n*I`N5MynAwn%e3-B9
zot&V!C<~HG2`?0iJ99|F4Rrl_2eSwmMH%o1B>(Vzxwueh`i3fW4DuWTEbW@`X+9o_
z3Gxx4T0>?9GeszdZK;gLhU3@z*0iLpz8E`pS8*g&k?eF-)+rm$U9>=~YHc@+11!Aq
zK|~8wc!;-F1{I&wdAgnR>+iLxR83Z$vAfF>^(z+$goM68w;USzX;5M7g2zvVlWsrF
zz78~~wZHq`T_ooc(YND4)t5W_PPL68RmfUX@4#}Fop*pb-sNMFz0@4lhT1%OLsPmZ
z+EqpC6=k&EtmPXOJX195deihKCBG(&pAmC7ukKjoD@v^236Hx|qQkOMS;^r`qqIvf
zqPf&)7os1dgo`@kRUW&;W~T5++b9mZX=)$!oz$1^kH*)#>jGA(p!kAPg=I;ZYTKM$
zzQAE1Q9sXK7*AQdgnl!`2S`1189tUJ4lR5z<`H?bJ7-$XA(wOH$fHN#pk-v0(a~7M
zomGUtA6#<K@U&J^{J3{mJI*@R4t%Vy)J?^NYpm*e_$oJjDpedPbSc5vY^Di7HS-|y
zS9!o3vB&ee7K#c++A4Sq<-sa~E`gAxs-9KNe8rd=SFnv?;q^WvZkjzKa}1MliwJqx
z1QK!G+?&3tu$hV((Y{!5Ml>PUm_|X0t(dZu8=81pIaqoRD_vs9Flt?_i$+xLOTjwp
z3O;@Yc-Qhyoejs5E|AMZ^K)#PXTi*lBSzHsFV?MM*hWd*S<F;asKZ=5i|A*MsjqBL
zHpxBO^~A<v8w_N%KC>Vd8=IHRWMtb)Ft!|fwW74ky5hFbv}G(82*fQsVSL@`?Bx_~
zia3m%xeygg`?lY$n6OF#Jz>2kM&mNDC?%a{;nAw+?vX2~;NtCHTvp49C-*`3&=Iw$
z1PO`}mzM=Y!Of%w5<1j+$GZusL&p9y!Gr#27W8a0Uztd#NwLoKlR2ZgCvtP+)K6Pj
z_))xi&EUWz7yd2Y6VLhLAQXFY;=6UhLx8*UibPEo+&M6avoJ+=RAyAl{bOy6)$W(}
zVc3Di%jdL}RJ%4CwwP$#hn>nb6dgX#ag2;A(iGR^psfZeK&^d&GRKcYxf@f%5ycw8
z`AotgNuA73af}`HqMCkgdRp%t*%6`AHCM-f0LcXc=0m&kD&D<!)7ns>!}kXctL;>T
zXGl<DXGM)GCYD}nf2**d3ZB;IQ#;*IqO-t1R;8OMrw-Pdj1?*M*muPn#NdGL=zstA
zU0ja=`rc(U%E#{k!d=)(x4_D|0ClG!k@GJET?>@Ms?`+cdVwcJC!Z9ihzs+Aa%F&E
zHo7OtNagtbhS!>t+8NhSbdY>04eBRBOzS@yb=#*t_=4#vU4!jTYE6)>FLj$D+NsCF
z+5b3*4uJj^*A2ksAIZkTei)5PZw|S0^m#bapG%@&lY0m={mFi6p)mnJaE;rUowUq|
zrZ$1SHtB(Cj|6vG-HPhaNsE*`Ij!Y6Y5v(Eycw0?dOm@U$skFFVgA)_eY<bX;U|f6
zPA9+B-hnj&4<3)!n>}J2W((?8TXT!3T)!6L=FExg6W)#$=_z|Es}vp@X1?}i8%~1Y
zRoC#eQ}kLcy=OA1-Kn=H2MvmQ-*ThhG4V9>dGJ76WWyA1V~N%%Ckrwx*jP!^9MoJH
zd9U?^jB3AKF{^&|32*=GZ1ld3f;%7x??T_SdZ)g9o#-SQJVi!$5G>OPPK1n!;G`bm
zJXq{_bcBhHsmWz<hvAhNqN{T8tBnp{t;~8buO{om#_80VlA7<$OIPYPZ{6layQ-}|
z+Pj(hj1N<@YPnrDP8XJ*vupY?vM<@!WkKr2b^j#NA%RPbrx3Kj8D`un)uJA8MI2#=
zWRkfCXw6i{Ye!Cqe}3<xjf7+JIl-(dfc4D=K@KNxhc*$c3EXQkds%(vlVE}2$9@yX
zbP^-`60WlGuo-WAHm0n0P38>ZIq%{9vUgX@*X>uz9q;#89ZV0rtgKd;V9;C_G2RaE
z)EDO{bO}&E`Zo@8iax!1CTZw?m+`&6PT&EDu$v*ANoV)=A{VXk(+B>q{4A6n;)nYR
zOi#_Md+OX^-@Irc4B`gxC`a@aBebfehdN`{fr-hn&Lui9sAihioTEdI6IB^=u}zrY
zD2Fq$Nmvu4E3#_&dAa&cWk(L`1a#RxePEdyAtBD&RB*04Vv(6AGf;hwJPyHemhm1?
z$JVkL(7X&oKTcI4oM^5XtG3XlyJP%e>+k-4Oix>#vt)W@-GSC2f<4Yk_9T4@c+R<X
zI5M6;e*N0PPv|jVEB~x8by+8GR?yCO<lObgOseD?CXKht>#^+Y0f|C|uPNrz3c21L
zyn<uDQ$!TJC^)qvy%xyG&eYD-Sf^e8n3JaQzOoE1tddCW6CTRexSD94Q?>~aGbd+U
zmZSIPF{AjPG8bo=5dgWNT!)3#%GMGtoc^k{(>iZ^`DA$~`a!i*fG6yebSt!%+J;l?
zyLoQH=o;hr1j&bs)rmqcr*||5uWsOszTi?D={s{CS!JhlZA3eL7)X)!s;R4-PUVt*
zeM?Ko=ei0Tj5p10(Be43`ndz4#6|;%vR;b;OFM#09T#g|)^`X#`q@qGvQUJF-81EV
zHf5wqa0|1MMa%eEd>(;s`}vXi#Nh491-2zD-kxlU?-gw!TXnt@ifkE>$sfNV<eTT0
z!Lj*QJ6wV8J!e9+jGOJMg&P*VN<SW}qq5WlOvPlX0^2zvt)@oLKSLto#Zz8*mOzzR
z^b&6nz6-a0_2q&qY{~i}T84lvtt7n>ruwyp#c0%#J)QuQSu3I_ZL;6ybN<!zLR^-7
zrqJk8Yw|Yc0giuSuACVktd2p{SY@UXi}n0gsrBBY3Zdwir|#<Hl_g4fiB@30*Wh8>
z(>k*03}yI0(Y&IUgWZD7)hb5#z}M^bgKowBoCaq`Cd^ERC0i-MLGLMZzq4xg0h~tY
zjxF0QenN;x$U)WV&xGJP%!}PueMwM)xSA}+qwF+PiImY)QnM(=A26EE8xNvqDUpG$
z<`{Izrs`5mC+N18286oHdhNQ(3ts$TdVQf2>k0jht5Pve^^_%@D;PAu;T<b7&jtmF
z&1+Re{h*sfuCpW+(YOzhp5o~%KA7=-%4T?~Et7hOWqoKSJSWC647}>=bgGer27Ds$
zxNxt7Fsz%y?(q8{CHp6x_4ojE3(Cmfj)Z&eU<C3yGwECPc0|>tvyX^sYLWtCQ=R9W
z;&oMrPNQe{siZ3M?z87zeM;u!GxzEZm|``*M~|{zO000Yt9aY2BGmiKMJ|)yEyGTt
zDlFePU{jdyv_%v879Ns&kP?KyW<a|~Y)##1;3EsK;*FSr^J+<v;7h7p%H}HKkH`ZH
zS~TQ59Ak3{0qfp|H%;5xF)3u3CLGR%XX{9YU~}2M--EUv(aLIAxm+e{=VHoBMrs2K
zgFPU6t5G78p)ekYxtCv6<p6QN=ybmY+2R~mOx5yWn@Xl;asf9VLj+9SX*<VZi1ZZ5
zUEJ@7+qhVizS*!q_)&@W!JAB0Wp63R+K-GP`th!cKdai^dOk3lNXcSf;6YVDdSvB*
zO5g8|6zLlgzwj@iCSAds@mqf3NF~ODhel3sruZ@|*@ogf1HpC5f=?%`eP1y`-i_*z
z`|_nzEha^ieXTii+g=ZZ{)mSz7ZOy1c9{B|>qGB~XIfl`AN;#$(c=!1oW$n6Rf9-j
ztgiUDwS$o&@zAJBjm9i)pK$h5!YBpJA5AJr>EB5=J{A!+#fIJ&lIph^>E&C>dRRy`
z{)oMa>|8f>-)my>ao-rF!sqm1p{Vxt)jQZ`tVF2drH@5PJG<rSY_?6mD;!vXzMi4s
zjB|ij&}#Ht9f7~Jx6x~Bv5_9#ep)JS9wS~}aT_h*8COZT?gFz3fS33`2Dx8GZeK=o
zxj5K(evfkhw*7sO8#Ivo|Hn<Js;X(r3)2fbTN&B@q9x>2{}@O9@8CEB>kDrU0<izf
zNwEF_M1zKk|8Gu${WmA^!i0eMh!-Y;gM$;{FY6$(g6-EnE>_mx`~QcT_*Kt8My)}`
zf3@b{hN=I`Oq7HhE=pfQ4xqh(5WEU+^8?e-CKP5w)Z)22=6f@P<(=N!+)hy~vDo^y
zq8dJ><6fGBsEkY9C%3dxLyj1AAnFsqPPIk3qWps!d2p-N?q?Ib$H<X4XlAE%W8KV+
zya(l5;hH|znH?V>s|6?JE7&#mIz3GZrJ^dx#|7ei>{n#@Sj~ppYB(OK8EjsV37o-@
z*!3ZQ^*718i%n5}Hn2FwDQaG=szKF17DgQ6YPw=^ywoJ5TLsh$7!UxIJ8=~D0cehx
zPKY4^R(I$vvMsSI0%%Fjd1qiDMGU4#B!Os5GLlU~aFWEv&5$CW`3oRKgi>?Q+Z}wB
z<$mO*w0XxTe7P-pGG-dMc!pisHb#+Ns~=9#|6j-Yb#Y%VI4jS8=!svq|MyM!H+tg#
z_9t5-ix-Ul7ohM0OCabla)S7MMm8=^04oa%3kW^n;QR+H0U{CpWF>f5IR3^;fWU|U
zuo4JdAZF*ktc0AIk*Srv#V>5<H#fln{2MpH1={)#H}R|Tzi<<*e-Qlt<tBa^es}&)
zZi4mC2?>8}g18BGHc%V>%^%%V{N!}huwLI@cPy|D%!|CHbuBEOYW~Vylt)p?(#eY_
zCxnRKZ^XL~lgNzEq?ywa$}_|w8<-J6n^iZqj*%*-HN+CqXB(M>9}$_srlm{0WfJMX
z|2kBkzxEjCxp(=S$4Tp6_S$`pk3u`|+Ep;pDkQv+Xk{%Vc{I{{&keCrok5caX0W70
z>aJQ~MK86CB&L4f5oZd%e6`*R@EJ}<N7koT<&kmLt-A9BPw<<h-rBCswd8XvQ;N@z
zHKuREkDYM}KULmFbd5v6E(<Olg0~#S4Sy>O`IJtHm-?9@2r(=W7G^sEdNZemd$ynL
z=T^|!0qLOr^1*{nNvgP9o`CBy1}b9eYa5aL@j4>YoPEMu2Ar*;)+;L76j53%grSWL
zDvbC%D3aQAA~_dAUs~9&$x2b}nSO92DfhIn=WnIHd7`i;CxkgshBXr3mlWCu9DmIK
z#aTGln^`oR$Nrv=Qm?Sf)&ZV|L~nbP2+JuP5<G^vwZJ48;(AF3WYMLJluS3n4fjj*
zS)08Af{~{hT#Oag=2<l+8HEvE5ls?YzfTAju2r_-P99F5px?Hx?C;)9Y=mg5Q#hRw
z#Q1CqpU0)WUrVQ<82i(4@1k6qy6I#R+d0uwny{5!{by=>gGXxE{^3KoF-kVAb8r^=
z-dL0_%n*q^^)^gZiR*V@d)hcOh31r`BX<=}lQxxd1qV#BA%^E_x_$jJ5lU&VRdb{(
z+@!2mDhAI+YOlhR&TfBuv;8~iH*5#ipLAc*WpMKXbuQ1>Z+B9U%}CyyYK}XS(7j^*
zII@+ob{mJZaHBYr1-Uokrcgb0oO^irR;grk_IpLt?M%OzZ2kI@feDa@&5;{km7<;B
zv{anxfgo`Vg@y(LlN8~ge$mxVQdIo%Aa{X2zB1y=(?Sn|9>pQeWqi8ZD1Gkw_K~HY
z&%DQFpO_{&RmMV{Ju3O*nYeop%A-l$;2B0W4)Tq3Ir<vEHp}-y!g~Xs(gT>BJYLzx
zjlQaafZEzyv90^*Hf?e={6*o$-WcBollo7`hkaM6z`jXIU+@fiao;0)hgn4G_90wK
zn5KwaN_UMBn{+g3_bOlMg$WMKoiCV4L*b}W6AuWVf{NOA)zYF9(i$Xcd@-MpF*6SA
zczqs3;H}`VuyAtwa0#FcZ9brIm@6Azy0g8qtz%^6`Q%Aya5erQLGM0o<~J98!bz{U
zYu*z-AjA8>6c#LZ!%^E&_Vf9SR|N2#Osth812cPx5=d~1HvPq{z^sdkVdWclUnb{C
z{&JTu1zV{8bOt#Z7LU>K(C`^46O394nT~84TZOYs`xxAqo+dBvo5X>m&XYBbMLzKv
z&6)k!o|4sOpyblL3H6X4#zEIenNk$$-fRS0WUrM5-m$t*Nf7*4KO*mj(!~dl5lEhM
zCyR*$tof?|?}<#e^4r`7b!-a*kbq;5pZYPhhU0|k6dfH-2^L?v<iov|y|#E{<JI}T
zqxifIR{keg)upE9|MAQI8^i<x**Jbn2G-wT9Ic&^iJ}TX-OSm=%E2D=bIb%}XW|6t
z(u%lQ*@8e(Zb>#4Ru)}4fU=vBv#U1%G^gs<^ej(Ty8oQ(H{VDr#>)yS%)$!f0djM&
z0NJ!zSZF|h|0(%bz!Nl2%hb&TG=K3|Q$Qj^6f|wo71Rc?mzh(nfAW~}4yJ$I{_oGT
zr?Z(k!V80m0D6l2`2lcpaIkRz%mIJcfb1L~obJ~?fc>8~7M2&)@edmt7YN<^hYi$=
z|0&19#R7UtynOz0KJJ&M{@upL$pz}^-)+CP{%!-Zvay41!@rheVdDnTdH*cO1M2BN
zY;2q$D)pZ>E}s9fv9tg0vFxDd@IQ}bXMX`@Uq1isFFPj>$e;dZ1NGzO!T1jw&;Rrd
z$O=+||6A_m{{Q`0HXsiOTKv0>o&Dv3{7)N*w*9A#<3+XnF6ZiO1fn9He@&iMvGNA_
z6$qAm<KO^7mtUd+<aN^a<_;i^`HyumkZR>;Gv?p{vY2u5aIhL1v2(K<o0yq#81ZnM
n8Uc;D*ttvv5&pf%A0)JkD=1`sIVzBylZ^|3ib`Bj0^$Dw+d@rf
literal 0
HcmV?d00001
diff --git a/docs/tex/figures/rmatrix_interior_region.pdf b/docs/tex/figures/rmatrix_interior_region.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..29f66dd2303be06919d7392d023ebc76300702e7
GIT binary patch
literal 37043
zcmaf)Q;=rCwyn!%myIslHoI)Q>Mz?iyKLLGZQHhO<Muvh--!EmUvkbhXJ(AC9@dJC
z%=k#<MZ{<s>6l?i2aoQLE=nG9X9tI2SO^&iZ4E78cz6iurHyS&oy-VX|CJO8>BY>g
zoQxg*MJod*V-aH`TYxbkA0LdPlY_B=HH;f@(UwdN&6xf6-ParH$PEb`-jkHG^U87%
z`!+PT0BnCn9kdW8c5d74%F7LbhWAN4E-<kOaC-Ngibh%-vK$XG*3wB#&d=@J$V|jf
z2VZs0%GKSQ@6XE#zxQ{}OwZ3$PIV6d_gTX1&)3;V_3afwx6aFgSG(6Yi|fzh-N(#M
zmeJR|v#;x0`(w|>lMm1H%I4Eb{m#oNVuJ?8j^2tjfA$Xk8-`Mcmo@K)rRP@q?!%q4
zJFngeOU}p2SF<&N%<<dfTN931hcDiUOXOj<o@@NZile8-`DpV;_T~FitF~=U)ZOYe
z{F+iV0ls|~-w77j$H8ecAZ5c{p+1K%=cQ)j%enHS`Ga=u$+API<=F16ou8m3CWr6k
zz_MqH?j>&P*~oG0`_p6VCWSTAKWFT@X2Pha{o2P14?WK6qrEG7S){oK`|9~=HIgZQ
z3Q8oUW`z~rY3^vr8<7Am?)2%YlQ-i!&?kDNIqK5Kb35wU&5M`*<v`3tY+0z$TjyG9
zf_Pmz^z?Z8q$}-8ujZhYtiy|!;3ZMSWhWc4z<MOboITZmK*riL{mR~0TjY3ty=7!Y
zklAIod+wzu)P`^C+5Pk@;=Crxg}K0a>+7PPQM;bHO0&|_mc{W(H^QgO?AD{?bA_ir
zpPhU4H=W+c!5Uj??}5vvj;m*z0lG=-iI3b-OV${J(27oXbxPHp&Blu08-RVH^``9F
zL@{Q?rgH<+(8cp1a-+%9`@`!J2VPrGuZ4W#cSoyh$K1)2K@R?yR|hX0#zRMa-WS7W
zQvD0Bw{DHzh>g_fbInvV=|k8DoN4Tc&xYBqgPRCUtBu}AH~YcF!$s?6MwY!^^IRl7
zeE;K^4XUp<LwH2njW~{oi!m_1eVf+M_aCvC=VDLq4!!ktGP_$#0xu8zH1M^f_yB~D
z@9}iscb@yAucud@Y`qT`ZR{9uCgp3-OXZKv^qmQ#j{AqzZv2=P2YgGXn~Mjt{F(yK
z9GdfE-<;4aew&oV`iGz|_ccDfk(CGMjp4D={W|;ll(?75kiUw<#y#5ndL30K`@cPT
z=;aWe*1L6wF(XVRcm|x=4&oCOW?amfbs6@j1vk&$KZafSaxSl23Wfo6?bugmWi120
z66*X;Q1BH#jeU8eM%rVpj-Y3*IZ8bNi~T9tsvYjv?Jw^hb}StG$VN)T-03nL^}Mv!
z!=AdB56rlAR_rX>mOTwm!M~fME3JKM(HI<jG3`WLwY<qYSd%U^uLJWoBEKxe5mPzF
zJM{3M5fe8FX6!+uee$AB<?jK3GVVVfx-n5~_}14)W;_|shfXiG0B(-xi`0RK`kR*C
zAdN{kufgB#)5qKR1t7y9YBZp!JUJ^<c4W66*B?)gj)7)#kM&(22~jp=b{g2E5Av@t
z2Cu&(^_t<1UgQ|}+&6N7VKaJk=mo&~k)q&lF`DlmS9=o$UFZqg`K>{M7%$a<^*mv)
zN678KFlA!IuQRW|p`l(Z>;6U#ZKZ+EwlQ{*5DsQ<1{ZHwMnXcRrilyXeR*^sl-ki@
z8qr*AG<&*2aK6A!1q%uAszLBo;{JK<l{IPah7j((G@)&|&^Ob6_5c#17|a`%=Rv51
zSlHV&^3P^%MPlJO+q;7o@rEztG2(t+mP8r3g7UtkQI;BF;C!IvveU1SGD!djpSi6y
zH3*ob{dln9DXrh4k1~Csn<Nhk49nmpvrLm4p7p_J4=05+&}|O5wAdK2riBj2yF9ov
zEaSvJSiklPoJ^(}p~%H!N6zTBo(b0lr|1i~tnX5-G+f+psbll#v<VPAK$}B2egH77
z7~$62aYNCd^SJ;UgC9vJvP0DhSu*iK&e;N5bau_#gm`$mZ2=f=tmtTHZtcQ$ty(X&
zpmq2mx0HWg+Vw_!DJX==J$dv_!}o{@@jYe8<`vl2GD>+`@yRjMc8?9TR&=gcobkj1
zqdt*!-K`F~g32LT6Rzly*)Kf*e&L|}X6C1hw+eKzvQ7pL*Sel~kwajd@J=;6Km!fp
zWujma1FFB85WHU>*=c2;b?@>M;o_qUgd_F?^6Og*hZMz<&PBqFmDDo15a7k~-bQp?
zT{rYR{(akfxWSB43wA39!PTe7M1@Wq1qr+wMmt(K_!vy3eK##Lri-CaIU!$LNesKC
zhn_|AFs2nABlHMo`o8N#lN|~NqfOCP8f$v_+2#o!HD3p~7z;$vfq&7AhPW_o4e%gJ
z<-Z<X*B%z2&nNB~vWeqvxwmw?{2^d4g8;?wd?ZD6b9ZyZsWvS8_UvJ-YHOHF6{@xO
zpwMpcsv}xu7$d?^M<af~O!VLjEeBJF3`LyGX4H?lb>B&Y9t2g5DBpFJhEoL*>vUB<
z@g&-N`kSwV`M7HjH%}~#(Kz~mBZp+L5je7csFlp-5BnQ}L<haCHg`7*zG@E+MVKD$
z5_T+)Yri2MTxI4smQg+BFIDLj97ggSUMq0hL46VQ$i!xZ!U&y(TR9d_wJ8lwhP2p@
zS}C{<{zvS(2+li8-kiyFcYGJpJ#-!mj}`=$EzV3RoBw%wmO*xNNi3YrahcHPKy$>V
z+-yh4!F3);W86|@RjtkGIJbMKw3SVfb2f|ni1k%P1-=W7roUihk0hppdUlu(kC9bX
z1Y9K~+x}_Go(l~*S702^c8uHTVaPK>sXgP1<W&e>mklU4ylW3csd8j;HvwZrm^EGs
zG@lxm`I<ugmvi~GGW09wHK$NR0T&blY79yYWw9X-C6zj+HjX9rB+6$e1&5g}N{nza
zh%X!R(Z(=Dc<9h}&53kKj2>ui|3|B#dsqgfUu~&<{pA_>ItZa^Pw~k0^(qKZ`&O=t
zlCCQLb?aXAI+@Y%vLHIUMhM1$+u=3i!%1P(0h+r8R1o>3_I<YJ9_~U*!ojBdT0>`X
zq`sDH#&bIi$j)>cYAp^tS<zt{^v-kIrAd$6+7j4loz;;K!I2<LUcT1e_g(s5fq1kB
z;6%iN*;q(8czI~%0wAa(U8OrguN<eNaP`A$P!(q6QCGQ$TwE|ZAfRw}d#p_yLxYp<
zUz1FU;8{p6)R2%mh`a0cLi?w3?gv?Fk#L3>Xam)-TnzORVd9TWcfc-lHq=0V%%?2J
zfQ&<AcnoB%g1+5L-}s&TIcRQIPL)^N81z+RycR<%CadZzjA2519EEZ39Mn2HNW=D)
zLK~ftJ9ql5+LRCP=cZFER;)G0=O#?*26L(;V6qpKaCgr)tz)%ctwPT-hXiRN#`jEs
zGe(@f_P`G(owDbtN-B#{s|^ul{|S-f(dqmUl0Vy;bpdc6c;Upe6P)5fGtKK%9IyUK
zZB~BoiGPQE$qt6qM4ZRUCwAjov?fk`Dx8=XTN%dEcEGa%4!`PMu|@^@dzzR}vZHyV
zhfYUkc6xrUIs{U`zmdwf3O}l@68rcvIeu7<4<x81L=Xe;X+%|tB>}tuq~G#3gjOX<
z$uqzoH_O>Ua#i8W-=qE~<zt|S(U3O{tN^t!4G*LK7xG0sEFkTTTY<0Tt`uprW-0vB
za<}u^=hyVj+O_1)-^mScBVGQc7?Q1{5N+kvt+GXiV$@`|1J|(OpjlSe;oV0D-A7H*
zt(7(kcx;f>@$mZCoQ|UYCtOyTaH;rfD)}P=t%F42$1<&>-kB)+*J0oBYqkDhkyF2D
zlP^-|<JWBX#2~_E?-q=bB9f_zuRyta<9x7Vj3hiK>FpA6oavuyt2ANU8WD(L<9*q*
zPchx4T&kMm;J8%VVT=+b$*u*+r5ZMS<C;4n#VU@#3>Dr(gqIHm$3#?-R-EHlXHpSi
zzz2Z5;OorJP1at@uvp+a7`hx<in=7V(QSDo$ZND-^-MBcg)Yg5H<)Sav7ysQ%0fve
z7BgTm!H)`f!#i~xG|Ju3wK}Q?Nq_ql*qJIL`ACqAc>$R_W&w_iW97Z-qx}!oKH+{P
z43|OhufZQMr}&}5UvFE<CWXKij<L&OrR;>~py4YLgvu9YF~F`vj5-JvgccB*+)3wm
z2@(AUl%JrO?G9UszGNiYBU8ZC->L&iG9x5zEZiyl-Sbdg74SV0OcX+X@DkdXqESxC
zy<gv8?}&qUKX%Wut_}(sFIBHJ^t(t5lusn4*5tG_&eJD1aVmA80U6REA%FXp(N?!A
zbDMcAr>88O)*UVIM^X=ut%4CD_T=l7fniLRb~z~?xQV?HWf`k}RC0&z$@+86#b{hE
zRs4;vGd@$HSdl6VutGzdmU2$oTc)emYzm;Hm)J5fAU{grpoXA5DBf4VACDNTX7RI1
zq(R2GfmEHYk}n=!lnpl-uq$(GMrvhoxURU=!^D#wBRQP*Y|KKJU2mTR>qx<nE$*t6
zC{=diKp26vEoe|eBWJ7Szoa}+#w`uA-(30C-wh}A2dM#resY<Sfvr5d)eTr$Nhec8
zjQ5c>{P#s-VNeP7hQr_0_AhKWxL!x@YL2#)uU6N_xX1~`-jbj0+qt~#HW%INp8P)C
zPB2x){jSa{k1%@28kIr)iHGVEzQDu|{iB{;uki>XrMFTL4v!uOR48x`U6lf5;MA@%
zf%=gowbz?0F;jZN?TSAbke!^sSU^YcZU>7EoQv(#jT}V22w-wR;EfydSh>!u<TF4*
zi%2jbY#%fjHq`h6X`}bXYdWvrn5d|6ss>cOz)u3$bE*{Bte~05`b*Rm6s4U=tHf#H
zDqM80rMIP2PPGiWu7A{unnYBe(gDcpwfuD};q>fino_ifW8dY*tu|WH(<sQCHj2Rj
za0oLa%#8j)R4(+Qao}Klms}BMd{u#LLkd+79_2b|ghqjBnhxAXY#gi%`B`a~1QrAn
zBkOW-7xI2kk$#j)T3;VZ^xqbb=i6q%;AJ8CTDcswqWp`!*8rz`%z=v9LbIW5QSdgv
zgs8iXi($2JX!>}jpNcXIE(Jcw8g%NpNQ*;ubbn$$&6K%_Gbt8<FT3_?KYfA(zuFT*
z^K6#Jl!L3&taI`(Np6fLX$n!@z`oNEn?<im)N?F}@&y*2)TR-0u4ouC;1XPtyN$@s
zfa5uzSINf$EvDW{OOCA}^Ui^!&6CYe1w8AbJk|MmK)L@eJ1;vIVesLyq<n<x8Apq^
zY&S%Am+Tml7cE6$o^i&xUFmQw8>!F&g~5sgA+$u4It03z|MuuUF*{O?XK5b}QmPfQ
zgz~T<y%;1~GgiD-ic{nusqPk>B<3sI6q%uaP2y8EQ$d+_wjb(AOmm`x6w}=c6PO(}
zK14{m8k&RwzPFdIwgCTPBZC19b2pPGcM1E5c*TpQ+I^a@KYU;SHHzk{u3iIYfCge5
z<{^-oW;^ek5T9Sme{P#8PEzV}tTq><3n=3@VPE#MQJK6Tuwm8`NZ^}%eBeQL7b1!j
z1uoWE=!(6^NN#oKw_OTx_8YOLqQMN=9B}2{4dHI^xlHX*6grngtN~e}y17yVJWu-t
zO|~K^R$4Y=G{~Z;amR#PRylDX`e->-W7SY@D7N$6bYCAKxcBYvb$U9GqdF^PRTm4M
z3pH!&PM7xdKZ59<I0ZOtBK9hE{#Gf_9YRI1^K12TQX!!O@rK-FoXY;z^=h!|frMBM
zXA*TJyk11Uy2^Q0u=K)c9DY1rk#s=Gi3ksN$qJdY(Y8x7+&~E>?7a1p**nHEJHs8<
zvLd0k0?COdbzThhBoTJ1m=MaxJ?f&L5|0zolUwG_tVTSrW>4xB!4sI0UeYdX-y|Y|
zEY<K)BAX!vJh1gxuURkyxZT3x2=~Q}hmQ`!1+YyzIFwg>iG(X+Twtedb&|;JN`Fai
zQq<24sjca7dizEC)TvS}e^*2VnADH1v)K(6e<B{IP|0+&7n}NWom1FQ@Z!)rA?pXC
zsy6kqJ29TQwO{eh<WNT{PgFLGYzcdEgeXl_4{Ujx@d)~=_ynmLSm1_bv-|ftg9e?I
zPmZV#e?YQ^l=_`?dOE;HWWJ$+)ZqF!#KK%%qw(EgwW8ToC2W*I$SC}dr8?5f-3JtT
z`qQQ`@~1A$A#TS1)={GtObxvK_p2@f&ALYOD}Ep{Y%t>-jcXBQ+pKLM9RQCK;HmGE
zOZvNs9h7g@S1v7ABFVIq?VRdosn767wbp(u$g==^b2WiHQJ2mJt2<&yCnN*xu{wbu
z@<a4x8U@Em8LaY9XgF&f&i?3#rS#5Eh?PqW8&v6;*m6x(#zZ!s4P1nDVtACJXv-Q6
z*F<&~)>C=;_xLpAK1@t?{z2;5I5KR(#v@g1Rtz}4XYfwjH1HCbEfH{%DgQtcq^KVx
zkl1y6S%=Av|HuMaq*bcuEHK`Fz>XxkN|EIh;Y2(+mH;isU?h53%T<K`pldOi!?J{#
zeVAmu1&tGiJJBVw)N&P>Vox7spn+M;-=+Xp;836|8+85@cc0`gOF;<52`A*vvLNLo
z(<h3o0NY@)MN3(502u*{O!MwW&qqrC5}2ip+S3vDn8#;1x`aS*L@~()NQ78lIsz%}
zf*5=PAr_%I2_9WF)k4mM?9oyH!^%>WpxD?)LJJx56u>$JwcL~o&TxFJ|HGp*elOfn
zhmIaD3XW^q1#$wpzPcf1V0jXk;G&JK^O@|R?hyV&wy-}r?1(c6N^q2+L8LPCx8<v0
z<m%37VM>6C4-qbg+wiu19wouhq&!f4e0@e(N}p?STIB!-xbJ~ROfn6V&oPqKxGF1?
zv~>nQF>LtkTQ;%h%u&myVYb261=eW*D5SQhm;0O`;E!}exOVq4a7#bn%tNUR><0pE
zmi952u*Ug07PP0F4uWsQ(QA={&C@O0s#+0S;GTA(03^vCf5*g+VGAv(?}<%RJHfca
z@4aA~tgim(S>m#e1+zSH?f88$t#-?Akf}xae8J7mn5?M<8f!N|*e7f&?orU&D>670
zx}9nulY7oR<PciDib)pRF0|5%E0?Un2JKdFNJwv8`64MT9(c}^oC)m$=6Gy!+C9uP
zOnGs^LbR>kfI0b*Q#|KRM7W}eH%`vGE=hE?P(Ny9*0=`nyn#&Ifh?g%OdQ8>!BMAL
zIClbujEax!I7rBFfxUNIiSA%bG~)KT+MLLutCV`<<w%2=(x<po*_wD+aB(_VvT>I;
z32;4zjssG`*C>9lO5W_UB75`}5ze%TQp_y}!8;DBc3T|_V_-^u7qF}}i8p;6#EJX;
z7&_(WTPy_J!DQ1$7}CoZzeHjPlaz*P=3xUqHgGp8p6ez!Gb+Nii7PNXZKWbfhSHcO
zOoI@id!S?Ui_^FwzaC|u75}@Sj93-3>kK)w{SiBvLVnWTh_zmV4F=`e0luUiMEf8g
z&L^JDCj_okOpeY?`dZ#9>v*DGkZvAAAtwY|sn4H#)eLJ9PS87utlS;t*g7<<_>_#M
z*_(EX9MwSKW<n`iZn#qcro4OsOvRQ*EcP9+9y#l$V|oa6^8k9lzPb9lKnRVRMx$ok
zg-hSl!$VpH!hn6)ajg_2LZ397gB%CNaHsK(i;pm}_p{ly(|?_ix|oq7-d2DU>kab<
zNRw}{vq%H{ed#T=MrQ8U;2+2nKcbw(EUA=AZ6)dBeK$mFHPL&#WA1BlNSXoU?lNiY
zeWnX=xD7~>`s==Bpo2L<Op<^sVf;W$PZBMFidX3sxB%|<^Yh*#zupBA63G_fN_r`B
z?i43^I3>#X#Q^Uf&~TB$MoOf0zk-<&T7Z5Ba_d8${u;dIRy-vQv}#^-S`01Z1ROhN
zlSSW>aegHV4>nZCG?N#_j9j+gP=lnC4mq|qr_&!N<euSI5%{O$_PEEHYnn0VJedZJ
zO%@87wN8q|L;auLsoGP~AsTq$6JaLTFKAkf2*(;UEVZy~ia}i>(m#2#qNds>A5@40
zR+6$D;M#pG^V)deqZbFvx{PXlCE3J~Qr55<l^`&2&^Hyu2|ETS1m?~Awkh^<8LASY
z(Q1ofzX%I1k(;R%W}Hhw$$F2ks<2fi!VGVVL+{RovV`}jB<dNVTLfUq+h1^^>db*0
z?0a2}%R5D-)XPIPv7zz31`<hw1J9Cvt=Y{u>$2xtpyvggF-G*=z?ddkXa)<JHUu^d
z4Tv=~eKMrs8kh1ESrN;I5N)BfQP)6g@JiU38@&0B_Kk}TcaDQ^z=om>yiPphE>6T=
zX?R<2T|69Xn_X4GSTfnsXsgNqK%1@;#+XE}H&(;Dqfq5(P*euPa;(cIr%l52t>m)#
z`;@IJ*)7&elM~w1LW(3Ao2^u7UE3j0x00u3lqD}0vFEy4H@G<U&#=4qMUq={E$_M7
zlzl?Ro5Q%k5+y`UG>I}oRZY|J9jP7nq-BHuB;Rm-)6PyiD{^eyLqS}siy>zyh^i&m
zJ2!jk6z6b(pj(+m%G}^Z0Ao5^`|xdzjNJkW;7L+mM=}ogR<h6>bUlDUDJEmbkDd-E
zki&yM8ylrGd|;s{R|2_*L6f94iLIVbz?-Y_TLKcsq=)|Mj>r<1Q#nU2bW8j&cW_h#
z@xAheQb`?}JD%$Qte~_P)vMnH5X>kVpk|L_EF9;<8$-UH2NCdPn5MWXpVCVfosa@A
zGx%HHPOo_ihR$_Fp4bIF0b!S|HSJQIR=qKKjp^v4prz7Q7HYJJ_cgcA@(lP)^~HVN
zZnENM7_FjoUSRXo6hx@l8Oq-L+lC^ppGtX5kj4CEIla++fpBX!q>`oa8b(>AFr$(^
zQGolRK%g)0KVN<vJ=YJPrznf&9C`+xmM6HhprqgBq*SaS%~V>J^s8Ruy8hIqgG*1~
zedXg3Qjc-Q7oIw=`t#5@Z=eS!Ti%LqZ$V$IX1HyfSSf4*WuUAN2&c7U-Y-=#!@Bca
zAWl{Ke6?}>oln-8I09zzFr*e|sJiAnp=j8ovX%_Er2L%2sIMNso;~7VQqpEhPV`1d
z$)>rs9vWz^n8CiXz8sjOW+t03sItW5iRY?ca1|m5PIlfpGopz*no{ABr$npN7l|<d
zCRIJCP0*vkPE<4P1pZ}R)u)PHJD>CpnhsT=OyQvO=;1^cEc6c26Slfm59m0r%E2{H
zqNk=;+16=Wte+x;lfjOyXK$zw)B!eAY{)Mt87>FAaPJ&wBRvTGGcNh0I#$a{ylIcB
zq<3^-r!Gw%4o4G_%YY^q16Ai|7$aY+bgN^23X<AO0P3Q0R*vP2cB)%MyjODW#l)?{
zg~?n=ZDc4*+8%<kKlBAiR&hDvT61DY?+e)=-CO!=1s6@f`<a=}EMB?e2{|^6+TBZe
zRcd!T{Rmrg+Nt$7la@86|F%oD7GNr;ytn=~TCT?7Vs0bqyjkXnSFqS7BG#oUc>*wP
zt2n6TM3iw^X5Ah!*jeG{LdclcTM>L8j>rrPoeHkRp6DUG5J6)7s^&uZ39~zPuLxj{
zJWO1aQSKu9HPj}2r2@wk`}5R`i_LBW^CZ{<e*NB^bC$WBm^SUO*nXFJrUB0d$?RF7
ztSfB^IDloWfIj%kVpTZOZ;|vU673?p6)=2u%A{c>H#CJ$L9F&%D>=fR7T6`!$)U^S
z&suTjjrUhWt|%&6WUPFb{;%0K7Cb2O&~k`H|8-u19){mK5GLm{SyaPT85j%WV>N8+
z({MD6#fDu!bC5GVPGV<NfyKz9gM=;#*GT6BxHVsvx$(SY8z`2S*yX5uo6eJ8^}%c)
zB0$<UDur)EkRv40W|(=>0w)|!=DF2R+9vjet2UDiV+?}kv@M_EeYT4ui7Y~e*#V&g
zz@ll~_8vQakju1M59t*A#-W{kP%lxSSZ2shI^ztL=opKsqY{Mn$9w9matc|u=J%ua
zK&9#o0toWf@`ZhtYq~OBTfMZBXkH}bR^gd7Kt2#rJ#@_XLbzX>Yz$;7y=uixRC|Lf
zOfA9prMy!PlwuUer2~L$0(0}n8aZ;Ue;M|^(WPb@HJf%LH7bo|sB03yA(Cs_IY*F@
zfUj<gqhqA9qTwOK^mI~w513r@z;X#GxYidOBhGD&V8#OKagsCfB=635P9T?tTUn0n
zqjIQmQM1PjT{7h%FEWLT3G=LOrK3(ISJu$?_8Q!q;39|`I3%r|CCjOBJ`|s?i%O1Y
zTWEG8sA8sbX(TS0bOh3395tA-C?!qklE4L1g3NY277qFMo!RL;Ie+?DF|-=SwsLt&
ziIG-d2B94%NIxa2per5`Y{i`wq#Gjb-*&70v=*v_Im6UF=eKGlm4Hq*R1CN+@{&jY
zT5M<-;bKUd>1w>)im~ombzG}paahBbL7O9Kn{}|0EY$+59j`yBsVX|;sVi)2d{piX
z>EP7s@>DXHSxcV!u-va!TDOln)yO(XN<MRnZcPO`N#uV(ha|q>(zQZUEogPt#EQtD
z=inAL>Ml7_&}<5d_FA!V>IdUd&s}uMw@BvMItffYr*ou_P%F-OAr-mDqMs?%yy<bx
zW}7%t@gPREHM5#-;$fG2SeFPrdx@6CnRz*vUN8X|cT1Bkd;GRqk6h%3&=?-TVh91L
zlqG|NF3%RJ#>J(vt$w5wo`5=<hsUTz6)c%k;22fs>bfX`I}ER@P9)DwM+gj2YR&Nc
z-5!@lRaDW6r<Wmum}DegA-84f4&RFu-3S_84l<uR%UAs_)u~X9`zd0Z{CAi>Yu4YN
z=vxNi)G0sZkLAW#IShRz^71)6K|0f1?q$s0#`F+j1U7Y&n$>{12~V!l0ll<|vB?^9
zstil8ifVubeYh%(Q@R#XD|Ch^tLXMPqMuDyxBnt2aYJZN`P~7ys6>daYs?EhY}9ZD
zwgDd3dGkeSQP>0sNo&?yDP%hS;v96wTdgv}+GF_c0)}94>m|vx=sQ;w6&9>mJ?x6Y
zHA8?~g>p?-6ekdB6TgUw+YHs#pG4<iKLC$+stUIE96;hMZOYe33y{rCSPnSs4GN4?
zDSK8=A~l8;Tb-j0$bK%~zT^p>w4ov9L`rx;J8FzVb5v<`!j+FTzAXz0WSD0K2dYpx
z$(RaeXkVd@_W)B}HRiBX`GA4`BSZnD&rqt+0cTO?LqA&XT<8*C$4J>sg%=GN=!I8H
z#m@Ov*}u*LS+U5TK00*cVJRzN>YP+Y9Rc5OjWu7D0$1EzDysx7;n;sZnq=w#-ljo!
zebtU2466v@K>9}<w_*`YHwbOQa3s~y6Uw+VN=duuM1^jk98AI|Uar?Tun&P3=1roz
zL6_Jch3X#9wrQ!$V3+H)Xc3<P%%({-j&uDgc)%R)l9%|v*^f2q=`H=s8Oy6S?GphQ
zxsU@gO~>K3MtpAYO(l2N5;86uJ@?V1cyAY!{g-zn^+<yhV3A{~@m2zlRe`6dJ6B&?
zl@$qUD0`d^)HO?zMO%*hV(;mE(m8PUzRZ6{rJ@+_<P_FeiqS*lvTPq<2KN#Ynr`~#
z8@RskJ}NUlpE}uj98%EXyt_6nha|6L>l%x2<>BxU0FIrRrTnEhtg?ryyy_6HSfWx4
z&;%#IpHn8TKt2{)q~Q-lvM)g@WOUZ04MaG{MB@PG0qzW~x9b&Wv9}E;MMF)D7~~$6
zd7DzZeJS^0tQ~?PxT>&nhOrtl;sss<>+gwl>~}Fsh6_<Mqv@okL9E&hxs~o>S?*k4
zP|x5ndp?+;9+}Wj8ru56tD;D&`gaRg8s=weN8W_>y_kkpVC@6wf@cdRY|2rA67pCS
zD|s+8HFl&fsj&;d1MX5OLXuFaE=D+{Fm+jGLWR5%u!`u(nYbd==~joRyDmZ(HIR$w
z%Bp5cIDh4fHuV{Tu?Sg|ho*v^OE_MK=k=~0zyuyg)xS)~4JkKFK2>ldAX2zigeg|U
zFmX>4;7}qpOTlZlmKG(WwHY#loJ*0A0p){%DbW&3UWpqRq%vSb9Tm!eO-nK@pNL(d
z7DvAJe`bPidKsGFoNv|jLFOCTu}rjOcF57(2tBE3=b@>KIl?^xHJw9+fhqyFk)N+9
zzMit~lU@VYwrb4WnD_x;-Riqw5~kIK)ua7xg;SQs5#*d&gabi^t~+~g)JX3G!AG8D
zk&Ihr0inPHP2OE-ENY|ME!!fJ9LR(Km0?mMY6voShet=t9Y0s!wTMRK<8CHGaa(2-
zVyMVA(J>BU?&wv&HiagQMmKX|=$JNZ7?{A-I95116F%y`(J5t6D)HcvBblLwL34hJ
zltzNT@e?ch8b+a+y{@jXVy2H0s83pjl~3=dE)eBZ<AY}-*>H$;u+P};M!yx{3{K8@
z2?tICDlWZ2Ci6YM3zjRONu#n|K{K|;Ruc2PkYUp8Q^&mDEUhJLt<GS8^NJt4KhYhx
zyWDc*TuFCq&AV&!16$<gbEr9mbWoR+)RGV`QE6OryTSewsxrFW{#2P*Ti1a5=qO0q
z@zKpU;5v-DFs709cBWIGHcbcvq}mnm{9wm}{U=?UDKaT0$vs}f3Ky!IjZoty9t(WH
z#wBf>#01!|DLhWFWmpP0exWH`+dqtmJNO(~pod@<%iB<6Va3=Ok39k0!mVH1lr}1a
z^bh_zlMkb2OT@FKHJA@~ocK3Kl%NhPEr=276SXTI^L^7CW=z7uD=${`tR|L*sWX-z
zTpE4Cl3c_9AP191Ph!}+&Yg>LzFY(|##&hMVJgyJJ0(eFQcl+nxWc?jBeX0=DHDFJ
zV6r(~ZTZWDVSw1dj)|OGoSAOg`@N*oE8lpmUc5CrrA8Mer<0AkrmPTlOOpm$(I95&
z4Uh<(XCPnnGCusSr)jmDpJ+zMr=aogY=2rqD2>gOks{FTW7a4S{ov0H;gy732<#CT
zI<ESq=o28hF1k(rZEoM`F%$atu0$PhImfbapelEr{z}{)Pv7<)RyIub6G9VIqIfKF
zL7@GbWJECHs|p?LwSg;aMW^5my6Q!l(9Wo|b+h;*(%o?V9#n}{XX(J_yCh@a*2|^@
zVxXU<I9J<6Z9p))_7`5Xnu>|K_elsq#iYp4p#^6DrBCjT1ft6B%Z55<RYgZY#5tUa
zlJcVQ8_oU6rsaE&y;WpLYGLA3M1P${$6ospKTGS3<X1nhZY$M~dISo*DCQ`5{IW9_
zUeNb1N)bb!EKpxcq9?FF9Dt>m`ZawSF)KDc2Zw`PG`C@6vlA;pInF?N0;-8?d_z&U
zgrxrL)L4P_hTlW$-16@f3y*DNg|FFMo8gxAfid-d(}Z+^q<9-0Tf9%cB1?2nJfwmT
z7GvS_=JD42;YxQCgqzI8W+xM4{esX(vT-ReBb|cKN_h8Tb4)%N)OG?@V@T_WJBE$g
zBpK5c93i{}-{rq}pZFI22wdpjPqz()RrMWl*H75nR_f8Kblc6$&>kZ80m|v>v34^_
zx+PQy)i=>ygnLYdR@<tc9oy}~vw}ee;*#R8M!6*`97towCs)V74HDIDVojo06wxP{
z9&rA!dpNR*7ifAEQ5U<7JRqN?NtJrcyYc7u3#G!m1ukLwYY9E-tM$|fx;@zSa}swP
zWuHVlP$9LS?x94jvz2rQ4rJsS(5n6tkhFk(B&7@FyqExP4Ti?o4m`Vg_8yKwdPwi6
zfHDXn>8d&*9?vOr>hh;<+BA4jxIBxG^f*6lBpD(g@tJ|nUlQ!kvsr5zGJbS{BNS|4
zy~*d1jb-{B5S({j(ku$MDkBQ+v7arxv=Dxh$+B^veE^{$k|LLRuHgV!O3EZ|6$`U=
zQGD{f=?ZELsPwe35~}5upS)jMZ4ophiZn*1U4*=4gxH6PBjO#vbSaaXd+mt|rKc;S
z*fr-?eK8h<JE)oA4U2kBeJpBndV8sJYau+oT?WG|g}N2>0X@=+if(Fkh^etPeF7u`
z%=X-v2^Q2E&TC4*c?O<65j2Xx{C`p5lE;R4I~zfx;;8ZHjJ|d_U=%}<F=)Be;%!(n
z9TQZDPW36HGo%%~x-KEya?7h^l;)vdRK@oP&}<L)FP!C`$c$|u46(vq4@u4y%T4%9
zV(<M%Go>Xsr4J)xM%CfS6+k5F*_G7L{7sbLnaN>G0AV~Xv<d;&w_7G|r(6N`WvOAj
zN_AthTU7iHzpcBz$zrR{4avd$I=(68W^vBig-}?ds|YVnW+b5uv@<0nfI#!7NjK9N
zWfLv?!3WO|CmhiUUo~lFBJUC@b<lM2yr2}=7A}XY+y^MQYmmg%B8!LJb%^!(aa`JP
z@(svKv-r`#x#4nbO0^Zpogn0$Re<^$TPxcqCsQ|OY6=h6xPT#710l2g_JWm)o`ifD
zhyxI`8>K=(f&X+)*|*6CDWFJ_7|6rnT67oFv;ZRo%DQ;I&d*lQlA$W~q?Pr;7_)J!
z($uy+z{OPU^<v6`Bx@4;wHd9t<Gb}D^5by~VT)gYUMfub2s-4p9&CibD)0aGHti8F
z2t0LXpW06^=!z|-J0TW;k9VY}m1`s52?s9-pzsX60Y}Aiw@qu^)%6cGiyBGvi+Ke&
zP^&mc2rxk+qB6`CB*%{<*_&2n9WN$U>=)1si6Sr=Bu6@X6z2qIX2EZjD+Xq`^0o%z
z`diD&q2d%r#!APzAZV-}d7!1hB~KefDxT@ryzu5W2_SFYzBc((ma6ge<Ai=2<yB|w
zG{M@wJ||wpJ2S8?9(?H%G+e9Ho-z2eY<C*xDretYcSdq8A4r=k`W_HbzskIOQ4f6z
zO}Hg~noiAd70(rWYln_CY@2Cy!j&FkmK6;kJx+06m!S{uXwBB~Om|6>CjSK|3LLki
zo^Hkn79>;-JYUyTsyc&eS*&u)Zd%)*L4X{xlw+<KWgo)+Zf#|~=yMpGKP6l|^y_ND
zy;^#0gJXH2dlifEd@5IAn1z~~Jxz~EvGOT_gj&1KUt9esB&@q%AB?a2iq;S5l53=x
zP_&Ag6;Dp4JvNS(93=t0$b|P-U~?tUoulVE9X1y{OVg@^xV67_=T#vJy`!lG0#OR4
zP?{^<y7Uu;L{FFnL;5Q)otSEX2$`i7h`%+HK<M6KQVr{PJYwRVn(h7qVT>1`R;^)M
z2)B=h2vLDs@(eXffx(tJf)OV+Ji}d<#v=FfLujT~Vz^qMS%00>yq>6GATtqCz@#DD
zGEOH4q(jd&Yg&YbK5G~3&(N;S+9Dk^S-p(i?t^HGynW`ZL&xgnWH_@(HJZp50K{1S
zUb)tkMd>+IuNgtUr~B18PwWNFDHW37lvETBhb|aoiDr7iDNGc<7O#>)HG40}OoXza
z=y|73R4ESC^HmR>W=xHGfCkV^xnJA=P&a)|OC|=c@DZ=4U|1P~Etw0%R)rWJ>e9%N
zu!}m!AHL6+9bcn;Jh_LW;L$^z=!M9ps>-}#@Fmk)!l|_-h<x^Tg&&$5q+046u@nvI
z_jUIlZ17F@bAOim_GpGqqhMbGPO@^wYb3n6ue{(|)wqBtJ4<@2xeTybgmPr7e}Jdv
z8l3GjWs-SF<JCEU&}ZzTOIrH{&OS#wCmEV6d&5*~LX5-ivg_fD+ogN88T2SQ2-F@b
z))o*UU<xATl54Wc7R;6J<tbrQ(S>lT9#Mys>zs;pJZhE>fy3#!WLN$+ls4Jyx{*92
zH|0UaX8UkFaW&Z5_byQhWD<W57|7X*xaXkL(j`TTDN$)Sb&l$k8}G!8zoLM^ju|tk
z<;6%cDA=;hCikX(Izt=u^CP8$^Ut#?xrZD63P~z2cBX*!1%=Pz8cL#?Syb8wj$-Vt
zBp=D(1s#n`mhA^^a28r)LDO}{5W+3%uLS<%M0Uw!LI{|#6UC#dX!a)C?RE9RA}v%=
z*OSX7L!Gj#=UH=WSqIVpItk;ePRMAs@nJDcXUH4U9$Av270!ELO=XPMJr5KzC1W%J
zr_&a5ynDspyYR_xDi&(=S`<0XG{{G#<HOgDk+!?*t0u0cCQ<rr=`c?VtlJy4pSui*
zyY(3>5l^(QxsP0F<n<l1fGiVLl`+aZ!zn<HH?}ic9V-qNJw;zcmmJYebs@@5t4w2%
zdRF<VMujeaf>MZ)=p{owfSXtPz}KBSvaAzul}#EHdx=&=kLy^{y~GPvVJUl^jc8d2
z(N4ZX-T^578N8(JPs<lC$NiP&yoPH~pnzXn&CK1=b(+lUF|)e2Hp}$oV(Cef4`M%-
z&vMYE?u<|W?-Z36f%;sSMw8|R_4jdEnJo8urjuNQ9hd*Dp)lmuc-l=??0pYk`KKj@
z9vAWo7t~FV0J7QG<)zbJ7)#Ql_z;@)+|~BD7VE}kAwk;bElJu6jNO{jN%`H5$8kDT
z1GV0Z-n-5Oh(|)VyIBtnLy8~=xrmi+%+6R()jFd+Zq7`0XMFvDflm=8D|yOW^rJvK
zFdaTk_g=1=HxPj~29c)f3BI<r4X_3ArXya&Rqh(}6Ew85%B|%a+$L@pmT>m&5F}fX
z2^*I~gqL1Vq-nWGO`Qe$0j>u?xnu=cJr{-Rc|OQ}62XvbfmsusJUQA&0sk+_BDB!r
zd3wf8uxt1ATl~))8JJ>!n0M^cK)%ih+ANjZ{`Lbc98!fHvg|I?_l9vS2WnYb3r1cT
z$Ypzn5Lc8OGxm7F*Gfl(eyn@V1&LWY6d4Ym?~(B=nWlLOcXO7w0FM9kjZy37bd)L#
zw?8@D(A&r_4DxKfa)l;L4q&#?MsI?A+Qsy2b@3dh5YIt<aWWD~^DZ{SFQ!`5;71O+
z>J`5&E?O(9+2Wka20_rvz!~s;jX3!U@@0Fz`GG-x5!qyp$Bx$Ri@z2GDkVL^Kkq7I
zfaHoMs&su9A)t>Nj(($^&Jj244vTPN%Zc+Ncp%GY3EH~Mw>{DRNA|iBs%Y$sE^2O0
zn-BtHJqwk9M(#pUc&yIdKQeV>iS`O>nRpn20u1x<zev1s8{qQZQ=<kldLtHy!REuW
zh!HyjG5nGLC`J;png_0kVRDFL;+uaDCnTm56cn5y=)ghh0e-tdshMaWK;0HCWCC=1
z=%ljdGjdu@44zlkM*JFoWjS!RB(Qh;4ng&@d`Pl=0nKtaO4Rpzs4m%d7xJwZ@C1z~
zH<<I8H37?9<Uxj~i$IE>Lsea4`*4RtqKg*42~wiq(?^~6PGOI*sL|K}N#i!TS>Tgc
zrVfx1a<C5Z$T+vB<-!t@Yf6FQ!IB$!{o-BjKXunz0fzZdL}&VFoUUnTY;SjKPtF)S
z2Z6!OV%&)I;M?Lp%H~op`9MG=5w3GGhX+BcQiZ{(U7#)8hlKUt&-|iu@+($m;?q?q
z+`&P3JvGex(;3(&BtA0PGM1_C#-`{mX2FxiF=_aP2{3~-Xje;o=Ib<&WK9a$xP|7=
zvI?3WK*i!s=Rvy+E7wn`4(|x-DUU+Ysnd@H=hs?+CRaKK2-s&RE1Sjns)A5(&gC+b
zA83;_`3ZfIpgEKZU}jy(58rw;<-_n}!qT2V5D*_*t#g$-&h|;2jCgxB0nHx-Ge6-I
z)d_Ww2f@7NeP=3KWjX`82w_J>jJ<i4fOEO=<k9fCurO>o+SUu~<SQb*>-@3k&`-Cb
z`;AqwFFS}10>|$%E1BR4HPsAfPj?0=5yk5=E)@Uhkir@RL-}=EerWL{S?c0cXcow8
zzhlp><S+iU0UOa#+9a(OH5liuLd(-gprGmH=p`G3Q)AWX)?;P^6R8@WESA%xpEER&
z1+0rx`JHt&qG>e@Lz7MR0kdE!zL-2Ed8U0q-a~S!lJ(0?t@-(Hxu35aC=){74^>fu
zPU<eNkOkgH--#q(=k?A#fpQjg2)+j#enw;eig=wF!vHmuXqJCffX+x_XpGkSgej^|
z1}n9u&MpIeGY@Zdgw!x<9X5&`sKba|r94Gz9Uf9MGDv&&SOYia_a*WlSo9>qy7;0B
z)f+xgkEZT_RP^(aD+A&^dSMEW1Sll8TN{BJqc%mgMk2&Q)_8yr(T@~*<^V{8;i1Rh
zjbRADh(C1k2hu#KF!$8(aR0cPc~)}j=2MY)#-msDK%!vxX~?TQHzFY9#+9J!0yHES
zWWXoSRAJs3a&&RXK|^EbEbEW7%25syhHg}>%{PvjCSlEQp^#XdO<IHuej;uNWrz(2
z1TR1u_jp{gYJ$%@x0yD93p(g-Q#Moa(;9ZN6(Z$*uDKRq$w$|9%0llVD<>GzF40d)
zjDJ_iH)0`)^6(g2>Bmwz#zwSNj}P8LmPiMb?pR3<mwDI_%}I?KuNPgR)WT-{+9J(h
zkJ2XZf5zdfF39y^&CENh|Kb_~I5)K>ta)~dve;+2t$&7JKDV^_-9D`7F!;GYuwiXt
z4ZzD~W@E=>dkQaiEf-gBX{%3+&+GqXrl_P&%U#trq#&MXzt$1rEQ`ET{BW&eyzzAr
z$RI9}R609${i<uw^1Zyg|K>J)fGFNef>Bxjsr6{KfSwr_&}z6$G89>ICsX2N#%viS
zTuVGTPs59U{g9q^4^3BI#@;g%d53nzY?7T=Q<T=Gof{ukPZ>|&`hNTQgl_iz{;ZPw
zIQe0j_-Xp)*|7b-d*Je=wf^`V*?BbG#KpIO*?4!f`7&Tx-kOkp(7?baMm(HQ^ZD27
zhnbs5|3>mFdskTd?AT8ujDday!?;-Zshc5I?V`UpSKS3>o_)I$hi{aB{yZ+A+Hsd6
z=!sh7pN6cwm^txbFWOf75cie6wmIv03X3_=e);TTUw_S5iGbnstk-Tg)mso``B}~m
z#~LC!LAfc6CpckF&8vJ_GN#!NvR^JC;4e?kCpzg7%uSo7eYoSD|1{#=^&arJZK3r3
zKCL-v+U&80{n<cteB|>5yZIcfjNl9l8kmbA_`ZF6;s4YR$l?FIeo*_lUip_iocR9q
zIWF&fP6&VB-@JW2?HqPUUru}2Q3_IL^ZJ(5_~|fHnBX-fLqQ_Qo~heG9ZcGJ{;>A(
zCqr?N4&O7${FJu&7=Gs<-u1CmRixuiO*dT>*eOU<R;mr$X<~6_C4H^rs6Dsvjb<-b
zJ%cWMU5E!P0Cfbte5b^GzNHcToSPoI_H=R#%4tqQ-90*PeA7m76D-=iKH&AVawJVe
z|McV9JDnvk(@VWgD}OIVd|<fBzI8_lldTQt@tp3|+hY$%e`2u9jwU33rd6$uG&TGF
zT&4Mb3@1H&-~UGAAalmn;&i?BI<)2YeIocisNw&SWq4ikeP_k}*z={K|IARK26r_1
zjF95X>7hAYy!RaYdF%P?JoJ72VWpszfHAfK{Fgrbm;DD?{12)4pUB9<!piuc_J1Cj
z{vV=I+1<{VkY3)v^nXSNV;d(z=KrM|6^$KjogIvf9SPa~w;*h5<MglZNcbNj@*n;v
zV+=4i5VCb6)MEHoU}R+^WMpC0f%!*3{#WNe>;5k}Dequwq-5+wsP#`wM2wJL+1SmA
zP=}CS*w)I{LCMa*$e8dyfTge_BO&{L<s6v^IsPZ*<NL>0{uBQ<1BPB%nVFE0@qec%
zE3*<Z{@1RuGW$Od|F_OW$oL;qivM`b{~($FHN^P;I{Gim$@pJ6*?;d%FZdsz)8-$|
zNk}hZ>|$<YtSBz@|K~ijl3kUR*3d&|y4bsBe-RUsK4N=76V7x0K?76xE8!;(5)wq_
zA_6XkicF~rQ0@g54<$AdMTHFvFkFGYN0J}zQxFk7+KRM<zNun;*iQc%(b!o#X<1n_
zz42aY2a^8`0PA;B2livhQ%AkN=+pj%GBNl9f{6r-pbp%-XJP^-{we~p_}RsqmR9;_
zxZ(Ml&JWPBLDM5o=D7Uh8%NA8OacJ}Bf7-K<3omV1d^!KFoebQ12+DcM9CDw$b_B;
zonJ|OFj!;tTyjj^F_xM_c9@5)F^$#9k{#J0znxCHR}cx7r=3c=Yg*t1Y22kOkq&h9
zLb0&$nkfy$fSRT^c|w+F^_NK$73=!%JqQp~;vi?I146_br&%_TTe0b3IM`na!(!x>
zRP&?LQIq$(2BkMcM(V@?nY}PK>6ynyxM&6pzZ%<QQD9OH>ol{tt18^9D~;u2v$vkL
z9ef|9FWym)50yKz%b9G!$ZU-rtIJCIE_9%063q;}hVCR4phjy5fup@jxf?>DdvKt}
z?aT-K5G&pI!F@P#*oezZD@WiQOFHUP_K%zZ+wq<d&X=@_>kn1#Vhn!&-x6rd#-c~X
zCB;%Alap`=DKmht7o?wqUQY9=u>qRQoL-E(;8PWa(?sZ?zh)i5JpSsjbO4wj-=#fY
zOg3^zET1e(R5NEiAn#yK`Bn+YQCnUh;oqPnHvAqS-WOU(j4-3!on}>WHI6Y%9^WVL
z1hCrSHha>7#7f7{a4`S}(tH}Mf}J3%K9FCrkWRTUEdF#1AT;{$xPHubpxcB%L4JRb
zK$Ah~{(zVZfYl4~tpdRaGOhx<1X|buE&6-Rg2@K3*+FQ7srAC!!NU283&4c*NihI#
z`<p`r+#;dn3zo;C7b2z!EhFJ*Lb(eI%5$KC4hjE_MT!@An<Xp7qzWw06PD+F{OyF@
z4y6<Lo(nlk$O7>N>>Y%h3bJ4TzY5gsw^qxI3nkt^u`A++mI;Z`yRj$Piq417(vPu+
za|=Whtk<6aB`^vFIwz(Mg>xq&6st}Gj7(%1M_dR}CYm0LP>9nO^(W5$5ELRb&ma{O
zeHiN?R3mcFP}N}BP?BLO)hJa}8snJF1c}-IEuhG7sjgU^yprDqnhiN4igr*{KSp1x
zHl+@9)!>pF7h$9qYaiFnrxjD1$%eHWtOao;vcvCU0Dh0`&aIPb8}%jtvCr|=(2J-W
z#uwKYe<y}uxQ9FzS`*AN0Ffw}ki?2a83`Ne1nMgYxt~SBzf{hNI0VUkP}`8QE_zk4
zQv#PvHUU*4gakv8gfgwsUs=L}Sci<4tcxgNj0+&{fT<y%D_2dDL#RiJ7|$=CNI`}w
zCy6U6v?j|b*(TsF;4WOG2w!Tms9v7ho~0?*CE_jVO)s9nobr%zFjkdN5oeink>W`z
zm$;JRnxaRSL#{{UEBRgg*$Sf2C(x(lUr?)>C$`tv&l@Zunx3Cz7-pDm_}4ISpLIxq
zv@_m6zU7x(nZQ}?JZTXTw$MV6`+RGoOe5F2@j3&ZID6s8Lc-b5Bf)9cBeXH8vDOjA
zzneAeqlR%sh<*nBS7t@5qR52Ej>wn?mgBaWgP9Gs8gt#BPRgV=DjO=VB;q8KB;cf&
za%mOYCDf&?a_e%rMFtBp3j>Qai;pF`il~{A8Q1KYEIpQ=!_Uz3+V;O5t?w331LwTw
z3E1h_-Pl;zD%dG3!>m~8HtA#ON9iXlBaLR7uuWi^N17*1x(rEa*OSU7qzw_Ac~#X{
zCA4#Vg<BQ8RYs)^>ZS#<4bvz(@pM}3f-TxDO0Gh3QuONddNm3+d3*{vRXK${;yqfv
z<Gr(l>-rIb8GWUB;dwm<*#-rBM!(DBD(0vPGz++gIgFa^!|(VGw8(1zW=X_LM2*QP
ztuAgW>$lG|&cIn7n~||puy%~(*KTTPREjO<at`o}dKI{5yivpQMyN+*p>Lt<(Ol6e
z(O%FHXi#c^t6Mjo*S-&|52jn{7<rF`SR5ENOc!q*H&vC<?zr?^d2^@h)NY}7$ac&;
zBRms-kbN*h@`k#Fb|Jj1I=N7E1bHtZU!3l>PTxfyK$3fs*DXkt>||+7Q%=KA7r??{
z++r-!Vmi#(@3rDO#L)rhBK6$t@)lJ#k`6R4-X~>NqE1`}tp~SOdDp&LKd2F<5aYxn
zMiNUBPOxWSb;D9>)Z)}?TH;>}Z!B&~__+A~@<s8Xbh~s{c+<Zce1Uwqyl?#<#@;eK
zZe`orHO7vaIfj_+m>FYcW@ct)h?$w0?U<RFnVC6eX8xRHWv{jGKIiW9qo1dxmei%L
z*)`_WJ5;)wKi_+tf06`Y1}XWt50MKZ0HOfK2}%1A0n{F(yA!ap*&ByyN|Qis1_g-c
znb*OO{UZaEI`X3}8s!)I5~5@026-nBCr1zp9ezIEo@SwlfvEw(kT4Wc6i0zU!CwAZ
zL2-Up{sex}1f?&^)jI;ADxtXf94I)L$gTtqHidUntD*th$6FBFr<8PR@zuvmHnqEj
z!{cR<nw`qlWZ0NEpVr~tf)Kk3cg4!CH5(mwLFQwc1D>My`pEafF4XV!pQAt$e5-sX
z`4W26gLH+<gpq}}fh4(WH|(o4FTHjOV<Tg8Na+eE3rCH8Ywl~Nc?h+GE6CO9IEY)R
zy6JPMd7FleXHVr3v$-at#7JzF4Vn|fU&U^OLJ3j`eUu@qO{&%m1@$wAq(|U?T<;|B
zSPXv}yc&G+U@%~Cv^Q*Xc=dnoWH>d2DfOExQ(JD7a8&PX+PrByiZI7D7g{_Y78nlG
z$6U7vUYn85l&)ygGO9lN(Z|!sBfZ&5F{TP*)@z1rcCu<vU23wN@L6N>MrU{{cuSIS
zCHiPx*<JBrb>!Cfq&4q0@5yn)0o-wA^`PlWDM?3JV{xKvL%no&<TCrRzFG0OO+j1L
zS_{@VLNB6*_Ip*UNV$pNY{6mfp%+F(@{iU-*ZPyRrT*pl_H}d5X}~bxUNBB<B&-(C
zfjcSFQf~8J?Ul`v?(w7S!=`paPfbt06QPT!aX~-9y#B5T`&qV`d8Y47v5Z||(S4QM
z*8P?*8#lbJh{Xp|bUBUpAk26y7hC=JIA`fl?2FF9?nMX0FB!LW6Dq+fS#v9ML3O!|
z#;#(n>j&Sa(>{%TqWGHf=5`%=o0MEVWGFfwHHMs;!jj?Wammx?cM%eV8o;V($Jtb~
zGnH0WQMNYh^$v0`8f^-fTc4ig6N(MXSk&3v)7)E6{9nT6u$$B4HIF@v4{FcMTMw+N
zU*fk*!`ndJ_a4=ssMc<q+;_v@(lCKTK0KaMwz<A(tZ*E-uf0ry6~bzK9dTiPF?!KG
z-p(e5kR(el`da!jdp~bb*m`}OIj=Qd9cUQg-@r@t_I_PivKw@~aGYGAM&MAeRB$}>
zA#~NH^1AnYI5c5;+pnGUweBu%vN*%T@u}5NXRznobn+<atH|2-HkQY^Tk}1={het?
z<FovN;I-nmueV+=Sx>sx{ZR+UlJ}Bv8DU=?-9A2FIuV&0{8+#9y?Xl3MEzG9`YSnS
zq@n$jul`I;f3AB^nuU3Jd9-cy^>BaXurj#nf3~6dnIr$nvj60?EWdJJDhXVg{~@Op
zw9$6{?@4W*BA8OlJO<~RP?yMptiZwmZRRn05}+O|x10`w5E|YG?{5txy%2L0Fj&YG
z!7?=}@FbKoTbUM8M-5V<pm`|84HYiqA2TOz8}B&BN8hks@7xUCjyTpm0l3r$;)JTK
z0l31MH8Bu|CDM~pyK+~7A-GV#0|{mh?d}RMOisdELBQ<=gYI)&+*Ltp3E6Z5o-kM+
zx8IVuabv@dv4X0?e~m~02KWIDP#QrT^#eH52ypiY<Ru|^08dFAG7ctyH5mW|S&nHI
zTB0v_4^UxXKU9=WNFv@!Di-DR;$#v!#i%%{{+rLN(d66J@L)V%^W-=PV_Zu~gVnu*
z?`^_GqZfEHuUle2bTDRb1SDTj6x<W=w-n*af_@&X4;Spp3P6}Tu7O9>d7U5Oo_O3;
zNg(;1FaUfdDyca?>gWb`_gsC>!M*iW8W@HY@>=+?g^~5m=MqF$Kn-cvb_>t{F|c52
zMTveL1z;+L3LFX}D&|1BadY4U9myMIIWElLE+Z-=aAcYk>SEj=bcp`~#1^XeF&sV4
zDKAarj$jUlb_N2;SU8`{3tkz*&ftrmyNF^NHTLcZIzW+f8$EWZU!C;!G=C>npbs7;
zk_c}U)}tr~-eCL{RG;so1X&1w8!wJ=Cy+HzFy2<LOc^~1hz=UL3b{~E0~dfzC;NQ@
zSWhMxH8(b#7ZA%3fLbIlCZdWKtSWdap}#nU;f~iAlJRd1ciYT|Imkv~AmKaScFc5`
zWtcIvfH-A1$^o|ne$Y1)ZSI%u&N+`*S#1E@<z7(XkevWns66z*cEf~z6Kz-vu-|0R
zv4+1nwV)Ud;2XkG)Z6!bpbxLPjxZVYBfqy%$3Kcpz^?=4O6ko+3&&gDNsnnF2uX!V
zK}F|&jQrBbNSZ1Qg0*8~*=QzqL_8j4`GQkB7El*{=i%1Ur{jjvM~-uv3eABO(MJrc
zas{)L#?bUAOTUXTk2YXN5M3lslgd(S6B2bcB6FYye>Qa3`4(9#xri}+N{weJz3q%=
z2=Qjw@~w$vo>Y+(mV^lqvCT8fPUaD}Nwg6xgAL~-2)iE)$+ZUy{+ZmHGn_`tSDC#L
zWcM>BCkd5j{gv#P!0p2@3>w~i2=j3KnKxQIFy>GRSNc5M_YBCZD6kv~A9nr~t8by`
z8O`t%+Y(%^!o}EH4yEk&fYe8`$>YPd139b0jCpHP##F+n<us8(KW5^gAPF)Aq_IJU
z@ihg!WnAa*<^W7#i_>pXZ#Jf(<|yVYOC;tfnJ;~nB(Vs?5l8tTCjk>H=6O<yl6SwS
z8~Kgb<IIce-4C!N4_Ngut&!wJMLguBVvN67V-IaJpit0zevwVeA+~3~lXB~)`=Ed9
zS#9JdK&;>!bvz*XsXKMECzHkuof3)>SU0h&KWP&-ilsXgzH`DaCkx6{09SXa-zhZJ
zS`Uo%EKpn5ep41%)IUd8jO+Cy9&GMqa_^^`yK+uiVy7UoWTWT8uKjbpa3hSukGib=
zTV#d<zA<qC3_%@0Mgd5D$Y~BVC4?g%ZKVhW<iTkXQV7R4zovprCE9&vsi5TtBpM`A
z7kZNpEsA4ulPbk1T!YEQ!MY&?7Iu{D?{fuk#0f$zGI}$6xsSoibdf17<d!piShG3%
z?lmK2Lail}7MaTGhw-5jEIE#f#McoP;N9BDFC*<woiXTNj|CWm|AS?TE=^hD{K)@Q
z%m@ZxTzAJ2PprU)I0hwjK<GLffY2#p3h42?*aW714rYR!X#=!9iTfM|4s?r~HWBy*
zu1icrTTiruRtko!6Qcs&43w=CTM7)LL)!|f#(R1L%<7{WXxawlbNaP6u@+nlNH?1Q
zBsFV((19*dBB4P5i|%P66^bvvR;3bcyuZGdj+lR(R)%)m0;?H$9b|ELTW@mZ^aAKH
zh6C79=VRs9ih5?R;tiDscnd$t&Q)th?C}2W>I*10PL0rn&EoS>CuofbrmcbtQ77WH
zu&<o~;9Mk#tiGh1Tn&hTd`M9|xrj14G}7F1@C<ywC4eVA(Ag<yxNDJeGBJA5Fw`Mg
zdO(Btdodw{aXSh&IEzB*gqD#UJGc+&JOyYn$0X@UF#1G<K2_gjBnq=<WWr^}Iw4j?
zorUvc?6o{rwAP{vlV<#8;$}`}d}d^4OlJaS@G!#iC988DCbEsxR5(jh>--cX*@T-V
zj`CU+q!g&7trWl&grwofW69)5j}@7-tkgH7x+=1hv-7eGbYeeiRtj0yZejPL^pXd+
z26u}bip+^{id={!i44awk~5H`$u<>St0^lliY@Z82q@>a$T?SE;_Y4yaSU0?(aV|1
z1IfwA>yZ`9-4><FH0E5UN))J0z8sKVyFHS*e0qU;0eoTLjoBR7puP_!3^ftJ-)7w|
zEXpp*BU7~xH>os<JA|JlF9J3RHc>DEG*PSVHJLRTHL0KRpJA9yo5`86olz`0Q*6&%
zE8w24m;#^LFpV`no@36rkcye0pNE>*G4{xB6ue3`C`XYWRtd?8E0iz137gY@Pt%}J
zjF*Cz{FY{y`fHo*!9S6I3YVxGGfC@aRcE!d53^fr0$N3Gf^M3(*E|rPx|&Dam*4+1
zb2Q^xJU#<EH9n<T>?!uv2578h3a4Aqp%u`{;^QT(64OF-K_oB6%6>r1yD~9HJ!h4*
zY0(YSjfbzB1BV|piIPJn0Nlsg_u7}#hZ!n~c9&w5e4iXB#+aB&?>sVNP?fYeGCEQ{
z!Y#`?EhU?DKsh~}-)%5w@X;X80BrO$g*>S_r69$U+L8{ZhPpCQTUy7uV~bdnU(``F
zYnN!)VOUXNPC-~<xHMe(M)^qDwj`t!R%yLDYx#b0q`t7SktK<B(cNZl=Om_lX{(O1
zj%V3qncSfvtvGGKqIs3UHMljPb)l{AHQpx}csZ+M^BZqOPPneGZs9gfe}U|m{9G|*
zwmkPC*LX;BOpn!5R%2#AmN?d0=9f*gqY>LOhc=ctP6nsL=t6PX4Dsp|qQpAgC395q
z1a!(_^(D1eJA2!>CdP)_X61&wMswTd-LhTmleVds7O-C3rhbG7g$Snfvh;`a01nSP
zoAaT|rL);R^An2mwe6RQ{*i#A>fwUrgoBhHPjQy@8HG6W<$Y&{p0=KCo~3X2w|Wjl
z&FL?8tfozNkCO-GK<vOMps5f9K)gWYKvZDHAcP?1&@OOhD5>ynxK7kPgnHTog;F9$
zPWwv}s#y3i5wiX0P_~e&NDho@gzS`VruXCUb?{Sx@#y!V73fEXD<L(ZNP^fQK+>t-
zZ=~;XN^|xEJ#l!$g2D^K9~kCH>j>&NB<L(GR$dztE~d8?``5)Qgd+)S2#bjFiRK8~
zL?Fae5@tATher76s0c9$LZVY-j7Wn>Ye{*ly$#G$XHyQNRnnIjmR%e+k0EWLe&~&}
za4OnUI-W++i>Syfz1BFckXS%F8eto*)j9jL0IU(MA+~+>1a8;dz*i!6iam{KqkJ#K
zh;`is+9xEH2(jQm1M7m*_5BS_N8I9&<7%0XcpYSJJF)yyYf=p={h3AG80VSmsqd0|
zBxEQL($82tx1YI<8)_I~hf~t#W6MF`I*%h42RIXMknU0BP+K%28#aWpT(TM}at7**
z_$PC=Hnz%9qamFkmqo-x<KwQs=uj=yqN%c5S}!A95$cP&B=~<>trs&^o~yzURn9vS
z(R7QyRu)Z?UYx25$Ov%r$V`={q-d{QF?|@L8ld9SRMVib?~O-3Bfm#RC0CA<k2_Pi
zRM2>yIv5_+^iYaxJG?ZRpJkhqnh%_}E4@)|woH3$+Omh8A6Hs$@M_G`=?)3AWzzVb
ztWawkGexxcZf}N9NvTsZQ?A}!RoI*xJ3N>Lt4Fs`tvs1^c)dMhdv>Hhre9KSygE_L
zF1I*?Se#YTm6xqeX=>KGD|bb>tMNQ}wO4;1E%Z+^Tzg%c?|M(!RQD7V>({N`4uS6h
z7rkB|XC8~!K|H2sHYO^LGRHcHcsC-CC$=r8+fG=qJQ_{{pQ8NFzO*kp$Xyxn<IgG0
zFguAkl{Aw!9;nzV*{X&p4o{waYF}SASyFLVd%8bF6d@jxaAQ_>v)PZ`ndvwPorYch
zQMbxLcQrCvO=C!v0r}POHDCj0tfqQdGX0Ka-KF!2=ZgO>q@S`;!{pfNfcY_JI6{!B
zS;L}b%OUTesDC!zbZuTj?XKD5QD7qs$HK-!<1qBNWiD>Q{z>7m^mO@o+1;_~jQy!_
zqhPaHbd#`ct8M9}2+SYW<dxw;6RcUiIpPlF*6tbW?rJrlB|y?+@M%}wa<Tkcvlu&x
zz39mH)bs@QwEfX(ZhMV5nz$Qyx4rPK?xb*Z`po0*tyS0Rht?V0K{c#riCfv5+gXS)
z)sla90CvlWGs|<)R_*JNyXDGyO}n_ulaW&=+fwtWr^IXZuKWFyD~=7P+dUJ7`Z?DB
zP{;i&y?&NsbaaeNe`>TpCECB$alhHdzv{T37~@YF_cxTW{ogRlPjX`ajzr!IJW*pk
z+jp+=lj^+Jh5x`Ev_BEZzaNuV+fLie((pI&vHc76`~#5uXDfbz7b;nM9lKwoNY2Jy
z|9A6#mZQHvloXSa5EmvFm!sf!va`|t4Qu%HZFOyot?VpqAZY*K8cTT#<6pC6(*ADj
z`wW^kwsyQm+BUd!@AO4X`yUI6#(H)}KhKN)o#g!6S^X1V{Z;VN{sn>l+l-v*k)0;p
z)Np)fkHH-I0k{Q*x+J84IMMN}F97@)nA|N0rVktK<+-s)E)(3<E_BsX{jaTt8A6^S
z6~G8#>1kRYi<KszV+`$`2=~k%TjfW`h{)15wN(**r1x`~7YAM|3d9p&o~)@gY~~r^
zY~iL8FS+9c6hWDWI*x4cg&nfmpjEFf_JkyHH)TJq?KVm-bIN*Bm8pX43M4VJlPzvk
z@af|D6MwHWZo0KQL|S;kM9!o4BwCaw2$;Ds@wm7N-Gl9c3z6jb`qre||DVD4>u31c
z;k4BMioIVy{=Wyo&tChxdwzG9gtqxR^!m@9G}AWx3H*NXH=bXxkAjf~mxAscyU{Q(
zFyk__FsnmQ3BN~`u`aiTp_%@B$Wd|I>iz_Y@1OnTXulVJ?Lx(?Z6%~{Y-sdO8Cl+s
zDr={2uJCgYF@0@4V+%tFW?Eb-rN6eIrFq|i+rjWxB;YbKF}(j5w4Hu0(J(Nw{BG2H
zm+RBw(*9<We@F7K6@O0qPn7(H2Y)ZV<4OkVpJ(=8W^t{R8<m`qg3Fk<P;J|>eTd9H
zumyxR_afvALRjfO#qb$`z*^$-gZ_du1cX4Js71g>6?U=1FM%a4Hqv0k6AFd^>vUrQ
zMZArZ$)uH5XUZ!k#;lbxcJ^Yhmcn#px~8hqlHnzz1PagEUwr_2j$Ig(Y5m+8{loUw
z`}}&RORlbC9WXFQwi=e$ow65PF`w?>V@5aj=7X`#eX2boqoiR%ygQ}e#}I?Pen{)W
zfQD3YD%9J6@}Am8J4V^Wx2OtdZ5r7?x)3KSwItUhPblj6YwMix{#78L9A%&{K0EsG
z?4oHO<(ioswzE1@>Ny3M1<74Jy~tjzUK-EHizz)8mD*F@>?-i*gG?!5u~mr6J{@;N
zj$CD2mhZA!7T}5j0~XtVnPTFG=bC5o3o#a6M@m^5^vAHTl5yrxUaa2WPcjj4k$^}3
zgpn1{25I&2$7Xtpf)lVji1ryMNDfYj?3`*}`m*YmH>8YI7u7G}Ym8Co$?=In_?UFk
z)RDE;i2S^w*$dHFRiEpA7>&(-6cja?KKKY#>m=kAs_SS3-aQAk2p^(5qTr+5S4WkM
zW-~njk$kccyCH!Gn6-Dfz$8uk$bh6OI|mJ^xJ}l#RX5Za-*FP_w`?7^To+^`g+Kdf
zl;2sdKqF;ASGj*Sx8<oq4ilfGq@z{2ta5Nsqu}5>CxMk$dzsnST`G^JBvC5=i0&_p
zA=Br8rAVg3L*8%RFa7C}Bb~Ub9u3Q3VqMg%QfbHrzY<(gUC>vMxzMy<yoB~KpcG_q
zSa|KwlS~Ow&QNEe14FTMX<NGD6dYm>hriSR{pb+s^c7x6X3v%oMFB`4O`zFks~nDY
zWvgsJnNWI<08Sf#%wX<2@VF4_Tdtj1m~vhUtk*1{BKC4*wmN}QCBCU6Mz~<%V@Bf0
z<udyr!IDk44xol_aa#7DVk<LF!z16gnu(43qs0Mv@~oW8>4wJVu2jk@ZVWelERV&Q
z7gvwh3ZaT1k%y!Jshue7-8YIjsdb3r6Hun<H<@xcoxl7K1I{0R0TVOzAF=xd;s5;e
zeoMvwK|@5vWySb;$mNX9^=&2e9c3)dwJoG%DR?Z+^nMR6;&Kqb2BCipT(o}~6XgEZ
zmA_#A|E4SNW5#b?dB3E}#PmLTF|**(y}xMR-~W6uzB>zkF8`a}{J9GIj|re@e~b5j
z9Xr&chD~~?q4@7!At(w$@FZAaA@Hch&<C<%lW&0$R6qLn(S%nItlzy~ZQwz5v?fqj
zj;^+SQBy@EalMN%VV1Hixn-9OQ55?G+ZWt|YcAIy9b8yx|JkQed9Op){3&Qi22LNR
zVx+UYhUK7eI{?k~D!H{1*t~5_JeWSjcAdQnnt)$E>Ie3ThRWSixR`R4g=tvJ$0L-o
z_TceZ8tu=_mq$V-Q|!$Om6j(R*|Ak*R0$##vu`r}#aTy|ar_!_(lXd~ghSZ?JTj*U
zoIrRRvLmP8;DQlPz2KyJj{(7j8!hp%y&_`;afu$>>0po}95odv)^x}1HtoC{k}KWb
zK$sdAa1X$ep?r-0hv@l}7tu2PD|&wQ>3>GgKYIOF6#SN}|3lEckMBPv41)1pihhRS
zUmC_h&-5;0)bExNdg^x}pr)gJ_oDn$#VFpl|CfxtCt3fJF<Kf%h=0f!BjdYb{Y%FF
zNEbcbd!+qKy69=%xA|MT=-$8kS6hBb7X<C^i}nAIu0JW{KLU>Kx0~g!3CL-1S(q9B
z57O1@;_N2JKeu04wCw8G#I|~HT2jx}N|1{P^ii2LZP(xc1l$V_1ray8BBx4F&l<!U
z5O{1O^ojXf4miwq&a_$BH@<%9R2mEBaJKIwn1=L+p&NU|cz0<{pQP8HJl0)3TiXh4
zi^f=L(^%~fXIc-G-M4wDI}Eg_4PM{xSIB&psmFsD(Olk^h=pbYpnpOwRcrYoT^9x{
z6`|_Z{m36=b9e>Nw?+urj7l&>?b~4Y5dlHp`*K6Is>Dz|JGBX<^2s0hO7Ol=`U^4D
zkp|P$*Ou{z;pPMiu>mj@_=Iw`Rx4l0CBSR`iJE6TXGAVVU7)i<iH$3KH1N5puJ$a1
zQ$Pl(3NE}65V%{JPvA;F+@L!Sj4joYP0Lzx#b?P@If&BTQVrLZ&PBU-R}~%5L~886
z<D`8aM^}>EMi1XW(`adVY8K%A*x<zW_0iZgj5;kXkBXZp@c0X-WyQQT)@N6a{4u16
z>aUdvI)tBR@+<bVpol(BV~a_Pku8ioYBS~gBx>{$47`-QNfF2p^umJ)k~7D%740({
z_Dlis7btz@0A|7cyqT1UufCZYJUbhvCo+tf#On;ozh`oDjN}#+R3&?iJ|I5B8q3zS
zU(D?K1AMV?tuU*9cl27!%&Zcrzz{|s302u-x-x)LjGTss8lOEdhzDuYnUD!}6Pr*m
zu;Rlsl8eC7xRkaS1_>;xFa<a^Ds0HhmgyF#^eh=AoNLcAKR4V-wj>rYV_*^F7Jn2r
zoMfOU%3?9_8T7;na62|Lvy}@M8XB6BbGe^|<%9jOEJcBeZ+v`}coz}!DjyS#iNTJ%
zL%92(9?`S+i2>N6G0}S>zX(wm^s)JX+a<Y8#1CX!o`?XgUCVm_LK!-x%U8Ts*$kfY
z6asWiegg?~j-*1$D;sDOA{P0cFu+WDMAo3}W)il-uMyl)mo*@W8?OsPj68PAf<D+b
zk;LSj5RPV6D>+0s6KCTJfzwdR)B(u%TeuXxb^)R}`C?I=N$Isj6{JZAUlG#&Mr7Hy
zWjIzA0*-zQI(PRJ;}i3I6+{X^99lI9J*;R8&?SO`@oV34yNvOgUPF~ly3yMt4EKC9
zoN{`=stOr|fE{H}&ioF08H4zPlrPimRbn`XNt^?;t<m~TG{ZHt!!^{yGx7SY+$U20
z_P0X*w9~t^vfN3e)gwp+qyeMQ1`}zSq!Ztu75h|ZdzniEYXbv^bSRv+gjGN&Vlx>9
z`g=5kYFU$EKVRsw1UeCIvHMwMH}ZMkD4`6}`lW;R0+lDAlec{<&Fc>~g=f)82cnU9
zg)<%Gv16UPB<CCNQTfmlv%{B7Z1aVP62(+}hosI4^%lWLW)0!MN9K}x%c$fUWR4Y$
zoZ}ntXUQo23bes?!4`}QL>fuXs=GdR!a(c@=dM5x%qz7Jb#@3sH(EXXvwH$%SPGG0
z(+2<(*@3WuuEr>ag)8Vl#qjF}AesWrj6_6b4Dz-($5wE52zO3j<P{{-!5{eLg34>+
zXu$`7J;+ievAmUA*35}hiH7vI8c^7IciBq!04V&&*9u4y;@=0*ujsQ%7!+u~31ONl
zM+kjFgvFKV6;Z_Z)+Mp|=y=q-%{PTGNaUfMO6B1d2J1o;v}Y}`r?TbS({m@i;K}DE
zi3PVV&leGV7Q05+wi^_aL~}u<4GNw4C0@gVrL!Nx^RtXu!u^zWTPn>(?-sLz7F-57
zOvpG&Lddw5yr&pDJZIK!SHJ)*(i$r9R3&ClKRfW2rRdg<_TU%JU|Cmi`SzS0Al8@$
zuJGV`m!V$qmPcu8-3tP1js$kHGLu30gl#Tx1(g|E>D04E(PJ_TL_<HxbN&E_W9?ce
zXc$4!@IX4Na9M;_ak5oH#ssZl8fzYAi3i;N0I;4wV#$*J+vjNB5>sPDQ)x_@3w53E
z*B`8F3_}wmYITo#af^Il$xy@S10o2B#z@$N%K@RCA*U6LYku&KdW=$ziiy`6q#A@8
z#1ds*n66+nGb)=-5*df7v?>(Kn}Slzde31ejEg=zV^tMXU=@PGfD&3}u}1*lNoD6z
z!#iYTJ7!n6Axh}#NMoAjk4_(E>v#TW5U>b|2TRFGo?AR|_kC{hp%;AG<Go^cyiPG*
zW1f^uLzZ_w5~6QJPcE2mlwuaC&yp9jj6h79Z@}kBR$KSLYL(v)Z=Pl;YuP>xhw&aQ
z2kc+MP!zYRWtdqw*ZfB5w=fI$yt(&?H*8y`WpMra!}w%!UEhH(#7SW6*eLvmnC-an
zSBd&bHhk#*1BGzbr3gfvRTSfGyDigwu1cC<G-ZE1q~$(%)D*#ZYnqxy=U}DQ&;A;E
z<iT04T)sNjDsYWxQ{}rl4MQIrW%5|QqZvy)0mPEo<Sl_Av3L<Q#bth;no#rtP#tEK
zB*>E`J!+XMjDo!J>n4#2&CF?~VhIIu-_-NtxCN^t?z9lEP(^mw2XheiUQN<+{QOiv
z_WUNVqICDRBCB^$!#cIHv{vBP6z(Di+z&H6WYQa5A}O~T^-3>nc=io%0e;r?DEouu
zr<s`s?|2cJ1uO>fy&pt^!`4AzidQDOa$(sRVk_9)*z*(zl8{`t<fUj)W*FMYGbl4Q
zD5n@}+z8R5_+REJv|(>sJ$?1LtB{`@_~RKja0E@y=Mh8cudi2_FM-2dD_RW1skc;u
zQ$geiyt%&#@%kzrHNty$GBD{h6@AB?2Z{18wV|0Erx6E&m;KO;It92BL9O0#eQ?g_
zEM(8&6i^;BPKRk>fvtTNd;hR$y5-+U4gC6%e*(B%rwkn?8Y5JN3Z4Q)i;j8F&JGeL
zuv^*4ue^i&D=<!nCs)ujY{gU#HDEdcB6Sruv~~mHkrPb~I5()6zhp%kS$2P&0{lq@
zRE!oRI}laZa-{dOzFE<sIn-xc?Rv6s3M#I{W<AD6We*7t)i!Y0L0W-M&~unUTn--m
zx_XQX!&P{aei}-jbvV?qT7(}RG7A7to1oDYZ<u0M#BMx3MT}^`;%M!fNP*|kZc-i!
zuaG<2;N4PTwdDZ;T2wv4UvDa0oWW*3n^UqwNp{fjNv;_xn-#R6JyWBwYO`SZc{o9j
zeJ+Sg&E>Gee<2?$MC#iP{m}u@@W})8PJ8v`+%>R^hWX<QA8uZ5DBnQq@qV0YfGPEu
zWG_pAHsj$%#5ug1C>BA$PK<T#$J%*ei7M_aLHXRGcy12>UM9M_7AS@6zEkg$3fOc%
z%Zf3QDsBymD^-+@{h};jeT6Iyi{3qgvY~+Yi`!PQ5s~%#6yCUc1DKs*#gl>f=3dGb
zAix2$4f*w*y5|rrFgV?~lN*cJxC}e2HtFia*t$;(!$tM-n$YbO<uPvo&r#2gSdFj@
z^uSA%<rLr7%_|W1oPpAP_N1wNj3C!_$|=o=Gt@*ah+w1FqZ0-(ci1p;hpC-B;?i|{
zkFjrqthmq+{N<PBJQXvrJ=D_!t8vlxAvSuj$*g_ptmi^DiDvYWZmz+c0LMDMZqPOO
za_k4eGbngVf(x>F)kK0-6rc{G)&$p0IUE~<wkBZfbWAB>9~s<L3;OABBg{dbL1aKA
z$YaX0$$`<YcB^;8W`&#EWUUauZb6%USvn%93B*<cW7<|(gM`&O6SV%c?(Zngi@IUS
z>`k>Hs^)bTh#{!m+b_|Ti!q-Nq06Yur4YG1$gu;*BB4Qy6V)C?RTx}k%t(=^ts-t}
zjH)h*)3?WT?feK@U5SOFXSx7$OYa)qikIleCP&)v$Y1oa$YR$0Fkt41fhGAO+1V+$
z-Hq^UD4=_7(|@zK`wsR^<94w2601>ljqocGPIv32;Dh8P*rj5yICTvc<QOTiqc)r)
z7ekpFT}@~0{g;0ADtN_LnEhV&cdiOo>jt;?K&#SKeE#A2)2pB3+8H>WiVp6e5hBZd
zsKRlBT2iSmU2Av=0f!#PqW9IRz$sBXK|7Ia>>fZ+OiV70;;Z^4CyV5mEDyzu1l<7%
z>xT@NC82~V=xYZT9QRP{{PC&130lrfoXPP6#gQ&DC0}!0*vf))n+KvN$S2>I7<USg
zb7jgF%2dTgxzVE9qJFu4x$(j_`GDE#S?ikuj9Mb`?dckm^qH2zs9KhD=#LxhW28%H
zfX5CkJ?`RLa{P?ocN^6q$0*MbJy@#%vV&*FOrrYQ$(>z0kX2!2IWCu=@s2s_k48+3
zeh#e=7y}?KZ0z*W&ke+%uer@`2wAy}aF=~Qtl@piVI|M4kgy?l8nhvS*YI8}dh&Da
zkldSu9Wd=;&hKxlTBz=#oGmbenOpemNt(DoE*DUD1D)3AAv!)e&jo9_X#q^~nRP`H
zY*1V-6LWy_5#8k3mNf~~ckvkV77P!de}TPbi!>77liSVet16VIKGT$|(l^k1v_Z|R
zfFV07`-xROV2cK*>$-lS$S+=RzLk1kH2`j75-teNWg)PYcs1nck|hoUAt)C6MfOdq
zc)t^S=BNfH!Q^NVO?}-OlE`<qqjE-mF~Cvp(J4vG?HCs(UWF`&^%ToC;;mkA-_LsG
zwZ#+-IN>2?7r~&eYe9v9%`l+qC^$y0@_&(}O*VkM%Zj+nKHYZOd<z!R!(bD;EpC%)
z9)LWjL;E(rIBHa1u(6w!pT*gbc8d8}UGa@m9Hkn!gdlHUAXw`oT{L<mXA6&qmjtfv
zLA(DvEDrW#y;^@dh6u)?f%CrPsh8knvsl;tt;))Q;}+$Cufg>f>jv3Z{L_Hh{bkm3
zK9|7Q4P!aKS0iAT^!kZq(+PafP>(}`Mwk!Aup>WOy8y5AN{d=6Y?XK@!UOIG9GF42
zLF*&=e7YDafEBGE^{U&eJU^butcD)Qh}+BSH++`UP@pYqFgi}`ngo65Y>{qc0c;;n
zIk65=PC`F0E~G5L@3j!EQyCE^%Hb}bHkl#wk_LK!x71Bw!`Kgo06e?D0Bt!w5#YIt
z09Ti0ipKCHL$tqgSsi!`%Jq#7d1VqN#UoXZBS3K^ltbBR#@BGP%j`S~k5QIgrtx(2
zsqg;uN$!$D#G@dZNqcR(6XG<`RM>}2q-iC}XnTpUHLA?t+il8lV&3%#^$_whOVYBV
z1khHxz)>H^S^<%eH!Uid(=9-|i&S8`1v<*82(?&;ZUpB*1I|2c3ENoc&WRP`GAGxg
z%~1o%i5W$XFH_@ysHiN$B-Ua@G=~{;;q-L)>}(ajzN4iq)7s0C`!4mC<fxDFv$QGP
zlX)O3lbY3wR8Job(aNK)1?y2S_2{Udt80Bzj%$A1+jonmfcl9^FLN#RL(Ahs^PV!t
z4H0-nJeY9U3`s(oLccZe0z37+@WU4SHNw_;`%RbJ8-XnIR^s@0qE89qyed7bY^|$D
zL36pTY)zQ7kH-_sb+1xII}$IX1-R|wI^ssvRD<l%G|3*R%7Mue=dr1u$81N<6=#L-
z16vTY5t1j}n8I^cLl8;#w6s~S$EXBLx66IBO80@({PU#M-4)C8fDTaP2!o2AQOcX|
z5H_k@!M?tc=DGT2->Omq8rp0(m}p8*y|{B?KnYx3HmDmNTH{%V&WbeV;(D5=reBrS
zG{9#)X4ZZxwwFW79^=4nD_Y)080qG*yPCP>TZF!v(#1vAnUQE_E_id57=jvGeCBvB
zZ7Hde&$K;I{bRo~THTDBSucDRCCl!)Sg$}Ox*wfx8I?7xZN_g^$IoA4e<98T$sk9%
z@o$Mzn^9OFn<8a0ADOhvx0*!Q8)+i*_H)pcJKxSwsoVjz4nq-_&VqB)ota|b1Z2C$
z9v={RXqOKj*1S-Gc+6TFpwC9`jPfG#{{;P(`y8{0?y7uccTHF0{8+N4@gnIIw%_UE
zirISFw^p`x+R);hK5u?;i)~1}IJg!Ef6Wnu95yUzDH*|dy5CXw1rOP%9_jG0MQ?eA
zGsrB3vG|3#t=`HqWevNVE2pivEN48R<#yWwKsZZAVwaC{>j&udjnO_$k^IhdgeX7?
za#<!^?4_HVVAcczj}SifR|!P=kk9j|QmoPED)e6|37DtuD8PlLiHuSZryB96RCbh@
z_l(&+&lmP|C7v6Kzh|s*W*hZFNX@R0&EQ3M((X18$#UYkea^_jL-QjQ{RG4|^%b~d
z(;B}QmNc_(0QMYYUMt))501-k^5#wxt?L{{;u(H!piQCnJ3fi9@P{=lI=M`t+G}YW
z@5IV7|FUo|kwC;N?GG-{<5+l+Me@ZG_!&U>(D&Yp;@;nwjx5Q_<s|CVO3WH%J~AZM
zL*b#Z_37Ryy?_h(1MphReI+Q|pl$H;X!&*}`%18;pnhK8Ev)<lE@;?NG;r0p)YwiR
z!>gvEX=*LkxJpteY2QeEIW=FjOHr|ZWX`%LEK_o{mQdL&TOcNW2scJ5hH$#XFF8x(
z8Gmj^YIE;E23o#a%%l!4WI>ulSa(RQYMI`|E75iqBh09J`6PN(Nw<1&(sx8yMb)Hi
zb;<;vv4BEe(<9Y>1LR_ryMj&$z2<uR+Jvm0D2%96Yij(<I9Tc6SR~{Z9}wj?uwyi~
z54)_2<vc<|?8#=e{)Mu~5&^Q?q~v52)p7Bmkdb!4t?TrrWoOIRQ0qW1agF|d^B>x5
z<BM&cU+2VmBSzreZ|M*3>dmwvRRkZdq#TLQF{d)59dibT17uG0kQ7&`Mze4!=#f>(
zjPvrR<ctezPzz$2hh8Y`TJjfX%+hs|j4Z{HHZ-B;r!lqhTS@ixt=Qb7vAsg&Fs-?o
zNErxc@%975F~nE{I_P<bWRZv;SCVw1QIHdMhek#&pVTCp#fv9@1UEM3JX5+E6SJl|
zfMqdLmByRONfQNC^UKH#1$xNJ9D8I);%VCxD>e@A66jc@z6cC`@Yg0ruCBrgk42&@
z^B#^*Fs*0dSIjbfe{S5DCB%CbO`wz&Px?hE{H@C#;|KU`QDd9!xSTVkteifY-cBrQ
zMuDl_#Z=0I(YS($>C`q&@?k}EsC<>S13T#aJeUs@sBAQs;<nmlh{%4!L-Vt=mn4nc
zruzZ%Yh)WP&E8~cRs>D4aqC6BPz6?^kS})*krkovAq;2(fKRexh_|v5$aXe}2R%5a
zITAYfism~-L2y*~Msy;LH6=BnAV6!h`N~{pxM%2l6qoLMMP~ErN#<&GJ;bo?Y$o03
z$fA159!gW<&=NyLuPu+H0<*bUEXUSw*C_$m#=|$LnH1v70}5(uge90uN<XNIbUeNy
z4!bUV6*Rn`Y#Ph_suVt_?-!AW^vn}oJR~1M8zzBah+*jA&0aXarNBXj9$MFg?!pux
z!m@0XBa$>mjXvUHfyCOXUeMhT_nmZ~;=>IoD@r>C<rWp=LOSn<7l)482<6fbHNp5O
z!BmA89z??V7@ug4AnXh5H4i~nr>}J<WJy10g$=(%<5AdRDXq?3DHw1F4|ROlEeUJR
z3~BgEp-AaahQWs_M;G`284n45f2bt_V=f;CWAU<h^$m0-yc1WE{V){?^<gMDsleCC
z+SSDzd-ifzQ}QJl#3TOhY8Vw{J3k~ta{L57kZiB&4%IcF{@%}VZr#VSi6k_dYNGL8
zWAvM&9}_I*&0HiYr6+!zQpxOyv8_uQgR}US_*Q-kSXevVsr9in_6Qr9M?&0=7$cj^
z&GAcG!>rv8sJ+EB7;gu1Vck&{XD_aZelz+H9Ow?P>-gA`{*UgFBUwHx-C$!sR-!}V
zDOns?Z<#>^Q$OUz%JG&-$Iy_?>l%;ZqK}12yPQS)4y)MD>YLvS78Fm|SXboJF$V^t
zU1;d}?6N6tg07(Ye2?oI<EGz+^W{-vSkXt`1m!y!g^3L%ueI*qC86Yjw3G3RJ=a(>
z6Hm%$QRC1xkbiedV}g|ox)j%D5<PjX&(<l`F9T!S1_!-AqvmUMkqMDx_jZ|Yk=cio
z#dUL>*YS_LuW%34TlRV}E3_WL`dJe7SrT-c(K7(i3^_j<;`UQPpjZQXwP+rp7yBSc
z@R7%gu8Tr3tUremKl?V2>c=<%+~#2+W%%b@quJ85a+@=z&f2C}6E*i85LUMeP@$hN
zM0*r?L~s_NUaReif5E5XXzd>a@E+Uo)wE%anI1P-iB1Z_Ij9^9Y!PW6Hxn8gvR7H)
zbT_5#{1Py>Q-X8N!D8fWE?=Q<#dj7wH<_mPOl3b-Y6aJDC56-m5k?~v+nO#_tr9cg
zj^3&JnfRMa{<43Bp32Q&Jk4fmqpeBuAyKnXG(I7|9<HqXyrzc}cM&NIX#w3s=hAcj
zXHQI5Cz&Gh!7(81nG*H3+()`)=+d3g>vuPZo)5b2u&IEf+?dgGmAJkI+q^)h;RUE0
zpl4EXO^KOXO!4Hr(i)mE#(Me`OQY?Oc%OZoDz7T0$D~8XE$0*PW&pWk9Y>k_)V=S^
zpf@pjM4pG@gLw||)B?Bwka*h&y=C~CQhqV+#6H`5MRB#p)H?IzB%-2XtdZ3kx$K~!
zkyV!c8Lg~N@k)m|)UpV}M;!44(YdnFcx$Ix*20*A)5|mlsun6&dhk#oR4f?-vwIW5
zy{x{E+}Y9P&M8MD&QUWQ&(g#~Tf^Q-Cnk?#j3~2sfp{nCwT0=*NF#MuxGC73C-FK!
zI57b$>?t{aNBq@Hr-anrB%SWq%;tyqEEV$@QE2L2C$0cJ1uB(B1(Z#>_rVZcAK<g}
z7J$CBPmpfT2eK%3BlMQ0ndk3PFwoe9B*em73%F&L6*Mab_x+O4ZL3ZW<O$nP7PBTb
zz@bNkvVbnJMPE#fvR4sIf`>Euzu=*!U(;0Asyuv{;6}p+&+BzdFrj}oLmPankhiWb
z5)2gzVz8<wqJef{!FJLD+>YYI9!L6WZ`sD+Hd-WQ&hOG0FXd{^Z7nQ27c3VumwB^$
z7+sC;idjsQUuL5Nu3shI$P_DWzw5i0dr@zpL@m#mq<w*WGzeAa+Hm4G&~-TIr@P1L
zl5Y`3RZ2=gfw9IpnkPP`7mq3XslKe33S5KtG}UB2apv*h%xvGoZ%tii9<BN8E88=C
ztGPv4uQ5+dZ_GYjV;FM9GHyT#2UIl2&X4BCp>&zm(*~j&4=6Fv>Q1wnq`e(*5AVSf
z*w}6I3L@=bVuVCsTXxwOTN{)|l*jVn#mMUEmu9RKVoJ?ODAupoD(F}qn)&a8EqG7R
zwvfZ^{Hr&Y+Uq%7GG70bO(+Wx8E<mm4oXQ9iw?%H{bq9_!IpLN-sak8KAxb}9e@wx
z_pszWhhAplt+tlQH;p4^r_NPZ(J@B`dN@OafcE)orIOPzxht#KTa(0o*LZ{gwdCRp
zuuG&K*(YChsKctuF_DS=+~wIjU~B@|nG>-NcNk@T+C_$OJ>G;tkOQjoc4DpJj-|f9
z5#Cz|FbIGl0tVChYLk6^KycXWVrp7g+S6*Jms#JQLw9yRjfstsz7W_C#~S;hqL#~y
z%MOa9%Ih=qamVWFB0M#zWMc?jc;qI`L76smDL>o02u#szO^JZWuz{9v>0G5B$<hj=
z`9!3iLh4#a*r19cF-e27u+46%uGUW>El%Ky@L8nC6U5PFizuh>&SqkT)?6l+lG**B
z%FmRDs-@7px9W7abQ<DNVWmQgNAeC@bgy2lU*ru^PN~-WKf&!U8u=5_GSSlii`@RY
zDgQso?K>U)|MQNC^U4cI@sP_po9kGbiOc;4qkq$02)e(#WBeBH#<6#Y&`*%6`^z2h
z_nN<HKm9*lWIq>v)BblC83R2F#6PM2ujBq_YybY{-!1vgng6qqzid%-?^yS5rc8}X
zLHq8wqoMg}jiRQ0p9$gLfb!qAsGlGH6DYs$^lw1<9UcFFfieUG(>pW%7f@!Te&6M9
zpiE8wS3`b#q28PId**{bj*MR`{+#PyUZ{7!-LFX;{&=D2X_*+`&*r~)q5M!G?T}_~
z*6s`(h;RmoxCR0el>-R;#qWdMq7%)cSHG3@aCskpm{~RB@dgrx#wC@r-N|eaS|I~F
zEbtE2lsGbjYp#TlKH5vw*<HXdkgxbA$Du&c|5zAzeBHLVi?}@9R)5y|<a*|@K61RI
zI%m(tdJPPwXk=djRuW(772h)PSgQh*00TTQ6`cO=1!CU?-)v@6yeSphK!=@vR8SPG
z;PC2JRxxyh$Mf3$qC)IgszE-M7ms)Sy|{^2*rN}o%e>eJGx~88ZF4Dk;}Axra1ozg
z{Pf^d-84%J)n&-V;y`F92lm_DX`#l|H)pnvpdAPy87NlnItQAHZh9r2^Mp%_kk9u$
zA$O#YVd(Pf-$9G`J={7)<A9uqU-uNILluiNz8m}IEAM^$a3VXsHA}CFy6)&u^f>4o
zz7gD)O`%-7t^DyuM*(UzQT#KL%2n;0n(pXy&qzMB1o@ZH%0eI49vMa@DUo44#ihZP
zE_6a=KY2o+jQt`tc@?Lv#g(oY`rEjXFDohx)mC(2#`JTDlsh8n6copl2O6vHhIi^y
zSOa53s#Ub|icnu&v<L5FFGy`a)3EO(7w~B)e13`(DnKw+{45$L<b#k@%9l?DUw}X=
z^EoE&!X(~AvA^iRq^PKfQC=nq;_yDvxoZ~*9?h~kq?ag2xk`%-ky@M{m^ZF-Rx5N{
z<A-?}Z#fMXkY$R2+j2=iwY_vP-jThLo^$82OoHx+y^C&e<3i&0HHOGEttOInhoqd3
zc^F>Jy^ayYRJ<F0@fs6I;E(u|hr!vifa4nm76#?nq$`Y-H+=}Do^Q*}S-WZgA1@hi
zT0#68V33mMPZc4~6hUf}zQc!Lz|REokCIY5xTLuERfBry<^zlXeLXGb*jU;>nBV|h
zo#w{ZGE-fT)4i@YR++KqqNevj1zX}#*MW9G1G|Q)-<(=ishL~4!@m{iESp`GUf4Ij
z;Ad)LUGb?cQ;EQ~dkV;eU(S~OAW+!+l-h)s=xzR1NbPUFH9*Rvn^Suuhye!DENz4Z
zhXLl>C!m;<H(4!1P%(%qpEai0&R%(HXj~W@!qwKTnP7faScf2cFwjWx#{co$SjhG<
z%&v6|jhA<)q@}J!q2jw1i0PLoy6BSBWwK8XR9n-+@o57|E}xj^!$c79TC=&s4f9l?
zs`Li13|@Sc{piv>hzI7op&l?ua%qCjzPSNh>Di=)KaEoDq;N;9>tT}*W+J$AvKVEd
z_<n8x6e-lw^rN$aE8s$eN)f~b;dCI6MSRh?hlc77*zk8CyI@}dNq(SS0q(6pzwKZr
z9cKra?<g?&px3SUy~CoS6U60~-MfE-?0gD6jvD9GU)4y1@A}M&(i%=?(`Bj+7~9+D
z9PA!)XDUc`lZ5O(?LqZ>fI*cuK2&FbO<D_dU+4HHsnZ7yul6mum5_`Js!`w{+E<n}
z#YhGnW=bE-XU=>Cg-=QEIi?@B4bmGY-Im-SiK1?v2Cfu0?5A!hOq@RXFT}J^y;9kR
zHAZYjN-)OU%$N?Q2q-~HM(#-81Im71@1$4g=D85F&2Avg^oluF1uEWTT!2^}3<1+-
zVh783@9@p#dqT|a$3?tGVPiQAS(vaE!!f3I!cPYqxTXnRqZM8bYhZWX5=##x2alg_
z=%~G`D-nt>$kambw$koFUSn7m!H&T=;|<SgPxk=Zf-<(&i!TRiFVrva4PqL-bc7@D
zgAL*NN1-Vyuv{`xE&RkMB<G-|BBZWwrI|?51HQL^=-<RY#OW?LXQ7Q9?3YXBac8{|
zvD=(&0I}?mIPO)y2kJY=Z41xXoHs*B8U0adx~MZZ=(3=KqWvMHiuaiQ2~1hJlcObJ
zeeCW+@j>-j{gqSxWmZN?g|sxrLCF6)-A>?9C3qP3Xr^F@+j)FI*V@u8N!d&x+5CqC
z9nXtw@CD(HI8AKiSMk_cxRT7FgRED?LwBTRik(RbCtn@n>^q>I4Z@-+MbdW54tS@G
zXEvCE4YvDqZ~W(!Z!ll_(UI24tvPQLhNfLsd|#Nq!OEoOIDLDh#>S`G-r2Mt8Mn|n
zS|qAVJJEry#A6%@mmw0f$PwE)e^?n#xYU3C&=!BT)4l<FE_iQ&z1{r`9VCn_6Jr-r
zqZ}+0Av`W@DdHI$J~+KA!XmaB2|GYFjI&&2_E4u>XP_!pS?GS9AJ*;RgqUsB(UgEH
z-hh09=BK$ythV)XOnp^J?|^g`xz>p=#D(n54q&=LUR43Gu5W8a3ad@tdj_NCHN27F
zhTs{h2_3M@urQKR@hLe^-Acg&+S?`(+J-3L0o-H!mKznSB1JHr=7kw0*_z5Vn(T+6
z6lk6dHkSTXF5VZNyyM7A(@^eOo$V_pzhv$OjaT@j<r0GpL%5xS{nymo=GsIK;c?%H
zi$og=Wu~qS{G<$ShSM;^F1o4=P%DJxkoizE><2{8ft9evW26qDA3_wx1;MI1oWn3(
z>)MLXt_L7kdN>^jE+)PuDObp=t*QsYwx3e<b@w?LrfqZkcTEZl+p3DHbk<f_6i1re
zeuN%O=f@|o6vS#M$f(gPx6foDYsgTOex+hE)VcM&*sh{ILD%iiEy&CN9xNWu%u8~$
z4-Gg<0)r+~*`~$a*l~jk?~Mu%<S&rxKS}FPbPF29ATq@tP3}Q(AR^Q>CYr5Y>|Jz8
zJDOwKw``#vqJ8ukr*nC=Nt3RvV#5#R3$p3}8V?rCQkJt#(@L@z;HWNr$r*$z(CH;@
zXnx+@(aopAU41xlaeV49T;1$7#NMD;BS5q4g3m)-pLjVjoST+)cMfaf!Z-QTwVEeu
z2KKD?*sxwNX@QS;T~YwI@^)+ZGS_5u7Y?C&WpYaC2R<$2^AG!X-}M|%pjhSCADwjW
za{7QBKt)6y5VTt8Zb?e+sc{`xxp1u6(=cTOaIlaw;9<e6=b^izJWwvBoWT*_zu0{^
z(dUQuvH~t_3y|40pA*7d-nv6?@ROTjYa6&E+tl2m%O$ajG05GwcTv302iPT|GV9pl
z?AOvrHyvOHbjGGw*_!?&Al`Ng+eFOY&+BBp{;HM`&z3B!fl_No1cdo1B?@G!Uk%Dm
zY69{7;g>z2JL+znRU~FJ<+N&YGI(KME)I64)oAQT{H%;93BM)d7$;0hpeq~a&VY5@
zLU0qKPDX|tH=(?K_zrYU#fc;Sk%+YJ^Ai(pVz$KCe6m-kZN;V?hHQQyg7hJ2fu3%y
zpQf}%9cQ1(4R*5tq<b$nVlU%<d7{9kBQu|OeXrVtK;UHiKtczD(J&6kJpJQ{Hee?@
zXMa)!pVi~I^_V5>zTDt=$eBT+*7x2$PxRYk>+~`R;OaN9X8g`O#-la<QqECC7=q%t
zWm*W)bAB#Tiyl#)z6KYZaYH^txZypNgkT%zBWHLXw*!AUzOO0rGbc3sc||oO-x<(u
zJG^_2CGDA`9e=!;2PYZ!P?|PYP#pM6Z;D|gQ!jtV@{6FQ;uvYAxE|47i=VS%wnvJf
zbW)e=FAd42Tv=K<#LR9dTbe^z$K_SP`F<rxj5yAe3)t|5j7<`mHo2oCM6SX|tXAoP
zm-3s3s6rJu3U;<9DGCK1AHA<sD4~&q=-Am^g3mRhoyf_x0uTb+0m`}>BL>&H%pM5<
z-2pk>#X54X#AC?NfokTIeUSLaNko-+9xNGin?T$6glr)^U$t60i}32nSNqwns3L)<
zdU?nbe0eEZ1{uP>(1Qd+R@xA(q;QFkV<v9*C8GW~TrvKB$TPX@F7<hxyVn81H=N_L
zkh!sFNA`<xa;LnifFy0PD|RQeqTOBP2R+kLx)gNz_@6jBqY4dK%d9po7@u)9W>DrY
z8e&n~>CvdVV7<Fwi<4l6i$QEI#N6~`#*6G*y@Mm;LPMeVMcuVuqW$w(4Q<yC>rUk%
zRfRUz*Uf~3|A!Lo&z(H9EPtD8f6a;Zrx5r*TeAhkRTLGJ$hmEdwaqC0n6dw}Q2T3E
zxWCQVbbsA$@ppOlzu)A;z`*!#rt4q({%Pr-lI1VE_kSx=)FWvuyK&+C96fr&2I0Ku
z?0AIai-fSF<*c88sZ%L(@43)mU+(}9^JM}sozC3PnLSLts@QzIH@wd82Jykiw7wOk
z2j>V6SF!~;5?hjxr;C9JHEdAb^OY6#0V92Xyp*Aygtgyl^9{#oh(pN#E96>ZqPU{)
z@^I5mD^G!#S{<5Fc6rXsou@IhL7);e0&78vA+tL>i`2?e-XK&Ks~~+yYQa(iw$S2M
zgVKbcKN_KeSkw|tOllQlX|UC_8VeDNwzOv!7T8%DZ}!ied~@%)=iYN?&&~Nxa7TxK
z>8+zDB5nqp^$P#eyH>v}xUTAEV%_mJzw$)it{={%{2pr9z5gVGk0-Tke>Y;K^&Ow<
z;#K;kgYmkGxX69xf3se=?3+DtO_!Baf2#A>-L19Fv1cM$!iGjW?|%^-y=>LkjyJxm
zn-E*Wtvv-HODwfw7sXZ-MbC$P%4#_6x3JPnhqwQ?z>XkyapE+V9nC<Yl4wLJb@vzn
z7X(h7Hw{tbT;8<c8s;iV(DU>kjDtER3t{dY{l~!qbLLPpq)QGp4N2GwAum$4k`jA6
zLS78b=KU|^P&)+9`8)T|T++TX<YgW4`%@y`NPWa6`DbyvC|bk~Bb%Z`jn|Mj9@f-m
zXwlw2rMZh%e!XAs7dNm5-`VW3qUOS3O<vOnqaS0sS3NfrjgN;9jPIza>Kz@#?9<Pe
z)l}{Mc5rk{ePyQx@3Lj*h@PoAU*UbHz1wp%<36pm?OQ(GWt$>HV!JOMp6+Y2jd^@x
z5xtL@On(iE1C8hVG4r#;ojvDX+t;m`#w&VJ?t#6%%+TbGs@sj@nqeX;W^K=!gd@vO
zM@&4qf2;V!lRx@w$Aqy;+v98ZW~NELsOxd{qfEaatF?*R(ncR%G<ii>^p<+h1|t69
zpF}tLKr`J?;IGxDX;Ys;wpC}b_xiVLKI_ogb$0CKnpcRw)5N$3=WR`6+#b)19*x%a
znLd$}zL8RM30X{)B|}C!Vn~EI1IZyKEz^);k}^49LI#8c1{rfLfkFP68G#l_`b`Q5
z@<%L%q~QAOL+dJ1#O(HH$$rS*RxMviICn4jNZIP>j~aWL{cns|j|aE0Cx`Wjd@CzH
z<?~0^r@kK%Ls!RT#jf8K)NysIts?T5Q7rzsnSbn)Tmv#z4aN2kAAK?R?!gs(*d6~Q
zZK(agPc<`A!Q_XS@B5caqb_W`bmd`G@}=R8Q_GDSO;~r?#1c;B<R;KOKkrn|#C+XO
zqqNz8XUK&`dDeWm?TI1j7#82Ai!aH08%p%>uOosYw(0S-5@TU;B@PuY9mO-ti}lXF
zXeT#Qm#~%sFhP+5$umGic#|N);Wv*|F2I~S8LDWSOC%ZSlCz|N*!6|7u^4nnP-<2>
z`b-Bmv6>e@FL*_Hp=`kjU{qqne8X9Wfz#H4&&t571yD_Cc>bIW%6h^n;3}iwo(r7L
z1qTlbvC~Bc?*iRHEn_)190zKsa1=@KFngE&W}jSTh-MTLg$oV=r$eptQtwhE#i-}I
zB#z=4I8$B5AZgys1|-KQ*KMvijsZ@Qs|@DGs>cOg!0Kuo=QaiqBY_&J#<7Ch&akC`
zC8EMnJaUsES|KzkZGO!uL;$lzEu#r{9LuZ61>3vnj7XTBsy_r(Y1RF~TDpya7y`Zp
zuDT$a72IWlyNscLII4P=;Tbnw7~XA9f-fxA52($+H7&#xT8<&F68sH5N$FN=G43E*
zgX1OVTdcsyc3i9`C%~=qI+-)mf{7*wK_WQ|!_kbzC=0S|wooRSX1O@*>5$n!Mn%PN
TlsFt1u>{LtVPT1zld%5)B`XE8
literal 0
HcmV?d00001
diff --git a/docs/tex/sammy_main.tex b/docs/tex/sammy_main.tex
index dd93ec6ec..da8f82f45 100644
--- a/docs/tex/sammy_main.tex
+++ b/docs/tex/sammy_main.tex
@@ -80,7 +80,6 @@
\begin{document}
%\include{} % titlepage material
% \include{} % include for acknowledgements
-<<<<<<< HEAD
\include{abstract} % abstract
\include{introduction}
\include{scattering-theory}
diff --git a/docs/tex/scattering-theory.tex b/docs/tex/scattering-theory.tex
index a50efe9b7..d1d27cc67 100644
--- a/docs/tex/scattering-theory.tex
+++ b/docs/tex/scattering-theory.tex
@@ -12,7 +12,68 @@ The particular aspect of scattering theory with which we are concerned is the R-
R-matrix theory is a mathematically rigorous phenomenological description of what is actually seen in an experiment (i.e., the measured cross section). The theory is not a model of neutron-nucleus interaction, in the sense that it makes no assumptions about the underlying physics of the interaction. Instead it parameterizes the measurement in terms of quantities such as the interaction radii and boundary conditions, resonance energies and widths, and quantum numbers; values for these parameters may be determined by fitting theoretical calculations to observed data. The theory is mathematically correct, in that it is analytic, unitary, and rigorous; nevertheless, in practical applications, the theory is always approximated in some fashion.
-R-matrix theory is based on the following assumptions: (1) the applicability of nonrelativistic quantum mechanics; (2) the absence or unimportance of all processes in which more than two product nuclei are formed; (3) the absence or unimportance of all processes of creation or destruction; and (4) the existence of a finite radial separation beyond which no nuclear interactions occur, although Coulomb interactions are given special treatment. [In practical applications two of these four assumptions may be violated in one degree or another: (1) The theory may be used for relativistic neutron energies, and corrected for relativistic effects; nevertheless, non-relativistic quantum mechanics is assumed. (2) A fission experiment with more than two final products is treated as a two-step process. That is, the immediate result of the neutron-nuclide interaction is assumed to be limited to two final products, at least one of which decays prior to detection.]
+R-matrix theory is based on the following assumptions\footnote{In practical applications two of these four assumptions may be violated in one degree or another: (1) The theory may be used for relativistic neutron energies, and corrected for relativistic effects; nevertheless, non-relativistic quantum mechanics is assumed. (2) A fission experiment with more than two final products is treated as a two-step process. That is, the immediate result of the neutron-nuclide interaction is assumed to be limited to two final products, at least one of which decays prior to detection.}:
+
+(1) the applicability of non-relativistic quantum mechanics;
+
+(2) the absence or unimportance of all processes in which more than two product nuclei are formed;
+
+(3) the absence or unimportance of all processes of creation or destruction; and
+
+(4) the existence of a finite radial separation beyond which no nuclear interactions occur, although Coulomb interactions are given special treatment.
+
+R-matrix theory is expressed in terms of channels, where a channel is defined as a pair of (incoming or outgoing) particles, plus specific information relevant to the interaction between the two particles. A schematic depicting entrance and exit channels is shown in Fig. \ref{scattering-theory_rmatrix_channel_diagram}. Note that entrance channels can also occur as exit channels, but some exit channels (e.g., fission channels) do not occur as entrance channels. Two interacting particles are shown in the portion of the figure that is labeled ``Interior Region''; here the particles are separated by less than the interaction radius $a$.
+
+\begin{figure}
+ \centering
+ \includegraphics[width=0.5\textwidth]{figures/rmatrix_inc_channel.pdf} \\[\smallskipamount]
+ \includegraphics[width=0.5\textwidth]{figures/rmatrix_interior_region.pdf}\hfill
+ \includegraphics[width=0.5\textwidth]{figures/rmatrix_exit_channel.pdf}
+ \caption{Schematic of entrance and exit channels as used in scattering theory. For the interior region (with separation distance $r < a$), no assumptions are made about the nature of the interaction. In the figure, $m$, $i$, and $z$ refer to the mass, spin, and charge of the incident particle while $M$, $I$ and $Z$ refer to the target particle. Orbital angular momentum is denoted by $l$ and velocity by $v$. Primes are used for post-collision quantities.}
+ \label{scattering-theory_rmatrix_channel_diagram}
+\end{figure}
+
+In Section II.A\ref{}, general equations of scattering theory are presented and their derivations
+discussed. The fundamental R-matrix equations are presented. Section II.A.1\ref{} gives a detailed
+derivation of the equations for a simple case. Section II.A.2\ref{} shows the relationship between the
+R-matrix and the A-matrix, which is another common representation of scattering theory.
+
+The approximations to R-matrix theory available in the SAMMY code are detailed in
+Section II.B\ref{}. The recommended choice for most applications is the Reich-Moore approximation,
+described in Section II.B.1\ref{}. For some applications, the Reich-Moore approximation is
+inadequate; for those cases, a method for using SAMMY's Reich-Moore approximation to
+mimic the full (exact) R-matrix is presented Section II.B.2\ref{}. Two historically useful but now
+obsolete approximations are single-level and multilevel Breit Wigner (SLBW and MLBW),
+discussed in Section II.B.3\ref{}. Provisions for including non-compound (direct) effects are
+discussed in Section II.B.4\ref{}.
+
+In Section II.C\ref{}, details are given for the SAMMY nomenclature and other conventions,
+for transformations to the center-of-momentum system, and for the calculation of penetrability,
+shift factors, and hard-sphere phase shifts in both Coulomb and non-Coulomb cases.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\section{Equations For Scattering theory} \label{sec:equations-for-scattering-theory}
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+In this section, equations for scattering theory are presented but not derived. Specifics for
+the R-matrix formulation of scattering theory are presented in Section II.A.1\ref{}, which provides a
+discussion of an alternative formulation (the A-matrix). Readers interested in the derivation of
+the equations for scattering theory are referred to the Lane and Thomas article \cite{lane_thomas_1958} for a
+detailed derivation in the general case, or to Section II.A.2\ref{} of this document for a simplified
+version.
+
+In scattering theory, a channel may be defined by $c = (\alpha, l, s, J)$, where the following
+definitions apply:
+
+\begin{itemize}
+\item $\alpha$ represents the two particles making up the channel; $\alpha$ includes mass ($m$ and $M$), charge ($z$ and $Z$), spin ($i$ and $I$ ) with associated parities, and all other quantum numbers for each of the two particles, plus the Q-value (equivalent to the negative of the threshold energy in the
+center of momentum system).
+\item $l$ is the orbital angular momentum of the pair, and the associated parity is given by $(-1)^l$.
+\item $s$ represents the channel spin (including the associated parity); that is, $s$ is the quantized
+vector sum of the spins of the two particles of the pair: $\vec{s} = \vec{i} + \vec{I}$
+\item $J$ is the total angular momentum (and associated parity); that is, $J$ is the quantized vector sum
+of $l$ and $s$: $\vec{J} = \vec{l} + \vec{s}$.
+\end{itemize}
diff --git a/sammy/PackagesList.cmake b/sammy/PackagesList.cmake
index 54dd1e89b..7d48709ed 100644
--- a/sammy/PackagesList.cmake
+++ b/sammy/PackagesList.cmake
@@ -16,6 +16,7 @@ SET( SAMMY_PACKAGES_AND_DIRS_AND_CLASSIFICATIONS
coulomb src/coulomb PS
endf src/endf PS
salmon src/salmon PS
+ convolution src/convolution PS
io src/io PS
sammy_executable src/sammy PS
samdis src/samdis PS
diff --git a/sammy/script/options_sammy_packages.cmake b/sammy/script/options_sammy_packages.cmake
index b25c25db1..3613e4871 100755
--- a/sammy/script/options_sammy_packages.cmake
+++ b/sammy/script/options_sammy_packages.cmake
@@ -9,6 +9,7 @@ SET(_list
coulomb
endf
salmon
+convolution
io
sammy_executable
samdis
diff --git a/sammy/src/blk/CapYCorrections_common.f90 b/sammy/src/blk/CapYCorrections_common.f90
new file mode 100644
index 000000000..e4427788e
--- /dev/null
+++ b/sammy/src/blk/CapYCorrections_common.f90
@@ -0,0 +1,12 @@
+! /**********************************************************
+! * This common block style module is a temporary solution
+! * used to pass the variables contained in C++ classes until
+! * the code has been fully modernized.
+! **********************************************************/
+module CapYCorrections_common_m
+ use CapYieldCorrections_M
+ IMPLICIT NONE
+
+ type(CapYieldCorrections)::capYieldCor
+
+end module CapYCorrections_common_m
diff --git a/sammy/src/blk/Logic_ssm_common.f90 b/sammy/src/blk/Logic_ssm_common.f90
index e07b0b584..fb1c57a90 100644
--- a/sammy/src/blk/Logic_ssm_common.f90
+++ b/sammy/src/blk/Logic_ssm_common.f90
@@ -1,6 +1,7 @@
! replaces contents of B58ZYX which contains common block 'Logic_Ssm'
module logic_ssm_common_m
! *** B58ZYX
+ use AllocateFunctions_m
IMPLICIT NONE
LOGICAL,save :: Self_Shield_Only
@@ -16,7 +17,7 @@ module logic_ssm_common_m
integer,save :: Isqfb
integer,save :: Idsqfb
integer,save :: Idpsqf
- integer,save :: Iqfb
+ real(kind=8), allocatable,dimension(:)::A_Iqfb
integer,save :: Idvqfb
integer,save :: Idelas
integer,save :: Idt
@@ -34,7 +35,7 @@ module logic_ssm_common_m
integer, save :: Icsx
integer, save :: Iepx
integer, save :: Iggx
- integer, save :: Iiex
+ integer, allocatable,dimension(:)::I_Iiex
integer, save :: Idyyy1
integer, save :: Idyyy2
integer, save :: Idyy2q
@@ -53,7 +54,7 @@ module logic_ssm_common_m
integer, save :: Idy2aa
integer, save :: Idy2aq
integer, save :: Idyaqq
- integer, save :: Ixtptw
+ real(kind=8), allocatable,dimension(:)::A_Ixtptw
integer, save :: Ixtptv
integer, save :: Interp_Small_Times
integer, save :: Icthet
@@ -71,4 +72,20 @@ module logic_ssm_common_m
real(8) :: Dkadu
real(8) :: corr_ka
+ contains
+ subroutine make_A_Ixtptw(want)
+ integer::want
+ call allocate_real_data(A_Ixtptw,want)
+ end subroutine make_A_Ixtptw
+
+ subroutine make_A_Iqfb(want)
+ integer::want
+ call allocate_real_data(A_Iqfb,want)
+ end subroutine make_A_Iqfb
+
+ subroutine make_I_Iiex(want)
+ integer::want
+ call allocate_integer_data(I_Iiex,want)
+ end subroutine make_I_Iiex
+
end module logic_ssm_common_m
diff --git a/sammy/src/convolution/CMakeLists.txt b/sammy/src/convolution/CMakeLists.txt
index 5599a146c..81c874b58 100644
--- a/sammy/src/convolution/CMakeLists.txt
+++ b/sammy/src/convolution/CMakeLists.txt
@@ -10,27 +10,30 @@ INCLUDE_DIRECTORIES(${CMAKE_CURRENT_BINARY_DIR})
# Set headers
SET(HEADERS
+ CapYieldCorrections.h
+
+ interface/cpp/CapYieldCorrectionsInterface.h
)
APPEND_SET(CONVOLUTION_SOURCES
+ CapYieldCorrections.cpp
-
+ interface/cpp/CapYieldCorrectionsInterface.cpp
+ interface/fortran/CapYieldCorrections_I.f90
+ interface/fortran/CapYieldCorrections_M.f90
)
TRIBITS_ADD_LIBRARY(
- SammyIOUtilsLib
+ SammyConvolutionUtilsLib
SOURCES ${CONVOLUTION_SOURCES}
)
INSTALL(FILES ${HEADERS} DESTINATION "src/convolution")
-# temporarily disable until we properly solve the
+
# Nemesis gtest dependency
-IF (TPL_ENABLE_NEMESIS)
- MESSAGE(STATUS "TPL_ENABLE_NEMESIS was ON, but io gtest is currently disabled")
- #TRIBITS_ADD_TEST_DIRECTORIES(tests)
-ENDIF()
+TRIBITS_ADD_TEST_DIRECTORIES(tests)
TRIBITS_PACKAGE_POSTPROCESS()
diff --git a/sammy/src/convolution/CapYieldCorrections.cpp b/sammy/src/convolution/CapYieldCorrections.cpp
new file mode 100644
index 000000000..ace8fdc6c
--- /dev/null
+++ b/sammy/src/convolution/CapYieldCorrections.cpp
@@ -0,0 +1,134 @@
+#include "CapYieldCorrections.h"
+#include <cmath>
+#include <iostream>
+#include <sstream>
+#include <exception>
+#include <stdexcept>
+
+namespace sammy{
+
+ // Maximum absolute value for the std::exp() function before
+ // under/overflow
+ #define MAX_IEEE_EXPONENT 708.4
+
+ CapYieldCorrections::CapYieldCorrections()
+ {
+ gammaCor = 0.0;
+ }
+
+ CapYieldCorrections::CapYieldCorrections(const CapYieldCorrections &orig)
+ {
+ gammaCor = orig.gammaCor;
+ }
+
+
+ void CapYieldCorrections::gammaAttenCorr(const double &thickness,
+ const double &sigma_t,
+ const double &attenFactor,
+ double &yield)
+ {
+
+ // Macroscopic cross section
+ double N_sigma = thickness*sigma_t;
+
+ // These checks prevent divide-by-zero situtations
+ CapYieldCorrections::check_nsigma(N_sigma);
+ CapYieldCorrections::check_attenFactor(attenFactor);
+
+ // Correction factor gammaCor for use in this class
+ gammaCor = 1.0/(1.0+attenFactor/N_sigma) * (1-std::exp(-N_sigma-attenFactor)) / (1-std::exp(-N_sigma));
+
+ CapYieldCorrections::check_gammaCor(gammaCor);
+
+ yield = yield * gammaCor;
+
+ }
+
+ void CapYieldCorrections::derivGammaAttenCorr(const double &thickness, const double &sigma_t,
+ const double &attenFactor,const double &derivSigmaTot,
+ const double &unattenuatedYield, double &derivYield )
+ {
+ // Macroscopic cross section
+ double N_sigma = thickness*sigma_t;
+ // e to the power of neg N_sigma
+ double exp_Nsig = std::exp(-N_sigma);
+ // e to the power of neg N_sigma minus attenFactor
+ double exp_Nsig_c1 = std::exp(-attenFactor-N_sigma);
+
+ // These checks prevent divide-by-zero situtations
+ CapYieldCorrections::check_nsigma(N_sigma);
+ CapYieldCorrections::check_attenFactor(attenFactor);
+
+ // Correction factor gammaCor for use in this class
+ if( gammaCor == 0.0 ){
+ gammaCor = 1.0/(1.0+attenFactor/N_sigma) * (1-std::exp(-N_sigma-attenFactor)) / (1-std::exp(-N_sigma));
+ }
+
+ CapYieldCorrections::check_gammaCor(gammaCor);
+
+ // Derivative of k_a w.r.t. total cross section
+ double alpha = (1-exp_Nsig) * (exp_Nsig_c1 * thickness * (1+attenFactor/(N_sigma))
+ + attenFactor/(thickness*std::pow(sigma_t,2)) * (1-exp_Nsig_c1)) / std::pow((1+attenFactor/(N_sigma)),2);
+ double beta = exp_Nsig*(1-exp_Nsig_c1) * thickness / (1+attenFactor/(N_sigma));
+ double tau = std::pow((1-exp_Nsig),2);
+ double dka_dtot = ( alpha - beta ) / tau;
+
+ // Derivative of k_a w.r.t. u-parameter (d(k_a)/dsig_t * d(sig_t)/du)
+ double dka_du = dka_dtot * derivSigmaTot;
+
+ // Derivative of (k_a * yield) w.r.t. u-paramater
+ derivYield = dka_du * unattenuatedYield + derivYield * gammaCor;
+ }
+
+ void CapYieldCorrections::check_nsigma(double &N_sigma)
+ {
+ // divide by zero check
+ if( N_sigma <= 0.0 ){
+ std::ostringstream err;
+ err << "(sample thickness [at/b]) * (tot. x.s. [b]) is less than zero" << std::endl;
+ throw std::runtime_error(err.str());
+ }
+
+ // under/overflow check for exponent (double assumed)
+ if( std::abs(N_sigma) > MAX_IEEE_EXPONENT){
+ std::ostringstream err;
+ err << "Under or overflow may occur in exponent. Check sample thickness" << std::endl;
+ err << " and total cross section values." << std::endl;
+ throw std::runtime_error(err.str());
+ }
+
+
+ }
+
+ void CapYieldCorrections::check_attenFactor(const double &attenFactor)
+ {
+ // divide by zero check
+ if( attenFactor <= 0.0 ){
+ std::ostringstream err;
+ err << "Gamma attenuation factor C1 (from documentation) is less than zero" << std::endl;
+ err << "C1 = " << attenFactor << std::endl;
+ throw std::runtime_error(err.str());
+ }
+
+ // under/overflow check for exponent (double assumed)
+ if( std::abs(attenFactor) > MAX_IEEE_EXPONENT){
+ std::ostringstream err;
+ err << "Gamma attenuation factor C1 (from documentation) is too large, and" << std::endl;
+ err << " may cause under/overflow issues." << std::endl;
+ err << "C1 = " << attenFactor << std::endl;
+ throw std::runtime_error(err.str());
+ }
+ }
+
+ void CapYieldCorrections::check_gammaCor(double &gammaCor)
+ {
+ if( gammaCor <= 0.0 or gammaCor > 1.0 ){
+ std::ostringstream err;
+ err << "The gamma attenuation correction to the yield is less than or" << std::endl;
+ err << "equal to zero or greater than 1.0" << std::endl;
+ err << "k_a = " << gammaCor << std::endl;
+ throw std::runtime_error(err.str());
+ }
+ }
+
+}
\ No newline at end of file
diff --git a/sammy/src/convolution/CapYieldCorrections.h b/sammy/src/convolution/CapYieldCorrections.h
index a019ba2f6..da172c42c 100644
--- a/sammy/src/convolution/CapYieldCorrections.h
+++ b/sammy/src/convolution/CapYieldCorrections.h
@@ -7,6 +7,10 @@ namespace sammy{
/*******************************************************
* Class contains corrections specific to the capture
* yield. This includes capture gamma attenuation.
+ *
+ * For future organization of the SAMMY code, it might be
+ * best to make this a child class of some yield/observable
+ * class.
*
*******************************************************/
class CapYieldCorrections
@@ -14,7 +18,7 @@ namespace sammy{
public:
CapYieldCorrections();
CapYieldCorrections(const CapYieldCorrections& orig);
- virtual ~CapYieldCorrections();
+ virtual ~CapYieldCorrections(){};
/**
* Calculate the correction factor \f$ k_a \f$ from input variable \f$ C1 \f$ according
@@ -22,18 +26,67 @@ namespace sammy{
* \f[ k_a = \frac{ (1-e^{-N\cdot \sigma_{t}(E)-C1}) }{ (1-e^{-N\cdot\sigma_{t}(E)}) } \cdot \left(\frac{ 1 }{ (1 + C1/N/\sigma_{t}(E)) }\right) \f]
* where \f$ \sigma_{t}(E) \f$ is the total cross section and \f$N\f$ is the sample thickness
* in atom/barn. This assumes a simple model of capture yield (only the first interaction).
+ * This will apply the correction to the yield and store the correction factor in memory for
+ * the derivative calculation.
+ *
* @param thickness The atom/barn thickness of the sample (\f$N\f$)
* @param sigma_t The total cross section at a single energy (\f$\sigma_t(E)\f$)
+ * @param attenFactor the attenuation factor (\f$C1\f$) shown above, analogous to a photon attenuation coefficient
* @param yield The yield, which will be modified by the correction factor \f$k_a\f$
*/
- void gammaAttenCorr(double thickness, std::vector<double> sigma_t, std::vector<double> &yield );
+ void gammaAttenCorr(const double &thickness, const double &sigma_t, const double &attenFactor, double &yield );
/**
- * Calculate the derivative
+ * Calculate the derivative of the attenuated yield with respect to the u-parameters
+ * and update the derivative to the calculated value:
+ * \f[ \frac{d}{du}(k_a Y) = \frac{d(k_a)}{d\sigma_t} \cdot \frac{d(\sigma_t)}{du} \cdot Y + \frac{d(Y)}{du} \cdot k_a \f]
+ *
+ * \f[ \frac{\partial (k_aY)}{\partial u} = \frac{\partial k_a}{\partial \sigma_t}\frac{\partial \sigma_t}{\partial u}Y + k_a\frac{\partial Y}{\partial u} \f]
+ *
+ * \f[ \frac{\partial k_a}{\partial \sigma_t} = \frac{\alpha - \beta}{\tau} \f]
+ *
+ * \f[ \alpha=\frac{(1-e^{-N\sigma_t})\left(e^{-(N\sigma_t+C_1)}N(1+\frac{C_1}{N\sigma_t})+\frac{C_1(1-e^{-(N\sigma_t+C_1)})}{N\sigma_t^2}\right)}{(1+\frac{C_1}{N\sigma_t})^2} \f]
+ *
+ * \f[ \beta = \frac{Ne^{-N\sigma_t}\left(1-e^{-(N\sigma_t+C_1)}\right)}{1+\frac{C_1}{N\sigma_t}} \f]
+ *
+ * \f[ \tau = (1-e^{-N\sigma_t})^2 \f]
+ *
+ * @param thickness The atom/barn thickness of the sample (\f$N\f$)
+ * @param sigma_t The total cross section at a single energy (\f$\sigma_t(E)\f$)
+ * @param attenFactor the attenuation factor (\f$C1\f$) shown above, analogous to a photon attenuation coefficient
+ * @param unattenuatedYield the yield before the attenuation correction has been applied
+ * @param derivSigmaTot the derivative of the total cross section w.r.t. the u-parameters
+ * @param derivYield the derivative of the unattenuated yield, which will be updated to the new value
*/
+ void derivGammaAttenCorr(const double &thickness, const double &sigma_t, const double &attenFactor,
+ const double &derivSigmaTot, const double &unattenuatedYield, double &derivYield );
private:
+ /* The gamma attenuation correction factor which multiplies the capture yield */
+ double gammaCor;
+
+ /**
+ * Check if input will cause mathematical errors: divide by zero and over/underflow
+ *
+ * @param N_sigma the thickness [at/b] multiplied by the total cross section [b]
+ */
+ void check_nsigma(double &N_sigma);
+
+ /**
+ * Check if input will cause mathematical errors: divide by zero and over/underflow
+ *
+ * @param attenFactor the attenuation factor (\f$C1\f$) shown above, analogous to a photon attenuation coefficient
+ */
+ void check_attenFactor(const double &attenFactor);
+
+ /**
+ * Check if input will cause mathematical errors: divide by zero and over/underflow
+ *
+ * @param gammaCor the gamma attenuation correction applied to the yield
+ */
+ void check_gammaCor(double &gammaCor);
+
};
}
diff --git a/sammy/src/convolution/cmake/Dependencies.cmake b/sammy/src/convolution/cmake/Dependencies.cmake
new file mode 100644
index 000000000..13244a48a
--- /dev/null
+++ b/sammy/src/convolution/cmake/Dependencies.cmake
@@ -0,0 +1,8 @@
+SET(LIB_REQUIRED_DEP_PACKAGES)
+SET(LIB_OPTIONAL_DEP_PACKAGES)
+SET(TEST_REQUIRED_DEP_PACKAGES)
+SET(TEST_OPTIONAL_DEP_PACKAGES)
+SET(LIB_REQUIRED_DEP_TPLS SCALE)
+SET(LIB_OPTIONAL_DEP_TPLS)
+SET(TEST_REQUIRED_DEP_TPLS Nemesis_gtest)
+SET(TEST_OPTIONAL_DEP_TPLS)
diff --git a/sammy/src/convolution/interface/cix/CapYieldCorrections.cpp2f.xml b/sammy/src/convolution/interface/cix/CapYieldCorrections.cpp2f.xml
new file mode 100644
index 000000000..4088cff04
--- /dev/null
+++ b/sammy/src/convolution/interface/cix/CapYieldCorrections.cpp2f.xml
@@ -0,0 +1,24 @@
+<generate name="CapYieldCorrections">
+ <include_relative name="../CapYieldCorrections.h"/>
+ <using_namespace name="sammy"/>
+
+ <class name="CapYieldCorrections">
+
+ <method name="gammaAttenCorr">
+ <param name="thickness" type="double"/>
+ <param name="sigma_t" type="double"/>
+ <param name="attenFactor" type="double"/>
+ <param name="yield" type="double"/>
+ </method>
+
+ <method name="derivGammaAttenCorr">
+ <param name="thickness" type="double"/>
+ <param name="sigma_t" type="double"/>
+ <param name="attenFactor" type="double"/>
+ <param name="derivSigmaTot" type="double"/>
+ <param name="unattenuatedYield" type="double"/>
+ <param name="derivYield" type="double"/>
+ </method>
+
+ </class>
+</generate>
\ No newline at end of file
diff --git a/sammy/src/convolution/interface/cpp/CapYieldCorrectionsInterface.cpp b/sammy/src/convolution/interface/cpp/CapYieldCorrectionsInterface.cpp
new file mode 100644
index 000000000..9c9678dd5
--- /dev/null
+++ b/sammy/src/convolution/interface/cpp/CapYieldCorrectionsInterface.cpp
@@ -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: Fri Feb 07 12:33:43 EST 2020
+* 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 "CapYieldCorrectionsInterface.h"
+using namespace sammy;
+void CapYieldCorrections_gammaAttenCorr(void * CapYieldCorrections_ptr,double * thickness,double * sigma_t,double * attenFactor,double * yield)
+{
+ ((CapYieldCorrections*)CapYieldCorrections_ptr)->gammaAttenCorr(*thickness,*sigma_t,*attenFactor,*yield);
+}
+
+void CapYieldCorrections_derivGammaAttenCorr(void * CapYieldCorrections_ptr,double * thickness,double * sigma_t,double * attenFactor,double * derivSigmaTot,double * unattenuatedYield,double * derivYield)
+{
+ ((CapYieldCorrections*)CapYieldCorrections_ptr)->derivGammaAttenCorr(*thickness,*sigma_t,*attenFactor,*derivSigmaTot,*unattenuatedYield,*derivYield);
+}
+
+void* CapYieldCorrections_initialize()
+{
+ return new CapYieldCorrections();
+}
+
+void CapYieldCorrections_destroy(void * CapYieldCorrections_ptr)
+{
+ delete (CapYieldCorrections*)CapYieldCorrections_ptr;
+}
+
diff --git a/sammy/src/convolution/interface/cpp/CapYieldCorrectionsInterface.h b/sammy/src/convolution/interface/cpp/CapYieldCorrectionsInterface.h
new file mode 100644
index 000000000..234028210
--- /dev/null
+++ b/sammy/src/convolution/interface/cpp/CapYieldCorrectionsInterface.h
@@ -0,0 +1,23 @@
+/*!
+* 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 07 12:33:43 EST 2020
+* 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 CAPYIELDCORRECTIONSINTERFACE_H
+#define CAPYIELDCORRECTIONSINTERFACE_H
+#include "../../CapYieldCorrections.h"
+using namespace sammy;
+#ifdef __cplusplus
+extern "C" {
+#endif
+void CapYieldCorrections_gammaAttenCorr(void * CapYieldCorrections_ptr,double * thickness,double * sigma_t,double * attenFactor,double * yield);
+void CapYieldCorrections_derivGammaAttenCorr(void * CapYieldCorrections_ptr,double * thickness,double * sigma_t,double * attenFactor,double * derivSigmaTot,double * unattenuatedYield,double * derivYield);
+void* CapYieldCorrections_initialize();
+void CapYieldCorrections_destroy(void * CapYieldCorrections_ptr);
+#ifdef __cplusplus
+}
+#endif
+#endif /* CAPYIELDCORRECTIONSINTERFACE_H */
diff --git a/sammy/src/convolution/interface/fortran/CapYieldCorrections_I.f90 b/sammy/src/convolution/interface/fortran/CapYieldCorrections_I.f90
new file mode 100644
index 000000000..6ae142960
--- /dev/null
+++ b/sammy/src/convolution/interface/fortran/CapYieldCorrections_I.f90
@@ -0,0 +1,43 @@
+!>
+!! 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 07 12:33:43 EST 2020
+!! 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 CapYieldCorrections_I
+use, intrinsic :: ISO_C_BINDING
+interface
+subroutine f_CapYieldCorrections_gammaAttenCorr(CapYieldCorrections_ptr, thickness,sigma_t,attenFactor,yield ) BIND(C,name="CapYieldCorrections_gammaAttenCorr")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: CapYieldCorrections_ptr;
+ real(C_DOUBLE) :: thickness;
+ real(C_DOUBLE) :: sigma_t;
+ real(C_DOUBLE) :: attenFactor;
+ real(C_DOUBLE) :: yield;
+end subroutine
+subroutine f_CapYieldCorrections_derivGammaAttenCorr(CapYieldCorrections_ptr, thickness,sigma_t,attenFactor,derivSigmaTot,unattenuatedYield,derivYield ) BIND(C,name="CapYieldCorrections_derivGammaAttenCorr")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: CapYieldCorrections_ptr;
+ real(C_DOUBLE) :: thickness;
+ real(C_DOUBLE) :: sigma_t;
+ real(C_DOUBLE) :: attenFactor;
+ real(C_DOUBLE) :: derivSigmaTot;
+ real(C_DOUBLE) :: unattenuatedYield;
+ real(C_DOUBLE) :: derivYield;
+end subroutine
+type(C_PTR) function f_CapYieldCorrections_initialize( )BIND(C,name="CapYieldCorrections_initialize")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR) :: CapYieldCorrections_ptr;
+end function
+subroutine f_CapYieldCorrections_destroy(this) BIND(C,name="CapYieldCorrections_destroy")
+ use,intrinsic :: ISO_C_BINDING
+ implicit none
+ type(C_PTR), value :: this;
+end subroutine
+end interface
+end module CapYieldCorrections_I
diff --git a/sammy/src/convolution/interface/fortran/CapYieldCorrections_M.f90 b/sammy/src/convolution/interface/fortran/CapYieldCorrections_M.f90
new file mode 100644
index 000000000..393f77dff
--- /dev/null
+++ b/sammy/src/convolution/interface/fortran/CapYieldCorrections_M.f90
@@ -0,0 +1,52 @@
+!>
+!! 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 07 12:33:43 EST 2020
+!! 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 CapYieldCorrections_M
+use, intrinsic :: ISO_C_BINDING
+use CapYieldCorrections_I
+type CapYieldCorrections
+ type(C_PTR) :: instance_ptr=C_NULL_PTR
+ contains
+ procedure, pass(this) :: gammaAttenCorr => CapYieldCorrections_gammaAttenCorr
+ procedure, pass(this) :: derivGammaAttenCorr => CapYieldCorrections_derivGammaAttenCorr
+ procedure, pass(this) :: initialize => CapYieldCorrections_initialize
+ procedure, pass(this) :: destroy => CapYieldCorrections_destroy
+end type CapYieldCorrections
+contains
+subroutine CapYieldCorrections_gammaAttenCorr(this, thickness, sigma_t, attenFactor, yield)
+ implicit none
+ class(CapYieldCorrections)::this
+ real(C_DOUBLE)::thickness
+ real(C_DOUBLE)::sigma_t
+ real(C_DOUBLE)::attenFactor
+ real(C_DOUBLE)::yield
+ call f_CapYieldCorrections_gammaAttenCorr(this%instance_ptr, thickness,sigma_t,attenFactor,yield)
+end subroutine
+subroutine CapYieldCorrections_derivGammaAttenCorr(this, thickness, sigma_t, attenFactor, derivSigmaTot, unattenuatedYield, derivYield)
+ implicit none
+ class(CapYieldCorrections)::this
+ real(C_DOUBLE)::thickness
+ real(C_DOUBLE)::sigma_t
+ real(C_DOUBLE)::attenFactor
+ real(C_DOUBLE)::derivSigmaTot
+ real(C_DOUBLE)::unattenuatedYield
+ real(C_DOUBLE)::derivYield
+ call f_CapYieldCorrections_derivGammaAttenCorr(this%instance_ptr, thickness,sigma_t,attenFactor,derivSigmaTot,unattenuatedYield,derivYield)
+end subroutine
+subroutine CapYieldCorrections_initialize(this)
+ implicit none
+ class(CapYieldCorrections) :: this
+ this%instance_ptr = f_CapYieldCorrections_initialize()
+end subroutine
+subroutine CapYieldCorrections_destroy(this)
+ implicit none
+ class(CapYieldCorrections) :: this
+ call f_CapYieldCorrections_destroy(this%instance_ptr)
+ this%instance_ptr = C_NULL_PTR
+end subroutine
+end module CapYieldCorrections_M
diff --git a/sammy/src/convolution/tests/CMakeLists.txt b/sammy/src/convolution/tests/CMakeLists.txt
new file mode 100644
index 000000000..50399bf91
--- /dev/null
+++ b/sammy/src/convolution/tests/CMakeLists.txt
@@ -0,0 +1,3 @@
+include(NemesisTest)
+
+ADD_NEMESIS_TEST(CapYieldCorrectionsTest.cpp TIMEOUT 60000 NP 1 )
diff --git a/sammy/src/convolution/tests/CapYieldCorrectionsTest.cpp b/sammy/src/convolution/tests/CapYieldCorrectionsTest.cpp
new file mode 100644
index 000000000..6ddc83b07
--- /dev/null
+++ b/sammy/src/convolution/tests/CapYieldCorrectionsTest.cpp
@@ -0,0 +1,359 @@
+#include "Nemesis/gtest/Gtest_Functions.hh"
+#include "Nemesis/gtest/nemesis_gtest.hh"
+#include "../CapYieldCorrections.h"
+#include <exception>
+#include <stdexcept>
+
+
+
+/**************************************************************************************************
+* Does the gamma attenuation function have the right math?
+**************************************************************************************************/
+TEST(CapYieldCorrections,gammaAttenuation){
+
+ const double thickness = std::log(2.0);
+ const double sigma_t = 2.0;
+ const double attenFactor = std::log(2.0);
+ double yield = 1.0;
+
+ sammy::CapYieldCorrections result;
+
+ // modifies the yield
+ result.gammaAttenCorr(thickness,sigma_t,attenFactor,yield);
+
+ double gold = 1.0/(1.0+1.0/2.0) * (1.0-1.0/8.0)/(1.0-1.0/4.0);
+
+ ASSERT_EQ(gold,yield);
+}
+
+
+/**************************************************************************************************
+* Does the derivative of the gamma attenuation function w.r.t. total x.s. have the right math?
+**************************************************************************************************/
+TEST(CapYieldCorrections,derivGammaAttenuation){
+
+ const double thickness = std::log(2.0);
+ const double sigma_t = 2.0;
+ const double attenFactor = std::log(2.0);
+ const double derivSigmaTot = 2.0;
+ const double unattenuatedYield = 1.0;
+ double derivYield = 1.0;
+
+
+ sammy::CapYieldCorrections result;
+
+ // -------------- unused but maybe helpful math -------------------------------------
+ // double gold_alpha = (1.0-1/4.0) * ( 1/8.0 * std::log(2) * (1.0+1/2.0) + 1/4.0*(1-1/8.0) ) / std::pow(1.0+1/2.0,2);
+ // double gold_beta = 1/4.0*(1.0-1/8.0)*std::log(2) / (1.0+1/2.0);
+ // double gold_tau = std::pow(1.0-1/4.0,2);
+ // double gold_broken_up_deriv_ka_sigtot = ( gold_alpha - gold_beta ) / gold_tau;
+ // ----------------------------------------------------------------------------------
+
+ // derivative of k_a w.r.t. the total cross section "sigma_t"
+ double gold_deriv_ka_sigtot = ( (1.0-1/4.0) * ( 1/8.0 * std::log(2) * (1.0+1/2.0) + 1/4.0*(1-1/8.0) ) / std::pow(1.0+1/2.0,2)
+ - 1/4.0*(1.0-1/8.0)*std::log(2) / (1.0+1/2.0) )
+ / std::pow(1.0-1/4.0,2);
+
+ double deriv_ka_du = derivSigmaTot * gold_deriv_ka_sigtot;
+
+ // { ----- Gamma attenuation correction ----- }
+ double gold_deriv = deriv_ka_du * unattenuatedYield + derivYield * 1.0/(1.0+1.0/2.0) * (1.0-1.0/8.0)/(1.0-1.0/4.0);
+
+ // modifies derivYield
+ result.derivGammaAttenCorr(thickness,sigma_t,attenFactor,derivSigmaTot,unattenuatedYield,derivYield);
+
+ ASSERT_EQ(gold_deriv,derivYield);
+}
+
+/**************************************************************************************************
+* Cause error to be thrown by gamma cor. func. from bad input thickness value (less than zero)
+**************************************************************************************************/
+TEST(CapYieldCorrections,throwError_gammAttCor_Nsigma_ltz){
+
+ int result;
+
+ sammy::CapYieldCorrections cyc;
+ const double thickness = -1.0;
+ const double sigma_t = 2.0;
+ const double attenFactor = std::log(2.0);
+ double yield = 1.0;
+
+ // Try the functions with bad input, if none throw an error the test has failed
+ try{
+ cyc.gammaAttenCorr(thickness,sigma_t,attenFactor,yield );
+
+ result = -1;
+ }
+ catch(...){
+ result = 0;
+ }
+
+ int gold = 0;
+
+ ASSERT_EQ(gold,result);
+}
+
+/**************************************************************************************************
+* Cause error to be thrown by gamma cor. func. from bad input thickness value (abs(N*sigma) > ~708)
+**************************************************************************************************/
+TEST(CapYieldCorrections,throwError_gammAttCor_Nsigma_gtmax){
+
+ int result;
+
+ sammy::CapYieldCorrections cyc;
+ const double thickness = 355.0;
+ const double sigma_t = 2.0;
+ const double attenFactor = 2.0;
+ double yield = 1.0;
+
+ // Try the functions with bad input, if none throw an error the test has failed
+ try{
+ cyc.gammaAttenCorr(thickness,sigma_t,attenFactor,yield );
+
+ result = -1;
+ }
+ catch(...){
+ result = 0;
+ }
+
+ int gold = 0;
+
+ ASSERT_EQ(gold,result);
+}
+
+/**************************************************************************************************
+* Cause error to be thrown by gamma cor. func. from bad attenuation factor (less than zero)
+**************************************************************************************************/
+TEST(CapYieldCorrections,throwError_gammAttCor_attFactor_ltz){
+
+ int result;
+
+ sammy::CapYieldCorrections cyc;
+ const double thickness = 1.0;
+ const double sigma_t = 2.0;
+ const double attenFactor = -1.0;
+ double yield = 1.0;
+
+ // Try the functions with bad input, if none throw an error the test has failed
+ try{
+ cyc.gammaAttenCorr(thickness,sigma_t,attenFactor,yield );
+
+ result = -1;
+ }
+ catch(...){
+ result = 0;
+ }
+
+ int gold = 0;
+
+ ASSERT_EQ(gold,result);
+}
+
+/**************************************************************************************************
+* Cause error to be thrown by gamma cor. func. from bad attenuation factor (abs(N*sigma) > ~708)
+**************************************************************************************************/
+TEST(CapYieldCorrections,throwError_gammAttCor_attFactor_gtmax){
+
+ int result;
+
+ sammy::CapYieldCorrections cyc;
+ const double thickness = 1.0;
+ const double sigma_t = 2.0;
+ const double attenFactor = 710.0;
+ double yield = 1.0;
+
+ // Try the functions with bad input, if none throw an error the test has failed
+ try{
+ cyc.gammaAttenCorr(thickness,sigma_t,attenFactor,yield );
+
+ result = -1;
+ }
+ catch(...){
+ result = 0;
+ }
+
+ int gold = 0;
+
+ ASSERT_EQ(gold,result);
+}
+
+/**************************************************************************************************
+* Cause error to be thrown by gamma cor. func. from bad calculated gamma attenuation correction (> 0)
+**************************************************************************************************/
+TEST(CapYieldCorrections,throwError_gammAttCor_gammaCor_gtone){
+
+ int result;
+
+ sammy::CapYieldCorrections cyc;
+ const double thickness = 1.0;
+ const double sigma_t = 0.1;
+ const double attenFactor = -0.01;
+ double yield = 1.0;
+
+ // Try the functions with bad input, if none throw an error the test has failed
+ try{
+ cyc.gammaAttenCorr(thickness,sigma_t,attenFactor,yield );
+
+ result = -1;
+ }
+ catch(...){
+ result = 0;
+ }
+
+ int gold = 0;
+
+ ASSERT_EQ(gold,result);
+}
+
+/**************************************************************************************************
+* Cause error to be thrown by derivative func. from bad input thickness value (less than zero)
+**************************************************************************************************/
+TEST(CapYieldCorrections,throwError_derivGammAttCor_Nsigma_ltz){
+
+ int result;
+
+ sammy::CapYieldCorrections cyc;
+ const double thickness = -1.0;
+ const double sigma_t = 2.0;
+ const double attenFactor = std::log(2.0);
+ const double derivSigmaTot = 2.0;
+ const double unattenuatedYield = 1.0;
+ double derivYield = 1.0;
+
+ // Try the functions with bad input, if none throw an error the test has failed
+ try{
+ cyc.derivGammaAttenCorr(thickness,sigma_t,attenFactor,derivSigmaTot,unattenuatedYield,derivYield );
+
+ result = -1;
+ }
+ catch(...){
+ result = 0;
+ }
+
+ int gold = 0;
+
+ ASSERT_EQ(gold,result);
+}
+
+/**************************************************************************************************
+* Cause error to be thrown by derivative func. from bad input thickness value (abs(N*sigma) > ~708)
+**************************************************************************************************/
+TEST(CapYieldCorrections,throwError_derivGammAttCor_Nsigma_gtmax){
+
+ int result;
+
+ sammy::CapYieldCorrections cyc;
+ const double thickness = 355.0;
+ const double sigma_t = 2.0;
+ const double attenFactor = 2.0;
+ const double derivSigmaTot = 2.0;
+ const double unattenuatedYield = 1.0;
+ double derivYield = 1.0;
+
+ // Try the functions with bad input, if none throw an error the test has failed
+ try{
+ cyc.derivGammaAttenCorr(thickness,sigma_t,attenFactor,derivSigmaTot,unattenuatedYield,derivYield );
+
+ result = -1;
+ }
+ catch(...){
+ result = 0;
+ }
+
+ int gold = 0;
+
+ ASSERT_EQ(gold,result);
+}
+
+/**************************************************************************************************
+* Cause error to be thrown by derivative func. from bad attenuation factor (less than zero)
+**************************************************************************************************/
+TEST(CapYieldCorrections,throwError_derivGammAttCor_attFactor_ltz){
+
+ int result;
+
+ sammy::CapYieldCorrections cyc;
+ const double thickness = 1.0;
+ const double sigma_t = 2.0;
+ const double attenFactor = -1.0;
+ const double derivSigmaTot = 2.0;
+ const double unattenuatedYield = 1.0;
+ double derivYield = 1.0;
+
+ // Try the functions with bad input, if none throw an error the test has failed
+ try{
+ cyc.derivGammaAttenCorr(thickness,sigma_t,attenFactor,derivSigmaTot,unattenuatedYield,derivYield );
+
+ result = -1;
+ }
+ catch(...){
+ result = 0;
+ }
+
+ int gold = 0;
+
+ ASSERT_EQ(gold,result);
+}
+
+/**************************************************************************************************
+* Cause error to be thrown by derivative func. from bad attenuation factor (abs(N*sigma) > ~708)
+**************************************************************************************************/
+TEST(CapYieldCorrections,throwError_derivGammAttCor_attFactor_gtmax){
+
+ int result;
+
+ sammy::CapYieldCorrections cyc;
+ const double thickness = 1.0;
+ const double sigma_t = 2.0;
+ const double attenFactor = 710.0;
+ const double derivSigmaTot = 2.0;
+ const double unattenuatedYield = 1.0;
+ double derivYield = 1.0;
+
+ // Try the functions with bad input, if none throw an error the test has failed
+ try{
+ cyc.derivGammaAttenCorr(thickness,sigma_t,attenFactor,derivSigmaTot,unattenuatedYield,derivYield );
+
+ result = -1;
+ }
+ catch(...){
+ result = 0;
+ }
+
+ int gold = 0;
+
+ ASSERT_EQ(gold,result);
+}
+
+/**************************************************************************************************
+* Cause error to be thrown by derivative func. from bad calculated gamma attenuation correction (> 0)
+**************************************************************************************************/
+TEST(CapYieldCorrections,throwError_derivGammAttCor_gammaCor_gtone){
+
+ int result;
+
+ sammy::CapYieldCorrections cyc;
+ const double thickness = 1.0;
+ const double sigma_t = 0.1;
+ const double attenFactor = -0.01;
+ const double derivSigmaTot = 2.0;
+ const double unattenuatedYield = 1.0;
+ double derivYield = 1.0;
+
+ // Try the functions with bad input, if none throw an error the test has failed
+ try{
+ cyc.derivGammaAttenCorr(thickness,sigma_t,attenFactor,derivSigmaTot,unattenuatedYield,derivYield );
+
+ result = -1;
+ }
+ catch(...){
+ result = 0;
+ }
+
+ int gold = 0;
+
+ ASSERT_EQ(gold,result);
+}
+
+
+
diff --git a/sammy/src/mso/mmso0.f b/sammy/src/mso/mmso0.f
index 37e073d05..7543ed373 100644
--- a/sammy/src/mso/mmso0.f
+++ b/sammy/src/mso/mmso0.f
@@ -18,6 +18,7 @@ C
use cbro_common_m
use lbro_common_m
use MultScatPars_common_m
+ use ssm_1_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION A(-Msize:Msize)
C
diff --git a/sammy/src/mso/mmso2.f b/sammy/src/mso/mmso2.f
index a74b73c77..833f7f1d0 100644
--- a/sammy/src/mso/mmso2.f
+++ b/sammy/src/mso/mmso2.f
@@ -23,6 +23,8 @@ C
use constn_common_m
use EndfData_common_m
use MultScatPars_common_m
+ use ssm_18_m
+ use ssm_20_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Another_Process_will_Happen
C
@@ -332,6 +334,7 @@ C
use cbro_common_m
use lbro_common_m
use MultScatPars_common_m
+ use ssm_9_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Forward, Backward
C
diff --git a/sammy/src/mso/mmso5.f b/sammy/src/mso/mmso5.f
index c0b966818..792fd5a5f 100644
--- a/sammy/src/mso/mmso5.f
+++ b/sammy/src/mso/mmso5.f
@@ -195,6 +195,7 @@ C
C
use fixedi_m
use ifwrit_m
+ use ssm_18_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Energb(*), Xtpt(*), Ftheta(*), Qfb(*), Dqfb(*),Delas(*),
* Dt(*), Dc(*), Ccclll(*), Dddlll(*), Totsig(*), Capsig(*),
diff --git a/sammy/src/sam/msam.F b/sammy/src/sam/msam.F
index ed1a51968..6f002252f 100755
--- a/sammy/src/sam/msam.F
+++ b/sammy/src/sam/msam.F
@@ -16,6 +16,7 @@ C
use EndfData_common_m
use MultScatPars_common_m
use ExpPars_common_m
+ use ssm_m
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C This is the main routine for the SAMMY program
diff --git a/sammy/src/sam012/CMakeLists.txt b/sammy/src/sam012/CMakeLists.txt
index d55f501d7..36ac21575 100644
--- a/sammy/src/sam012/CMakeLists.txt
+++ b/sammy/src/sam012/CMakeLists.txt
@@ -12,7 +12,7 @@ TRIBITS_ADD_EXECUTABLE(
sam012
NOEXEPREFIX
NOEXESUFFIX
- SOURCES ${SAM012_SOURCES} ../ssm/m012.f
+ SOURCES ${SAM012_SOURCES} ../ssm/m012.f90
LINKER_LANGUAGE Fortran
INSTALLABLE
)
diff --git a/sammy/src/sammy/CMakeLists.txt b/sammy/src/sammy/CMakeLists.txt
index 7ecb1ea9f..503470e75 100644
--- a/sammy/src/sammy/CMakeLists.txt
+++ b/sammy/src/sammy/CMakeLists.txt
@@ -417,30 +417,30 @@ APPEND_SET(SAMMY_SOURCES
../squ/msqu0.f
- ../ssm/mssm00.f
- ../ssm/mssm01.f
- ../ssm/mssm02.f
- ../ssm/mssm03.f
- ../ssm/mssm04.f
- ../ssm/mssm05.f
- ../ssm/mssm06.f
- ../ssm/mssm07.f
- ../ssm/mssm08.f
- ../ssm/mssm09.f
- ../ssm/mssm10.f
- ../ssm/mssm11.f
- ../ssm/mssm12.f
- ../ssm/mssm13.f
- ../ssm/mssm14.f
- ../ssm/mssm15.f
- ../ssm/mssm16.f
- ../ssm/mssm17.f
- ../ssm/mssm18.f
- ../ssm/mssm19.f
- ../ssm/mssm20.f
- ../ssm/mssm21.f
- ../ssm/mssm21a.f
- ../ssm/mssm22.f
+ ../ssm/mssm00.f90
+ ../ssm/mssm01.f90
+ ../ssm/mssm02.f90
+ ../ssm/mssm03.f90
+ ../ssm/mssm04.f90
+ ../ssm/mssm05.f90
+ ../ssm/mssm06.f90
+ ../ssm/mssm07.f90
+ ../ssm/mssm08.f90
+ ../ssm/mssm09.f90
+ ../ssm/mssm10.f90
+ ../ssm/mssm11.f90
+ ../ssm/mssm12.f90
+ ../ssm/mssm13.f90
+ ../ssm/mssm14.f90
+ ../ssm/mssm15.f90
+ ../ssm/mssm16.f90
+ ../ssm/mssm17.f90
+ ../ssm/mssm18.f90
+ ../ssm/mssm19.f90
+ ../ssm/mssm20.f90
+ ../ssm/mssm21.f90
+ ../ssm/mssm22.f90
+ ../ssm/ssm_utils.f90
../the/mthe0.f
../the/mthe1.f
@@ -572,6 +572,7 @@ APPEND_SET(SAMMY_SOURCES
../blk/AllocateFunctions.f90
../blk/ExpPars_common.f90
../blk/MultScatPars_common.f90
+ ../blk/CapYCorrections_common.f90
)
TRIBITS_ADD_LIBRARY(
diff --git a/sammy/src/sammy/cmake/Dependencies.cmake b/sammy/src/sammy/cmake/Dependencies.cmake
index 3cbe5fa0e..82851db70 100644
--- a/sammy/src/sammy/cmake/Dependencies.cmake
+++ b/sammy/src/sammy/cmake/Dependencies.cmake
@@ -2,7 +2,7 @@
# it here for clarity - we can iterate on this later
#add back in self_shielding library dependency when it is reintroduced (SSM subdir)
#add back in global_data library when equivalency problems in library are resolved
-SET(LIB_REQUIRED_DEP_PACKAGES endf coulomb salmon io)
+SET(LIB_REQUIRED_DEP_PACKAGES endf coulomb salmon io convolution)
SET(LIB_OPTIONAL_DEP_PACKAGES)
SET(TEST_REQUIRED_DEP_PACKAGES TestRunner)
SET(TEST_OPTIONAL_DEP_PACKAGES)
diff --git a/sammy/src/ssm/m012.f b/sammy/src/ssm/m012.f90
similarity index 85%
rename from sammy/src/ssm/m012.f
rename to sammy/src/ssm/m012.f90
index b278036a7..e0321a522 100755
--- a/sammy/src/ssm/m012.f
+++ b/sammy/src/ssm/m012.f90
@@ -1,30 +1,28 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
PROGRAM Fix_Sam012
use EndfData_common_m
-C
-C *** PURPOSE -- Read ascii file (pieces of multiple-scattering
-C *** correction) and create comparable odf file
-C
-C
+!
+! *** PURPOSE -- Read ascii file (pieces of multiple-scattering
+! *** correction) and create comparable odf file
+!
+!
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION Energy(50000), Fzer(50000), Fone(50000), Ftwo(50000)
CHARACTER*70 Asciif, Blank
CHARACTER*50 Title
DATA Nchmax /50000/
- DATA Blank /' *
- * '/
-C
+ DATA Blank /' '/
+!
call resParData%initialize()
WRITE (6,10000)
-10000 FORMAT (/,
- 1' **********************************************************')
+10000 FORMAT (/,' **********************************************************')
WRITE (6,10100)
10100 FORMAT (/, ' *** SAM012 14 Aug 08 ***')
WRITE (6,10000)
-C
+!
WRITE (6,10200)
10200 FORMAT (' What is name of ASCII file containing Y0, Y1, & Y2 ?')
READ (5,10300) Asciif
@@ -32,7 +30,7 @@ C
IF (Asciif.EQ.Blank) Asciif='fort.22'
WRITE (6,10400) Asciif
10400 FORMAT (' <<< ', A70, ' >>>')
-C
+!
CALL Filopn (14, Asciif, 0)
READ (14,10500) Title
10500 FORMAT (A50)
@@ -40,8 +38,7 @@ C
10600 FORMAT (' TITLE ###', A50, '###')
READ (14,10500) Title
DO II=1,Nchmax
- READ (14,10700,END=10) Energy(Ii), Fzer(Ii), Fone(Ii),
- * Ftwo(Ii)
+ READ (14,10700,END=10) Energy(Ii), Fzer(Ii), Fone(Ii),Ftwo(Ii)
END DO
10700 FORMAT (E17.1,4E15.1)
Ii = Nchmax + 1
@@ -51,7 +48,7 @@ C
WRITE (6,10800) Nchi
10800 FORMAT (' Number of channels is', I8)
IF (Nchi.GT.Nchmax) STOP '[STOP in Fix_Sam012 in ssm/m012.f]'
-C
+!
Nch = Nchi
Nsect = 6
Kkkkev = 1
@@ -69,7 +66,7 @@ C
END DO
CALL Pltout (Iu, Nsect, 5, 1, Nch, Fone, 1)
CALL Pltout (Iu, Nsect, 6, 1, Nch, Ftwo, 1)
-C
+!
CALL Newopn (14, 'Y0.DAT ', 0)
DO I=1,Nch
Err = Fzer(I)/10.0d0
@@ -77,21 +74,21 @@ C
END DO
11000 FORMAT (F20.10, F20.15, F20.15)
CLOSE (UNIT=14)
-C
+!
CALL Newopn (14, 'Y1.DAT ', 0)
DO I=1,Nch
Err = Fone(I)/10.0d0
WRITE (14,11000) Energy(I), Fone(I), Err
END DO
CLOSE (UNIT=14)
-C
+!
CALL Newopn (14, 'Y2.DAT ', 0)
DO I=1,Nch
Err = Ftwo(I)/10.0d0
WRITE (14,11000) Energy(I), Ftwo(I), Err
END DO
CLOSE (UNIT=14)
-C
+!
WRITE (6,11100)
11100 FORMAT ( ' Normal finish in Fix_Sam012 in ssm/m012.f')
call resParData%destroy()
diff --git a/sammy/src/ssm/mssm00.f b/sammy/src/ssm/mssm00.f90
similarity index 75%
rename from sammy/src/ssm/mssm00.f
rename to sammy/src/ssm/mssm00.f90
index b6e46c972..afffd5b1e 100644
--- a/sammy/src/ssm/mssm00.f
+++ b/sammy/src/ssm/mssm00.f90
@@ -1,11 +1,13 @@
-C
-C
+!
+module ssm_m
+ contains
+!
SUBROUTINE Samssm_0 (A)
-C
-C *** Self-Shielding Multiple Scattering
-C *** This version contains both single & double scattering
-C *** plus of course self-shielding
-C
+!
+! *** Self-Shielding Multiple Scattering
+! *** This version contains both single & double scattering
+! *** plus of course self-shielding
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -16,10 +18,12 @@ C
use cbro_common_m
use lbro_common_m
use MultScatPars_common_m
+ use ssm_1_m
+ use ssm_2_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION A(-Msize:Msize)
-C
-C
+!
+!
WRITE (6,99999)
99999 FORMAT (' *** SAMMY-SSM 28 Aug 08 ***')
Segmen(1) = 'S'
@@ -27,7 +31,7 @@ C
Segmen(3) = 'M'
Nowwww = 0
-C
+!
CALL Initix
Nthhhh = multScat%getNumTheta()
Kthhhh = multScat%getNumThetaNearZero()
@@ -37,47 +41,47 @@ C
Ntheta = 10
call multScat%setNumTheta(10)
end if
-C
-C *** Set logical flags for this module
+!
+! *** Set logical flags for this module
CALL Set_Logic_Ssm
-C
+!
Kdatb = Ndatmx
-C *** Read first portion of file holding edge-effects, if needed
+! *** Read first portion of file holding edge-effects, if needed
CALL Qqqxxx (Delthe)
CALL Estss1 (Nx, Mx)
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- Ixtptw = Idimen (Nx, 1, 'Nx, 1')
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
+ call make_A_Ixtptw(Nx)
+ Ixtptw = Idimen (1, 1, 'Nx, 1')
Ixtptv = Idimen (Mx, 1, 'Mx, 1')
-C *** Read Xtpt's
- CALL Qqqyyy (A(Ixtptw), A(Ixtptv))
-C
-C
-C *** Guesstimate size of array needed for Samssm
- CALL Estssm (Kdatb, Nf, M1, M2, M3, M4, Nd, Ng, Nh, Maxx, Ndbl,
- * Nx, Nnx)
-C
-C
+! *** Read Xtpt's
+ CALL Qqqyyy (A_Ixtptw, A(Ixtptv))
+!
+!
+! *** Guesstimate size of array needed for Samssm
+ CALL Estssm (Kdatb, Nf, M1, M2, M3, M4, Nd, Ng, Nh, Maxx, Ndbl, Nx, Nnx)
+!
+!
Ie = Ienerg
Ieb = Ienerb + (Ndatmn-1)
-C
-C ### One ###
+!
+! ### One ###
CALL Set_Kws
-C
-C ### Two ###
+!
+! ### Two ###
Ifthet = Idimen (Nf, 1, 'Nf, 1')
Isqfb = Idimen (M2, 1, 'M2, 1')
-C *** Call Thtget for no finite size corrections (no edge effects)
+! *** Call Thtget for no finite size corrections (no edge effects)
IF (Single_Inf) CALL Thtget(A(Ifthet))
-C *** Read rest of file containing edge effects
+! *** Read rest of file containing edge effects
IF (Single_Fin) CALL Qqqget (A(Ifthet), A(Isqfb), Delthe)
-C
-C
-C ### three ###
- CALL Ssm_Get_Organized (A, Kdatb, Nf, M1, M2, M3, M4, Nd, Ng,
- * Nh, Maxx, Ndbl, Nx, Nnx)
-C
-C ### ??? ###
+!
+!
+! ### three ###
+ CALL Ssm_Get_Organized (A, Kdatb, Nf, M1, M2, M3, M4, Nd, &
+ Ng, Nh, Maxx, Ndbl, Nx, Nnx)
+!
+! ### ??? ###
IF (Double_Plus) THEN
Idps = Idimen (Kdatb*2, 1, 'Kdatb*2, 1')
Kthet2 = 65
@@ -98,16 +102,16 @@ C ### ??? ###
Isphi = 1
END IF
-C
-C *** Do the self shielding and multiple scattering corrections
- CALL Ssssds ( A, I_Ixciso , A(Ie), A(Ieb), A(Itotsi), A(Icapsi),
- * A(Iy2ccc), A(Idy2cc), Nx, Maxx, Kdatb)
-C
-C
+!
+! *** Do the self shielding and multiple scattering corrections
+ CALL Ssssds ( A, I_Ixciso , A(Ie), A(Ieb), A(Itotsi), A(Icapsi), &
+ A(Iy2ccc), A(Idy2cc), Nx, Maxx, Kdatb)
+!
+!
I = Idimen (Ixtptw, -1, 'Ixtptw, -1')
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
-C
-C
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
+!
+!
Jwwwww = 8
Numcro = 1
Nnnsig = 1
@@ -123,12 +127,12 @@ C
IF (Nudwhi.NE.0) Segnam = 'samudr'
IF (Numorr.GT.0) Segnam = 'samorr'
IF (Numrpi.GT.0) Segnam = 'samrpi'
- IF (Numorr.GT.0 .AND. Numrpi.GT.0)
- * STOP '[STOP -- Cannot do both RPI and ORR resolution]'
- IF (Numorr.GT.0 .AND. Nudwhi.NE.0)
- * STOP '[STOP -- Cannot do both ORR and UDR resolution]'
- IF (Nudwhi.NE.0 .AND. Numrpi.GT.0)
- * STOP '[STOP -- Cannot do both RPI and UDR resolution]'
+ IF (Numorr.GT.0 .AND. Numrpi.GT.0) &
+ STOP '[STOP -- Cannot do both RPI and ORR resolution]'
+ IF (Numorr.GT.0 .AND. Nudwhi.NE.0) &
+ STOP '[STOP -- Cannot do both ORR and UDR resolution]'
+ IF (Nudwhi.NE.0 .AND. Numrpi.GT.0) &
+ STOP '[STOP -- Cannot do both RPI and UDR resolution]'
IF (Kkkdex.NE.0) Segnam = 'samdex'
ELSE
IF (Kkkdex.EQ.0) THEN
@@ -138,9 +142,9 @@ C
END IF
END IF
END IF
-C
-c here is stop
-c stop
+!
+! here is stop
+! stop
call multScat%setNumTheta( Nthhhh )
Ntheta = Nthhhh ! remove
call multScat%setNumThetaNearZero( Kthhhh )
@@ -158,15 +162,15 @@ c stop
END IF
RETURN
END
-C
-C
-C _______________________________________________________________
-C
+!
+!
+! _______________________________________________________________
+!
SUBROUTINE Estss1 (Nx, Mx)
use fixedi_m
use ifwrit_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
IF (Kssmsc.EQ.1) THEN
Nx = Nxtptw
Mx = Nxtptv
@@ -178,25 +182,24 @@ C
END IF
RETURN
END
-C
-C
-C _______________________________________________________________
-C
- SUBROUTINE Estssm (Kdatb, NF, M1, M2, M3, M4, ND, NG, NH, Maxx,
- * Ndbl, Nx, Nnx)
-C
-C *** Purpose -- Guesstimate size of array needed for samSSM
-C
+!
+!
+! _______________________________________________________________
+!
+ SUBROUTINE Estssm (Kdatb, NF, M1, M2, M3, M4, ND, NG, NH, Maxx, Ndbl, Nx, Nnx)
+!
+! *** Purpose -- Guesstimate size of array needed for samSSM
+!
use fixedi_m
use ifwrit_m
use lbro_common_m
use MultScatPars_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
Nnparx = Nnpar
IF (Nnpar.EQ.0 .OR. Ksolve.EQ.2) Nnparx = 1
-C
-C ### Two ###
+!
+! ### Two ###
M1 = Nsqfb*Nxtptw*multScat%getNumTheta()
M2 = M1*Nxtptv
IF (Kssmsc.NE.1) M1 = 1
@@ -206,12 +209,12 @@ C ### Two ###
call multScat%setNumThetaNearOne(multScat%getNumTheta())
end if
Nf = Jtheta
-cx M4 = M2
-cx IF (Nnpar.EQ.0 .OR. Ksolve.EQ.2) M4 = 1
-cx K2 = M2 + M4 + Nf
+!x M4 = M2
+!x IF (Nnpar.EQ.0 .OR. Ksolve.EQ.2) M4 = 1
+!x K2 = M2 + M4 + Nf
K2 = M2 + Nf
-C
-C ### three ###
+!
+! ### three ###
M3 = M1
IF (Nnpar.EQ.0 .OR. Ksolve.EQ.2) M3 = 1
Nh = Nnpar
@@ -223,9 +226,9 @@ C ### three ###
Maxx = 100
K3 = M1 + M3 + 3*Nh + Nnnsig*Niniso + Nd + 3*Kdatb + 2*Ng
K3 = K3 + 3*Niniso + Maxx*4
-C
+!
K = K2 + K3
-C
+!
Nx = Nnpar
IF (Ksolve.EQ.2) Nx = 0
IF (Nx.EQ.0) THEN
@@ -240,21 +243,21 @@ C
Ndbl = 1
IF (Kssdbl.EQ.1) Ndbl = Kdatb
K = K + Ndbl*(Nnx+1) + 2*Nx + 14*Nnx
-C
+!
Kk = Idimen (K, 1, 'K, 1')
I = Idimen (Kk, -1, 'Kk, -1')
I = Idimen (0, 0, '0, 0')
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Set_Logic_Ssm
use ifwrit_m
use logic_ssm_common_m
use lbro_common_m
-C
+!
Another_Process_Will_Happen = Yresol.OR.Yaverg
Self_Shield_Only = .FALSE.
Single_Inf = .FALSE.
@@ -271,11 +274,11 @@ C
WRITE (6,10100)
WRITE (21,10100)
ELSE
-cx WRITE (6,10200)
+!x WRITE (6,10200)
WRITE (21,10200)
END IF
-10100 FORMAT (' Using linear interpolation for multiple-scattering')
-10200 FORMAT(' Using quadratic interpolation for multiple-scattering')
+10100 FORMAT(' Using linear interpolation for multiple-scattering')
+10200 FORMAT(' Using quadratic interpolation for multiple-scattering')
ELSE IF (Kssmsc.EQ.2) THEN
Single_Inf = .TRUE.
END IF
@@ -284,12 +287,12 @@ cx WRITE (6,10200)
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ssm_Get_Organized (A, Kdatb, Nf, M1, M2, M3, M4, Nd,
- * Ng, Nh, Maxx, Ndbl, Nx, Nnx)
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ssm_Get_Organized (A, Kdatb, Nf, M1, M2, M3, M4, Nd, &
+ Ng, Nh, Maxx, Ndbl, Nx, Nnx)
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -298,8 +301,8 @@ C
use lbro_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION A(-Msize:Msize)
-C
- Iqfb = Idimen (M1, 1, 'M1, 1')
+!
+ call make_A_Iqfb(M1)
Idvqfb = Idimen (M3, 1, 'M3, 1')
Idelas = Idimen (Nh, 1, 'Nh, 1')
Idt = Idimen (Nh, 1, 'Nh, 1')
@@ -317,7 +320,7 @@ C
Icsx = Idimen (Maxx, 1, 'Maxx, 1')
Iepx = Idimen (Maxx, 1, 'Maxx, 1')
Iggx = Idimen (Maxx, 1, 'Maxx, 1')
- Iiex = Idimen (Maxx, 1, 'Maxx, 1')
+ call make_I_Iiex(Maxx)
Idyyy1 = Idimen (Nx, 1, 'Nx, 1')
Idyyy2 = Idimen (Nnx, 1, 'Nnx, 1')
Idyy2q = Idimen (Nnx, 1, 'Nnx, 1')
@@ -336,6 +339,13 @@ C
Idy2aa = Idimen (Nnx, 1, 'Nnx, 1')
Idy2aq = Idimen (Nnx, 1, 'Nnx, 1')
Idyaqq = Idimen (Nnx, 1, 'Nnx, 1')
- CALL Zero_Array ( A(Iqfb), (Idyaqq-Iqfb+Nnx) )
+ ! ---------------------------
+ ! Idvqfb and Idyaqq+Nnx define the limits of the
+ ! array we need to zero out, this will change for
+ ! each move we make from Idimen to make_A_*
+ ! ---------------------------
+ CALL Zero_Array ( A(Idvqfb), (Idyaqq-Idvqfb+Nnx) )
RETURN
END
+
+end module ssm_m
diff --git a/sammy/src/ssm/mssm01.f b/sammy/src/ssm/mssm01.f90
similarity index 74%
rename from sammy/src/ssm/mssm01.f
rename to sammy/src/ssm/mssm01.f90
index 65effe9e7..fe1df2e8a 100644
--- a/sammy/src/ssm/mssm01.f
+++ b/sammy/src/ssm/mssm01.f90
@@ -1,15 +1,17 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module ssm_1_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Qqqxxx (Delthe)
-C
-C *** Read the dimensions of Xtpt_V & _W etc ***
-C *** Xtpt_V is log of energy grid for V=sigma_total(E)
-C *** Xtpt_W is log of energy grid for W=sigma_total(Ep)
-C *** Both are to be used for interpolation on Sqfb(V,W,mu)
-C *** where mu = cos(theta)
-C
+!
+! *** Read the dimensions of Xtpt_V & _W etc ***
+! *** Xtpt_V is log of energy grid for V=sigma_total(E)
+! *** Xtpt_W is log of energy grid for W=sigma_total(Ep)
+! *** Both are to be used for interpolation on Sqfb(V,W,mu)
+! *** where mu = cos(theta)
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -22,19 +24,19 @@ C
use MultScatPars_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA One /1.0d0/
-C
+!
Dthick = Thick
IF (Self_Shield_Only) THEN
-C *** Here for no multiple-scattering at all
+! *** Here for no multiple-scattering at all
Nxtptw = 1
Nzzz = 1
Ntheta = 1
-C
+!
ELSE IF (Single_Inf) THEN
-C *** Here for multiple-scattering without edge effects
-C
+! *** Here for multiple-scattering without edge effects
+!
ELSE
-C *** Here for multiple-scattering with edge effects
+! *** Here for multiple-scattering with edge effects
IF (Debug) WRITE (6,10100) Fqqqqq
10100 FORMAT (' Fqqqqq = <<< ', A70, ' >>>')
CALL Filopn (25, Fqqqqq, 1)
@@ -53,18 +55,18 @@ C *** Here for multiple-scattering with edge effects
IF (Nxtptw.NE.Nxtptwa .OR. Nxtptv.NE.Nxtptva) THEN
IF (Nxtptw.NE.0 .OR. Nxtptv.NE.0) THEN
WRITE (6,10101) Nxtptva, Nxtptwa, Nxtptv, Nxtptw
-10101 FORMAT (' Dimensions in SSM file are different from those',
- * /, ' specified in INPut file.', /,
- * ' In *.SSM file, Nxtptv and Nxtptw =', 2I5, /,
- * ' In INPut file, ', 2I5, /,
- * ' Values from *.SSM file will be used.')
+10101 FORMAT (' Dimensions in SSM file are different from those', &
+ /, ' specified in INPut file.', /, &
+ ' In *.SSM file, Nxtptv and Nxtptw =', 2I5, /, &
+ ' In INPut file, ', 2I5, /, &
+ ' Values from *.SSM file will be used.')
END IF
Nxtptv = Nxtptva
Nxtptw = Nxtptwa
END IF
READ (25) Rs, Rb, Sthick, Dthick, Densty, A1, B1, Costh1, Area
IF (Densty.NE.Dnsty) Dnsty = Densty
-cx READ (25) Xtpt_W, Xtpt_V
+!x READ (25) Xtpt_W, Xtpt_V
N = Ntheta - 1
Jtheta = Ntheta
call multScat%setNumThetaNearOne(multScat%getNumTheta())
@@ -79,51 +81,51 @@ cx READ (25) Xtpt_W, Xtpt_V
END IF
END IF
RETURN
-C
+!
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Qqqyyy (Xtpt_W, Xtpt_V)
-C
-C *** Read the Xtpt's ***
-C
+!
+! *** Read the Xtpt's ***
+!
use fixedi_m
use logic_ssm_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Xtpt_W(Nxtptw), Xtpt_V(Nxtptv)
-C
+!
IF (Self_Shield_Only) THEN
ELSE IF (Single_Inf) THEN
ELSE
-C *** Here for multiple-scattering with edge effects
+! *** Here for multiple-scattering with edge effects
READ (25) Xtpt_W, Xtpt_V
END IF
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Thtget (Ftheta)
-C
-C *** Initialize array Ftheta, when there are no edge corrections
-C
+!
+! *** Initialize array Ftheta, when there are no edge corrections
+!
use fixedi_m
use ifwrit_m
use MultScatPars_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Ftheta(*)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
D = One/(Ntheta-One)
Ftheta(1) = Zero
DO I=2,Ntheta-1
Ftheta(I) = D*(I-One)
END DO
Ftheta(Ntheta) = One
-C
+!
IF (Kdebug.NE.0) THEN
WRITE (6,10000) Ntheta
10000 FORMAT (/, ' ### Ftheta(I), I=1,', I5, ' =')
@@ -132,21 +134,21 @@ C
END IF
Jtheta = Ntheta
call multScat%setNumThetaNearOne(multScat%getNumTheta())
-C
+!
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Qqqget (Ftheta, Sqfb, Delthe)
-C
-C *** Read the arrays Ftheta and Sqfb
-C *** Also generate rest of Ftheta
-C *** (NOTE that dimension of Ftheta may be larger than Ntheta, which is
-C *** the number of points on which Sqfb is to be interpolated.
-C *** Dimension of Ftheta is Jtheta, the total number of THETA points.)
-C
+!
+! *** Read the arrays Ftheta and Sqfb
+! *** Also generate rest of Ftheta
+! *** (NOTE that dimension of Ftheta may be larger than Ntheta, which is
+! *** the number of points on which Sqfb is to be interpolated.
+! *** Dimension of Ftheta is Jtheta, the total number of THETA points.)
+!
use fixedi_m
use ifwrit_m
use ssssss_common_m
@@ -154,13 +156,13 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Ftheta(Jtheta), Sqfb(Nsqfb,Nxtptv,Nxtptw,Ntheta)
DATA One /1.0d0/
-C
+!
READ (25) (Ftheta(I),I=1,Ntheta)
READ (25) Sqfb
CLOSE (UNIT=25)
-C
+!
IF (Jtheta.NE.Ntheta) THEN
-C
+!
Min = Ntheta + 1
IF (Min.NE.Jtheta) THEN
Max = Jtheta - 1
@@ -184,12 +186,12 @@ C
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Ssm_Initialize (Aaa, Bbb, Rmass, Iv, Kk)
-C
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -201,16 +203,16 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Rmass(*), Aaa(*), Bbb(*)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
R0 = Zero
Rd = Zero
Fffdbl = One
-C
+!
R0 = Rs
IF (Rb.LT.Rs) R0 = Rb
Rd = dSQRT(Area/Pi)
IF (Rd.NE.Zero) Fffdbl = One + Sthick/Rd
-C
+!
IF (Numiso.EQ.0) THEN
Rmass(1) = Aaawww/A_Mass_Small
Aaa(1) = Rmass(1)**2
@@ -233,26 +235,26 @@ C
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Getcrs (Ccclll, Dddlll, Isopar, Vsigxx, Vdasig, Vdbsig,
- * We, Totsig, Capsig, Dtotsi, Dcapsi, Ee, Elastic, Nx, Nn, Istop)
-C
-C *** Purpose -- Find next cross section, store values in appropriate places
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Getcrs (Ccclll, Dddlll, Isopar, Vsigxx, Vdasig, Vdbsig, &
+ We, Totsig, Capsig, Dtotsi, Dcapsi, Ee, Elastic, Nx, Nn, Istop)
+!
+! *** Purpose -- Find next cross section, store values in appropriate places
+!
use fixedi_m
use ifwrit_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Ccclll(Nnnsig,*), Dddlll(Nnnsig,Nnpar,*), Isopar(*),
- * Vsigxx(Nnnsig,Niniso,*), Vdasig(Nnnsig,Ndaxxx,*),
- * Vdbsig(Nnnsig,Ndbxxx,Niniso,*), We(*), Totsig(*), Capsig(*),
- * Dtotsi(Nx,*), Dcapsi(Nx,*)
-C
+!
+ DIMENSION Ccclll(Nnnsig,*), Dddlll(Nnnsig,Nnpar,*), Isopar(*), &
+ Vsigxx(Nnnsig,Niniso,*), Vdasig(Nnnsig,Ndaxxx,*), &
+ Vdbsig(Nnnsig,Ndbxxx,Niniso,*), We(*), Totsig(*), &
+ Capsig(*), Dtotsi(Nx,*), Dcapsi(Nx,*)
+!
Istop = 0
-C
+!
Elastic = 0.0d0
N = Nn
Ee = We(N)
@@ -262,8 +264,7 @@ C
END DO
Elastic = Elastic + Ccclll(1,Iso)
END DO
- IF (Nnpar.GT.0 .AND. KSOLVE.NE.2) CALL Zero_Array (Dddlll,
- * Nnnsig*Ndasig*Niniso)
+ IF (Nnpar.GT.0 .AND. KSOLVE.NE.2) CALL Zero_Array (Dddlll, Nnnsig*Ndasig*Niniso)
IF (Ndasig.GT.0) THEN
DO Iso=1,Niniso
DO J=1,Ndasig
@@ -284,12 +285,12 @@ C
END DO
END DO
END IF
-C
+!
DO Iso=1,Niniso
Totsig(N) = Ccclll(Lllmax+1,Iso) + Totsig(N)
Capsig(N) = Ccclll(Lllmax+2,Iso) + Capsig(N)
END DO
-C
+!
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
DO Iso=1,Niniso
DO J=1,Nnpar
@@ -298,55 +299,55 @@ C
END DO
END DO
END IF
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Getem (Em, Kkkdat, Idone)
-C
-C *** Purpose -- Determine where we are, energy-wise; i.e. which pieces
-C *** of the calculation need doing now
-C
+!
+! *** Purpose -- Determine where we are, energy-wise; i.e. which pieces
+! *** of the calculation need doing now
+!
use ifwrit_m
use fixedr_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
IF (Em.LT.Eminr) THEN
-C
+!
IF (Kssdbl.EQ.1) THEN
Idone = 3
-C *** "Idone = 3" means E < Eminr = min energy at which we need to
-C *** calculate the yields; however, need to calculate pieces
-C *** of Y2 anyway
+! *** "Idone = 3" means E < Eminr = min energy at which we need to
+! *** calculate the yields; however, need to calculate pieces
+! *** of Y2 anyway
ELSE
Idone = 1
-C *** "Idone = 1" means don't calculate yields, don't calculate
-C *** pieces of Y2, just store arrays etc for use in generating Y1
+! *** "Idone = 1" means don't calculate yields, don't calculate
+! *** pieces of Y2, just store arrays etc for use in generating Y1
END IF
-C
+!
ELSE IF (Em.GT.Emaxr) THEN
Idone = 2
-C *** "Idone = 2" means bigger than biggest energy so just quit
-C
+! *** "Idone = 2" means bigger than biggest energy so just quit
+!
ELSE
-C *** Here for normal state, Eminr < Em < Emaxr so calculate everything
+! *** Here for normal state, Eminr < Em < Emaxr so calculate everything
Idone = 0
Kkkdat = Kkkdat + 1
-C
+!
END IF
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Get_Angles (Ctheta, Stheta, Cphi, Sphi)
-C
-C *** Purpose -- Define angle grids
-C
+!
+! *** Purpose -- Define angle grids
+!
use logic_ssm_common_m
use ssssss_common_m
use xsect_x_common_m
@@ -354,7 +355,7 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Ctheta(*), Stheta(*), Cphi(*), Sphi(*)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
D = One/(Kthet2-One)
Ctheta(1) = Zero
Stheta(1) = One
@@ -364,7 +365,7 @@ C
END DO
Ctheta(Kthet2) = One
Stheta(Kthet2) = Zero
-C
+!
D = One/(Kphi2-One)
Cphi(1) = Zero
DO I=2,Kphi2-1
@@ -376,13 +377,14 @@ C
Cphi(I) = dCOS(Cc)
Sphi(I) = dSIN(Cc)
END DO
-C
+!
Kkphi = Kphi2 - 1
Kkthet = Kthet2 - 1
-cx X_Mult = Ctheta(1)/(Kphi-One) wrong!
-cx X_Mult = Ctheta(1)/(Kkphi-One) maybe?
+!
X_Mult = Ctheta(1)/(Kphi2-One)
X_Mult = X_Mult**2 * Pi
-C
+!
RETURN
END
+
+end module ssm_1_m
diff --git a/sammy/src/ssm/mssm02.f b/sammy/src/ssm/mssm02.f
deleted file mode 100644
index 3ddde1deb..000000000
--- a/sammy/src/ssm/mssm02.f
+++ /dev/null
@@ -1,316 +0,0 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ssssds (A, Jxciso, Energy, Energb, Totsig, Capsig,
- * Y2cccc, Dy2ccc, Nx, Maxx, Kdatb)
-C
-C *** Ssssds generates the the self-shielded + multiple-scattered
-C *** capture yield for an infinite slab, and calls Mulsca to
-C *** generate the finite-slab results
-C
- use oops_common_m
- use fixedi_m
- use ifwrit_m
- use exploc_common_m
- use samxxx_common_m
- use array_sizes_common_m
- use fixedr_m
- use logic_ssm_common_m
- use lbro_common_m
- use ssssss_common_m
- use xsect_x_common_m
- use constn_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*),
- * Totsig(*), Capsig(*), Y2cccc(*), Dy2ccc(Nx,*)
-C
- IF (Kssmpr.EQ.1) THEN
- CALL Newopn (60, 'SAM012.DAT', 0)
- WRITE (60,10000)
-10000 FORMAT (' SAMMY-calculated values')
- WRITE (60,10100)
-10100 FORMAT (' Energy, Zero-scat, One-scat, Two-scat, Sum=Yield')
- END IF
-C
- Ksolvx = Ksolve
- CALL Ssm_Initialize ( A(Iaaa), A(Ibbb), A(Irmass),Iv,Kk)
-
- Jgbmax = 0
- Kkknew = 0
- CALL Read_Cross_Sections (A(Ivsigx), A(Ivdasi), A(Ivdbsi),
- * A(Ivsigs), A_Ivdass , A_Ivdbss , A(Iwe), Jgbmax, Kkknew, 1, Iv)
- IF (Kdatb.NE.Kkknew) THEN
- WRITE (6,10200) Kdatb, Kkknew, Jgbmax, Iv
-10200 FORMAT (' Kdatb, Kkknew, Jgbmax, Iv =', I10, 6I5)
- STOP '[STOP in Ssssds in ssm/mssm02.f]'
- END IF
-C
- CALL Zero_Cross_Sections (A(Ith), A(Iwsigx), A(Iwdasi), A(Iwdbsi),
- * A(Isigxx), A(Isigxx), A(Isigxx), Kk, Kdatb, 0)
-C
- IF (Kwssms.EQ.1) CALL Newopn (15, Sam15x, 1)
- CALL Zero_Array (Totsig, Kdatb)
- CALL Zero_Array (Capsig, Kdatb)
- IF (Ksolve.NE.2) CALL Zero_Array (A(Idtots), Nnpar*Kdatb)
- IF (Ksolve.NE.2) CALL Zero_Array (A(Idcaps), Nnpar*Kdatb)
-C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
- IF (Self_Shield_Only) THEN
-C *** Case 0: self-shielding and nothing else
- CALL Ssssds_0xx (A, Jxciso, Energy, Energb, Totsig,
- * Capsig, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
- ELSE IF (Double_Plus) THEN
- IF (Single_Fin) THEN
- IF (Linear.EQ.0) THEN
-C *** Case 2fl: Double sct, finite slab, linear interpolation
- CALL Ssssds_2fl (A, Jxciso, Energy, Energb, Totsig,
- * Capsig, Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn,
- * Kkkdat)
- ELSE
-C *** Case 2fq: Double sct, finite slab, quadratic interpolation
- CALL Ssssds_2fq (A, Jxciso, Energy, Energb, Totsig,
- * Capsig, Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn,
- * Kkkdat)
- END IF
- ELSE
- IF (Linear.EQ.0) THEN
-C *** Case 2il: Double sct, infinite slab, linear interpolation
- CALL Ssssds_2il (A, Jxciso, Energy, Energb, Totsig,
- * Capsig, Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn,
- * Kkkdat)
- ELSE
-C *** Case 2iq: Double sct, infinite slab, quadratic interpolation
- CALL Ssssds_2iq (A, Jxciso, Energy, Energb, Totsig,
- * Capsig, Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn,
- * Kkkdat)
- END IF
- END IF
- ELSE IF (Single_Fin) THEN
- IF (Linear.EQ.0) THEN
-C *** Case 1fl: Single sct, finite slab, linear interpolation
- CALL Ssssds_1fl (A, Jxciso, Energy, Energb, Totsig,
- * Capsig, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
- ELSE
-C *** Case 1fq: Single sct, finite slab, quadratic interpolation
- CALL Ssssds_1fq (A, Jxciso, Energy, Energb, Totsig,
- * Capsig, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
- END IF
- ELSE
- IF (Linear.EQ.0) THEN
-C *** Case 1il: Single sct, infinite slab, linear interpolation
- CALL Ssssds_1il (A, Jxciso, Energy, Energb, Totsig,
- * Capsig, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
- ELSE
-C *** Case 1iq: Single sct, infinite slab, quadratic interpolation
- CALL Ssssds_1iq (A, Jxciso, Energy, Energb, Totsig,
- * Capsig, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
- END IF
- END IF
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C
- CLOSE (UNIT=66)
- CALL Finish_02 (A, Energy, Energb, Kkkdat, Kdatmn)
- RETURN
- END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Zero0_1f (A, Yyy1fb, Y0, Yyy1, Nx)
- use oops_common_m
- use fixedi_m
- use ifwrit_m
- use array_sizes_common_m
- use logic_ssm_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION A(-Msize:Msize), Yyy1fb(*)
- DATA Zero /0.0d0/
-C
- Y0 = Zero
- Yyy1 = Zero
- Yyy1fb(1) = Zero
- Yyy1fb(2) = Zero
- IF (Ksolve.NE.2) CALL Zero_Array (A(Idyyy1), Nx)
-C
- RETURN
- END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Zero0_2i (A, Y0, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx)
- use oops_common_m
- use fixedi_m
- use ifwrit_m
- use array_sizes_common_m
- use logic_ssm_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION A(-Msize:Msize)
- DATA Zero /0.0d0/
-C
- Y0 = Zero
- Yyy1 = Zero
-C
- IF (Ksolve.NE.2) CALL Zero_Array (A(Idyyy1), Nx)
-C
- Yyy2 = Zero
- Y2bbbb = Zero
- IF (Double_Plus) THEN
- Yyy2q = Zero
- Y2cccc = Zero
- Y2bbbq = Zero
-C
- IF (Ksolve.NE.2) THEN
- CALL Zero_Array (A(Idyyy2), Nx)
- CALL Zero_Array (A(Idyy2q), Nx)
- CALL Zero_Array (A(Idy2qq), Nx)
- CALL Zero_Array (A(Idy2cc), Nx)
- CALL Zero_Array (A(Idy2bb), Nx)
- CALL Zero_Array (A(Idy2bq), Nx)
- CALL Zero_Array (A(Idybqq), Nx)
- END IF
- END IF
- RETURN
- END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Zero0_2f (A, Yyy1fb, Y0, Yyy1, Yyy2, Yyy2q,
- * Y2bbbb, Y2bbbq, Nx)
- use oops_common_m
- use fixedi_m
- use ifwrit_m
- use array_sizes_common_m
- use logic_ssm_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION A(-Msize:Msize), Yyy1fb(*)
- DATA Zero /0.0d0/
-C
- Y0 = Zero
- Yyy1 = Zero
- Yyy1fb(1) = Zero
- Yyy1fb(2) = Zero
-C
- IF (Ksolve.NE.2) CALL Zero_Array (A(Idyyy1), Nx)
-C
- Yyy2 = Zero
- Y2bbbb = Zero
- IF (Double_Plus) THEN
- Yyy2q = Zero
- Y2cccc = Zero
- Y2bbbq = Zero
-C
- IF (Ksolve.NE.2) THEN
- CALL Zero_Array (A(Idyyy2), Nx)
- CALL Zero_Array (A(Idyy2q), Nx)
- CALL Zero_Array (A(Idy2qq), Nx)
- CALL Zero_Array (A(Idy2cc), Nx)
- CALL Zero_Array (A(Idy2bb), Nx)
- CALL Zero_Array (A(Idy2bq), Nx)
- CALL Zero_Array (A(Idybqq), Nx)
- END IF
- END IF
- RETURN
- END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Tell_Finite (A)
- use oops_common_m
- use fixedi_m
- use logic_ssm_common_m
- use MultScatPars_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION A(-Msize:Msize)
- DATA Zero /0.0d0/
- IF (multScat%getLogSigmaTotMax().GT.Zero) THEN
- call multScat%setLogSigmaTotMin(
- * dLOG(multScat%getLogSigmaTotMin()) )
- Xtmin = dLOG(multScat%getLogSigmaTotMin())
- call multScat%setLogSigmaTotMax(
- * dLOG(multScat%getLogSigmaTotMax()) )
- Xtmax = dLOG(multScat%getLogSigmaTotMax())
- WRITE ( 6,10200) multScat%getLogSigmaTotMin(),
- * multScat%getLogSigmaTotMax()
- WRITE (21,10200) multScat%getLogSigmaTotMin(),
- * multScat%getLogSigmaTotMax()
- WRITE ( 6,10300) A(Ixtptv), A(Ixtptv-1+Nxtptv)
- WRITE (21,10300) A(Ixtptv), A(Ixtptv-1+Nxtptv)
-10200 FORMAT ('Interpolation limits needed: Xtmin, Xtmax=', 1P5G14.6)
-10300 FORMAT ('Interpolation limits used: Xtmin, Xtmax=', 1P5G14.6)
- END IF
- IF (Interp_Small_Times.GT.0) THEN
- WRITE ( 6,10400)
- WRITE (21,10400)
-10400 FORMAT (' Expand interpolation limits and try again.')
- STOP
- END IF
- RETURN
- END
-
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE X_Trpths_Lin (A, Ftheta, Knthet, Jfb, Jth, Itntrp, Nn,
- * Nxtptwn)
- use oops_common_m
- use ifwrit_m
- use logic_ssm_common_m
- use ssssss_common_m
- use xsect_x_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION A(-Msize:Msize)
-C
- CALL Trpths1_Lin (A(Ixtptw), Ftheta, A(Iqfb), A(Idvqfb), Knthet,
- * Jfb, Jth, Itntrp, Nn, Nxtptwn)
- Fz1 = Fz
- IF (Ksolvx.NE.2) THEN
- Dfz1 = Dfz
- Dpfz1 = Dpfz
- Dnfz1 = Dnfz
- END IF
- CALL Trpths2
- Fz = Fz1 + Fz
- IF (Ksolvx.NE.2) THEN
- Dfz = Dfz1 + Dfz
- Dpfz = Dpfz1 + Dpfz
- Dnfz = Dnfz1 + Dnfz
- END IF
- RETURN
- END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE X_Trpths_Quad (A, Ftheta, Knthet, Jfb, Jth, Itntrp, Nn,
- * Nxtptwn)
- use oops_common_m
- use ifwrit_m
- use logic_ssm_common_m
- use ssssss_common_m
- use xsect_x_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION A(-Msize:Msize)
-C
- CALL Trpths1_Quad (A(Ixtptw), Ftheta, A(Iqfb), A(Idvqfb), Knthet,
- * Jfb, Jth, Itntrp, Nn, Nxtptwn)
- Fz1 = Fz
- IF (Ksolvx.NE.2) THEN
- Dfz1 = Dfz
- Dpfz1 = Dpfz
- Dnfz1 = Dnfz
- END IF
- CALL Trpths2
- Fz = Fz1 + Fz
- IF (Ksolvx.NE.2) THEN
- Dfz = Dfz1 + Dfz
- Dpfz = Dpfz1 + Dpfz
- Dnfz = Dnfz1 + Dnfz
- END IF
- RETURN
- END
diff --git a/sammy/src/ssm/mssm02.f90 b/sammy/src/ssm/mssm02.f90
new file mode 100644
index 000000000..e16800062
--- /dev/null
+++ b/sammy/src/ssm/mssm02.f90
@@ -0,0 +1,129 @@
+!
+module ssm_2_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ssssds (A, Jxciso, Energy, Energb, Totsig, Capsig, &
+ Y2cccc, Dy2ccc, Nx, Maxx, Kdatb)
+!
+! *** Ssssds generates the the self-shielded + multiple-scattered
+! *** capture yield for an infinite slab, and calls Mulsca to
+! *** generate the finite-slab results
+!
+ use oops_common_m
+ use fixedi_m
+ use ifwrit_m
+ use exploc_common_m
+ use samxxx_common_m
+ use array_sizes_common_m
+ use fixedr_m
+ use logic_ssm_common_m
+ use lbro_common_m
+ use ssssss_common_m
+ use xsect_x_common_m
+ use constn_common_m
+ use ssm_1_m
+ use ssm_3_m
+ use ssm_4_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+!
+ DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*), &
+ Totsig(*), Capsig(*), Y2cccc(*), Dy2ccc(Nx,*)
+!
+ IF (Kssmpr.EQ.1) THEN
+ CALL Newopn (60, 'SAM012.DAT', 0)
+ WRITE (60,10000)
+10000 FORMAT (' SAMMY-calculated values')
+ WRITE (60,10100)
+10100 FORMAT (' Energy, Zero-scat, One-scat, Two-scat, Sum=Yield')
+ END IF
+!
+ Ksolvx = Ksolve
+ CALL Ssm_Initialize ( A(Iaaa), A(Ibbb), A(Irmass),Iv,Kk)
+
+ Jgbmax = 0
+ Kkknew = 0
+ CALL Read_Cross_Sections (A(Ivsigx), A(Ivdasi), A(Ivdbsi), &
+ A(Ivsigs), A_Ivdass , A_Ivdbss , A(Iwe), Jgbmax, Kkknew, 1, Iv)
+ IF (Kdatb.NE.Kkknew) THEN
+ WRITE (6,10200) Kdatb, Kkknew, Jgbmax, Iv
+10200 FORMAT (' Kdatb, Kkknew, Jgbmax, Iv =', I10, 6I5)
+ STOP '[STOP in Ssssds in ssm/mssm02.f]'
+ END IF
+!
+ CALL Zero_Cross_Sections (A(Ith), A(Iwsigx), A(Iwdasi), A(Iwdbsi), &
+ A(Isigxx), A(Isigxx), A(Isigxx), Kk, Kdatb, 0)
+!
+ IF (Kwssms.EQ.1) CALL Newopn (15, Sam15x, 1)
+ CALL Zero_Array (Totsig, Kdatb)
+ CALL Zero_Array (Capsig, Kdatb)
+ IF (Ksolve.NE.2) CALL Zero_Array (A(Idtots), Nnpar*Kdatb)
+ IF (Ksolve.NE.2) CALL Zero_Array (A(Idcaps), Nnpar*Kdatb)
+!
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! -----------------------------------------------------------------------------
+! ----------- SELF SHIELDING --------------------------------------------------
+! -----------------------------------------------------------------------------
+ IF (Self_Shield_Only) THEN
+! *** Case 0: self-shielding and nothing else
+ CALL Ssssds_0xx (A, Jxciso, Energy, Energb, Totsig, &
+ Capsig, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+! -----------------------------------------------------------------------------
+! ----------- MULTIPLE SCATTERING ---------------------------------------------
+! -----------------------------------------------------------------------------
+ ELSE IF (Double_Plus) THEN
+ IF (Single_Fin) THEN
+ IF (Linear.EQ.0) THEN
+! *** Case 2fl: Double sct, finite slab, linear interpolation
+ CALL Ssssds_2fl (A, Jxciso, Energy, Energb, Totsig, &
+ Capsig, Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+ ELSE
+! *** Case 2fq: Double sct, finite slab, quadratic interpolation
+ CALL Ssssds_2fq (A, Jxciso, Energy, Energb, Totsig, &
+ Capsig, Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+ END IF
+ ELSE
+ IF (Linear.EQ.0) THEN
+! *** Case 2il: Double sct, infinite slab, linear interpolation
+ CALL Ssssds_2il (A, Jxciso, Energy, Energb, Totsig, &
+ Capsig, Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+ ELSE
+! *** Case 2iq: Double sct, infinite slab, quadratic interpolation
+ CALL Ssssds_2iq (A, Jxciso, Energy, Energb, Totsig, &
+ Capsig, Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+ END IF
+ END IF
+! -----------------------------------------------------------------------------
+! ----------- SINGLE SCATTERING -----------------------------------------------
+! -----------------------------------------------------------------------------
+ ELSE IF (Single_Fin) THEN
+ IF (Linear.EQ.0) THEN
+! *** Case 1fl: Single sct, finite slab, linear interpolation
+ CALL Ssssds_1fl (A, Jxciso, Energy, Energb, Totsig, &
+ Capsig, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+ ELSE
+! *** Case 1fq: Single sct, finite slab, quadratic interpolation
+ CALL Ssssds_1fq (A, Jxciso, Energy, Energb, Totsig, &
+ Capsig, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+ END IF
+ ELSE
+ IF (Linear.EQ.0) THEN
+! *** Case 1il: Single sct, infinite slab, linear interpolation
+ CALL Ssssds_1il (A, Jxciso, Energy, Energb, Totsig, &
+ Capsig, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+ ELSE
+! *** Case 1iq: Single sct, infinite slab, quadratic interpolation
+ CALL Ssssds_1iq (A, Jxciso, Energy, Energb, Totsig, &
+ Capsig, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+ END IF
+ END IF
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!
+ CLOSE (UNIT=66)
+ CALL Finish_02 (A, Energy, Energb, Kkkdat, Kdatmn)
+ RETURN
+ END
+
+
+end module ssm_2_m
diff --git a/sammy/src/ssm/mssm03.f b/sammy/src/ssm/mssm03.f90
similarity index 54%
rename from sammy/src/ssm/mssm03.f
rename to sammy/src/ssm/mssm03.f90
index d56ba5109..53712221a 100644
--- a/sammy/src/ssm/mssm03.f
+++ b/sammy/src/ssm/mssm03.f90
@@ -1,13 +1,15 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ssssds_0xx (A, Jxciso, Energy, Energb, Totsig, Capsig,
- * Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
-C
-C *** Ssssds_0xx generates the the self-shielded capture yield with
-C *** no multiple-scattering corrections
-C
+!
+module ssm_3_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ssssds_0xx (A, Jxciso, Energy, Energb, Totsig, Capsig, &
+ Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+!
+! *** Ssssds_0xx generates the the self-shielded capture yield with
+! *** no multiple-scattering corrections
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -20,115 +22,115 @@ C
use ssssss_common_m
use xsect_x_common_m
use constn_common_m
+ use ssm_1_m
+ use ssm_19_m
+ use ssm_20_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*),
- * Totsig(*), Capsig(*)
-C
+!
+ DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*), Totsig(*), Capsig(*)
+!
DIMENSION Wssmsc(10)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Itimes = 1
Imin = 1
Kkkdat = 0
Kdatmn = 0
Nsen = 1
-C
-C *** Start major do-loop on Energy
+!
+! *** Start major do-loop on Energy
DO N=1,Kdatb
Nn = N
Y0 = Zero
- CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx),
- * A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig,
- * A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
+ CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
+ A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
-C
-C *** get Energy Em
+!
+! *** get Energy Em
Em = Energb(Nn)
CALL Getem (Em, Kkkdat, Idone)
-C
+!
IF (Idone.EQ.2) THEN
-C *** Here E > Emax, so we're done.
+! *** Here E > Emax, so we're done.
GO TO 80
-C
+!
ELSE IF (Idone.EQ.0) THEN
-C *** If Idone=0, energy Em is bigger than Eminr, so
-C *** calculation can proceed
-C
+! *** If Idone=0, energy Em is bigger than Eminr, so
+! *** calculation can proceed
+!
IF (Kdatmn.EQ.0) Kdatmn = Nn
Total = Totsig(N)
Exp1 = dEXP(-Dthick*Total)
-C
+!
IF (Kwssms.EQ.1) THEN
Wssmsc(1) = Em
Wssmsc(2) = Capsig(N)
Wssmsc(3) = Totsig(N)
END IF
-C
+!
CALL Zero_Array (A(Isigxx), 1)
IF (Ksolve.NE.2) THEN
IF (Ndasig.GT.0) CALL Zero_Array (A(Idasig), Ndasig)
IF (Ndbsig.GT.0) CALL Zero_Array (A(Idbsig), Ndbsig)
END IF
-C
-C *** Y0 is self-shielded capture yield; normalized to be the
-C *** cross section in the limit of Zero thickness
+!
+! *** Y0 is self-shielded capture yield; normalized to be the
+! *** cross section in the limit of Zero thickness
Td = Total*Dthick
IF (Nonu.EQ.0) THEN
-C *** Uniform thickness
+! *** Uniform thickness
Exxxx = Exp1
ELSE
-C *** Non-uniform thickness
- CALL Non_Uniform_Thickness (A_Iznonu , A_Irnonu ,
- * Td, Exxxx, Nonu)
+! *** Non-uniform thickness
+ CALL Non_Uniform_Thickness (A_Iznonu, A_Irnonu, Td, Exxxx, Nonu)
END IF
Y0 = (One-Exxxx)*Capsig(N)/Td
-C
+!
IF (Sensin.NE.Zero) THEN
-C *** When neutron sensitivity is given (as "miscellaneous
-C *** parameters card 11"), then correction term is added
+! *** When neutron sensitivity is given (as "miscellaneous
+! *** parameters card 11"), then correction term is added
CALL Get_Ratio_Sensin (Em, Ratio_Sensin, Nsen, Itimes)
- Asensn = (One-Exp1) * Ratio_Sensin *
- * (100.0d0*Fourpi*Elastic/Total) / Dthick
-C *** Remember that "Fourpi" is really 4*pi/100
+ Asensn = (One-Exp1) * Ratio_Sensin * (100.0d0*Fourpi*Elastic/Total) / Dthick
+! *** Remember that "Fourpi" is really 4*pi/100
Y0 = Y0 + Asensn*Sensin
END IF
-C
-C *** Normalize if needed; store in Sigxxx; calc derivs
+!
+! *** Normalize if needed; store in Sigxxx; calc derivs
Dddyy0 = Zero
- CALL Ynrm_0 (Capsig, A(Idtots), A(Idcaps), A(Isigxx),
- * A(Idasig), A(Idbsig), Y0, Dthick, Total, Exp1, Em,
- * Dddyy0, Asensn, Nn)
-C
-C *** Modify for self-indication experiments
- IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig),
- * A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
-C
+ CALL Ynrm_0 (Capsig, A(Idtots), A(Idcaps), A(Isigxx), &
+ A(Idasig), A(Idbsig), Y0, Dthick, Total, Exp1, Em, &
+ Dddyy0, Asensn, Nn)
+!
+! *** Modify for self-indication experiments
+ IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig), &
+ A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
+!
IF (Debug) THEN
WRITE (66,10200) Em, Y0
10200 FORMAT (' E,Y0=', F12.4, 1p4g14.5)
END IF
CALL Finish_01 (A, Ee, Wssmsc, Em, Y0, Kdatb, Kkkdat, N)
END IF
-C
+!
END DO
-C *** Done with loop on Energies Em
+! *** Done with loop on Energies Em
IF (Kssmpr.EQ.1) CLOSE (UNIT=60)
-C
+!
80 CONTINUE
-C *** Completely done
+! *** Completely done
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ssssds_1il (A, Jxciso, Energy, Energb, Totsig, Capsig,
- * Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
-C
-C *** Ssssds_1il generates the the self-shielded + single-scattered
-C *** capture yield for an infinite slab with linear interpolation
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ssssds_1il (A, Jxciso, Energy, Energb, Totsig, Capsig, &
+ Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+!
+! *** Ssssds_1il generates the the self-shielded + single-scattered
+! *** capture yield for an infinite slab with linear interpolation
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -142,156 +144,156 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use ssm_1_m
+ use ssm_5_m
+ use ssm_20_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*),
- * Totsig(*), Capsig(*)
-C
+!
+ DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*), Totsig(*), Capsig(*)
+!
DIMENSION Wssmsc(10)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Itimes = 1
Kountr = 0
-C
+!
CALL Findpr (multScat%getNumTheta(), Knthet)
CALL Findpr (Nxtptw, Nxtptwn)
CALL Findpr (Nxtptv, Nxtptvm)
-C
+!
Imin = 1
Kkkdat = 0
Kdatmn = 0
Nsen = 1
-C
-C *** Start major do-loop on Energy
+!
+! *** Start major do-loop on Energy
DO N=1,Kdatb
Nn = N
-C
+!
Y0 = Zero
Yyy1 = Zero
IF (Ksolve.NE.2) CALL Zero_Array (A(Idyyy1), Nx)
-C
- CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx),
- * A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig,
- * A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
+!
+ CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
+ A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
-C
-C *** get Energy Em
+!
+! *** get Energy Em
Em = Energb(Nn)
CALL Getem (Em, Kkkdat, Idone)
-C
+!
IF (Idone.EQ.2) THEN
-C *** Here E > Emax, so we're done.
+! *** Here E > Emax, so we're done.
GO TO 80
-C
-C
+!
+!
ELSE IF (Idone.EQ.0) THEN
-C *** Here if Idone=0, energy Em is bigger than Eminr, so
-C *** calculation can proceed
-C
+! *** Here if Idone=0, energy Em is bigger than Eminr, so
+! *** calculation can proceed
+!
IF (Kdatmn.EQ.0) Kdatmn = Nn
Total = Totsig(N)
Exp1 = dEXP(-Dthick*Total)
-C
+!
IF (Kwssms.EQ.1) THEN
Wssmsc(1) = Em
Wssmsc(2) = Capsig(N)
Wssmsc(3) = Totsig(N)
END IF
-C
+!
CALL Zero_Array (A(Isigxx), 1)
IF (Ksolve.NE.2) THEN
IF (Ndasig.GT.0) CALL Zero_Array (A(Idasig), Ndasig)
IF (Ndbsig.GT.0) CALL Zero_Array (A(Idbsig), Ndbsig)
END IF
-C
-C
-C *** Here begin multiple-scattering calculation
-C
+!
+!
+! *** Here begin multiple-scattering calculation
+!
Wssmsc(5) = Zero
Wssmsc(6) = Zero
DO Iso=1,Niniso
-C *** Start loop over nuclides (ie over "isotopes")
+! *** Start loop over nuclides (ie over "isotopes")
IF (Jxciso(Iso).NE.1) THEN
Iiso = Iso
- CALL Mulsca_1il (A, Energb, A(Ifthet), Totsig, Capsig,
- * A(Irmass), A(Iaaa), A(Ibbb), A(Icsx), A(Iepx),
- * A(Iggx), A(Iiex), Wssmsc, Em, Exp1, Yyy1,
- * Nx, Maxx, Kdatb, Iiso, Nn, Imin, Idone,
- * Knthet, Kountr, Nxtptwn, Nxtptvm)
+ CALL Mulsca_1il (A, Energb, A(Ifthet), Totsig, Capsig, &
+ A(Irmass), A(Iaaa), A(Ibbb), A(Icsx), A(Iepx), &
+ A(Iggx), I_Iiex, Wssmsc, Em, Exp1, Yyy1, &
+ Nx, Maxx, Kdatb, Iiso, Nn, Imin, Idone, &
+ Knthet, Kountr, Nxtptwn, Nxtptvm)
END IF
END DO
-C *** END of loop on Isotopes
-C
-C *** Fix value of Y1 (Needs multiply by Pi)
+! *** END of loop on Isotopes
+!
+! *** Fix value of Y1 (Needs multiply by Pi)
CALL Fixy_1i (A(Idyyy1), Yyy1)
-C
-C *** Finished with multiple-scattering corrections
-C
-C *** Y0 is self-shielded capture yield; normalized to be the
-C *** cross section in the limit of Zero thickness
+!
+! *** Finished with multiple-scattering corrections
+!
+! *** Y0 is self-shielded capture yield; normalized to be the
+! *** cross section in the limit of Zero thickness
Td = Total*Dthick
IF (Nonu.EQ.0) THEN
-C *** Uniform thickness
+! *** Uniform thickness
Exxxx = Exp1
ELSE
-C *** Non-uniform thickness
- CALL Non_Uniform_Thickness (A_Iznonu , A_Irnonu ,
- * Td, Exxxx, Nonu)
+! *** Non-uniform thickness
+ CALL Non_Uniform_Thickness (A_Iznonu, A_Irnonu, Td, Exxxx, Nonu)
END IF
Y0 = (One-Exxxx)*Capsig(N)/Td
-C
+!
IF (Sensin.NE.Zero) THEN
-C *** When neutron sensitivity is given (as "miscellaneous
-C *** parameters card 11"), then correction term is added
+! *** When neutron sensitivity is given (as "miscellaneous
+! *** parameters card 11"), then correction term is added
CALL Get_Ratio_Sensin (Em, Ratio_Sensin, Nsen, Itimes)
- Asensn = (One-Exp1) * Ratio_Sensin *
- * (100.0d0*Fourpi*Elastic/Total) / Dthick
-C *** Remember that "Fourpi" is really 4*pi/100
+ Asensn = (One-Exp1) * Ratio_Sensin * (100.0d0*Fourpi*Elastic/Total) / Dthick
+! *** Remember that "Fourpi" is really 4*pi/100
Y0 = Y0 + Asensn*Sensin
END IF
-C
-C *** Normalize Y1 same as Y0; renormalize all if needed;
-C *** store in Sigxxx; also calculate derivs for all pieces
+!
+! *** Normalize Y1 same as Y0; renormalize all if needed;
+! *** store in Sigxxx; also calculate derivs for all pieces
Dddyy0 = Zero
- CALL Ynrm_1 (Capsig, A(Idtots), A(Idcaps), A(Isigxx),
- * A(Idasig), A(Idbsig), A(Idyyy1), Y0, Yyy1,
- * Dthick, Total, Exp1, Em, Dddyy0, Asensn, Nn)
-C
-C *** Modify for self-indication experiments
- IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig),
- * A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
-C
+ CALL Ynrm_1 (Capsig, A(Idtots), A(Idcaps), A(Isigxx), &
+ A(Idasig), A(Idbsig), A(Idyyy1), Y0, Yyy1, &
+ Dthick, Total, Exp1, Em, Dddyy0, Asensn, Nn)
+!
+! *** Modify for self-indication experiments
+ IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig), &
+ A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
+!
IF (Debug) THEN
WRITE (66,10400) Em, Y0, Yyy1
10400 FORMAT (' E,0,1=', F12.4, 1p4g14.5)
END IF
CALL Finish_01 (A, Ee, Wssmsc, Em, Y0, Kdatb, Kkkdat, N)
-C
+!
ELSE IF (Idone.EQ.1) THEN
-C *** Here E < Eminr, so do not calculate Yield.
-C
+! *** Here E < Eminr, so do not calculate Yield.
+!
END IF
-C finish check on value of Idone
+! finish check on value of Idone
END DO
-C *** Done with loop on Energies Em
+! *** Done with loop on Energies Em
IF (Kssmpr.EQ.1) CLOSE (UNIT=60)
-C
-C
+!
+!
80 CONTINUE
-C *** Completely done
-C
+! *** Completely done
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ssssds_1iq (A, Jxciso, Energy, Energb, Totsig, Capsig,
- * Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
-C
-C *** Ssssds_1iq generates the the self-shielded + single-scattered
-C *** capture yield for an infinite slab with quadratic interpolation
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ssssds_1iq (A, Jxciso, Energy, Energb, Totsig, Capsig, &
+ Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+!
+! *** Ssssds_1iq generates the the self-shielded + single-scattered
+! *** capture yield for an infinite slab with quadratic interpolation
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -305,155 +307,155 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use ssm_1_m
+ use ssm_5_m
+ use ssm_20_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*),
- * Totsig(*), Capsig(*)
-C
+!
+ DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*), Totsig(*), Capsig(*)
+!
DIMENSION Wssmsc(10)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Itimes = 1
Kountr = 0
-C
+!
CALL Findpr (multScat%getNumTheta(), Knthet)
CALL Findpr (Nxtptw, Nxtptwn)
CALL Findpr (Nxtptv, Nxtptvm)
-C
+!
Imin = 1
Kkkdat = 0
Kdatmn = 0
Nsen = 1
-C
-C *** Start major do-loop on Energy
+!
+! *** Start major do-loop on Energy
DO N=1,Kdatb
Nn = N
-C
+!
Y0 = Zero
Yyy1 = Zero
IF (Ksolve.NE.2) CALL Zero_Array (A(Idyyy1), Nx)
-C
- CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx),
- * A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig,
- * A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
+!
+ CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
+ A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
-C
-C *** get Energy Em
+!
+! *** get Energy Em
Em = Energb(Nn)
CALL Getem (Em, Kkkdat, Idone)
-C
+!
IF (Idone.EQ.2) THEN
-C *** Here E > Emax, so we're done.
+! *** Here E > Emax, so we're done.
GO TO 80
-C
-C
+!
+!
ELSE IF (Idone.EQ.0) THEN
-C *** Here if Idone=0, energy Em is bigger than Eminr, so
-C *** calculation can proceed
-C
+! *** Here if Idone=0, energy Em is bigger than Eminr, so
+! *** calculation can proceed
+!
IF (Kdatmn.EQ.0) Kdatmn = Nn
Total = Totsig(N)
Exp1 = dEXP(-Dthick*Total)
-C
+!
IF (Kwssms.EQ.1) THEN
Wssmsc(1) = Em
Wssmsc(2) = Capsig(N)
Wssmsc(3) = Totsig(N)
END IF
-C
+!
CALL Zero_Array (A(Isigxx), 1)
IF (Ksolve.NE.2) THEN
IF (Ndasig.GT.0) CALL Zero_Array (A(Idasig), Ndasig)
IF (Ndbsig.GT.0) CALL Zero_Array (A(Idbsig), Ndbsig)
END IF
-C
-C
-C *** Here begin multiple-scattering calculation
-C
+!
+!
+! *** Here begin multiple-scattering calculation
+!
Wssmsc(5) = Zero
Wssmsc(6) = Zero
DO Iso=1,Niniso
-C *** Start loop over nuclides (ie over "isotopes")
+! *** Start loop over nuclides (ie over "isotopes")
IF (Jxciso(Iso).NE.1) THEN
Iiso = Iso
- CALL Mulsca_1iq (A, Energb, A(Ifthet), Totsig, Capsig,
- * A(Irmass), A(Iaaa), A(Ibbb), A(Icsx), A(Iepx),
- * A(Iggx), A(Iiex), Wssmsc, Em, Exp1, Yyy1,
- * Nx, Maxx, Kdatb, Iiso, Nn, Imin, Idone,
- * Knthet, Kountr, Nxtptwn, Nxtptvm)
+ CALL Mulsca_1iq (A, Energb, A(Ifthet), Totsig, Capsig, &
+ A(Irmass), A(Iaaa), A(Ibbb), A(Icsx), A(Iepx), &
+ A(Iggx), I_Iiex, Wssmsc, Em, Exp1, Yyy1, &
+ Nx, Maxx, Kdatb, Iiso, Nn, Imin, Idone, &
+ Knthet, Kountr, Nxtptwn, Nxtptvm)
END IF
END DO
-C *** END of loop on Isotopes
-C
-C *** Fix value of Y1 (Needs multiply by Pi)
+! *** END of loop on Isotopes
+!
+! *** Fix value of Y1 (Needs multiply by Pi)
CALL Fixy_1i (A(Idyyy1), Yyy1)
-C
-C *** Finished with multiple-scattering corrections
-C
-C *** Y0 is self-shielded capture yield; normalized to be the
-C *** cross section in the limit of Zero thickness
+!
+! *** Finished with multiple-scattering corrections
+!
+! *** Y0 is self-shielded capture yield; normalized to be the
+! *** cross section in the limit of Zero thickness
Td = Total*Dthick
IF (Nonu.EQ.0) THEN
-C *** Uniform thickness
+! *** Uniform thickness
Exxxx = Exp1
ELSE
-C *** Non-uniform thickness
- CALL Non_Uniform_Thickness (A_Iznonu , A_Irnonu ,
- * Td, Exxxx, Nonu)
+! *** Non-uniform thickness
+ CALL Non_Uniform_Thickness (A_Iznonu, A_Irnonu, Td, Exxxx, Nonu)
END IF
Y0 = (One-Exxxx)*Capsig(N)/Td
-C
+!
IF (Sensin.NE.Zero) THEN
-C *** When neutron sensitivity is given (as "miscellaneous
-C *** parameters card 11"), then correction term is added
+! *** When neutron sensitivity is given (as "miscellaneous
+! *** parameters card 11"), then correction term is added
CALL Get_Ratio_Sensin (Em, Ratio_Sensin, Nsen, Itimes)
- Asensn = (One-Exp1) * Ratio_Sensin *
- * (100.0d0*Fourpi*Elastic/Total) / Dthick
-C *** Remember that "Fourpi" is really 4*pi/100
+ Asensn = (One-Exp1) * Ratio_Sensin * (100.0d0*Fourpi*Elastic/Total) / Dthick
+! *** Remember that "Fourpi" is really 4*pi/100
Y0 = Y0 + Asensn*Sensin
END IF
-C
-C *** Normalize Y1 same as Y0; renormalize all if needed;
-C *** store in Sigxxx; also calculate derivs for all pieces
+!
+! *** Normalize Y1 same as Y0; renormalize all if needed;
+! *** store in Sigxxx; also calculate derivs for all pieces
Dddyy0 = Zero
- CALL Ynrm_1 (Capsig, A(Idtots), A(Idcaps), A(Isigxx),
- * A(Idasig), A(Idbsig), A(Idyyy1), Y0, Yyy1,
- * Dthick, Total, Exp1, Em, Dddyy0, Asensn, Nn)
-C
-C *** Modify for self-indication experiments
- IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig),
- * A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
-C
+ CALL Ynrm_1 (Capsig, A(Idtots), A(Idcaps), A(Isigxx), &
+ A(Idasig), A(Idbsig), A(Idyyy1), Y0, Yyy1, &
+ Dthick, Total, Exp1, Em, Dddyy0, Asensn, Nn)
+!
+! *** Modify for self-indication experiments
+ IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig), &
+ A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
+!
IF (Debug) THEN
WRITE (66,10400) Em, Y0, Yyy1
10400 FORMAT (' E,0,1=', F12.4, 1p4g14.5)
END IF
CALL Finish_01 (A, Ee, Wssmsc, Em, Y0, Kdatb, Kkkdat, N)
-C
+!
ELSE IF (Idone.EQ.1) THEN
-C *** Here E < Eminr, so do not calculate Yield.
-C
+! *** Here E < Eminr, so do not calculate Yield.
+!
END IF
-C finish check on value of Idone
+! finish check on value of Idone
END DO
-C *** Done with loop on Energies Em
+! *** Done with loop on Energies Em
IF (Kssmpr.EQ.1) CLOSE (UNIT=60)
-C
-C
+!
+!
80 CONTINUE
-C *** Completely done
+! *** Completely done
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ssssds_1fl (A, Jxciso, Energy, Energb, Totsig, Capsig,
- * Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
-C
-C *** Ssssds_1fl generates the the self-shielded + single-scattered
-C *** capture yield for a finite slab with linear interpolation
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ssssds_1fl (A, Jxciso, Energy, Energb, Totsig, Capsig, &
+ Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+!
+! *** Ssssds_1fl generates the the self-shielded + single-scattered
+! *** capture yield for a finite slab with linear interpolation
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -467,160 +469,161 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use ssm_1_m
+ use ssm_utils_m
+ use ssm_6_m
+ use ssm_20_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
DIMENSION Yyy1fb(2)
- DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*),
- * Totsig(*), Capsig(*)
-C
+ DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*), Totsig(*), Capsig(*)
+!
DIMENSION Wssmsc(10)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Itimes = 1
Kountr = 0
-C
+!
CALL Findpr (multScat%getNumTheta(), Knthet)
CALL Findpr (Nxtptw, Nxtptwn)
CALL Findpr (Nxtptv, Nxtptvm)
-C
+!
Imin = 1
Kkkdat = 0
Kdatmn = 0
Nsen = 1
-C
-C
+!
+!
call multScat%setLogSigmaTotMin( 1.d20)
call multScat%setLogSigmaTotMax( -1.0d0)
Interp_Small_Times = 0
-C *** Start major do-loop on Energy
+! *** Start major do-loop on Energy
DO N=1,Kdatb
Nn = N
-C
+!
CALL Zero0_1f (A, Yyy1fb, Y0, Yyy1, Nx)
-C
- CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx),
- * A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig,
- * A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
+!
+ CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
+ A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
-C
-C *** get Energy Em
+!
+! *** get Energy Em
Em = Energb(Nn)
CALL Getem (Em, Kkkdat, Idone)
-C
+!
IF (Idone.EQ.2) THEN
-C *** Here E > Emax, so we're done.
+! *** Here E > Emax, so we're done.
GO TO 80
-C
-C
+!
+!
ELSE IF (Idone.EQ.0) THEN
-C *** Here if Idone=0, energy Em is bigger than Eminr, so
-C *** calculation can proceed
-C
+! *** Here if Idone=0, energy Em is bigger than Eminr, so
+! *** calculation can proceed
+!
IF (Kdatmn.EQ.0) Kdatmn = Nn
Total = Totsig(N)
Exp1 = dEXP(-Dthick*Total)
-C
+!
IF (Kwssms.EQ.1) THEN
Wssmsc(1) = Em
Wssmsc(2) = Capsig(N)
Wssmsc(3) = Totsig(N)
END IF
-C
+!
CALL Zero_Array (A(Isigxx), 1)
IF (Ksolve.NE.2) THEN
IF (Ndasig.GT.0) CALL Zero_Array (A(Idasig), Ndasig)
IF (Ndbsig.GT.0) CALL Zero_Array (A(Idbsig), Ndbsig)
END IF
-C
-C
-C *** Here begin multiple-scattering calculation
-C
+!
+!
+! *** Here begin multiple-scattering calculation
+!
Wssmsc(5) = Zero
Wssmsc(6) = Zero
DO Iso=1,Niniso
-C *** Start loop over nuclides (ie over "isotopes")
+! *** Start loop over nuclides (ie over "isotopes")
IF (Jxciso(Iso).NE.1) THEN
Iiso = Iso
- CALL Mulsca_1fl (A, Energb, A(Ifthet), Totsig, Capsig,
- * A(Irmass), A(Iaaa), A(Ibbb), A(Icsx), A(Iepx),
- * A(Iggx), A(Iiex), Wssmsc, Em, Exp1, Yyy1,
- * Yyy1fb, Nx, Maxx, Kdatb, Iiso, Nn, Imin, Idone,
- * Knthet, Kountr, Nxtptwn, Nxtptvm)
+ CALL Mulsca_1fl (A, Energb, A(Ifthet), Totsig, Capsig, &
+ A(Irmass), A(Iaaa), A(Ibbb), A(Icsx), A(Iepx), &
+ A(Iggx), I_Iiex, Wssmsc, Em, Exp1, Yyy1, &
+ Yyy1fb, Nx, Maxx, Kdatb, Iiso, Nn, Imin, Idone, &
+ Knthet, Kountr, Nxtptwn, Nxtptvm)
END IF
END DO
-C *** END of loop on Isotopes
-C
-C *** Fix value of Y1 (Needs multiply by Pi)
+! *** END of loop on Isotopes
+!
+! *** Fix value of Y1 (Needs multiply by Pi)
CALL Fixy_1f (A(Idyyy1), Yyy1, Yyy1fb)
-C
-C *** Finished with multiple-scattering corrections
-C
-C *** Y0 is self-shielded capture yield; normalized to be the
-C *** cross section in the limit of Zero thickness
+!
+! *** Finished with multiple-scattering corrections
+!
+! *** Y0 is self-shielded capture yield; normalized to be the
+! *** cross section in the limit of Zero thickness
Td = Total*Dthick
IF (Nonu.EQ.0) THEN
-C *** Uniform thickness
+! *** Uniform thickness
Exxxx = Exp1
ELSE
-C *** Non-uniform thickness
- CALL Non_Uniform_Thickness (A_Iznonu , A_Irnonu ,
- * Td, Exxxx, Nonu)
+! *** Non-uniform thickness
+ CALL Non_Uniform_Thickness (A_Iznonu, A_Irnonu, Td, Exxxx, Nonu)
END IF
Y0 = (One-Exxxx)*Capsig(N)/Td
-C
+!
IF (Sensin.NE.Zero) THEN
-C *** When neutron sensitivity is given (as "miscellaneous
-C *** parameters card 11"), then correction term is added
+! *** When neutron sensitivity is given (as "miscellaneous
+! *** parameters card 11"), then correction term is added
CALL Get_Ratio_Sensin (Em, Ratio_Sensin, Nsen, Itimes)
- Asensn = (One-Exp1) * Ratio_Sensin *
- * (100.0d0*Fourpi*Elastic/Total) / Dthick
-C *** Remember that "Fourpi" is really 4*pi/100
+ Asensn = (One-Exp1) * Ratio_Sensin * (100.0d0*Fourpi*Elastic/Total) / Dthick
+! *** Remember that "Fourpi" is really 4*pi/100
Y0 = Y0 + Asensn*Sensin
END IF
-C
-C *** Normalize Y1 same as Y0; renormalize all if needed;
-C *** store in Sigxxx; also calculate derivs for all pieces
+!
+! *** Normalize Y1 same as Y0; renormalize all if needed;
+! *** store in Sigxxx; also calculate derivs for all pieces
Dddyy0 = Zero
- CALL Ynrm_1 (Capsig, A(Idtots), A(Idcaps), A(Isigxx),
- * A(Idasig), A(Idbsig), A(Idyyy1), Y0, Yyy1,
- * Dthick, Total, Exp1, Em, Dddyy0, Asensn, Nn)
-C
-C *** Modify for self-indication experiments
- IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig),
- * A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
-C
+ CALL Ynrm_1 (Capsig, A(Idtots), A(Idcaps), A(Isigxx), &
+ A(Idasig), A(Idbsig), A(Idyyy1), Y0, Yyy1, &
+ Dthick, Total, Exp1, Em, Dddyy0, Asensn, Nn)
+!
+! *** Modify for self-indication experiments
+ IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig), &
+ A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
+!
IF (Debug) THEN
WRITE (66,10400) Em, Y0, Yyy1
10400 FORMAT (' E,0,1=', F12.4, 1p4g14.5)
END IF
CALL Finish_01 (A, Ee, Wssmsc, Em, Y0, Kdatb, Kkkdat, N)
-C
+!
ELSE IF (Idone.EQ.1) THEN
-C *** Here E < Eminr, so do not calculate Yield.
-C
+! *** Here E < Eminr, so do not calculate Yield.
+!
END IF
-C finish check on value of Idone
+! finish check on value of Idone
END DO
-C *** Done with loop on Energies Em
+! *** Done with loop on Energies Em
IF (Kssmpr.EQ.1) CLOSE (UNIT=60)
-C
-C
+!
+!
80 CONTINUE
-C *** Completely done
+! *** Completely done
Call Tell_Finite (A)
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ssssds_1fq (A, Jxciso, Energy, Energb, Totsig, Capsig,
- * Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
-C
-C *** Ssssds_1fq generates the the self-shielded + single-scattered
-C *** capture yield for a finite slab with quadratic interpolation
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ssssds_1fq (A, Jxciso, Energy, Energb, Totsig, Capsig, &
+ Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+!
+! *** Ssssds_1fq generates the the self-shielded + single-scattered
+! *** capture yield for a finite slab with quadratic interpolation
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -634,146 +637,149 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use ssm_1_m
+ use ssm_utils_m
+ use ssm_6_m
+ use ssm_20_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
DIMENSION Yyy1fb(2)
- DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*),
- * Totsig(*), Capsig(*)
-C
+ DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*), Totsig(*), Capsig(*)
+!
DIMENSION Wssmsc(10)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Itimes = 1
Kountr = 0
-C
+!
CALL Findpr (multScat%getNumTheta(), Knthet)
CALL Findpr (Nxtptw, Nxtptwn)
CALL Findpr (Nxtptv, Nxtptvm)
-C
+!
Imin = 1
Kkkdat = 0
Kdatmn = 0
Nsen = 1
-C
-C
+!
+!
call multScat%setLogSigmaTotMin( 1.d20 )
call multScat%setLogSigmaTotMax( -1.0d0 )
Interp_Small_Times = 0
-C *** Start major do-loop on Energy
+! *** Start major do-loop on Energy
DO N=1,Kdatb
Nn = N
-C
+!
CALL Zero0_1f (A, Yyy1fb, Y0, Yyy1, Nx)
-C
- CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx),
- * A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig,
- * A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
+!
+ CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
+ A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
-C
-C *** get Energy Em
+!
+! *** get Energy Em
Em = Energb(Nn)
CALL Getem (Em, Kkkdat, Idone)
-C
+!
IF (Idone.EQ.2) THEN
-C *** Here E > Emax, so we're done.
+! *** Here E > Emax, so we're done.
GO TO 80
-C
-C
+!
+!
ELSE IF (Idone.EQ.0) THEN
-C *** Here if Idone=0, energy Em is bigger than Eminr, so
-C *** calculation can proceed
-C
+! *** Here if Idone=0, energy Em is bigger than Eminr, so
+! *** calculation can proceed
+!
IF (Kdatmn.EQ.0) Kdatmn = Nn
Total = Totsig(N)
Exp1 = dEXP(-Dthick*Total)
-C
+!
IF (Kwssms.EQ.1) THEN
Wssmsc(1) = Em
Wssmsc(2) = Capsig(N)
Wssmsc(3) = Totsig(N)
END IF
-C
+!
CALL Zero_Array (A(Isigxx), 1)
IF (Ksolve.NE.2) THEN
IF (Ndasig.GT.0) CALL Zero_Array (A(Idasig), Ndasig)
IF (Ndbsig.GT.0) CALL Zero_Array (A(Idbsig), Ndbsig)
END IF
-C
-C
-C *** Here begin multiple-scattering calculation
-C
+!
+!
+! *** Here begin multiple-scattering calculation
+!
Wssmsc(5) = Zero
Wssmsc(6) = Zero
DO Iso=1,Niniso
-C *** Start loop over nuclides (ie over "isotopes")
+! *** Start loop over nuclides (ie over "isotopes")
IF (Jxciso(Iso).NE.1) THEN
Iiso = Iso
- CALL Mulsca_1fq (A, Energb, A(Ifthet), Totsig, Capsig,
- * A(Irmass), A(Iaaa), A(Ibbb), A(Icsx), A(Iepx),
- * A(Iggx), A(Iiex), Wssmsc, Em, Exp1, Yyy1,
- * Yyy1fb, Nx, Maxx, Kdatb, Iiso, Nn, Imin, Idone,
- * Knthet, Kountr, Nxtptwn, Nxtptvm)
+ CALL Mulsca_1fq (A, Energb, A(Ifthet), Totsig, Capsig, &
+ A(Irmass), A(Iaaa), A(Ibbb), A(Icsx), A(Iepx), &
+ A(Iggx), I_Iiex, Wssmsc, Em, Exp1, Yyy1, &
+ Yyy1fb, Nx, Maxx, Kdatb, Iiso, Nn, Imin, Idone, &
+ Knthet, Kountr, Nxtptwn, Nxtptvm)
END IF
END DO
-C *** END of loop on Isotopes
-C
-C *** Fix value of Y1 (Needs multiply by Pi)
+! *** END of loop on Isotopes
+!
+! *** Fix value of Y1 (Needs multiply by Pi)
CALL Fixy_1f (A(Idyyy1), Yyy1, Yyy1fb)
-C
-C *** Finished with multiple-scattering corrections
-C
-C *** Y0 is self-shielded capture yield; normalized to be the
-C *** cross section in the limit of Zero thickness
+!
+! *** Finished with multiple-scattering corrections
+!
+! *** Y0 is self-shielded capture yield; normalized to be the
+! *** cross section in the limit of Zero thickness
Td = Total*Dthick
IF (Nonu.EQ.0) THEN
-C *** Uniform thickness
+! *** Uniform thickness
Exxxx = Exp1
ELSE
-C *** Non-uniform thickness
- CALL Non_Uniform_Thickness (A_Iznonu , A_Irnonu ,
- * Td, Exxxx, Nonu)
+! *** Non-uniform thickness
+ CALL Non_Uniform_Thickness (A_Iznonu, A_Irnonu, Td, Exxxx, Nonu)
END IF
Y0 = (One-Exxxx)*Capsig(N)/Td
-C
+!
IF (Sensin.NE.Zero) THEN
-C *** When neutron sensitivity is given (as "miscellaneous
-C *** parameters card 11"), then correction term is added
+! *** When neutron sensitivity is given (as "miscellaneous
+! *** parameters card 11"), then correction term is added
CALL Get_Ratio_Sensin (Em, Ratio_Sensin, Nsen, Itimes)
- Asensn = (One-Exp1) * Ratio_Sensin *
- * (100.0d0*Fourpi*Elastic/Total) / Dthick
-C *** Remember that "Fourpi" is really 4*pi/100
+ Asensn = (One-Exp1) * Ratio_Sensin * (100.0d0*Fourpi*Elastic/Total) / Dthick
+! *** Remember that "Fourpi" is really 4*pi/100
Y0 = Y0 + Asensn*Sensin
END IF
-C
-C *** Normalize Y1 same as Y0; renormalize all if needed;
-C *** store in Sigxxx; also calculate derivs for all pieces
+!
+! *** Normalize Y1 same as Y0; renormalize all if needed;
+! *** store in Sigxxx; also calculate derivs for all pieces
Dddyy0 = Zero
- CALL Ynrm_1 (Capsig, A(Idtots), A(Idcaps), A(Isigxx),
- * A(Idasig), A(Idbsig), A(Idyyy1), Y0, Yyy1,
- * Dthick, Total, Exp1, Em, Dddyy0, Asensn, Nn)
-C
-C *** Modify for self-indication experiments
- IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig),
- * A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
-C
+ CALL Ynrm_1 (Capsig, A(Idtots), A(Idcaps), A(Isigxx), &
+ A(Idasig), A(Idbsig), A(Idyyy1), Y0, Yyy1, &
+ Dthick, Total, Exp1, Em, Dddyy0, Asensn, Nn)
+!
+! *** Modify for self-indication experiments
+ IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig), &
+ A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
+!
IF (Debug) THEN
WRITE (66,10400) Em, Y0, Yyy1
10400 FORMAT (' E,0,1=', F12.4, 1p4g14.5)
END IF
CALL Finish_01 (A, Ee, Wssmsc, Em, Y0, Kdatb, Kkkdat, N)
-C
+!
ELSE IF (Idone.EQ.1) THEN
-C *** Here E < Eminr, so do not calculate Yield.
-C
+! *** Here E < Eminr, so do not calculate Yield.
+!
END IF
-C finish check on value of Idone
+! finish check on value of Idone
END DO
-C *** Done with loop on Energies Em
+! *** Done with loop on Energies Em
IF (Kssmpr.EQ.1) CLOSE (UNIT=60)
-C
-C
+!
+!
80 CONTINUE
-C *** Completely done
+! *** Completely done
Call Tell_Finite (A)
RETURN
END
+
+end module ssm_3_m
diff --git a/sammy/src/ssm/mssm04.f b/sammy/src/ssm/mssm04.f90
similarity index 51%
rename from sammy/src/ssm/mssm04.f
rename to sammy/src/ssm/mssm04.f90
index 976608503..d1bb6de4b 100644
--- a/sammy/src/ssm/mssm04.f
+++ b/sammy/src/ssm/mssm04.f90
@@ -1,13 +1,15 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ssssds_2il (A, Jxciso, Energy, Energb, Totsig, Capsig,
- * Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
-C
-C *** Ssssds_2il generates the the self-shielded + multiple-scattered
-C *** capture yield for an infinite slab with linear interpolation
-C
+!
+module ssm_4_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ssssds_2il (A, Jxciso, Energy, Energb, Totsig, Capsig, &
+ Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+!
+! *** Ssssds_2il generates the the self-shielded + multiple-scattered
+! *** capture yield for an infinite slab with linear interpolation
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -21,66 +23,71 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use ssm_1_m
+ use ssm_utils_m
+ use ssm_7_m
+ use ssm_18_m
+ use ssm_20_m
+ use ssm_21_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*),
- * Totsig(*), Capsig(*), Y2cccc(*), Dy2ccc(Nx,*)
-C
+!
+ DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*), &
+ Totsig(*), Capsig(*), Y2cccc(*), Dy2ccc(Nx,*)
+!
DIMENSION Wssmsc(10)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Itimes = 1
Kountr = 0
-C
+!
IF (Mcy2.EQ.1) CALL Gety2zzz (Emy2_a, Emy2_b, Y2tab_a, Y2tab_b)
-C
+!
CALL Findpr (multScat%getNumTheta(), Knthet)
CALL Findpr (Nxtptw, Nxtptwn)
CALL Findpr (Nxtptv, Nxtptvm)
-C
+!
Imin = 1
Kkkdat = 0
Kdatmn = 0
Nsen = 1
-C
-C *** Start major do-loop on Energy
+!
+! *** Start major do-loop on Energy
DO N=1,Kdatb
Nn = N
-C
+!
CALL Zero0_2i (A, Y0, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx)
-C
- CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx),
- * A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig,
- * A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
+!
+ CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
+ A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
-C
-C *** get Energy Em
+!
+! *** get Energy Em
Em = Energb(Nn)
CALL Getem (Em, Kkkdat, Idone)
- IF (Mcy2.EQ.1) CALL Gety2tab (Em, Y2tab, Emy2_a, Emy2_b,
- * Y2tab_a, Y2tab_b)
-C
+ IF (Mcy2.EQ.1) CALL Gety2tab (Em, Y2tab, Emy2_a, Emy2_b, Y2tab_a, Y2tab_b)
+!
IF (Idone.EQ.2) THEN
-C *** Here E > Emax, so we're done.
+! *** Here E > Emax, so we're done.
GO TO 80
-C
+!
ELSE IF (Idone.EQ.3 .OR. Idone.EQ.0) THEN
-C *** Here if Idone=3, which means don't calculate yield, but do
-C *** calculate the pieces needed for Y2
-C
-C *** Also here if Idone=0, energy Em is bigger than Eminr, so
-C *** calculation can proceed
-C
+! *** Here if Idone=3, which means don't calculate yield, but do
+! *** calculate the pieces needed for Y2
+!
+! *** Also here if Idone=0, energy Em is bigger than Eminr, so
+! *** calculation can proceed
+!
IF (Idone.NE.3 .AND. Kdatmn.EQ.0) Kdatmn = Nn
Total = Totsig(N)
Exp1 = dEXP(-Dthick*Total)
-C
+!
IF (Kwssms.EQ.1) THEN
Wssmsc(1) = Em
Wssmsc(2) = Capsig(N)
Wssmsc(3) = Totsig(N)
END IF
-C
+!
IF (Idone.NE.3) THEN
CALL Zero_Array (A(Isigxx), 1)
IF (Ksolve.NE.2) THEN
@@ -88,106 +95,103 @@ C
IF (Ndbsig.GT.0) CALL Zero_Array (A(Idbsig), Ndbsig)
END IF
END IF
-C
-C *** Here begin multiple-scattering calculation
-C
+!
+! *** Here begin multiple-scattering calculation
+!
Wssmsc(5) = Zero
Wssmsc(6) = Zero
DO Iso=1,Niniso
-C *** Start loop over nuclides (ie over "isotopes")
+! *** Start loop over nuclides (ie over "isotopes")
IF (Jxciso(Iso).NE.1) THEN
Iiso = Iso
- CALL Mulsca_2il (A, Energb, A(Ifthet), Totsig,
- * Capsig, A(Irmass), A(Iaaa), A(Ibbb), A(Icsx),
- * A(Iepx), A(Iggx), A(Iiex), Y2cccc, Dy2ccc,
- * Wssmsc, Em, Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb,
- * Y2bbbq, Nx, Maxx, Kdatb, Iiso, Nn, Imin,
- * Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
+ CALL Mulsca_2il (A, Energb, A(Ifthet), Totsig, &
+ Capsig, A(Irmass), A(Iaaa), A(Ibbb), A(Icsx), &
+ A(Iepx), A(Iggx), I_Iiex, Y2cccc, Dy2ccc, &
+ Wssmsc, Em, Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb, &
+ Y2bbbq, Nx, Maxx, Kdatb, Iiso, Nn, Imin, &
+ Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
END IF
END DO
-C *** END of loop on Isotopes
-C
-C *** Fix value of Y1 (Needs multiply by Pi)
+! *** END of loop on Isotopes
+!
+! *** Fix value of Y1 (Needs multiply by Pi)
IF (Idone.NE.3) CALL Fixy_1i (A(Idyyy1), Yyy1)
-C
-C *** Now fix the value of Y2cccc & derivatives; also fix Yyy2
- CALL Fixy_2 (A(Idyyy2), A(Idyy2q), A(Idy2qq), Y2cccc(Nn),
- * Dy2ccc(1,Nn), A(Idy2bb), A(Idy2bq), A(Idybqq), Yyy2,
- * Yyy2q, Y2bbbb, Y2bbbq, Idone, Nn, Em)
-C
-C *** Finished with multiple-scattering corrections
+!
+! *** Now fix the value of Y2cccc & derivatives; also fix Yyy2
+ CALL Fixy_2 (A(Idyyy2), A(Idyy2q), A(Idy2qq), Y2cccc(Nn), &
+ Dy2ccc(1,Nn), A(Idy2bb), A(Idy2bq), A(Idybqq), Yyy2, &
+ Yyy2q, Y2bbbb, Y2bbbq, Idone, Nn, Em)
+!
+! *** Finished with multiple-scattering corrections
END IF
-C
+!
IF (Idone.NE.3) THEN
-C
-C *** Y0 is self-shielded capture yield; normalized to be the
-C *** cross section in the limit of Zero thickness
+!
+! *** Y0 is self-shielded capture yield; normalized to be the
+! *** cross section in the limit of Zero thickness
Td = Total*Dthick
IF (Nonu.EQ.0) THEN
-C *** Uniform thickness
+! *** Uniform thickness
Exxxx = Exp1
ELSE
-C *** Non-uniform thickness
- CALL Non_Uniform_Thickness (A_Iznonu , A_Irnonu ,
- * Td, Exxxx, Nonu)
+! *** Non-uniform thickness
+ CALL Non_Uniform_Thickness (A_Iznonu, A_Irnonu, Td, Exxxx, Nonu)
END IF
Y0 = (One-Exxxx)*Capsig(N)/Td
-C
+!
IF (Sensin.NE.Zero) THEN
-C *** When neutron sensitivity is given (as "miscellaneous
-C *** parameters card 11"), then correction term is added
+! *** When neutron sensitivity is given (as "miscellaneous
+! *** parameters card 11"), then correction term is added
CALL Get_Ratio_Sensin (Em, Ratio_Sensin, Nsen, Itimes)
- Asensn = (One-Exp1) * Ratio_Sensin *
- * (100.0d0*Fourpi*Elastic/Total) / Dthick
-C *** Remember that "Fourpi" is really 4*pi/100
+ Asensn = (One-Exp1) * Ratio_Sensin * (100.0d0*Fourpi*Elastic/Total) / Dthick
+! *** Remember that "Fourpi" is really 4*pi/100
Y0 = Y0 + Asensn*Sensin
END IF
-C
-C *** Normalize Y1 & Y2 same as Y0; renormalize all if needed;
-C *** store in Sigxxx; also calculate derivs for all pieces
+!
+! *** Normalize Y1 & Y2 same as Y0; renormalize all if needed;
+! *** store in Sigxxx; also calculate derivs for all pieces
Dddyy0 = Zero
- CALL Ynrm_2 (Capsig, A(Idtots), A(Idcaps), A(Isigxx),
- * A(Idasig), A(Idbsig), A(Idyyy1), A(Idyyy2), Y0, Yyy1,
- * Yyy2, Dthick, Total, Exp1, Em, Dddyy0, Asensn, Y2tab,
- * Nn)
-C
-C *** Modify for self-indication experiments
- IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig),
- * A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
-C
-C
+ CALL Ynrm_2 (Capsig, A(Idtots), A(Idcaps), A(Isigxx), &
+ A(Idasig), A(Idbsig), A(Idyyy1), A(Idyyy2), Y0, Yyy1, &
+ Yyy2, Dthick, Total, Exp1, Em, Dddyy0, Asensn, Y2tab, Nn)
+!
+! *** Modify for self-indication experiments
+ IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig), &
+ A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
+!
+!
IF (Debug) THEN
WRITE (66,10300) Em, Y0, Yyy1, Yyy2, Y2bbbb
10300 FORMAT (' E,0,1,2,x=', F12.4, 1p4g14.5)
END IF
CALL Finish_01 (A, Ee, Wssmsc, Em, Y0, Kdatb, Kkkdat, N)
-C
+!
ELSE IF (Idone.EQ.1) THEN
-C *** Here E < Eminr, so do not calculate Yield.
-C *** Also do not calculate Pieces of Y2.
-C
+! *** Here E < Eminr, so do not calculate Yield.
+! *** Also do not calculate Pieces of Y2.
+!
END IF
-C finish check on value of Idone
+! finish check on value of Idone
END DO
-C *** Done with loop on Energies Em
+! *** Done with loop on Energies Em
IF (Kssmpr.EQ.1) CLOSE (UNIT=60)
-C
-C
+!
+!
80 CONTINUE
-C *** Completely done
+! *** Completely done
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ssssds_2iq (A, Jxciso, Energy, Energb, Totsig, Capsig,
- * Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
-C
-C *** Ssssds_2iq generates the the self-shielded + multiple-scattered
-C *** capture yield for an infinite slab with quadratic interpolation
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ssssds_2iq (A, Jxciso, Energy, Energb, Totsig, Capsig, &
+ Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+!
+! *** Ssssds_2iq generates the the self-shielded + multiple-scattered
+! *** capture yield for an infinite slab with quadratic interpolation
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -201,66 +205,71 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use ssm_1_m
+ use ssm_utils_m
+ use ssm_7_m
+ use ssm_18_m
+ use ssm_20_m
+ use ssm_21_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*),
- * Totsig(*), Capsig(*), Y2cccc(*), Dy2ccc(Nx,*)
-C
+!
+ DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*), &
+ Totsig(*), Capsig(*), Y2cccc(*), Dy2ccc(Nx,*)
+!
DIMENSION Wssmsc(10)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Itimes = 1
Kountr = 0
-C
+!
IF (Mcy2.EQ.1) CALL Gety2zzz (Emy2_a, Emy2_b, Y2tab_a, Y2tab_b)
-C
+!
CALL Findpr (multScat%getNumTheta(), Knthet)
CALL Findpr (Nxtptw, Nxtptwn)
CALL Findpr (Nxtptv, Nxtptvm)
-C
+!
Imin = 1
Kkkdat = 0
Kdatmn = 0
Nsen = 1
-C
-C *** Start major do-loop on Energy
+!
+! *** Start major do-loop on Energy
DO N=1,Kdatb
Nn = N
-C
+!
CALL Zero0_2i (A, Y0, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx)
-C
- CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx),
- * A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig,
- * A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
+!
+ CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
+ A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
-C
-C *** get Energy Em
+!
+! *** get Energy Em
Em = Energb(Nn)
CALL Getem (Em, Kkkdat, Idone)
- IF (Mcy2.EQ.1) CALL Gety2tab (Em, Y2tab, Emy2_a, Emy2_b,
- * Y2tab_a, Y2tab_b)
-C
+ IF (Mcy2.EQ.1) CALL Gety2tab (Em, Y2tab, Emy2_a, Emy2_b, Y2tab_a, Y2tab_b)
+!
IF (Idone.EQ.2) THEN
-C *** Here E > Emax, so we're done.
+! *** Here E > Emax, so we're done.
GO TO 80
-C
+!
ELSE IF (Idone.EQ.3 .OR. Idone.EQ.0) THEN
-C *** Here if Idone=3, which means don't calculate yield, but do
-C *** calculate the pieces needed for Y2
-C
-C *** Also here if Idone=0, energy Em is bigger than Eminr, so
-C *** calculation can proceed
-C
+! *** Here if Idone=3, which means don't calculate yield, but do
+! *** calculate the pieces needed for Y2
+!
+! *** Also here if Idone=0, energy Em is bigger than Eminr, so
+! *** calculation can proceed
+!
IF (Idone.NE.3 .AND. Kdatmn.EQ.0) Kdatmn = Nn
Total = Totsig(N)
Exp1 = dEXP(-Dthick*Total)
-C
+!
IF (Kwssms.EQ.1) THEN
Wssmsc(1) = Em
Wssmsc(2) = Capsig(N)
Wssmsc(3) = Totsig(N)
END IF
-C
+!
IF (Idone.NE.3) THEN
CALL Zero_Array (A(Isigxx), 1)
IF (Ksolve.NE.2) THEN
@@ -268,107 +277,105 @@ C
IF (Ndbsig.GT.0) CALL Zero_Array (A(Idbsig), Ndbsig)
END IF
END IF
-C
-C *** Here begin multiple-scattering calculation
-C
+!
+! *** Here begin multiple-scattering calculation
+!
Wssmsc(5) = Zero
Wssmsc(6) = Zero
DO Iso=1,Niniso
-C *** Start loop over nuclides (ie over "isotopes")
+! *** Start loop over nuclides (ie over "isotopes")
IF (Jxciso(Iso).NE.1) THEN
Iiso = Iso
- CALL Mulsca_2iq (A, Energb, A(Ifthet), Totsig,
- * Capsig, A(Irmass), A(Iaaa), A(Ibbb), A(Icsx),
- * A(Iepx), A(Iggx), A(Iiex), Y2cccc, Dy2ccc,
- * Wssmsc, Em, Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb,
- * Y2bbbq, Nx, Maxx, Kdatb, Iiso, Nn, Imin,
- * Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
+ CALL Mulsca_2iq (A, Energb, A(Ifthet), Totsig, &
+ Capsig, A(Irmass), A(Iaaa), A(Ibbb), A(Icsx), &
+ A(Iepx), A(Iggx), I_Iiex, Y2cccc, Dy2ccc, &
+ Wssmsc, Em, Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb, &
+ Y2bbbq, Nx, Maxx, Kdatb, Iiso, Nn, Imin, &
+ Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
END IF
END DO
-C *** END of loop on Isotopes
-C
-C *** Fix value of Y1 (Needs multiply by Pi)
+! *** END of loop on Isotopes
+!
+! *** Fix value of Y1 (Needs multiply by Pi)
IF (Idone.NE.3) CALL Fixy_1i (A(Idyyy1), Yyy1)
-C
-C *** Now fix the value of Y2cccc & derivatives; also fix Yyy2
- CALL Fixy_2 (A(Idyyy2), A(Idyy2q), A(Idy2qq), Y2cccc(Nn),
- * Dy2ccc(1,Nn), A(Idy2bb), A(Idy2bq), A(Idybqq), Yyy2,
- * Yyy2q, Y2bbbb, Y2bbbq, Idone, Nn, Em)
-C
-C *** Finished with multiple-scattering corrections
+!
+! *** Now fix the value of Y2cccc & derivatives; also fix Yyy2
+ CALL Fixy_2 (A(Idyyy2), A(Idyy2q), A(Idy2qq), Y2cccc(Nn), &
+ Dy2ccc(1,Nn), A(Idy2bb), A(Idy2bq), A(Idybqq), Yyy2, &
+ Yyy2q, Y2bbbb, Y2bbbq, Idone, Nn, Em)
+!
+! *** Finished with multiple-scattering corrections
END IF
-C
+!
IF (Idone.NE.3) THEN
-C
-C *** Y0 is self-shielded capture yield; normalized to be the
-C *** cross section in the limit of Zero thickness
+!
+! *** Y0 is self-shielded capture yield; normalized to be the
+! *** cross section in the limit of Zero thickness
Td = Total*Dthick
IF (Nonu.EQ.0) THEN
-C *** Uniform thickness
+! *** Uniform thickness
Exxxx = Exp1
ELSE
-C *** Non-uniform thickness
- CALL Non_Uniform_Thickness (A_Iznonu , A_Irnonu ,
- * Td, Exxxx, Nonu)
+! *** Non-uniform thickness
+ CALL Non_Uniform_Thickness (A_Iznonu, A_Irnonu, Td, Exxxx, Nonu)
END IF
Y0 = (One-Exxxx)*Capsig(N)/Td
-C
+!
IF (Sensin.NE.Zero) THEN
-C *** When neutron sensitivity is given (as "miscellaneous
-C *** parameters card 11"), then correction term is added
+! *** When neutron sensitivity is given (as "miscellaneous
+! *** parameters card 11"), then correction term is added
CALL Get_Ratio_Sensin (Em, Ratio_Sensin, Nsen, Itimes)
- Asensn = (One-Exp1) * Ratio_Sensin *
- * (100.0d0*Fourpi*Elastic/Total) / Dthick
-C *** Remember that "Fourpi" is really 4*pi/100
+ Asensn = (One-Exp1) * Ratio_Sensin * (100.0d0*Fourpi*Elastic/Total) / Dthick
+! *** Remember that "Fourpi" is really 4*pi/100
Y0 = Y0 + Asensn*Sensin
END IF
-C
-C *** Normalize Y1 & Y2 same as Y0; renormalize all if needed;
-C *** store in Sigxxx; also calculate derivs for all pieces
+!
+! *** Normalize Y1 & Y2 same as Y0; renormalize all if needed;
+! *** store in Sigxxx; also calculate derivs for all pieces
Dddyy0 = Zero
- CALL Ynrm_2 (Capsig, A(Idtots), A(Idcaps), A(Isigxx),
- * A(Idasig), A(Idbsig), A(Idyyy1), A(Idyyy2), Y0, Yyy1,
- * Yyy2, Dthick, Total, Exp1, Em, Dddyy0, Asensn, Y2tab,
- * Nn)
-C
-C *** Modify for self-indication experiments
- IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig),
- * A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
-C
-C
+ CALL Ynrm_2 (Capsig, A(Idtots), A(Idcaps), A(Isigxx), &
+ A(Idasig), A(Idbsig), A(Idyyy1), A(Idyyy2), Y0, Yyy1, &
+ Yyy2, Dthick, Total, Exp1, Em, Dddyy0, Asensn, Y2tab, &
+ Nn)
+!
+! *** Modify for self-indication experiments
+ IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig), &
+ A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
+!
+!
IF (Debug) THEN
WRITE (66,10300) Em, Y0, Yyy1, Yyy2, Y2bbbb
10300 FORMAT (' E,0,1,2,x=', F12.4, 1p4g14.5)
END IF
CALL Finish_01 (A, Ee, Wssmsc, Em, Y0, Kdatb, Kkkdat, N)
-C
+!
ELSE IF (Idone.EQ.1) THEN
-C *** Here E < Eminr, so do not calculate Yield.
-C *** Also do not calculate Pieces of Y2.
-C
+! *** Here E < Eminr, so do not calculate Yield.
+! *** Also do not calculate Pieces of Y2.
+!
END IF
-C finish check on value of Idone
+! finish check on value of Idone
END DO
-C *** Done with loop on Energies Em
+! *** Done with loop on Energies Em
IF (Kssmpr.EQ.1) CLOSE (UNIT=60)
-C
+!
80 CONTINUE
-C *** Completely done
+! *** Completely done
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ssssds_2fl (A, Jxciso, Energy, Energb, Totsig, Capsig,
- * Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
-C
-C *** Ssssds_2fl generates the the self-shielded + multiple-scattered
-C *** capture yield for an infinite slab, calls Mulsca to generate
-C *** the finite-slab results.
-C *** Using linear interpolation.
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ssssds_2fl (A, Jxciso, Energy, Energb, Totsig, Capsig, &
+ Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+!
+! *** Ssssds_2fl generates the the self-shielded + multiple-scattered
+! *** capture yield for an infinite slab, calls Mulsca to generate
+! *** the finite-slab results.
+! *** Using linear interpolation.
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -382,71 +389,75 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use ssm_1_m
+ use ssm_utils_m
+ use ssm_8_m
+ use ssm_18_m
+ use ssm_20_m
+ use ssm_21_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
DIMENSION Yyy1fb(2)
- DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*),
- * Totsig(*), Capsig(*), Y2cccc(*), Dy2ccc(Nx,*)
-C
+ DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*), &
+ Totsig(*), Capsig(*), Y2cccc(*), Dy2ccc(Nx,*)
+!
DIMENSION Wssmsc(10)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Itimes = 1
Kountr = 0
-C
+!
IF (Mcy2.EQ.1) CALL Gety2zzz (Emy2_a, Emy2_b, Y2tab_a, Y2tab_b)
-C
+!
CALL Findpr (multScat%getNumTheta(), Knthet)
CALL Findpr (Nxtptw, Nxtptwn)
CALL Findpr (Nxtptv, Nxtptvm)
-C
+!
Imin = 1
Kkkdat = 0
Kdatmn = 0
Nsen = 1
-C
+!
call multScat%setLogSigmaTotMin(1.d20)
call multScat%setLogSigmaTotMax( -1.0d0)
Interp_Small_Times = 0
-C *** Start major do-loop on Energy
+! *** Start major do-loop on Energy
DO N=1,Kdatb
Nn = N
-C
- CALL Zero0_2f (A, Yyy1fb, Y0, Yyy1, Yyy2, Yyy2q,
- * Y2bbbb, Y2bbbq, Nx)
-C
- CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx),
- * A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig,
- * A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
+!
+ CALL Zero0_2f (A, Yyy1fb, Y0, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx)
+!
+ CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
+ A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
-C
-C *** get Energy Em
+!
+! *** get Energy Em
Em = Energb(Nn)
CALL Getem (Em, Kkkdat, Idone)
- IF (Mcy2.EQ.1) CALL Gety2tab (Em, Y2tab, Emy2_a, Emy2_b,
- * Y2tab_a, Y2tab_b)
-C
+ IF (Mcy2.EQ.1) CALL Gety2tab (Em, Y2tab, Emy2_a, Emy2_b, Y2tab_a, Y2tab_b)
+!
IF (Idone.EQ.2) THEN
-C *** Here E > Emax, so we're done.
+! *** Here E > Emax, so we're done.
GO TO 80
-C
+!
ELSE IF (Idone.EQ.3 .OR. Idone.EQ.0) THEN
-C *** Here if Idone=3, which means don't calculate yield, but do
-C *** calculate the pieces needed for Y2
-C
-C *** Also here if Idone=0, energy Em is bigger than Eminr, so
-C *** calculation can proceed
-C
+! *** Here if Idone=3, which means don't calculate yield, but do
+! *** calculate the pieces needed for Y2
+!
+! *** Also here if Idone=0, energy Em is bigger than Eminr, so
+! *** calculation can proceed
+!
IF (Idone.NE.3 .AND. Kdatmn.EQ.0) Kdatmn = Nn
Total = Totsig(N)
Exp1 = dEXP(-Dthick*Total)
-C
+!
IF (Kwssms.EQ.1) THEN
Wssmsc(1) = Em
Wssmsc(2) = Capsig(N)
Wssmsc(3) = Totsig(N)
END IF
-C
+!
IF (Idone.NE.3) THEN
CALL Zero_Array (A(Isigxx), 1)
IF (Ksolve.NE.2) THEN
@@ -454,107 +465,105 @@ C
IF (Ndbsig.GT.0) CALL Zero_Array (A(Idbsig), Ndbsig)
END IF
END IF
-C
-C *** Here begin multiple-scattering calculation
-C
+!
+! *** Here begin multiple-scattering calculation
+!
Wssmsc(5) = Zero
Wssmsc(6) = Zero
DO Iso=1,Niniso
-C *** Start loop over nuclides (ie over "isotopes")
+! *** Start loop over nuclides (ie over "isotopes")
IF (Jxciso(Iso).NE.1) THEN
Iiso = Iso
- CALL Mulsca_2fl (A, Energb, A(Ifthet), Totsig,
- * Capsig, A(Irmass), A(Iaaa), A(Ibbb), A(Icsx),
- * A(Iepx), A(Iggx), A(Iiex), Y2cccc, Dy2ccc,
- * Wssmsc, Em, Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb,
- * Y2bbbq, Yyy1fb, Nx, Maxx, Kdatb, Iiso, Nn,
- * Imin, Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
+ CALL Mulsca_2fl (A, Energb, A(Ifthet), Totsig, &
+ Capsig, A(Irmass), A(Iaaa), A(Ibbb), A(Icsx), &
+ A(Iepx), A(Iggx), I_Iiex, Y2cccc, Dy2ccc, &
+ Wssmsc, Em, Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb, &
+ Y2bbbq, Yyy1fb, Nx, Maxx, Kdatb, Iiso, Nn, &
+ Imin, Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
END IF
END DO
-C *** END of loop on Isotopes
-C
-C *** Fix value of Y1 (Needs multiply by Pi)
+! *** END of loop on Isotopes
+!
+! *** Fix value of Y1 (Needs multiply by Pi)
IF (Idone.NE.3) CALL Fixy_1f (A(Idyyy1), Yyy1, Yyy1fb)
-C
-C *** Now fix the value of Y2cccc & derivatives; also fix Yyy2
- CALL Fixy_2 (A(Idyyy2), A(Idyy2q), A(Idy2qq), Y2cccc(Nn),
- * Dy2ccc(1,Nn), A(Idy2bb), A(Idy2bq), A(Idybqq), Yyy2,
- * Yyy2q, Y2bbbb, Y2bbbq, Idone, Nn, Em)
-C
-C *** Finished with multiple-scattering corrections
+!
+! *** Now fix the value of Y2cccc & derivatives; also fix Yyy2
+ CALL Fixy_2 (A(Idyyy2), A(Idyy2q), A(Idy2qq), Y2cccc(Nn), &
+ Dy2ccc(1,Nn), A(Idy2bb), A(Idy2bq), A(Idybqq), Yyy2, &
+ Yyy2q, Y2bbbb, Y2bbbq, Idone, Nn, Em)
+!
+! *** Finished with multiple-scattering corrections
END IF
-C
+!
IF (Idone.NE.3) THEN
-C
-C *** Y0 is self-shielded capture yield; normalized to be the
-C *** cross section in the limit of Zero thickness
+!
+! *** Y0 is self-shielded capture yield; normalized to be the
+! *** cross section in the limit of Zero thickness
Td = Total*Dthick
IF (Nonu.EQ.0) THEN
-C *** Uniform thickness
+! *** Uniform thickness
Exxxx = Exp1
ELSE
-C *** Non-uniform thickness
- CALL Non_Uniform_Thickness (A_Iznonu , A_Irnonu ,
- * Td, Exxxx, Nonu)
+! *** Non-uniform thickness
+ CALL Non_Uniform_Thickness (A_Iznonu, A_Irnonu, Td, Exxxx, Nonu)
END IF
Y0 = (One-Exxxx)*Capsig(N)/Td
-C
+!
IF (Sensin.NE.Zero) THEN
-C *** When neutron sensitivity is given (as "miscellaneous
-C *** parameters card 11"), then correction term is added
+! *** When neutron sensitivity is given (as "miscellaneous
+! *** parameters card 11"), then correction term is added
CALL Get_Ratio_Sensin (Em, Ratio_Sensin, Nsen, Itimes)
- Asensn = (One-Exp1) * Ratio_Sensin *
- * (100.0d0*Fourpi*Elastic/Total) / Dthick
-C *** Remember that "Fourpi" is really 4*pi/100
+ Asensn = (One-Exp1) * Ratio_Sensin * (100.0d0*Fourpi*Elastic/Total) / Dthick
+! *** Remember that "Fourpi" is really 4*pi/100
Y0 = Y0 + Asensn*Sensin
END IF
-C
-C *** Normalize Y1 & Y2 same as Y0; renormalize all if needed;
-C *** store in Sigxxx; also calculate derivs for all pieces
+!
+! *** Normalize Y1 & Y2 same as Y0; renormalize all if needed;
+! *** store in Sigxxx; also calculate derivs for all pieces
Dddyy0 = Zero
- CALL Ynrm_2 (Capsig, A(Idtots), A(Idcaps), A(Isigxx),
- * A(Idasig), A(Idbsig), A(Idyyy1), A(Idyyy2), Y0, Yyy1,
- * Yyy2, Dthick, Total, Exp1, Em, Dddyy0, Asensn, Y2tab, Nn)
-C
-C *** Modify for self-indication experiments
- IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig),
- * A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
-C
+ CALL Ynrm_2 (Capsig, A(Idtots), A(Idcaps), A(Isigxx), &
+ A(Idasig), A(Idbsig), A(Idyyy1), A(Idyyy2), Y0, Yyy1, &
+ Yyy2, Dthick, Total, Exp1, Em, Dddyy0, Asensn, Y2tab, Nn)
+!
+! *** Modify for self-indication experiments
+ IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig), &
+ A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
+!
IF (Debug) THEN
WRITE (66,10300) Em, Y0, Yyy1, Yyy2, Y2bbbb
10300 FORMAT (' E,0,1,2,x=', F12.4, 1p4g14.5)
END IF
CALL Finish_01 (A, Ee, Wssmsc, Em, Y0, Kdatb, Kkkdat, N)
-C
+!
ELSE IF (Idone.EQ.1) THEN
-C *** Here E < Eminr, so do not calculate Yield.
-C *** Also do not calculate Pieces of Y2.
-C
+! *** Here E < Eminr, so do not calculate Yield.
+! *** Also do not calculate Pieces of Y2.
+!
END IF
-C finish check on value of Idone
+! finish check on value of Idone
END DO
-C *** Done with loop on Energies Em
+! *** Done with loop on Energies Em
IF (Kssmpr.EQ.1) CLOSE (UNIT=60)
-C
+!
80 CONTINUE
-C *** Completely done
-C
+! *** Completely done
+!
Call Tell_Finite (A)
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ssssds_2fq (A, Jxciso, Energy, Energb, Totsig, Capsig,
- * Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
-C
-C *** Ssssds_2fq generates the the self-shielded + multiple-scattered
-C *** capture yield for an infinite slab, calls Mulsca to generate
-C *** the finite-slab results.
-C *** Using quadratic interpolation.
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ssssds_2fq (A, Jxciso, Energy, Energb, Totsig, Capsig, &
+ Y2cccc, Dy2ccc, Nx, Maxx, Kdatb, Kdatmn, Kkkdat)
+!
+! *** Ssssds_2fq generates the the self-shielded + multiple-scattered
+! *** capture yield for an infinite slab, calls Mulsca to generate
+! *** the finite-slab results.
+! *** Using quadratic interpolation.
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -568,71 +577,75 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use ssm_1_m
+ use ssm_utils_m
+ use ssm_8_m
+ use ssm_18_m
+ use ssm_20_m
+ use ssm_21_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
DIMENSION Yyy1fb(2)
- DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*),
- * Totsig(*), Capsig(*), Y2cccc(*), Dy2ccc(Nx,*)
-C
+ DIMENSION A(-Msize:Msize), Jxciso(*), Energy(*), Energb(*), &
+ Totsig(*), Capsig(*), Y2cccc(*), Dy2ccc(Nx,*)
+!
DIMENSION Wssmsc(10)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Itimes = 1
Kountr = 0
-C
+!
IF (Mcy2.EQ.1) CALL Gety2zzz (Emy2_a, Emy2_b, Y2tab_a, Y2tab_b)
-C
+!
CALL Findpr (multScat%getNumTheta(), Knthet)
CALL Findpr (Nxtptw, Nxtptwn)
CALL Findpr (Nxtptv, Nxtptvm)
-C
+!
Imin = 1
Kkkdat = 0
Kdatmn = 0
Nsen = 1
-C
+!
call multScat%setLogSigmaTotMin(1.d20)
call multScat%setLogSigmaTotMax( -1.0d0)
Interp_Small_Times = 0
-C *** Start major do-loop on Energy
+! *** Start major do-loop on Energy
DO N=1,Kdatb
Nn = N
-C
- CALL Zero0_2f (A, Yyy1fb, Y0, Yyy1, Yyy2, Yyy2q,
- * Y2bbbb, Y2bbbq, Nx)
-C
- CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx),
- * A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig,
- * A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
+!
+ CALL Zero0_2f (A, Yyy1fb, Y0, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx)
+!
+ CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
+ A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
-C
-C *** get Energy Em
+!
+! *** get Energy Em
Em = Energb(Nn)
CALL Getem (Em, Kkkdat, Idone)
- IF (Mcy2.EQ.1) CALL Gety2tab (Em, Y2tab, Emy2_a, Emy2_b,
- * Y2tab_a, Y2tab_b)
-C
+ IF (Mcy2.EQ.1) CALL Gety2tab (Em, Y2tab, Emy2_a, Emy2_b, Y2tab_a, Y2tab_b)
+!
IF (Idone.EQ.2) THEN
-C *** Here E > Emax, so we're done.
+! *** Here E > Emax, so we're done.
GO TO 80
-C
+!
ELSE IF (Idone.EQ.3 .OR. Idone.EQ.0) THEN
-C *** Here if Idone=3, which means don't calculate yield, but do
-C *** calculate the pieces needed for Y2
-C
-C *** Also here if Idone=0, energy Em is bigger than Eminr, so
-C *** calculation can proceed
-C
+! *** Here if Idone=3, which means don't calculate yield, but do
+! *** calculate the pieces needed for Y2
+!
+! *** Also here if Idone=0, energy Em is bigger than Eminr, so
+! *** calculation can proceed
+!
IF (Idone.NE.3 .AND. Kdatmn.EQ.0) Kdatmn = Nn
Total = Totsig(N)
Exp1 = dEXP(-Dthick*Total)
-C
+!
IF (Kwssms.EQ.1) THEN
Wssmsc(1) = Em
Wssmsc(2) = Capsig(N)
Wssmsc(3) = Totsig(N)
END IF
-C
+!
IF (Idone.NE.3) THEN
CALL Zero_Array (A(Isigxx), 1)
IF (Ksolve.NE.2) THEN
@@ -640,93 +653,93 @@ C
IF (Ndbsig.GT.0) CALL Zero_Array (A(Idbsig), Ndbsig)
END IF
END IF
-C
-C *** Here begin multiple-scattering calculation
-C
+!
+! *** Here begin multiple-scattering calculation
+!
Wssmsc(5) = Zero
Wssmsc(6) = Zero
DO Iso=1,Niniso
-C *** Start loop over nuclides (ie over "isotopes")
+! *** Start loop over nuclides (ie over "isotopes")
IF (Jxciso(Iso).NE.1) THEN
Iiso = Iso
- CALL Mulsca_2fq (A, Energb, A(Ifthet), Totsig,
- * Capsig, A(Irmass), A(Iaaa), A(Ibbb), A(Icsx),
- * A(Iepx), A(Iggx), A(Iiex), Y2cccc, Dy2ccc,
- * Wssmsc, Em, Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb,
- * Y2bbbq, Yyy1fb, Nx, Maxx, Kdatb, Iiso, Nn,
- * Imin, Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
+ CALL Mulsca_2fq (A, Energb, A(Ifthet), Totsig, &
+ Capsig, A(Irmass), A(Iaaa), A(Ibbb), A(Icsx), &
+ A(Iepx), A(Iggx), I_Iiex, Y2cccc, Dy2ccc, &
+ Wssmsc, Em, Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb, &
+ Y2bbbq, Yyy1fb, Nx, Maxx, Kdatb, Iiso, Nn, &
+ Imin, Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
END IF
END DO
-C *** END of loop on Isotopes
-C
-C *** Fix value of Y1 (Needs multiply by Pi)
+! *** END of loop on Isotopes
+!
+! *** Fix value of Y1 (Needs multiply by Pi)
IF (Idone.NE.3) CALL Fixy_1f (A(Idyyy1), Yyy1, Yyy1fb)
-C
-C *** Now fix the value of Y2cccc & derivatives; also fix Yyy2
- CALL Fixy_2 (A(Idyyy2), A(Idyy2q), A(Idy2qq), Y2cccc(Nn),
- * Dy2ccc(1,Nn), A(Idy2bb), A(Idy2bq), A(Idybqq), Yyy2,
- * Yyy2q, Y2bbbb, Y2bbbq, Idone, Nn, Em)
-C
-C *** Finished with multiple-scattering corrections
+!
+! *** Now fix the value of Y2cccc & derivatives; also fix Yyy2
+ CALL Fixy_2 (A(Idyyy2), A(Idyy2q), A(Idy2qq), Y2cccc(Nn), &
+ Dy2ccc(1,Nn), A(Idy2bb), A(Idy2bq), A(Idybqq), Yyy2, &
+ Yyy2q, Y2bbbb, Y2bbbq, Idone, Nn, Em)
+!
+! *** Finished with multiple-scattering corrections
END IF
-C
+!
IF (Idone.NE.3) THEN
-C
-C *** Y0 is self-shielded capture yield; normalized to be the
-C *** cross section in the limit of Zero thickness
+!
+! *** Y0 is self-shielded capture yield; normalized to be the
+! *** cross section in the limit of Zero thickness
Td = Total*Dthick
IF (Nonu.EQ.0) THEN
-C *** Uniform thickness
+! *** Uniform thickness
Exxxx = Exp1
ELSE
-C *** Non-uniform thickness
- CALL Non_Uniform_Thickness (A_Iznonu , A_Irnonu ,
- * Td, Exxxx, Nonu)
+! *** Non-uniform thickness
+ CALL Non_Uniform_Thickness (A_Iznonu, A_Irnonu, Td, Exxxx, Nonu)
END IF
Y0 = (One-Exxxx)*Capsig(N)/Td
-C
+!
IF (Sensin.NE.Zero) THEN
-C *** When neutron sensitivity is given (as "miscellaneous
-C *** parameters card 11"), then correction term is added
+! *** When neutron sensitivity is given (as "miscellaneous
+! *** parameters card 11"), then correction term is added
CALL Get_Ratio_Sensin (Em, Ratio_Sensin, Nsen, Itimes)
- Asensn = (One-Exp1) * Ratio_Sensin *
- * (100.0d0*Fourpi*Elastic/Total) / Dthick
-C *** Remember that "Fourpi" is really 4*pi/100
+ Asensn = (One-Exp1) * Ratio_Sensin * (100.0d0*Fourpi*Elastic/Total) / Dthick
+! *** Remember that "Fourpi" is really 4*pi/100
Y0 = Y0 + Asensn*Sensin
END IF
-C
-C *** Normalize Y1 & Y2 same as Y0; renormalize all if needed;
-C *** store in Sigxxx; also calculate derivs for all pieces
+!
+! *** Normalize Y1 & Y2 same as Y0; renormalize all if needed;
+! *** store in Sigxxx; also calculate derivs for all pieces
Dddyy0 = Zero
- CALL Ynrm_2 (Capsig, A(Idtots), A(Idcaps), A(Isigxx),
- * A(Idasig), A(Idbsig), A(Idyyy1), A(Idyyy2), Y0, Yyy1,
- * Yyy2, Dthick, Total, Exp1, Em, Dddyy0, Asensn, Y2tab, Nn)
-C
-C *** Modify for self-indication experiments
- IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig),
- * A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
-C
+ CALL Ynrm_2 (Capsig, A(Idtots), A(Idcaps), A(Isigxx), &
+ A(Idasig), A(Idbsig), A(Idyyy1), A(Idyyy2), Y0, Yyy1, &
+ Yyy2, Dthick, Total, Exp1, Em, Dddyy0, Asensn, Y2tab, Nn)
+!
+! *** Modify for self-indication experiments
+ IF (Yselfi) CALL Selfin (A(Isigxx), A(Idasig), A(Idbsig), &
+ A(Ivsigs), A_Ivdass , A_Ivdbss , A(Idtots), Total, Nn)
+!
IF (Debug) THEN
WRITE (66,10300) Em, Y0, Yyy1, Yyy2, Y2bbbb
10300 FORMAT (' E,0,1,2,x=', F12.4, 1p4g14.5)
END IF
CALL Finish_01 (A, Ee, Wssmsc, Em, Y0, Kdatb, Kkkdat, N)
-C
+!
ELSE IF (Idone.EQ.1) THEN
-C *** Here E < Eminr, so do not calculate Yield.
-C *** Also do not calculate Pieces of Y2.
-C
+! *** Here E < Eminr, so do not calculate Yield.
+! *** Also do not calculate Pieces of Y2.
+!
END IF
-C finish check on value of Idone
+! finish check on value of Idone
END DO
-C *** Done with loop on Energies Em
+! *** Done with loop on Energies Em
IF (Kssmpr.EQ.1) CLOSE (UNIT=60)
-C
-C
+!
+!
80 CONTINUE
-C *** Completely done
+! *** Completely done
Call Tell_Finite (A)
-C
+!
RETURN
END
+
+end module ssm_4_m
diff --git a/sammy/src/ssm/mssm05.f b/sammy/src/ssm/mssm05.f90
similarity index 55%
rename from sammy/src/ssm/mssm05.f
rename to sammy/src/ssm/mssm05.f90
index 8c425ae5f..79e0c64cc 100644
--- a/sammy/src/ssm/mssm05.f
+++ b/sammy/src/ssm/mssm05.f90
@@ -1,24 +1,26 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Mulsca_1il (A, Energb, Ftheta, Totsig, Capsig, Rmass,
- * Aaa, Bbb, Csx, Epx, Ggx, Iex, Wssmsc, Em, Exp1, Yyy1, Nx, Maxx,
- * Kdatb, Iiso, Nn, Imin, Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
-C
-C *** Mulsca generates the [approximation to] the multiple-scattering
-C *** correction to the capture & fission yield
-C *** The integration over mu is performed on a grid composed of:
-C *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
-C *** (2) Values of mu corresponding to E' as in Energb grid
-C *** (3) Extra points as needed when integrand changes rapidly
-C *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
-C *** calculated earlier (in INP); these are used for edge-effects
-C *** correction to single-scattering term
-C *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
-C *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
-C *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
-C
+!
+module ssm_5_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Mulsca_1il (A, Energb, Ftheta, Totsig, Capsig, Rmass, &
+ Aaa, Bbb, Csx, Epx, Ggx, Iex, Wssmsc, Em, Exp1, Yyy1, Nx, Maxx, &
+ Kdatb, Iiso, Nn, Imin, Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
+!
+! *** Mulsca generates the [approximation to] the multiple-scattering
+! *** correction to the capture & fission yield
+! *** The integration over mu is performed on a grid composed of:
+! *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
+! *** (2) Values of mu corresponding to E' as in Energb grid
+! *** (3) Extra points as needed when integrand changes rapidly
+! *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
+! *** calculated earlier (in INP); these are used for edge-effects
+! *** correction to single-scattering term
+! *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
+! *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
+! *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -31,14 +33,16 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use ssm_9_m
+ use ssm_11_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Backward, Forward
DIMENSION A(-Msize:Msize)
-C
- DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*),
- * Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*),
- * Wssmsc(*)
-C
+!
+ DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*), &
+ Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*), &
+ Wssmsc(*)
+!
DATA Big /1.5d0/, Small /1.0d-12/, Lost /0/
DATA Zero /0.0d0/, One /1.0d0/, Two/2.0d0/
@@ -46,17 +50,17 @@ C
character(len=80)::srcfile
interpType = "Mulsca_1il"
srcfile = "mssm05.f"
-C
-C
+!
+!
CALL Zero2_1 (A, Sumw, Yyy1xx, Nx)
-C
-C *** Costhe (E') integration: first, find limits
-C
+!
+! *** Costhe (E') integration: first, find limits
+!
CALL Limit (Energb, E1, E2, Rmass(Iiso), I1, Nn, Imin)
-C *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
-C *** E2=E*((M-1)/(M+1))
-C *** I1=grid Number just above E1
-C
+! *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
+! *** E2=E*((M-1)/(M+1))
+! *** I1=grid Number just above E1
+!
Ggg = Zero
Gggnew = Zero
Izero = 1
@@ -66,163 +70,159 @@ C
J1 = I1
J2 = 0
Ientrp = 0
-C
-C *** Find Ggg for Costhe & Eb
- CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Eb, J1+1, Ientrp,
- * Kdatb, Nn, Idone)
+!
+! *** Find Ggg for Costhe & Eb
+ CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Eb, J1+1, Ientrp, &
+ Kdatb, Nn, Idone)
CALL Getggg (Exp1, Ggg)
-C
+!
Cosold = Cosb
Cosp = Cosb
Kadd = 0
Kaddm = 0
call multScat%setNumThetaNearZero( 0 )
-C
-C *** Do integrations from mu = -1 to mu = +1:
-C *** for Backward (E1 <E'<E1e) top
-C *** (E1e<E'<E2 ) edge
-C *** and Forward (E2 <E'<E2e) edge
-C *** (E2e<E'<Em ) bottom
-C *** (if assume beam goes from top to bottom)
+!
+! *** Do integrations from mu = -1 to mu = +1:
+! *** for Backward (E1 <E'<E1e) top
+! *** (E1e<E'<E2 ) edge
+! *** and Forward (E2 <E'<E2e) edge
+! *** (E2e<E'<Em ) bottom
+! *** (if assume beam goes from top to bottom)
DO 80 Jfbx=1,2
IF (Jfbx.EQ.1) THEN
-C Jfbx=1 => Backward (low E, high angle, Negative cosine)
+! Jfbx=1 => Backward (low E, high angle, Negative cosine)
Jfb = 2
Backward = .TRUE.
Forward = .FALSE.
ELSE
-C Jfbx=2 => Forward (high E, low angle, positive cosine)
+! Jfbx=2 => Forward (high E, low angle, positive cosine)
Jfb = 1
Backward = .FALSE.
Forward = .TRUE.
Cosb = Zero
Eb = E2
END IF
-C
+!
Jthxx = 0
-C ------ Loop over cosine(theta) (& therefore over E'=Ep)
+! ------ Loop over cosine(theta) (& therefore over E'=Ep)
DO Jthx=1,Jtheta
IF (Jthx.EQ.1) Jthxx = 1
Jth = Jthx
-C = 1 to Jtheta
+! = 1 to Jtheta
IF (Backward) Jth = Jtheta + 1 - Jthx
-C = Jtheta to 1
+! = Jtheta to 1
Cosa = Cosb
Ea = Eb
IF (Forward .AND.Jth.LT.Jtheta) Cosb = Ftheta(Jth+1)
IF (Backward.AND.Jth.GT.1 ) Cosb = - Ftheta(Jth-1)
Itntb = 1
- Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) )
- * /Bbb(Iiso) )**2
+ Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) ) / Bbb(Iiso) )**2
IF (Jth+1.EQ.Jtheta .AND. Forward) Eb = Em
-C
-C *** ----- Are there energy-points between Cosa & Cosb ?
+!
+! *** ----- Are there energy-points between Cosa & Cosb ?
CALL Pickee (Energb, Ea, Eb, J1, J2, Kdatb)
-C
+!
IF (Forward) THEN
IF (Jth+1.EQ.Jtheta) THEN
-C if (Forward & next point is last...)
+! if (Forward & next point is last...)
IF (J2.EQ.Nn) J2 = Nn - 1
ELSE IF (Jth.EQ.Jtheta) THEN
-C IF (Forward & this point is last...)
+! IF (Forward & this point is last...)
IF (J2.GE.Nn) J2 = Nn - 1
IF (J1.GE.Nn) J1 = Nn
END IF
END IF
-C
+!
Ep = Ea
Costhe = Cosa
J3 = J2 + 1
Ientrp = 0
Itntrp = 1
-C
-C --------- Loop on energy points between Cosa & Cosb
+!
+! --------- Loop on energy points between Cosa & Cosb
DO Jjj=J1,J3
Jj = Jjj
-C
+!
10 CONTINUE
-C *** -------- Find Gggnew for Costhe & Ep_new
- CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone)
+! *** -------- Find Gggnew for Costhe & Ep_new
+ CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj, &
+ Ientrp, Kdatb, Nn, Idone)
CALL Getggg (Exp1, Gggnew)
-C
-C ------------ Compare Gggnew to Ggg
+!
+! ------------ Compare Gggnew to Ggg
Ag = dABS(Gggnew-Ggg)
IF (Ggg+Ag.EQ.Ggg) GO TO 30
Bg = Ag/Gggnew
Ag = Ag/Ggg
IF (Ag.LT.Big .AND. Bg.LT.Big) GO TO 30
IF (Ggg.LT.Small .AND. Gggnew.LT.Small) GO TO 30
-C
-C ------------ Additional points are needed so store this one
+!
+! ------------ Additional points are needed so store this one
Kadd = Kadd + 1
Kaddm = Kaddm + 1
IF (Kadd.GT.Maxx) then
call talk_kadd_gt_maxx(Kadd,Maxx,srcfile,interpType)
- CALL Talk (Kadd, Maxx, Em, Eb, Ea,
- * Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind,
- * Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar,
- * Nn, Iiso, 1)
+ CALL Talk (Kadd, Maxx, Em, Eb, Ea, &
+ Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind, &
+ Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar, &
+ Nn, Iiso, 1)
end if
-C
+!
IF (Lost.GT.20 .AND. Kadd.GT.20) then
- call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,
- * interpType)
- CALL Talk (Kadd, Maxx,
- * Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx,
- * Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig,
- * Niniso, Nnpar, Nn, Iiso, 2)
+ call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,interpType)
+ CALL Talk (Kadd, Maxx, &
+ Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, &
+ Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig, &
+ Niniso, Nnpar, Nn, Iiso, 2)
end if
-C
+!
Csx(Kadd) = Costhe
Epx(Kadd) = Ep
Ggx(Kadd) = Gggnew
Iex(Kadd) = Ientrp
-C
+!
20 CONTINUE
-C ------------ Figure location of next possible point
+! ------------ Figure location of next possible point
Costhe = (Cosold+Costhe)/Two
- Ep = Em*((Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2))
- * /Bbb(Iiso))**2
+ Ep = Em*( (Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2)) / Bbb(Iiso) )**2
Ientrp = 0
Itntrp = 0
GO TO 10
-C
+!
30 CONTINUE
-C ------------ This point is acceptable so add in the integral
-C ------------ from Cosold to Costhe
+! ------------ This point is acceptable so add in the integral
+! ------------ from Cosold to Costhe
W = Costhe - Cosold
Sumw = Sumw + W
-C
-C *** Add contributions from Eold (ie from Cosold)
+!
+! *** Add contributions from Eold (ie from Cosold)
IF (Jthxx.NE.1 .AND. Izero.EQ.1) THEN
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
-C
-C ------------ Now, find values of everything for new point
- call multScat%setNumThetaNearZero(
- * multScat%getNumThetaNearZero() + 1 )
+!
+! ------------ Now, find values of everything for new point
+ call multScat%setNumThetaNearZero( multScat%getNumThetaNearZero() + 1 )
Ktheta = multScat%getNumThetaNearZero() + 1
- CALL Finds_1il (A, A(Ieb), A(Icccll), A(Idddll), Ftheta,
- * A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots),
- * A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Exp1, Ep, Ggg,
- * Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth, Knthet, Nn,
- * Kdatb, Izero, Idone, Nxtptwn)
-C
+ CALL Finds_1il (A, A(Ieb), A(Icccll), A(Idddll), Ftheta, &
+ A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots), &
+ A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Exp1, Ep, Ggg, &
+ Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth, Knthet, Nn, &
+ Kdatb, Izero, Idone, Nxtptwn)
+!
IF (Jthxx.EQ.1) THEN
Jthxx = 0
GO TO 40
END IF
-C
-C *** Add contributions from Enew (ie from Costhe)
+!
+! *** Add contributions from Enew (ie from Costhe)
IF (Izero.EQ.1) THEN
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
-C
+!
Cosold = Costhe
IF (Kadd.EQ.0) GO TO 40
-C
+!
Ep = Epx(Kadd)
Costhe = Csx(Kadd)
Gggnew = Ggx(Kadd)
@@ -234,15 +234,15 @@ C
Ag = Ag/Ggg
IF (Ag.GT.Big .OR. Bg.GT.Big) GO TO 20
Kadd = Kadd - 1
- CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone)
+ CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj, &
+ Ientrp, Kdatb, Nn, Idone)
CALL Getggg (Exp1, Gggnew)
GO TO 30
-C
+!
40 CONTINUE
-C *** -------- Finished adding extra points for rapid changes in Ggg
-C
-C *** -------- Now pick next Ep & Cosp
+! *** -------- Finished adding extra points for rapid changes in Ggg
+!
+! *** -------- Now pick next Ep & Cosp
IF (Ep.NE.Em) THEN
IF (Jj.LE.J2) THEN
Ientrp = Jj
@@ -257,28 +257,27 @@ C *** -------- Now pick next Ep & Cosp
Itntrp = Itntb
END IF
END IF
-C
-C *** -------- Update cos(theta) and continue
+!
+! *** -------- Update cos(theta) and continue
Costhe = Cosp
END DO
-C *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
-C
+! *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
+!
END DO
-C *** -- Finished do-loop on Jtheta (ie on mu)
-C
+! *** -- Finished do-loop on Jtheta (ie on mu)
+!
80 CONTINUE
-C *** Finished do-loop on Jfb (ie on positive vs negative mu)
-C
- CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr,
- * Nn, I1)
+! *** Finished do-loop on Jfb (ie on positive vs negative mu)
+!
+ CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr, Nn, I1)
IF (Kwssms.EQ.1) Wssmsc(5) = Yyy1*Pi/Dthick + Wssmsc(5)
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Zero2_1 (A, Sumw, Yyy1xx, Nx)
use oops_common_m
use fixedi_m
@@ -288,36 +287,36 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION A(-Msize:Msize)
DATA Zero /0.0d0/
-C
+!
Sumw = Zero
Yyy1xx = Zero
IF (Ksolve.NE.2) THEN
CALL Zero_Array (A(Idyy1x), Nx)
END IF
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Mulsca_1iq (A, Energb, Ftheta, Totsig, Capsig, Rmass,
- * Aaa, Bbb, Csx, Epx, Ggx, Iex, Wssmsc, Em, Exp1, Yyy1, Nx, Maxx,
- * Kdatb, Iiso, Nn, Imin, Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
-C
-C *** Mulsca generates the [approximation to] the multiple-scattering
-C *** correction to the capture & fission yield
-C *** The integration over mu is performed on a grid composed of:
-C *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
-C *** (2) Values of mu corresponding to E' as in Energb grid
-C *** (3) Extra points as needed when integrand changes rapidly
-C *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
-C *** calculated earlier (in INP); these are used for edge-effects
-C *** correction to single-scattering term
-C *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
-C *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
-C *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Mulsca_1iq (A, Energb, Ftheta, Totsig, Capsig, Rmass, &
+ Aaa, Bbb, Csx, Epx, Ggx, Iex, Wssmsc, Em, Exp1, Yyy1, Nx, Maxx, &
+ Kdatb, Iiso, Nn, Imin, Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
+!
+! *** Mulsca generates the [approximation to] the multiple-scattering
+! *** correction to the capture & fission yield
+! *** The integration over mu is performed on a grid composed of:
+! *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
+! *** (2) Values of mu corresponding to E' as in Energb grid
+! *** (3) Extra points as needed when integrand changes rapidly
+! *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
+! *** calculated earlier (in INP); these are used for edge-effects
+! *** correction to single-scattering term
+! *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
+! *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
+! *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -330,14 +329,16 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use ssm_9_m
+ use ssm_11_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Backward, Forward
DIMENSION A(-Msize:Msize)
-C
- DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*),
- * Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*),
- * Wssmsc(*)
-C
+!
+ DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*), &
+ Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*), &
+ Wssmsc(*)
+!
DATA Big /1.5d0/, Small /1.0d-12/, Lost /0/
DATA Zero /0.0d0/, One /1.0d0/, Two/2.0d0/
@@ -345,17 +346,17 @@ C
character(len=80)::srcfile
interpType = "Mulsca_1iq"
srcfile = "mssm05.f"
-C
-C
+!
+!
CALL Zero2_1 (A, Sumw, Yyy1xx, Nx)
-C
-C *** Costhe (E') integration: first, find limits
-C
+!
+! *** Costhe (E') integration: first, find limits
+!
CALL Limit (Energb, E1, E2, Rmass(Iiso), I1, Nn, Imin)
-C *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
-C *** E2=E*((M-1)/(M+1))
-C *** I1=grid Number just above E1
-C
+! *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
+! *** E2=E*((M-1)/(M+1))
+! *** I1=grid Number just above E1
+!
Ggg = Zero
Gggnew = Zero
Izero = 1
@@ -365,163 +366,159 @@ C
J1 = I1
J2 = 0
Ientrp = 0
-C
-C *** find Ggg for Costhe & Eb
- CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Eb, J1+1, Ientrp,
- * Kdatb, Nn, Idone, Not_Quad)
+!
+! *** find Ggg for Costhe & Eb
+ CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Eb, J1+1, Ientrp, &
+ Kdatb, Nn, Idone, Not_Quad)
CALL Getggg (Exp1, Ggg)
-C
+!
Cosold = Cosb
Cosp = Cosb
Kadd = 0
Kaddm = 0
call multScat%setNumThetaNearZero( 0 )
-C
-C *** Do integrations from mu = -1 to mu = +1:
-C *** for Backward (E1 <E'<E1e) top
-C *** (E1e<E'<E2 ) edge
-C *** and Forward (E2 <E'<E2e) edge
-C *** (E2e<E'<Em ) bottom
-C *** (if assume beam goes from top to bottom)
+!
+! *** Do integrations from mu = -1 to mu = +1:
+! *** for Backward (E1 <E'<E1e) top
+! *** (E1e<E'<E2 ) edge
+! *** and Forward (E2 <E'<E2e) edge
+! *** (E2e<E'<Em ) bottom
+! *** (if assume beam goes from top to bottom)
DO 80 Jfbx=1,2
IF (Jfbx.EQ.1) THEN
-C Jfbx=1 => Backward (low E, high angle, Negative cosine)
+! Jfbx=1 => Backward (low E, high angle, Negative cosine)
Jfb = 2
Backward = .TRUE.
Forward = .FALSE.
ELSE
-C Jfbx=2 => Forward (high E, low angle, positive cosine)
+! Jfbx=2 => Forward (high E, low angle, positive cosine)
Jfb = 1
Backward = .FALSE.
Forward = .TRUE.
Cosb = Zero
Eb = E2
END IF
-C
+!
Jthxx = 0
-C ------ Loop over cosine(theta) (& therefore over E'=Ep)
+! ------ Loop over cosine(theta) (& therefore over E'=Ep)
DO Jthx=1,Jtheta
IF (Jthx.EQ.1) Jthxx = 1
Jth = Jthx
-C = 1 to Jtheta
+! = 1 to Jtheta
IF (Backward) Jth = Jtheta + 1 - Jthx
-C = Jtheta to 1
+! = Jtheta to 1
Cosa = Cosb
Ea = Eb
IF (Forward .AND.Jth.LT.Jtheta) Cosb = Ftheta(Jth+1)
IF (Backward.AND.Jth.GT.1 ) Cosb = - Ftheta(Jth-1)
Itntb = 1
- Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) )
- * /Bbb(Iiso) )**2
+ Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) ) / Bbb(Iiso) )**2
IF (Jth+1.EQ.Jtheta .AND. Forward) Eb = Em
-C
-C *** ----- Are there energy-points between Cosa & Cosb ?
+!
+! *** ----- Are there energy-points between Cosa & Cosb ?
CALL Pickee (Energb, Ea, Eb, J1, J2, Kdatb)
-C
+!
IF (Forward) THEN
IF (Jth+1.EQ.Jtheta) THEN
-C if (Forward & next point is last...)
+! if (Forward & next point is last...)
IF (J2.EQ.Nn) J2 = Nn - 1
ELSE IF (Jth.EQ.Jtheta) THEN
-C IF (Forward & this point is last...)
+! IF (Forward & this point is last...)
IF (J2.GE.Nn) J2 = Nn - 1
IF (J1.GE.Nn) J1 = Nn
END IF
END IF
-C
+!
Ep = Ea
Costhe = Cosa
J3 = J2 + 1
Ientrp = 0
Itntrp = 1
-C
-C --------- Loop on energy points between Cosa & Cosb
+!
+! --------- Loop on energy points between Cosa & Cosb
DO Jjj=J1,J3
Jj = Jjj
-C
+!
10 CONTINUE
-C *** -------- Find Gggnew for Costhe & Ep_new
- CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone, Not_Quad)
+! *** -------- Find Gggnew for Costhe & Ep_new
+ CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj, &
+ Ientrp, Kdatb, Nn, Idone, Not_Quad)
CALL Getggg (Exp1, Gggnew)
-C
-C ------------ Compare Gggnew to Ggg
+!
+! ------------ Compare Gggnew to Ggg
Ag = dABS(Gggnew-Ggg)
IF (Ggg+Ag.EQ.Ggg) GO TO 30
Bg = Ag/Gggnew
Ag = Ag/Ggg
IF (Ag.LT.Big .AND. Bg.LT.Big) GO TO 30
IF (Ggg.LT.Small .AND. Gggnew.LT.Small) GO TO 30
-C
-C ------------ Additional points are needed so store this one
+!
+! ------------ Additional points are needed so store this one
Kadd = Kadd + 1
Kaddm = Kaddm + 1
IF (Kadd.GT.Maxx) then
call talk_kadd_gt_maxx(Kadd,Maxx,srcfile,interpType)
- CALL Talk (Kadd, Maxx, Em, Eb, Ea,
- * Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind,
- * Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar,
- * Nn, Iiso, 1)
+ CALL Talk (Kadd, Maxx, Em, Eb, Ea, &
+ Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind, &
+ Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar, &
+ Nn, Iiso, 1)
end if
-C
+!
IF (Lost.GT.20 .AND. Kadd.GT.20) then
- call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,
- * interpType)
- CALL Talk (Kadd, Maxx,
- * Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx,
- * Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig,
- * Niniso, Nnpar, Nn, Iiso, 2)
+ call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,interpType)
+ CALL Talk (Kadd, Maxx, &
+ Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, &
+ Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig, &
+ Niniso, Nnpar, Nn, Iiso, 2)
end if
-C
+!
Csx(Kadd) = Costhe
Epx(Kadd) = Ep
Ggx(Kadd) = Gggnew
Iex(Kadd) = Ientrp
-C
+!
20 CONTINUE
-C ------------ Figure location of next possible point
+! ------------ Figure location of next possible point
Costhe = (Cosold+Costhe)/Two
- Ep = Em*((Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2))
- * /Bbb(Iiso))**2
+ Ep = Em*( (Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2)) / Bbb(Iiso) )**2
Ientrp = 0
Itntrp = 0
GO TO 10
-C
+!
30 CONTINUE
-C ------------ This point is acceptable so add in the integral
-C ------------ from Cosold to Costhe
+! ------------ This point is acceptable so add in the integral
+! ------------ from Cosold to Costhe
W = Costhe - Cosold
Sumw = Sumw + W
-C
-C *** Add contributions from Eold (ie from Cosold)
+!
+! *** Add contributions from Eold (ie from Cosold)
IF (Jthxx.NE.1 .AND. Izero.EQ.1) THEN
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
-C
-C ------------ Now, find values of everything for new point
- call multScat%setNumThetaNearZero(
- * multScat%getNumThetaNearZero() + 1 )
+!
+! ------------ Now, find values of everything for new point
+ call multScat%setNumThetaNearZero( multScat%getNumThetaNearZero() + 1 )
Ktheta = multScat%getNumThetaNearZero() + 1
- CALL Finds_1iq (A, A(Ieb), A(Icccll), A(Idddll), Ftheta,
- * A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots),
- * A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Exp1, Ep, Ggg,
- * Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth, Knthet, Nn,
- * Kdatb, Izero, Idone, Nxtptwn)
-C
+ CALL Finds_1iq (A, A(Ieb), A(Icccll), A(Idddll), Ftheta, &
+ A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots), &
+ A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Exp1, Ep, Ggg, &
+ Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth, Knthet, Nn, &
+ Kdatb, Izero, Idone, Nxtptwn)
+!
IF (Jthxx.EQ.1) THEN
Jthxx = 0
GO TO 40
END IF
-C
-C *** Add contributions from Enew (ie from Costhe)
+!
+! *** Add contributions from Enew (ie from Costhe)
IF (Izero.EQ.1) THEN
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
-C
+!
Cosold = Costhe
IF (Kadd.EQ.0) GO TO 40
-C
+!
Ep = Epx(Kadd)
Costhe = Csx(Kadd)
Gggnew = Ggx(Kadd)
@@ -533,15 +530,15 @@ C
Ag = Ag/Ggg
IF (Ag.GT.Big .OR. Bg.GT.Big) GO TO 20
Kadd = Kadd - 1
- CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone, Not_Quad)
+ CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj, &
+ Ientrp, Kdatb, Nn, Idone, Not_Quad)
CALL Getggg (Exp1, Gggnew)
GO TO 30
-C
+!
40 CONTINUE
-C *** -------- Finished adding extra points for rapid changes in Ggg
-C
-C *** -------- Now pick next Ep & Cosp
+! *** -------- Finished adding extra points for rapid changes in Ggg
+!
+! *** -------- Now pick next Ep & Cosp
IF (Ep.NE.Em) THEN
IF (Jj.LE.J2) THEN
Ientrp = Jj
@@ -556,22 +553,23 @@ C *** -------- Now pick next Ep & Cosp
Itntrp = Itntb
END IF
END IF
-C
-C *** -------- Update cos(theta) and continue
+!
+! *** -------- Update cos(theta) and continue
Costhe = Cosp
END DO
-C *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
-C
-C
+! *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
+!
+!
END DO
-C *** -- Finished do-loop on Jtheta (ie on mu)
-C
+! *** -- Finished do-loop on Jtheta (ie on mu)
+!
80 CONTINUE
-C *** Finished do-loop on Jfb (ie on positive vs negative mu)
-C
- CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr,
- * Nn, I1)
+! *** Finished do-loop on Jfb (ie on positive vs negative mu)
+!
+ CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr, Nn, I1)
IF (Kwssms.EQ.1) Wssmsc(5) = Yyy1*Pi/Dthick + Wssmsc(5)
-C
+!
RETURN
END
+
+end module ssm_5_m
diff --git a/sammy/src/ssm/mssm06.f b/sammy/src/ssm/mssm06.f90
similarity index 53%
rename from sammy/src/ssm/mssm06.f
rename to sammy/src/ssm/mssm06.f90
index dfee22677..20d64092f 100644
--- a/sammy/src/ssm/mssm06.f
+++ b/sammy/src/ssm/mssm06.f90
@@ -1,25 +1,27 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Mulsca_1fl (A, Energb, Ftheta, Totsig, Capsig, Rmass,
- * Aaa, Bbb, Csx, Epx, Ggx, Iex, Wssmsc, Em, Exp1, Yyy1, Yyy1fb,
- * Nx, Maxx, Kdatb, Iiso, Nn, Imin, Idone, Knthet, Kountr,
- * Nxtptwn, Nxtptvm)
-C
-C *** Mulsca generates the [approximation to] the multiple-scattering
-C *** correction to the capture & fission yield
-C *** The integration over mu is performed on a grid composed of:
-C *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
-C *** (2) Values of mu corresponding to E' as in Energb grid
-C *** (3) Extra points as needed when integrand changes rapidly
-C *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
-C *** calculated earlier (in INP); these are used for edge-effects
-C *** correction to single-scattering term
-C *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
-C *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
-C *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
-C
+!
+module ssm_6_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Mulsca_1fl (A, Energb, Ftheta, Totsig, Capsig, Rmass, &
+ Aaa, Bbb, Csx, Epx, Ggx, Iex, Wssmsc, Em, Exp1, Yyy1, Yyy1fb, &
+ Nx, Maxx, Kdatb, Iiso, Nn, Imin, Idone, Knthet, Kountr, &
+ Nxtptwn, Nxtptvm)
+!
+! *** Mulsca generates the [approximation to] the multiple-scattering
+! *** correction to the capture & fission yield
+! *** The integration over mu is performed on a grid composed of:
+! *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
+! *** (2) Values of mu corresponding to E' as in Energb grid
+! *** (3) Extra points as needed when integrand changes rapidly
+! *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
+! *** calculated earlier (in INP); these are used for edge-effects
+! *** correction to single-scattering term
+! *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
+! *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
+! *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -31,14 +33,18 @@ C
use ssssss_common_m
use xsect_x_common_m
use MultScatPars_common_m
+ use ssm_5_m
+ use ssm_9_m
+ use ssm_10_m
+ use ssm_11_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Backward, Forward
DIMENSION A(-Msize:Msize)
-C
- DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*),
- * Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*),
- * Wssmsc(*), Yyy1fb(*)
-C
+!
+ DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*), &
+ Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*), &
+ Wssmsc(*), Yyy1fb(*)
+!
DATA Big /1.5d0/, Small /1.0d-12/, Lost /0/
DATA Zero /0.0d0/, One /1.0d0/, Two/2.0d0/
@@ -46,37 +52,28 @@ C
character(len=80)::srcfile
interpType = "Mulsca_1fl"
srcfile = "mssm06.f"
-
- write(6,*) "-----------------------------------------------------"
- write(6,*) "Jtheta,multScat%getNumThetaNearOne() = ",Jtheta,
- *multScat%getNumThetaNearOne()
- write(6,*) "Ktheta,multScat%getNumThetaNearZero() = ",Ktheta,
- *multScat%getNumThetaNearZero()
- write(6,*) "Ntheta,multScat%getNumTheta() = ",Ntheta,
- *multScat%getNumTheta()
- write(6,*) "-----------------------------------------------------"
-C
-C
-C *** Interpolate Sqfb to give Qfb at Total(E) (if doing edge-effects
-C *** correction to single-scattering)
- CALL Trptot_Lin (A(Ixtptv), A(Isqfb), A(Iqfb), A(Idvqfb),
- * Total, Nxtptvm, Em)
+!
+!
+! *** Interpolate Sqfb to give Qfb at Total(E) (if doing edge-effects
+! *** correction to single-scattering)
+ CALL Trptot_Lin (A(Ixtptv), A(Isqfb), A_Iqfb, A(Idvqfb), &
+ Total, Nxtptvm, Em)
IF (Total.LT.multScat%getLogSigmaTotMin()) then
call multScat%setLogSigmaTotMin( Total)
end if
IF (Total.GT.multScat%getLogSigmaTotMax()) then
call multScat%setLogSigmaTotMax( Total)
end if
-C
+!
CALL Zero2_1 (A, Sumw, Yyy1xx, Nx)
-C
-C *** Costhe (E') integration: first, find limits
-C
+!
+! *** Costhe (E') integration: first, find limits
+!
CALL Limit (Energb, E1, E2, Rmass(Iiso), I1, Nn, Imin)
-C *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
-C *** E2=E*((M-1)/(M+1))
-C *** I1=grid Number just above E1
-C
+! *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
+! *** E2=E*((M-1)/(M+1))
+! *** I1=grid Number just above E1
+!
Ggg = Zero
Gggnew = Zero
Izero = 1
@@ -86,164 +83,159 @@ C
J1 = I1
J2 = 0
Ientrp = 0
-C
-C *** find Ggg for Costhe & Eb
- CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Eb, J1+1, Ientrp,
- * Kdatb, Nn, Idone)
+!
+! *** find Ggg for Costhe & Eb
+ CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Eb, J1+1, Ientrp, Kdatb, Nn, Idone)
CALL Getggg (Exp1, Ggg)
-C
+!
Cosold = Cosb
Cosp = Cosb
Kadd = 0
Kaddm = 0
call multScat%setNumThetaNearZero( 0 )
-C
-C *** Do integrations from mu = -1 to mu = +1:
-C *** for Backward (E1 <E'<E1e) top
-C *** (E1e<E'<E2 ) edge
-C *** and Forward (E2 <E'<E2e) edge
-C *** (E2e<E'<Em ) bottom
-C *** (if assume beam goes from top to bottom)
+!
+! *** Do integrations from mu = -1 to mu = +1:
+! *** for Backward (E1 <E'<E1e) top
+! *** (E1e<E'<E2 ) edge
+! *** and Forward (E2 <E'<E2e) edge
+! *** (E2e<E'<Em ) bottom
+! *** (if assume beam goes from top to bottom)
DO 80 Jfbx=1,2
IF (Jfbx.EQ.1) THEN
-C Jfbx=1 => Backward (low E, high angle, Negative cosine)
+! Jfbx=1 => Backward (low E, high angle, Negative cosine)
Jfb = 2
Backward = .TRUE.
Forward = .FALSE.
ELSE
-C Jfbx=2 => Forward (high E, low angle, positive cosine)
+! Jfbx=2 => Forward (high E, low angle, positive cosine)
Jfb = 1
Backward = .FALSE.
Forward = .TRUE.
Cosb = Zero
Eb = E2
END IF
-C
+!
Jthxx = 0
-C ------ Loop over cosine(theta) (& therefore over E'=Ep)
+! ------ Loop over cosine(theta) (& therefore over E'=Ep)
DO Jthx=1,Jtheta
IF (Jthx.EQ.1) Jthxx = 1
Jth = Jthx
-C = 1 to Jtheta
+! = 1 to Jtheta
IF (Backward) Jth = Jtheta + 1 - Jthx
-C = Jtheta to 1
+! = Jtheta to 1
Cosa = Cosb
Ea = Eb
IF (Forward .AND.Jth.LT.Jtheta) Cosb = Ftheta(Jth+1)
IF (Backward.AND.Jth.GT.1 ) Cosb = - Ftheta(Jth-1)
Itntb = 1
- Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) )
- * /Bbb(Iiso) )**2
+ Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) ) / Bbb(Iiso) )**2
IF (Jth+1.EQ.Jtheta .AND. Forward) Eb = Em
-C
-C *** ----- Are there energy-points between Cosa & Cosb ?
+!
+! *** ----- Are there energy-points between Cosa & Cosb ?
CALL Pickee (Energb, Ea, Eb, J1, J2, Kdatb)
-C
+!
IF (Forward) THEN
IF (Jth+1.EQ.Jtheta) THEN
-C if (Forward & next point is last...)
+! if (Forward & next point is last...)
IF (J2.EQ.Nn) J2 = Nn - 1
ELSE IF (Jth.EQ.Jtheta) THEN
-C IF (Forward & this point is last...)
+! IF (Forward & this point is last...)
IF (J2.GE.Nn) J2 = Nn - 1
IF (J1.GE.Nn) J1 = Nn
END IF
END IF
-C
+!
Ep = Ea
Costhe = Cosa
J3 = J2 + 1
Ientrp = 0
Itntrp = 1
-C
-C --------- Loop on energy points between Cosa & Cosb
+!
+! --------- Loop on energy points between Cosa & Cosb
DO Jjj=J1,J3
Jj = Jjj
-C
+!
10 CONTINUE
-C *** -------- Find Gggnew for Costhe & Ep_new
- CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone)
+! *** -------- Find Gggnew for Costhe & Ep_new
+ CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj, &
+ Ientrp, Kdatb, Nn, Idone)
CALL Getggg (Exp1, Gggnew)
-C
-C ------------ Compare Gggnew to Ggg
+!
+! ------------ Compare Gggnew to Ggg
Ag = dABS(Gggnew-Ggg)
IF (Ggg+Ag.EQ.Ggg) GO TO 30
Bg = Ag/Gggnew
Ag = Ag/Ggg
IF (Ag.LT.Big .AND. Bg.LT.Big) GO TO 30
IF (Ggg.LT.Small .AND. Gggnew.LT.Small) GO TO 30
-C
-C ------------ Additional points are needed so store this one
+!
+! ------------ Additional points are needed so store this one
Kadd = Kadd + 1
Kaddm = Kaddm + 1
IF (Kadd.GT.Maxx) then
call talk_kadd_gt_maxx(Kadd,Maxx,srcfile,interpType)
- CALL Talk (Kadd, Maxx, Em, Eb, Ea,
- * Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind,
- * Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar,
- * Nn, Iiso, 1)
+ CALL Talk (Kadd, Maxx, Em, Eb, Ea, &
+ Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind, &
+ Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar, &
+ Nn, Iiso, 1)
end if
-C
+!
IF (Lost.GT.20 .AND. Kadd.GT.20) then
- call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,
- * interpType)
- CALL Talk (Kadd, Maxx,
- * Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx,
- * Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig,
- * Niniso, Nnpar, Nn, Iiso, 2)
+ call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,interpType)
+ CALL Talk (Kadd, Maxx, &
+ Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, &
+ Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig, &
+ Niniso, Nnpar, Nn, Iiso, 2)
end if
-C
+!
Csx(Kadd) = Costhe
Epx(Kadd) = Ep
Ggx(Kadd) = Gggnew
Iex(Kadd) = Ientrp
-C
+!
20 CONTINUE
-C ------------ Figure location of next possible point
+! ------------ Figure location of next possible point
Costhe = (Cosold+Costhe)/Two
- Ep = Em*((Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2))
- * /Bbb(Iiso))**2
+ Ep = Em*( (Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2)) / Bbb(Iiso) )**2
Ientrp = 0
Itntrp = 0
GO TO 10
-C
+!
30 CONTINUE
-C ------------ This point is acceptable so add in the integral
-C ------------ from Cosold to Costhe
+! ------------ This point is acceptable so add in the integral
+! ------------ from Cosold to Costhe
W = Costhe - Cosold
Sumw = Sumw + W
-C
-C *** Add contributions from Eold (ie from Cosold)
+!
+! *** Add contributions from Eold (ie from Cosold)
IF (Jthxx.NE.1 .AND. Izero.EQ.1) THEN
Yyy1fb(Jfb) = Yyy1fb(Jfb) -Yyy1zz*W
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
-C
-C ------------ Now, find values of everything for new point
- call multScat%setNumThetaNearZero(
- * multScat%getNumThetaNearZero() + 1 )
+!
+! ------------ Now, find values of everything for new point
+ call multScat%setNumThetaNearZero( multScat%getNumThetaNearZero() + 1 )
- CALL Finds_1fl (A, A(Ieb), A(Icccll), A(Idddll), Ftheta,
- * A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots),
- * A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Yyy1zz,
- * Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp,
- * Jfb, Jth, Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
-C
+ CALL Finds_1fl (A, A(Ieb), A(Icccll), A(Idddll), Ftheta, &
+ A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots), &
+ A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Yyy1zz, &
+ Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp, &
+ Jfb, Jth, Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
+!
IF (Jthxx.EQ.1) THEN
Jthxx = 0
GO TO 40
END IF
-C
-C *** Add contributions from Enew (ie from Costhe)
+!
+! *** Add contributions from Enew (ie from Costhe)
IF (Izero.EQ.1) THEN
Yyy1fb(Jfb) = Yyy1fb(Jfb) -Yyy1zz*W
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
-C
+!
Cosold = Costhe
IF (Kadd.EQ.0) GO TO 40
-C
+!
Ep = Epx(Kadd)
Costhe = Csx(Kadd)
Gggnew = Ggx(Kadd)
@@ -255,15 +247,15 @@ C
Ag = Ag/Ggg
IF (Ag.GT.Big .OR. Bg.GT.Big) GO TO 20
Kadd = Kadd - 1
- CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone)
+ CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj, &
+ Ientrp, Kdatb, Nn, Idone)
CALL Getggg (Exp1, Gggnew)
GO TO 30
-C
+!
40 CONTINUE
-C *** -------- Finished adding extra points for rapid changes in Ggg
-C
-C *** -------- Now pick next Ep & Cosp
+! *** -------- Finished adding extra points for rapid changes in Ggg
+!
+! *** -------- Now pick next Ep & Cosp
IF (Ep.NE.Em) THEN
IF (Jj.LE.J2) THEN
Ientrp = Jj
@@ -278,47 +270,46 @@ C *** -------- Now pick next Ep & Cosp
Itntrp = Itntb
END IF
END IF
-C
-C *** -------- Update cos(theta) and continue
+!
+! *** -------- Update cos(theta) and continue
Costhe = Cosp
END DO
-C *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
-C
-C
+! *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
+!
+!
END DO
-C *** -- Finished do-loop on Jtheta (ie on mu)
-C
+! *** -- Finished do-loop on Jtheta (ie on mu)
+!
80 CONTINUE
-C *** Finished do-loop on Jfb (ie on positive vs negative mu)
-C
- CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr,
- * Nn, I1)
+! *** Finished do-loop on Jfb (ie on positive vs negative mu)
+!
+ CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr, Nn, I1)
CALL W_Wssmsc (Yyy1, Dthick, Total, Wssmsc, Yyy1fb, Kwssms)
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Mulsca_1fq (A, Energb, Ftheta, Totsig, Capsig, Rmass,
- * Aaa, Bbb, Csx, Epx, Ggx, Iex, Wssmsc, Em, Exp1, Yyy1, Yyy1fb,
- * Nx, Maxx, Kdatb, Iiso, Nn, Imin, Idone, Knthet, Kountr,
- * Nxtptwn, Nxtptvm)
-C
-C *** Mulsca generates the [approximation to] the multiple-scattering
-C *** correction to the capture & fission yield
-C *** The integration over mu is performed on a grid composed of:
-C *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
-C *** (2) Values of mu corresponding to E' as in Energb grid
-C *** (3) Extra points as needed when integrand changes rapidly
-C *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
-C *** calculated earlier (in INP); these are used for edge-effects
-C *** correction to single-scattering term
-C *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
-C *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
-C *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Mulsca_1fq (A, Energb, Ftheta, Totsig, Capsig, Rmass, &
+ Aaa, Bbb, Csx, Epx, Ggx, Iex, Wssmsc, Em, Exp1, Yyy1, Yyy1fb, &
+ Nx, Maxx, Kdatb, Iiso, Nn, Imin, Idone, Knthet, Kountr, &
+ Nxtptwn, Nxtptvm)
+!
+! *** Mulsca generates the [approximation to] the multiple-scattering
+! *** correction to the capture & fission yield
+! *** The integration over mu is performed on a grid composed of:
+! *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
+! *** (2) Values of mu corresponding to E' as in Energb grid
+! *** (3) Extra points as needed when integrand changes rapidly
+! *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
+! *** calculated earlier (in INP); these are used for edge-effects
+! *** correction to single-scattering term
+! *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
+! *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
+! *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -330,14 +321,18 @@ C
use ssssss_common_m
use xsect_x_common_m
use MultScatPars_common_m
+ use ssm_5_m
+ use ssm_9_m
+ use ssm_10_m
+ use ssm_11_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Backward, Forward
DIMENSION A(-Msize:Msize)
-C
- DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*),
- * Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*),
- * Wssmsc(*), Yyy1fb(*)
-C
+!
+ DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*), &
+ Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*), &
+ Wssmsc(*), Yyy1fb(*)
+!
DATA Big /1.5d0/, Small /1.0d-12/, Lost /0/
DATA Zero /0.0d0/, One /1.0d0/, Two/2.0d0/
@@ -345,28 +340,28 @@ C
character(len=80)::srcfile
interpType = "Mulsca_1fq"
srcfile = "mssm06.f"
-C
-C
-C *** Interpolate Sqfb to give Qfb at Total(E) (if doing edge-effects
-C *** correction to single-scattering)
- CALL Trptot_Quad (A(Ixtptv), A(Isqfb), A(Iqfb), A(Idvqfb),
- * Total, Nxtptvm, Em)
+!
+!
+! *** Interpolate Sqfb to give Qfb at Total(E) (if doing edge-effects
+! *** correction to single-scattering)
+ CALL Trptot_Quad (A(Ixtptv), A(Isqfb), A_Iqfb, A(Idvqfb), &
+ Total, Nxtptvm, Em)
IF (Total.LT.multScat%getLogSigmaTotMin()) then
call multScat%setLogSigmaTotMin( Total)
end if
IF (Total.GT.multScat%getLogSigmaTotMax()) then
call multScat%setLogSigmaTotMax( Total)
end if
-C
+!
CALL Zero2_1 (A, Sumw, Yyy1xx, Nx)
-C
-C *** Costhe (E') integration: first, find limits
-C
+!
+! *** Costhe (E') integration: first, find limits
+!
CALL Limit (Energb, E1, E2, Rmass(Iiso), I1, Nn, Imin)
-C *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
-C *** E2=E*((M-1)/(M+1))
-C *** I1=grid Number just above E1
-C
+! *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
+! *** E2=E*((M-1)/(M+1))
+! *** I1=grid Number just above E1
+!
Ggg = Zero
Gggnew = Zero
Izero = 1
@@ -376,163 +371,159 @@ C
J1 = I1
J2 = 0
Ientrp = 0
-C
-C *** find Ggg for Costhe & Eb
- CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Eb, J1+1, Ientrp,
- * Kdatb, Nn, Idone, Not_Quad)
+!
+! *** find Ggg for Costhe & Eb
+ CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Eb, J1+1, Ientrp, &
+ Kdatb, Nn, Idone, Not_Quad)
CALL Getggg (Exp1, Ggg)
-C
+!
Cosold = Cosb
Cosp = Cosb
Kadd = 0
Kaddm = 0
call multScat%setNumThetaNearZero( 0 )
-C
-C *** Do integrations from mu = -1 to mu = +1:
-C *** for Backward (E1 <E'<E1e) top
-C *** (E1e<E'<E2 ) edge
-C *** and Forward (E2 <E'<E2e) edge
-C *** (E2e<E'<Em ) bottom
-C *** (if assume beam goes from top to bottom)
+!
+! *** Do integrations from mu = -1 to mu = +1:
+! *** for Backward (E1 <E'<E1e) top
+! *** (E1e<E'<E2 ) edge
+! *** and Forward (E2 <E'<E2e) edge
+! *** (E2e<E'<Em ) bottom
+! *** (if assume beam goes from top to bottom)
DO 80 Jfbx=1,2
IF (Jfbx.EQ.1) THEN
-C Jfbx=1 => Backward (low E, high angle, Negative cosine)
+! Jfbx=1 => Backward (low E, high angle, Negative cosine)
Jfb = 2
Backward = .TRUE.
Forward = .FALSE.
ELSE
-C Jfbx=2 => Forward (high E, low angle, positive cosine)
+! Jfbx=2 => Forward (high E, low angle, positive cosine)
Jfb = 1
Backward = .FALSE.
Forward = .TRUE.
Cosb = Zero
Eb = E2
END IF
-C
+!
Jthxx = 0
-C ------ Loop over cosine(theta) (& therefore over E'=Ep)
+! ------ Loop over cosine(theta) (& therefore over E'=Ep)
DO Jthx=1,Jtheta
IF (Jthx.EQ.1) Jthxx = 1
Jth = Jthx
-C = 1 to Jtheta
+! = 1 to Jtheta
IF (Backward) Jth = Jtheta + 1 - Jthx
-C = Jtheta to 1
+! = Jtheta to 1
Cosa = Cosb
Ea = Eb
IF (Forward .AND.Jth.LT.Jtheta) Cosb = Ftheta(Jth+1)
IF (Backward.AND.Jth.GT.1 ) Cosb = - Ftheta(Jth-1)
Itntb = 1
- Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) )
- * /Bbb(Iiso) )**2
+ Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) ) / Bbb(Iiso) )**2
IF (Jth+1.EQ.Jtheta .AND. Forward) Eb = Em
-C
-C *** ----- Are there energy-points between Cosa & Cosb ?
+!
+! *** ----- Are there energy-points between Cosa & Cosb ?
CALL Pickee (Energb, Ea, Eb, J1, J2, Kdatb)
-C
+!
IF (Forward) THEN
IF (Jth+1.EQ.Jtheta) THEN
-C if (Forward & next point is last...)
+! if (Forward & next point is last...)
IF (J2.EQ.Nn) J2 = Nn - 1
ELSE IF (Jth.EQ.Jtheta) THEN
-C IF (Forward & this point is last...)
+! IF (Forward & this point is last...)
IF (J2.GE.Nn) J2 = Nn - 1
IF (J1.GE.Nn) J1 = Nn
END IF
END IF
-C
+!
Ep = Ea
Costhe = Cosa
J3 = J2 + 1
Ientrp = 0
Itntrp = 1
-C
-C --------- Loop on energy points between Cosa & Cosb
+!
+! --------- Loop on energy points between Cosa & Cosb
DO Jjj=J1,J3
Jj = Jjj
-C
+!
10 CONTINUE
-C *** -------- Find Gggnew for Costhe & Ep_new
- CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone, Not_Quad)
+! *** -------- Find Gggnew for Costhe & Ep_new
+ CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj, &
+ Ientrp, Kdatb, Nn, Idone, Not_Quad)
CALL Getggg (Exp1, Gggnew)
-C
-C ------------ Compare Gggnew to Ggg
+!
+! ------------ Compare Gggnew to Ggg
Ag = dABS(Gggnew-Ggg)
IF (Ggg+Ag.EQ.Ggg) GO TO 30
Bg = Ag/Gggnew
Ag = Ag/Ggg
IF (Ag.LT.Big .AND. Bg.LT.Big) GO TO 30
IF (Ggg.LT.Small .AND. Gggnew.LT.Small) GO TO 30
-C
-C ------------ Additional points are needed so store this one
+!
+! ------------ Additional points are needed so store this one
Kadd = Kadd + 1
Kaddm = Kaddm + 1
IF (Kadd.GT.Maxx) then
call talk_kadd_gt_maxx(Kadd,Maxx,srcfile,interpType)
- CALL Talk (Kadd, Maxx, Em, Eb, Ea,
- * Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind,
- * Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar,
- * Nn, Iiso, 1)
+ CALL Talk (Kadd, Maxx, Em, Eb, Ea, &
+ Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind, &
+ Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar, &
+ Nn, Iiso, 1)
end if
-C
+!
IF (Lost.GT.20 .AND. Kadd.GT.20) then
- call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,
- * interpType)
- CALL Talk (Kadd, Maxx,
- * Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx,
- * Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig,
- * Niniso, Nnpar, Nn, Iiso, 2)
+ call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,interpType)
+ CALL Talk (Kadd, Maxx, &
+ Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, &
+ Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig, &
+ Niniso, Nnpar, Nn, Iiso, 2)
end if
-C
+!
Csx(Kadd) = Costhe
Epx(Kadd) = Ep
Ggx(Kadd) = Gggnew
Iex(Kadd) = Ientrp
-C
+!
20 CONTINUE
-C ------------ Figure location of next possible point
+! ------------ Figure location of next possible point
Costhe = (Cosold+Costhe)/Two
- Ep = Em*((Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2))
- * /Bbb(Iiso))**2
+ Ep = Em*( (Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2)) / Bbb(Iiso) )**2
Ientrp = 0
Itntrp = 0
GO TO 10
-C
+!
30 CONTINUE
-C ------------ This point is acceptable so add in the integral
-C ------------ from Cosold to Costhe
+! ------------ This point is acceptable so add in the integral
+! ------------ from Cosold to Costhe
W = Costhe - Cosold
Sumw = Sumw + W
-C
-C *** Add contributions from Eold (ie from Cosold)
+!
+! *** Add contributions from Eold (ie from Cosold)
IF (Jthxx.NE.1 .AND. Izero.EQ.1) THEN
Yyy1fb(Jfb) = Yyy1fb(Jfb) -Yyy1zz*W
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
-C
-C ------------ Now, find values of everything for new point
- call multScat%setNumThetaNearZero(
- * multScat%getNumThetaNearZero() + 1 )
- CALL Finds_1fq (A, A(Ieb), A(Icccll), A(Idddll), Ftheta,
- * A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots),
- * A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Yyy1zz,
- * Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp,
- * Jfb, Jth, Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
-C
+!
+! ------------ Now, find values of everything for new point
+ call multScat%setNumThetaNearZero( multScat%getNumThetaNearZero() + 1 )
+ CALL Finds_1fq (A, A(Ieb), A(Icccll), A(Idddll), Ftheta, &
+ A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots), &
+ A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Yyy1zz, &
+ Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp, &
+ Jfb, Jth, Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
+!
IF (Jthxx.EQ.1) THEN
Jthxx = 0
GO TO 40
END IF
-C
-C *** Add contributions from Enew (ie from Costhe)
+!
+! *** Add contributions from Enew (ie from Costhe)
IF (Izero.EQ.1) THEN
Yyy1fb(Jfb) = Yyy1fb(Jfb) -Yyy1zz*W
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
-C
+!
Cosold = Costhe
IF (Kadd.EQ.0) GO TO 40
-C
+!
Ep = Epx(Kadd)
Costhe = Csx(Kadd)
Gggnew = Ggx(Kadd)
@@ -544,15 +535,15 @@ C
Ag = Ag/Ggg
IF (Ag.GT.Big .OR. Bg.GT.Big) GO TO 20
Kadd = Kadd - 1
- CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone, Not_Quad)
+ CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj, &
+ Ientrp, Kdatb, Nn, Idone, Not_Quad)
CALL Getggg (Exp1, Gggnew)
GO TO 30
-C
+!
40 CONTINUE
-C *** -------- Finished adding extra points for rapid changes in Ggg
-C
-C *** -------- Now pick next Ep & Cosp
+! *** -------- Finished adding extra points for rapid changes in Ggg
+!
+! *** -------- Now pick next Ep & Cosp
IF (Ep.NE.Em) THEN
IF (Jj.LE.J2) THEN
Ientrp = Jj
@@ -567,22 +558,23 @@ C *** -------- Now pick next Ep & Cosp
Itntrp = Itntb
END IF
END IF
-C
-C *** -------- Update cos(theta) and continue
+!
+! *** -------- Update cos(theta) and continue
Costhe = Cosp
END DO
-C *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
-C
-C
+! *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
+!
+!
END DO
-C *** -- Finished do-loop on Jtheta (ie on mu)
-C
+! *** -- Finished do-loop on Jtheta (ie on mu)
+!
80 CONTINUE
-C *** Finished do-loop on Jfb (ie on positive vs negative mu)
-C
- CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr,
- * Nn, I1)
+! *** Finished do-loop on Jfb (ie on positive vs negative mu)
+!
+ CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr, Nn, I1)
CALL W_Wssmsc (Yyy1, Dthick, Total, Wssmsc, Yyy1fb, Kwssms)
-C
+!
RETURN
END
+
+end module ssm_6_m
diff --git a/sammy/src/ssm/mssm07.f b/sammy/src/ssm/mssm07.f90
similarity index 52%
rename from sammy/src/ssm/mssm07.f
rename to sammy/src/ssm/mssm07.f90
index 4fe73baf8..02824638e 100644
--- a/sammy/src/ssm/mssm07.f
+++ b/sammy/src/ssm/mssm07.f90
@@ -1,25 +1,27 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Mulsca_2il (A, Energb, Ftheta, Totsig, Capsig, Rmass,
- * Aaa, Bbb, Csx, Epx, Ggx, Iex, Y2cccc, Dy2ccc, Wssmsc, Em,
- * Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx, Maxx, Kdatb,
- * Iiso, Nn, Imin, Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
-C
-C *** Mulsca generates the [approximation to] the multiple-scattering
-C *** correction to the capture & fission yield
-C *** The integration over mu is performed on a grid composed of:
-C *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
-C *** (2) Values of mu corresponding to E' as in Energb grid
-C *** (3) Extra points as needed when integrand changes rapidly
-C *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
-C *** calculated earlier (in INP); these are used for edge-effects
-C *** correction to single-scattering term
-C *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
-C *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
-C *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
-C
+!
+module ssm_7_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Mulsca_2il (A, Energb, Ftheta, Totsig, Capsig, Rmass, &
+ Aaa, Bbb, Csx, Epx, Ggx, Iex, Y2cccc, Dy2ccc, Wssmsc, Em, &
+ Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx, Maxx, Kdatb, &
+ Iiso, Nn, Imin, Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
+!
+! *** Mulsca generates the [approximation to] the multiple-scattering
+! *** correction to the capture & fission yield
+! *** The integration over mu is performed on a grid composed of:
+! *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
+! *** (2) Values of mu corresponding to E' as in Energb grid
+! *** (3) Extra points as needed when integrand changes rapidly
+! *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
+! *** calculated earlier (in INP); these are used for edge-effects
+! *** correction to single-scattering term
+! *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
+! *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
+! *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -32,14 +34,17 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use ssm_9_m
+ use ssm_11_m
+ use ssm_18_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Backward, Forward
DIMENSION A(-Msize:Msize)
-C
- DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*),
- * Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*),
- * Y2cccc(*), Dy2ccc(Nx,*), Wssmsc(*)
-C
+!
+ DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*), &
+ Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*), &
+ Y2cccc(*), Dy2ccc(Nx,*), Wssmsc(*)
+!
DATA Big /1.5d0/, Small /1.0d-12/, Lost /0/
DATA Zero /0.0d0/, One /1.0d0/, Two/2.0d0/
@@ -47,17 +52,17 @@ C
character(len=80)::srcfile
interpType = "Mulsca_2il"
srcfile = "mssm07.f"
-C
-C
+!
+!
CALL Zero2_2 (A, Sumw, Yyy1xx, Yyy2xx, Yyy2xq, Y2aaaa, Y2aaaq, Nx)
-C
-C *** Costhe (E') integration: first, find limits
-C
+!
+! *** Costhe (E') integration: first, find limits
+!
CALL Limit (Energb, E1, E2, Rmass(Iiso), I1, Nn, Imin)
-C *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
-C *** E2=E*((M-1)/(M+1))
-C *** I1=grid Number just above E1
-C
+! *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
+! *** E2=E*((M-1)/(M+1))
+! *** I1=grid Number just above E1
+!
Ggg = Zero
Gggnew = Zero
Izero = 1
@@ -67,187 +72,181 @@ C
J1 = I1
J2 = 0
Ientrp = 0
-C
-C *** find Ggg for Costhe & Eb
+!
+! *** find Ggg for Costhe & Eb
IF (Idone.NE.3) THEN
- CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Eb, J1+1, Ientrp,
- * Kdatb, Nn, Idone)
+ CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Eb, J1+1, Ientrp, Kdatb, Nn, Idone)
CALL Getggg (Exp1, Ggg)
END IF
-C
+!
Cosold = Cosb
Cosp = Cosb
Kadd = 0
Kaddm = 0
call multScat%setNumThetaNearZero( 0 )
-C
-C *** Do integrations from mu = -1 to mu = +1:
-C *** for Backward (E1 <E'<E1e) top
-C *** (E1e<E'<E2 ) edge
-C *** and Forward (E2 <E'<E2e) edge
-C *** (E2e<E'<Em ) bottom
-C *** (if assume beam goes from top to bottom)
+!
+! *** Do integrations from mu = -1 to mu = +1:
+! *** for Backward (E1 <E'<E1e) top
+! *** (E1e<E'<E2 ) edge
+! *** and Forward (E2 <E'<E2e) edge
+! *** (E2e<E'<Em ) bottom
+! *** (if assume beam goes from top to bottom)
DO 80 Jfbx=1,2
IF (Jfbx.EQ.1) THEN
-C Jfbx=1 => Backward (low E, high angle, Negative cosine)
+! Jfbx=1 => Backward (low E, high angle, Negative cosine)
Jfb = 2
Backward = .TRUE.
Forward = .FALSE.
ELSE
-C Jfbx=2 => Forward (high E, low angle, positive cosine)
+! Jfbx=2 => Forward (high E, low angle, positive cosine)
Jfb = 1
Backward = .FALSE.
Forward = .TRUE.
Cosb = Zero
Eb = E2
END IF
-C
+!
Jthxx = 0
-C ------ Loop over cosine(theta) (& therefore over E'=Ep)
+! ------ Loop over cosine(theta) (& therefore over E'=Ep)
DO Jthx=1,Jtheta
IF (Jthx.EQ.1) Jthxx = 1
Jth = Jthx
-C = 1 to Jtheta
+! = 1 to Jtheta
IF (Backward) Jth = Jtheta + 1 - Jthx
-C = Jtheta to 1
+! = Jtheta to 1
Cosa = Cosb
Ea = Eb
IF (Forward .AND.Jth.LT.Jtheta) Cosb = Ftheta(Jth+1)
IF (Backward.AND.Jth.GT.1 ) Cosb = - Ftheta(Jth-1)
Itntb = 1
- Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) )
- * /Bbb(Iiso) )**2
+ Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) ) / Bbb(Iiso) )**2
IF (Jth+1.EQ.Jtheta .AND. Forward) Eb = Em
-C
-C *** ----- Are there energy-points between Cosa & Cosb ?
+!
+! *** ----- Are there energy-points between Cosa & Cosb ?
CALL Pickee (Energb, Ea, Eb, J1, J2, Kdatb)
-C
+!
IF (Forward) THEN
IF (Jth+1.EQ.Jtheta) THEN
-C if (Forward & next point is last...)
+! if (Forward & next point is last...)
IF (J2.EQ.Nn) J2 = Nn - 1
ELSE IF (Jth.EQ.Jtheta) THEN
-C IF (Forward & this point is last...)
+! IF (Forward & this point is last...)
IF (J2.GE.Nn) J2 = Nn - 1
IF (J1.GE.Nn) J1 = Nn
END IF
END IF
-C
+!
Ep = Ea
Costhe = Cosa
J3 = J2 + 1
Ientrp = 0
Itntrp = 1
-C
-C --------- Loop on energy points between Cosa & Cosb
+!
+! --------- Loop on energy points between Cosa & Cosb
DO Jjj=J1,J3
Jj = Jjj
-C
+!
10 CONTINUE
-C *** -------- Find Gggnew for Costhe & Ep_new
- CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone)
+! *** -------- Find Gggnew for Costhe & Ep_new
+ CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj, Ientrp, Kdatb, Nn, Idone)
CALL Getggg (Exp1, Gggnew)
-C
+!
IF (Idone.EQ.3) GO TO 30
-C
-C ------------ Compare Gggnew to Ggg
+!
+! ------------ Compare Gggnew to Ggg
Ag = dABS(Gggnew-Ggg)
IF (Ggg+Ag.EQ.Ggg) GO TO 30
Bg = Ag/Gggnew
Ag = Ag/Ggg
IF (Ag.LT.Big .AND. Bg.LT.Big) GO TO 30
IF (Ggg.LT.Small .AND. Gggnew.LT.Small) GO TO 30
-C
-C ------------ Additional points are needed so store this one
+!
+! ------------ Additional points are needed so store this one
Kadd = Kadd + 1
Kaddm = Kaddm + 1
IF (Kadd.GT.Maxx) then
call talk_kadd_gt_maxx(Kadd,Maxx,srcfile,interpType)
- CALL Talk (Kadd, Maxx, Em, Eb, Ea,
- * Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind,
- * Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar,
- * Nn, Iiso, 1)
+ CALL Talk (Kadd, Maxx, Em, Eb, Ea, &
+ Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind, &
+ Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar, &
+ Nn, Iiso, 1)
end if
-C
+!
IF (Lost.GT.20 .AND. Kadd.GT.20) then
- call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,
- * interpType)
- CALL Talk (Kadd, Maxx,
- * Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx,
- * Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig,
- * Niniso, Nnpar, Nn, Iiso, 2)
+ call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,interpType)
+ CALL Talk (Kadd, Maxx, &
+ Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, &
+ Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig, &
+ Niniso, Nnpar, Nn, Iiso, 2)
end if
-C
+!
Csx(Kadd) = Costhe
Epx(Kadd) = Ep
Ggx(Kadd) = Gggnew
Iex(Kadd) = Ientrp
-C
+!
20 CONTINUE
-C ------------ Figure location of next possible point
+! ------------ Figure location of next possible point
Costhe = (Cosold+Costhe)/Two
- Ep = Em*((Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2))
- * /Bbb(Iiso))**2
+ Ep = Em*( (Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2) ) / Bbb(Iiso) )**2
Ientrp = 0
Itntrp = 0
GO TO 10
-C
+!
30 CONTINUE
-C ------------ This point is acceptable so add in the integral
-C ------------ from Cosold to Costhe
+! ------------ This point is acceptable so add in the integral
+! ------------ from Cosold to Costhe
W = Costhe - Cosold
Sumw = Sumw + W
-C
-C *** Add contributions from Eold (ie from Cosold)
+!
+! *** Add contributions from Eold (ie from Cosold)
IF (Jthxx.NE.1 .AND. Izero.EQ.1) THEN
IF (Idone.NE.3) THEN
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
- CALL Ssum_2 ( A(Idyyy2), A(Idyy2q), A(Idy2qq),
- * A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb),
- * A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq),
- * A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq,
- * Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
+ CALL Ssum_2 ( A(Idyyy2), A(Idyy2q), A(Idy2qq), &
+ A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb), &
+ A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq), &
+ A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq, &
+ Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
END IF
-C
-C ------------ Now, find values of everything for new point
- call multScat%setNumThetaNearZero(
- * multScat%getNumThetaNearZero() + 1 )
+!
+! ------------ Now, find values of everything for new point
+ call multScat%setNumThetaNearZero( multScat%getNumThetaNearZero() + 1 )
- CALL Finds_1il (A, A(Ieb), A(Icccll), A(Idddll), Ftheta,
- * A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots),
- * A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Exp1, Ep, Ggg,
- * Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth, Knthet, Nn,
- * Kdatb, Izero, Idone, Nxtptwn)
- CALL Finds_2 (A(Ieb), A(Idelas), A(Idt), A(Idc),
- * A(Idtots), A(Idyy2x), A(Idy2xq), A(Idyxqq),
- * A(Idy2dd), A(Idy2dq), Y2cccc, Dy2ccc, A(Idy2aa),
- * A(Idy2aq), A(Idyaqq), Yyy2xx, Yyy2xq, Y2aaaa,
- * Y2aaaq, Ep, Ggg, Nx, Ientrp, Nn, Izero, Idone,
- * Not_Quad)
-C
+ CALL Finds_1il (A, A(Ieb), A(Icccll), A(Idddll), Ftheta, &
+ A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots), &
+ A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Exp1, Ep, Ggg, &
+ Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth, Knthet, Nn, &
+ Kdatb, Izero, Idone, Nxtptwn)
+ CALL Finds_2 (A(Ieb), A(Idelas), A(Idt), A(Idc), &
+ A(Idtots), A(Idyy2x), A(Idy2xq), A(Idyxqq), &
+ A(Idy2dd), A(Idy2dq), Y2cccc, Dy2ccc, A(Idy2aa), &
+ A(Idy2aq), A(Idyaqq), Yyy2xx, Yyy2xq, Y2aaaa, &
+ Y2aaaq, Ep, Ggg, Nx, Ientrp, Nn, Izero, Idone, &
+ Not_Quad)
+!
IF (Jthxx.EQ.1) THEN
Jthxx = 0
GO TO 40
END IF
-C
-C *** Add contributions from Enew (ie from Costhe)
+!
+! *** Add contributions from Enew (ie from Costhe)
IF (Izero.EQ.1) THEN
IF (Idone.NE.3) THEN
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
- CALL Ssum_2 (A(Idyyy2), A(Idyy2q), A(Idy2qq),
- * A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb),
- * A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq),
- * A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq,
- * Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
+ CALL Ssum_2 (A(Idyyy2), A(Idyy2q), A(Idy2qq), &
+ A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb), &
+ A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq), &
+ A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq, &
+ Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
END IF
-C
+!
Cosold = Costhe
IF (Idone.EQ.3) GO TO 40
IF (Kadd.EQ.0) GO TO 40
-C
+!
Ep = Epx(Kadd)
Costhe = Csx(Kadd)
Gggnew = Ggx(Kadd)
@@ -259,15 +258,15 @@ C
Ag = Ag/Ggg
IF (Ag.GT.Big .OR. Bg.GT.Big) GO TO 20
Kadd = Kadd - 1
- CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone)
+ CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj, &
+ Ientrp, Kdatb, Nn, Idone)
CALL Getggg (Exp1, Gggnew)
GO TO 30
-C
+!
40 CONTINUE
-C *** -------- Finished adding extra points for rapid changes in Ggg
-C
-C *** -------- Now pick next Ep & Cosp
+! *** -------- Finished adding extra points for rapid changes in Ggg
+!
+! *** -------- Now pick next Ep & Cosp
IF (Ep.NE.Em) THEN
IF (Jj.LE.J2) THEN
Ientrp = Jj
@@ -282,31 +281,29 @@ C *** -------- Now pick next Ep & Cosp
Itntrp = Itntb
END IF
END IF
-C
-C *** -------- Update cos(theta) and continue
+!
+! *** -------- Update cos(theta) and continue
Costhe = Cosp
END DO
-C *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
-C
-C
+! *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
+!
+!
END DO
-C *** -- Finished do-loop on Jtheta (ie on mu)
-C
+! *** -- Finished do-loop on Jtheta (ie on mu)
+!
80 CONTINUE
-C *** Finished do-loop on Jfb (ie on positive vs negative mu)
-C
- CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr,
- * Nn, I1)
+! *** Finished do-loop on Jfb (ie on positive vs negative mu)
+!
+ CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr, Nn, I1)
IF (Kwssms.EQ.1) Wssmsc(5) = Yyy1*Pi/Dthick + Wssmsc(5)
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Zero2_2 (A, Sumw, Yyy1xx, Yyy2xx, Yyy2xq, Y2aaaa,
- * Y2aaaq, Nx)
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Zero2_2 (A, Sumw, Yyy1xx, Yyy2xx, Yyy2xq, Y2aaaa, Y2aaaq, Nx)
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -315,13 +312,13 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION A(-Msize:Msize)
DATA Zero /0.0d0/
-C
+!
Sumw = Zero
Yyy1xx = Zero
IF (Ksolve.NE.2) THEN
CALL Zero_Array (A(Idyy1x), Nx)
END IF
-C
+!
Yyy2xx = Zero
Yyy2xq = Zero
Y2aaaa = Zero
@@ -338,28 +335,28 @@ C
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Mulsca_2iq (A, Energb, Ftheta, Totsig, Capsig, Rmass,
- * Aaa, Bbb, Csx, Epx, Ggx, Iex, Y2cccc, Dy2ccc, Wssmsc, Em,
- * Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx, Maxx, Kdatb,
- * Iiso, Nn, Imin, Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
-C
-C *** Mulsca generates the [approximation to] the multiple-scattering
-C *** correction to the capture & fission yield
-C *** The integration over mu is performed on a grid composed of:
-C *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
-C *** (2) Values of mu corresponding to E' as in Energb grid
-C *** (3) Extra points as needed when integrand changes rapidly
-C *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
-C *** calculated earlier (in INP); these are used for edge-effects
-C *** correction to single-scattering term
-C *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
-C *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
-C *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Mulsca_2iq (A, Energb, Ftheta, Totsig, Capsig, Rmass, &
+ Aaa, Bbb, Csx, Epx, Ggx, Iex, Y2cccc, Dy2ccc, Wssmsc, Em, &
+ Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx, Maxx, Kdatb, &
+ Iiso, Nn, Imin, Idone, Knthet, Kountr, Nxtptwn, Nxtptvm)
+!
+! *** Mulsca generates the [approximation to] the multiple-scattering
+! *** correction to the capture & fission yield
+! *** The integration over mu is performed on a grid composed of:
+! *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
+! *** (2) Values of mu corresponding to E' as in Energb grid
+! *** (3) Extra points as needed when integrand changes rapidly
+! *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
+! *** calculated earlier (in INP); these are used for edge-effects
+! *** correction to single-scattering term
+! *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
+! *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
+! *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -372,14 +369,17 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use ssm_9_m
+ use ssm_11_m
+ use ssm_18_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Backward, Forward
DIMENSION A(-Msize:Msize)
-C
- DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*),
- * Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*),
- * Y2cccc(*), Dy2ccc(Nx,*), Wssmsc(*)
-C
+!
+ DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*), &
+ Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*), &
+ Y2cccc(*), Dy2ccc(Nx,*), Wssmsc(*)
+!
DATA Big /1.5d0/, Small /1.0d-12/, Lost /0/
DATA Zero /0.0d0/, One /1.0d0/, Two/2.0d0/
@@ -387,17 +387,17 @@ C
character(len=80)::srcfile
interpType = "Mulsca_2iq"
srcfile = "mssm07.f"
-C
-C
+!
+!
CALL Zero2_2 (A, Sumw, Yyy1xx, Yyy2xx, Yyy2xq, Y2aaaa, Y2aaaq, Nx)
-C
-C *** Costhe (E') integration: first, find limits
-C
+!
+! *** Costhe (E') integration: first, find limits
+!
CALL Limit (Energb, E1, E2, Rmass(Iiso), I1, Nn, Imin)
-C *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
-C *** E2=E*((M-1)/(M+1))
-C *** I1=grid Number just above E1
-C
+! *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
+! *** E2=E*((M-1)/(M+1))
+! *** I1=grid Number just above E1
+!
Ggg = Zero
Gggnew = Zero
Izero = 1
@@ -407,189 +407,185 @@ C
J1 = I1
J2 = 0
Ientrp = 0
-C
-C *** find Ggg for Costhe & Eb
+!
+! *** find Ggg for Costhe & Eb
IF (Idone.NE.3) THEN
- CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Eb, J1+1, Ientrp,
- * Kdatb, Nn, Idone, Not_Quad)
+ CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Eb, J1+1, Ientrp, &
+ Kdatb, Nn, Idone, Not_Quad)
CALL Getggg (Exp1, Ggg)
END IF
-C
+!
Cosold = Cosb
Cosp = Cosb
Kadd = 0
Kaddm = 0
call multScat%setNumThetaNearZero( 0 )
-C
-C *** Do integrations from mu = -1 to mu = +1:
-C *** for Backward (E1 <E'<E1e) top
-C *** (E1e<E'<E2 ) edge
-C *** and Forward (E2 <E'<E2e) edge
-C *** (E2e<E'<Em ) bottom
-C *** (if assume beam goes from top to bottom)
+!
+! *** Do integrations from mu = -1 to mu = +1:
+! *** for Backward (E1 <E'<E1e) top
+! *** (E1e<E'<E2 ) edge
+! *** and Forward (E2 <E'<E2e) edge
+! *** (E2e<E'<Em ) bottom
+! *** (if assume beam goes from top to bottom)
DO 80 Jfbx=1,2
IF (Jfbx.EQ.1) THEN
-C Jfbx=1 => Backward (low E, high angle, Negative cosine)
+! Jfbx=1 => Backward (low E, high angle, Negative cosine)
Jfb = 2
Backward = .TRUE.
Forward = .FALSE.
ELSE
-C Jfbx=2 => Forward (high E, low angle, positive cosine)
+! Jfbx=2 => Forward (high E, low angle, positive cosine)
Jfb = 1
Backward = .FALSE.
Forward = .TRUE.
Cosb = Zero
Eb = E2
END IF
-C
+!
Jthxx = 0
-C ------ Loop over cosine(theta) (& therefore over E'=Ep)
+! ------ Loop over cosine(theta) (& therefore over E'=Ep)
DO Jthx=1,Jtheta
IF (Jthx.EQ.1) Jthxx = 1
Jth = Jthx
-C = 1 to Jtheta
+! = 1 to Jtheta
IF (Backward) Jth = Jtheta + 1 - Jthx
-C = Jtheta to 1
+! = Jtheta to 1
Cosa = Cosb
Ea = Eb
IF (Forward .AND.Jth.LT.Jtheta) Cosb = Ftheta(Jth+1)
IF (Backward.AND.Jth.GT.1 ) Cosb = - Ftheta(Jth-1)
Itntb = 1
- Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) )
- * /Bbb(Iiso) )**2
+ Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) ) / Bbb(Iiso) )**2
IF (Jth+1.EQ.Jtheta .AND. Forward) Eb = Em
-C
-C *** ----- Are there energy-points between Cosa & Cosb ?
+!
+! *** ----- Are there energy-points between Cosa & Cosb ?
CALL Pickee (Energb, Ea, Eb, J1, J2, Kdatb)
-C
+!
IF (Forward) THEN
IF (Jth+1.EQ.Jtheta) THEN
-C if (Forward & next point is last...)
+! if (Forward & next point is last...)
IF (J2.EQ.Nn) J2 = Nn - 1
ELSE IF (Jth.EQ.Jtheta) THEN
-C IF (Forward & this point is last...)
+! IF (Forward & this point is last...)
IF (J2.GE.Nn) J2 = Nn - 1
IF (J1.GE.Nn) J1 = Nn
END IF
END IF
-C
+!
Ep = Ea
Costhe = Cosa
J3 = J2 + 1
Ientrp = 0
Itntrp = 1
-C
-C --------- Loop on energy points between Cosa & Cosb
+!
+! --------- Loop on energy points between Cosa & Cosb
DO Jjj=J1,J3
Jj = Jjj
-C
+!
10 CONTINUE
-C *** -------- Find Gggnew for Costhe & Ep_new
- CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone, Not_Quad)
+! *** -------- Find Gggnew for Costhe & Ep_new
+ CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj, &
+ Ientrp, Kdatb, Nn, Idone, Not_Quad)
CALL Getggg (Exp1, Gggnew)
-C
+!
IF (Idone.EQ.3) GO TO 30
-C
-C ------------ Compare Gggnew to Ggg
+!
+! ------------ Compare Gggnew to Ggg
Ag = dABS(Gggnew-Ggg)
IF (Ggg+Ag.EQ.Ggg) GO TO 30
Bg = Ag/Gggnew
Ag = Ag/Ggg
IF (Ag.LT.Big .AND. Bg.LT.Big) GO TO 30
IF (Ggg.LT.Small .AND. Gggnew.LT.Small) GO TO 30
-C
-C ------------ Additional points are needed so store this one
+!
+! ------------ Additional points are needed so store this one
Kadd = Kadd + 1
Kaddm = Kaddm + 1
IF (Kadd.GT.Maxx) then
write(6,*) "Failure in Mulsca_2iq in mssm07.f"
call talk_kadd_gt_maxx(Kadd,Maxx,srcfile,interpType)
- CALL Talk (Kadd, Maxx, Em, Eb, Ea,
- * Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind,
- * Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar,
- * Nn, Iiso, 1)
+ CALL Talk (Kadd, Maxx, Em, Eb, Ea, &
+ Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind, &
+ Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar, &
+ Nn, Iiso, 1)
end if
-C
+!
IF (Lost.GT.20 .AND. Kadd.GT.20) then
write(6,*) "Failure in Mulsca_2iq in mssm07.f"
- call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,
- * interpType)
- CALL Talk (Kadd, Maxx,
- * Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx,
- * Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig,
- * Niniso, Nnpar, Nn, Iiso, 2)
+ call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,interpType)
+ CALL Talk (Kadd, Maxx, &
+ Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, &
+ Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig, &
+ Niniso, Nnpar, Nn, Iiso, 2)
end if
-C
+!
Csx(Kadd) = Costhe
Epx(Kadd) = Ep
Ggx(Kadd) = Gggnew
Iex(Kadd) = Ientrp
-C
+!
20 CONTINUE
-C ------------ Figure location of next possible point
+! ------------ Figure location of next possible point
Costhe = (Cosold+Costhe)/Two
- Ep = Em*((Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2))
- * /Bbb(Iiso))**2
+ Ep = Em*( (Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2)) / Bbb(Iiso) )**2
Ientrp = 0
Itntrp = 0
GO TO 10
-C
+!
30 CONTINUE
-C ------------ This point is acceptable so add in the integral
-C ------------ from Cosold to Costhe
+! ------------ This point is acceptable so add in the integral
+! ------------ from Cosold to Costhe
W = Costhe - Cosold
Sumw = Sumw + W
-C
-C *** Add contributions from Eold (ie from Cosold)
+!
+! *** Add contributions from Eold (ie from Cosold)
IF (Jthxx.NE.1 .AND. Izero.EQ.1) THEN
IF (Idone.NE.3) THEN
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
- CALL Ssum_2 (A(Idyyy2), A(Idyy2q), A(Idy2qq),
- * A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb),
- * A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq),
- * A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq,
- * Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
+ CALL Ssum_2 (A(Idyyy2), A(Idyy2q), A(Idy2qq), &
+ A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb), &
+ A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq), &
+ A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq, &
+ Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
END IF
-C
-C ------------ Now, find values of everything for new point
- call multScat%setNumThetaNearZero(
- * multScat%getNumThetaNearZero() + 1 )
+!
+! ------------ Now, find values of everything for new point
+ call multScat%setNumThetaNearZero( multScat%getNumThetaNearZero() + 1 )
- CALL Finds_1iq (A, A(Ieb), A(Icccll), A(Idddll), Ftheta,
- * A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots),
- * A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Exp1, Ep, Ggg,
- * Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth, Knthet, Nn,
- * Kdatb, Izero, Idone, Nxtptwn)
- CALL Finds_2 (A(Ieb), A(Idelas), A(Idt), A(Idc),
- * A(Idtots), A(Idyy2x), A(Idy2xq), A(Idyxqq),
- * A(Idy2dd), A(Idy2dq), Y2cccc, Dy2ccc, A(Idy2aa),
- * A(Idy2aq), A(Idyaqq), Yyy2xx, Yyy2xq, Y2aaaa,
- * Y2aaaq, Ep, Ggg, Nx, Ientrp, Nn, Izero, Idone,
- * Not_Quad)
-C
+ CALL Finds_1iq (A, A(Ieb), A(Icccll), A(Idddll), Ftheta, &
+ A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots), &
+ A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Exp1, Ep, Ggg, &
+ Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth, Knthet, Nn, &
+ Kdatb, Izero, Idone, Nxtptwn)
+ CALL Finds_2 (A(Ieb), A(Idelas), A(Idt), A(Idc), &
+ A(Idtots), A(Idyy2x), A(Idy2xq), A(Idyxqq), &
+ A(Idy2dd), A(Idy2dq), Y2cccc, Dy2ccc, A(Idy2aa), &
+ A(Idy2aq), A(Idyaqq), Yyy2xx, Yyy2xq, Y2aaaa, &
+ Y2aaaq, Ep, Ggg, Nx, Ientrp, Nn, Izero, Idone, &
+ Not_Quad)
+!
IF (Jthxx.EQ.1) THEN
Jthxx = 0
GO TO 40
END IF
-C
-C *** Add contributions from Enew (ie from Costhe)
+!
+! *** Add contributions from Enew (ie from Costhe)
IF (Izero.EQ.1) THEN
IF (Idone.NE.3) THEN
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
- CALL Ssum_2 ( A(Idyyy2), A(Idyy2q), A(Idy2qq),
- * A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb),
- * A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq),
- * A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq,
- * Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
+ CALL Ssum_2 ( A(Idyyy2), A(Idyy2q), A(Idy2qq), &
+ A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb), &
+ A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq), &
+ A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq, &
+ Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
END IF
-C
+!
Cosold = Costhe
IF (Idone.EQ.3) GO TO 40
IF (Kadd.EQ.0) GO TO 40
-C
+!
Ep = Epx(Kadd)
Costhe = Csx(Kadd)
Gggnew = Ggx(Kadd)
@@ -601,15 +597,15 @@ C
Ag = Ag/Ggg
IF (Ag.GT.Big .OR. Bg.GT.Big) GO TO 20
Kadd = Kadd - 1
- CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone, Not_Quad)
+ CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj, &
+ Ientrp, Kdatb, Nn, Idone, Not_Quad)
CALL Getggg (Exp1, Gggnew)
GO TO 30
-C
+!
40 CONTINUE
-C *** -------- Finished adding extra points for rapid changes in Ggg
-C
-C *** -------- Now pick next Ep & Cosp
+! *** -------- Finished adding extra points for rapid changes in Ggg
+!
+! *** -------- Now pick next Ep & Cosp
IF (Ep.NE.Em) THEN
IF (Jj.LE.J2) THEN
Ientrp = Jj
@@ -624,22 +620,23 @@ C *** -------- Now pick next Ep & Cosp
Itntrp = Itntb
END IF
END IF
-C
-C *** -------- Update cos(theta) and continue
+!
+! *** -------- Update cos(theta) and continue
Costhe = Cosp
END DO
-C *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
-C
-C
+! *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
+!
+!
END DO
-C *** -- Finished do-loop on Jtheta (ie on mu)
-C
+! *** -- Finished do-loop on Jtheta (ie on mu)
+!
80 CONTINUE
-C *** Finished do-loop on Jfb (ie on positive vs negative mu)
-C
- CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr,
- * Nn, I1)
+! *** Finished do-loop on Jfb (ie on positive vs negative mu)
+!
+ CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr, Nn, I1)
IF (Kwssms.EQ.1) Wssmsc(5) = Yyy1*Pi/Dthick + Wssmsc(5)
-C
+!
RETURN
END
+
+end module ssm_7_m
diff --git a/sammy/src/ssm/mssm08.f b/sammy/src/ssm/mssm08.f90
similarity index 52%
rename from sammy/src/ssm/mssm08.f
rename to sammy/src/ssm/mssm08.f90
index 42376af03..f84756eca 100644
--- a/sammy/src/ssm/mssm08.f
+++ b/sammy/src/ssm/mssm08.f90
@@ -1,26 +1,28 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Mulsca_2fl (A, Energb, Ftheta, Totsig, Capsig, Rmass,
- * Aaa, Bbb, Csx, Epx, Ggx, Iex, Y2cccc, Dy2ccc, Wssmsc, Em,
- * Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Yyy1fb, Nx,
- * Maxx, Kdatb, Iiso, Nn, Imin, Idone, Knthet, Kountr, Nxtptwn,
- * Nxtptvm)
-C
-C *** Mulsca generates the [approximation to] the multiple-scattering
-C *** correction to the capture & fission yield
-C *** The integration over mu is performed on a grid composed of:
-C *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
-C *** (2) Values of mu corresponding to E' as in Energb grid
-C *** (3) Extra points as needed when integrand changes rapidly
-C *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
-C *** calculated earlier (in INP); these are used for edge-effects
-C *** correction to single-scattering term
-C *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
-C *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
-C *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
-C
+!
+module ssm_8_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Mulsca_2fl (A, Energb, Ftheta, Totsig, Capsig, Rmass, &
+ Aaa, Bbb, Csx, Epx, Ggx, Iex, Y2cccc, Dy2ccc, Wssmsc, Em, &
+ Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Yyy1fb, Nx, &
+ Maxx, Kdatb, Iiso, Nn, Imin, Idone, Knthet, Kountr, Nxtptwn, &
+ Nxtptvm)
+!
+! *** Mulsca generates the [approximation to] the multiple-scattering
+! *** correction to the capture & fission yield
+! *** The integration over mu is performed on a grid composed of:
+! *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
+! *** (2) Values of mu corresponding to E' as in Energb grid
+! *** (3) Extra points as needed when integrand changes rapidly
+! *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
+! *** calculated earlier (in INP); these are used for edge-effects
+! *** correction to single-scattering term
+! *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
+! *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
+! *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -32,14 +34,19 @@ C
use ssssss_common_m
use xsect_x_common_m
use MultScatPars_common_m
+ use ssm_7_m
+ use ssm_9_m
+ use ssm_10_m
+ use ssm_11_m
+ use ssm_18_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Backward, Forward
DIMENSION A(-Msize:Msize)
-C
- DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*),
- * Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*),
- * Y2cccc(*), Dy2ccc(Nx,*), Wssmsc(*), Yyy1fb(*)
-C
+!
+ DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*), &
+ Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*), &
+ Y2cccc(*), Dy2ccc(Nx,*), Wssmsc(*), Yyy1fb(*)
+!
DATA Big /1.5d0/, Small /1.0d-12/, Lost /0/
DATA Zero /0.0d0/, One /1.0d0/, Two/2.0d0/
@@ -47,13 +54,12 @@ C
character(len=80)::srcfile
interpType = "Mulsca_2fl"
srcfile = "mssm08.f"
-C
-C
-C *** Interpolate Sqfb to give Qfb at Total(E) (if doing edge-effects
-C *** correction to single-scattering)
+!
+!
+! *** Interpolate Sqfb to give Qfb at Total(E) (if doing edge-effects
+! *** correction to single-scattering)
IF (Idone.NE.3) THEN
- CALL Trptot_Lin (A(Ixtptv), A(Isqfb), A(Iqfb), A(Idvqfb),
- * Total, Nxtptvm, Em)
+ CALL Trptot_Lin (A(Ixtptv), A(Isqfb), A_Iqfb, A(Idvqfb), Total, Nxtptvm, Em)
if ( Total.lt.multScat%getLogSigmaTotMin() ) then
call multScat%setLogSigmaTotMin( Total )
@@ -63,16 +69,16 @@ C *** correction to single-scattering)
end if
END IF
-C
+!
CALL Zero2_2 (A, Sumw, Yyy1xx, Yyy2xx, Yyy2xq, Y2aaaa, Y2aaaq, Nx)
-C
-C *** Costhe (E') integration: first, find limits
-C
+!
+! *** Costhe (E') integration: first, find limits
+!
CALL Limit (Energb, E1, E2, Rmass(Iiso), I1, Nn, Imin)
-C *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
-C *** E2=E*((M-1)/(M+1))
-C *** I1=grid Number just above E1
-C
+! *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
+! *** E2=E*((M-1)/(M+1))
+! *** I1=grid Number just above E1
+!
Ggg = Zero
Gggnew = Zero
Izero = 1
@@ -82,189 +88,183 @@ C
J1 = I1
J2 = 0
Ientrp = 0
-C
-C *** find Ggg for Costhe & Eb
+!
+! *** find Ggg for Costhe & Eb
IF (Idone.NE.3) THEN
- CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Eb, J1+1, Ientrp,
- * Kdatb, Nn, Idone)
+ CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Eb, J1+1, Ientrp, Kdatb, Nn, Idone)
CALL Getggg (Exp1, Ggg)
END IF
-C
+!
Cosold = Cosb
Cosp = Cosb
Kadd = 0
Kaddm = 0
call multScat%setNumThetaNearZero( 0 )
-C
-C *** Do integrations from mu = -1 to mu = +1:
-C *** for Backward (E1 <E'<E1e) top
-C *** (E1e<E'<E2 ) edge
-C *** and Forward (E2 <E'<E2e) edge
-C *** (E2e<E'<Em ) bottom
-C *** (if assume beam goes from top to bottom)
+!
+! *** Do integrations from mu = -1 to mu = +1:
+! *** for Backward (E1 <E'<E1e) top
+! *** (E1e<E'<E2 ) edge
+! *** and Forward (E2 <E'<E2e) edge
+! *** (E2e<E'<Em ) bottom
+! *** (if assume beam goes from top to bottom)
DO 80 Jfbx=1,2
IF (Jfbx.EQ.1) THEN
-C Jfbx=1 => Backward (low E, high angle, Negative cosine)
+! Jfbx=1 => Backward (low E, high angle, Negative cosine)
Jfb = 2
Backward = .TRUE.
Forward = .FALSE.
ELSE
-C Jfbx=2 => Forward (high E, low angle, positive cosine)
+! Jfbx=2 => Forward (high E, low angle, positive cosine)
Jfb = 1
Backward = .FALSE.
Forward = .TRUE.
Cosb = Zero
Eb = E2
END IF
-C
+!
Jthxx = 0
-C ------ Loop over cosine(theta) (& therefore over E'=Ep)
+! ------ Loop over cosine(theta) (& therefore over E'=Ep)
DO Jthx=1,Jtheta
IF (Jthx.EQ.1) Jthxx = 1
Jth = Jthx
-C = 1 to Jtheta
+! = 1 to Jtheta
IF (Backward) Jth = Jtheta + 1 - Jthx
-C = Jtheta to 1
+! = Jtheta to 1
Cosa = Cosb
Ea = Eb
IF (Forward .AND.Jth.LT.Jtheta) Cosb = Ftheta(Jth+1)
IF (Backward.AND.Jth.GT.1 ) Cosb = - Ftheta(Jth-1)
Itntb = 1
- Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) )
- * /Bbb(Iiso) )**2
+ Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) ) / Bbb(Iiso) )**2
IF (Jth+1.EQ.Jtheta .AND. Forward) Eb = Em
-C
-C *** ----- Are there energy-points between Cosa & Cosb ?
+!
+! *** ----- Are there energy-points between Cosa & Cosb ?
CALL Pickee (Energb, Ea, Eb, J1, J2, Kdatb)
-C
+!
IF (Forward) THEN
IF (Jth+1.EQ.Jtheta) THEN
-C if (Forward & next point is last...)
+! if (Forward & next point is last...)
IF (J2.EQ.Nn) J2 = Nn - 1
ELSE IF (Jth.EQ.Jtheta) THEN
-C IF (Forward & this point is last...)
+! IF (Forward & this point is last...)
IF (J2.GE.Nn) J2 = Nn - 1
IF (J1.GE.Nn) J1 = Nn
END IF
END IF
-C
+!
Ep = Ea
Costhe = Cosa
J3 = J2 + 1
Ientrp = 0
Itntrp = 1
-C
-C --------- Loop on energy points between Cosa & Cosb
+!
+! --------- Loop on energy points between Cosa & Cosb
DO Jjj=J1,J3
Jj = Jjj
-C
+!
10 CONTINUE
-C *** -------- Find Gggnew for Costhe & Ep_new
- CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone)
+! *** -------- Find Gggnew for Costhe & Ep_new
+ CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj, Ientrp, Kdatb, Nn, Idone)
CALL Getggg (Exp1, Gggnew)
-C
+!
IF (Idone.EQ.3) GO TO 30
-C
-C ------------ Compare Gggnew to Ggg
+!
+! ------------ Compare Gggnew to Ggg
Ag = dABS(Gggnew-Ggg)
IF (Ggg+Ag.EQ.Ggg) GO TO 30
Bg = Ag/Gggnew
Ag = Ag/Ggg
IF (Ag.LT.Big .AND. Bg.LT.Big) GO TO 30
IF (Ggg.LT.Small .AND. Gggnew.LT.Small) GO TO 30
-C
-C ------------ Additional points are needed so store this one
+!
+! ------------ Additional points are needed so store this one
Kadd = Kadd + 1
Kaddm = Kaddm + 1
IF (Kadd.GT.Maxx) then
call talk_kadd_gt_maxx(Kadd,Maxx,srcfile,interpType)
- CALL Talk (Kadd, Maxx, Em, Eb, Ea,
- * Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind,
- * Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar,
- * Nn, Iiso, 1)
+ CALL Talk (Kadd, Maxx, Em, Eb, Ea, &
+ Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind, &
+ Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar, &
+ Nn, Iiso, 1)
end if
-C
+!
IF (Lost.GT.20 .AND. Kadd.GT.20) then
- call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,
- * interpType)
- CALL Talk (Kadd, Maxx,
- * Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx,
- * Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig,
- * Niniso, Nnpar, Nn, Iiso, 2)
+ call talk_kadd_and_lost_gt(Kadd,Lost,srcfile,interpType)
+ CALL Talk (Kadd, Maxx, &
+ Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, &
+ Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig, &
+ Niniso, Nnpar, Nn, Iiso, 2)
end if
-C
+!
Csx(Kadd) = Costhe
Epx(Kadd) = Ep
Ggx(Kadd) = Gggnew
Iex(Kadd) = Ientrp
-C
+!
20 CONTINUE
-C ------------ Figure location of next possible point
+! ------------ Figure location of next possible point
Costhe = (Cosold+Costhe)/Two
- Ep = Em*((Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2))
- * /Bbb(Iiso))**2
+ Ep = Em*( ( Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2) ) / Bbb(Iiso) )**2
Ientrp = 0
Itntrp = 0
GO TO 10
-C
+!
30 CONTINUE
-C ------------ This point is acceptable so add in the integral
-C ------------ from Cosold to Costhe
+! ------------ This point is acceptable so add in the integral
+! ------------ from Cosold to Costhe
W = Costhe - Cosold
Sumw = Sumw + W
-C
-C *** Add contributions from Eold (ie from Cosold)
+!
+! *** Add contributions from Eold (ie from Cosold)
IF (Jthxx.NE.1 .AND. Izero.EQ.1) THEN
IF (Idone.NE.3) THEN
Yyy1fb(Jfb) = Yyy1fb(Jfb) -Yyy1zz*W
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
- CALL Ssum_2 ( A(Idyyy2), A(Idyy2q), A(Idy2qq),
- * A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb),
- * A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq),
- * A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq,
- * Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
+ CALL Ssum_2 ( A(Idyyy2), A(Idyy2q), A(Idy2qq), &
+ A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb), &
+ A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq), &
+ A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq, &
+ Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
END IF
-C
-C ------------ Now, find values of everything for new point
- call multScat%setNumThetaNearZero(
- * multScat%getNumThetaNearZero() + 1 )
+!
+! ------------ Now, find values of everything for new point
+ call multScat%setNumThetaNearZero( multScat%getNumThetaNearZero() + 1 )
- CALL Finds_1fl (A, A(Ieb), A(Icccll), A(Idddll), Ftheta,
- * A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots),
- * A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Yyy1zz,
- * Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp,
- * Jfb, Jth, Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
- CALL Finds_2 (A(Ieb), A(Idelas), A(Idt), A(Idc),
- * A(Idtots), A(Idyy2x), A(Idy2xq), A(Idyxqq),
- * A(Idy2dd), A(Idy2dq), Y2cccc, Dy2ccc, A(Idy2aa),
- * A(Idy2aq), A(Idyaqq), Yyy2xx, Yyy2xq, Y2aaaa,
- * Y2aaaq, Ep, Ggg, Nx, Ientrp, Nn, Izero, Idone,
- * Not_Quad)
-C
+ CALL Finds_1fl (A, A(Ieb), A(Icccll), A(Idddll), Ftheta, &
+ A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots), &
+ A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Yyy1zz, &
+ Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp, &
+ Jfb, Jth, Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
+ CALL Finds_2 (A(Ieb), A(Idelas), A(Idt), A(Idc), &
+ A(Idtots), A(Idyy2x), A(Idy2xq), A(Idyxqq), &
+ A(Idy2dd), A(Idy2dq), Y2cccc, Dy2ccc, A(Idy2aa), &
+ A(Idy2aq), A(Idyaqq), Yyy2xx, Yyy2xq, Y2aaaa, &
+ Y2aaaq, Ep, Ggg, Nx, Ientrp, Nn, Izero, Idone, &
+ Not_Quad)
+!
IF (Jthxx.EQ.1) THEN
Jthxx = 0
GO TO 40
END IF
-C
-C *** Add contributions from Enew (ie from Costhe)
+!
+! *** Add contributions from Enew (ie from Costhe)
IF (Izero.EQ.1) THEN
IF (Idone.NE.3) THEN
Yyy1fb(Jfb) = Yyy1fb(Jfb) -Yyy1zz*W
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
- CALL Ssum_2 ( A(Idyyy2), A(Idyy2q), A(Idy2qq),
- * A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb),
- * A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq),
- * A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq,
- * Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
+ CALL Ssum_2 ( A(Idyyy2), A(Idyy2q), A(Idy2qq), &
+ A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb), &
+ A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq), &
+ A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq, &
+ Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
END IF
-C
+!
Cosold = Costhe
IF (Idone.EQ.3) GO TO 40
IF (Kadd.EQ.0) GO TO 40
-C
+!
Ep = Epx(Kadd)
Costhe = Csx(Kadd)
Gggnew = Ggx(Kadd)
@@ -276,15 +276,14 @@ C
Ag = Ag/Ggg
IF (Ag.GT.Big .OR. Bg.GT.Big) GO TO 20
Kadd = Kadd - 1
- CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone)
+ CALL Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj, Ientrp, Kdatb, Nn, Idone)
CALL Getggg (Exp1, Gggnew)
GO TO 30
-C
+!
40 CONTINUE
-C *** -------- Finished adding extra points for rapid changes in Ggg
-C
-C *** -------- Now pick next Ep & Cosp
+! *** -------- Finished adding extra points for rapid changes in Ggg
+!
+! *** -------- Now pick next Ep & Cosp
IF (Ep.NE.Em) THEN
IF (Jj.LE.J2) THEN
Ientrp = Jj
@@ -299,48 +298,47 @@ C *** -------- Now pick next Ep & Cosp
Itntrp = Itntb
END IF
END IF
-C
-C *** -------- Update cos(theta) and continue
+!
+! *** -------- Update cos(theta) and continue
Costhe = Cosp
END DO
-C *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
-C
-C
+! *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
+!
+!
END DO
-C *** -- Finished do-loop on Jtheta (ie on mu)
-C
+! *** -- Finished do-loop on Jtheta (ie on mu)
+!
80 CONTINUE
-C *** Finished do-loop on Jfb (ie on positive vs negative mu)
-C
- CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr,
- * Nn, I1)
+! *** Finished do-loop on Jfb (ie on positive vs negative mu)
+!
+ CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr, Nn, I1)
CALL W_Wssmsc (Yyy1, Dthick, Total, Wssmsc, Yyy1fb, Kwssms)
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Mulsca_2fq (A, Energb, Ftheta, Totsig, Capsig, Rmass,
- * Aaa, Bbb, Csx, Epx, Ggx, Iex, Y2cccc, Dy2ccc, Wssmsc, Em,
- * Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Yyy1fb, Nx,
- * Maxx, Kdatb, Iiso, Nn, Imin, Idone, Knthet, Kountr, Nxtptwn,
- * Nxtptvm)
-C
-C *** Mulsca generates the [approximation to] the multiple-scattering
-C *** correction to the capture & fission yield
-C *** The integration over mu is performed on a grid composed of:
-C *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
-C *** (2) Values of mu corresponding to E' as in Energb grid
-C *** (3) Extra points as needed when integrand changes rapidly
-C *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
-C *** calculated earlier (in INP); these are used for edge-effects
-C *** correction to single-scattering term
-C *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
-C *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
-C *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Mulsca_2fq (A, Energb, Ftheta, Totsig, Capsig, Rmass, &
+ Aaa, Bbb, Csx, Epx, Ggx, Iex, Y2cccc, Dy2ccc, Wssmsc, Em, &
+ Exp1, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Yyy1fb, Nx, &
+ Maxx, Kdatb, Iiso, Nn, Imin, Idone, Knthet, Kountr, Nxtptwn, &
+ Nxtptvm)
+!
+! *** Mulsca generates the [approximation to] the multiple-scattering
+! *** correction to the capture & fission yield
+! *** The integration over mu is performed on a grid composed of:
+! *** (1) Values of mu = Ftheta(1:Jtheta) where Jtheta > or = Ntheta
+! *** (2) Values of mu corresponding to E' as in Energb grid
+! *** (3) Extra points as needed when integrand changes rapidly
+! *** Values of Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta) have been
+! *** calculated earlier (in INP); these are used for edge-effects
+! *** correction to single-scattering term
+! *** Log interpolation gives Qfb(N*sigma',Ftheta,ifb) =
+! *** Sqfb(ifb,N*sigma(E),N*sigma(E'),Ftheta).
+! *** Log interpolation is used on Ftheta and N*sigma', to give Fz.
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -352,14 +350,19 @@ C
use ssssss_common_m
use xsect_x_common_m
use MultScatPars_common_m
+ use ssm_7_m
+ use ssm_9_m
+ use ssm_10_m
+ use ssm_11_m
+ use ssm_18_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Backward, Forward
DIMENSION A(-Msize:Msize)
-C
- DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*),
- * Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*),
- * Y2cccc(*), Dy2ccc(Nx,*), Wssmsc(*), Yyy1fb(*)
-C
+!
+ DIMENSION Energb(*), Ftheta(Jtheta), Totsig(*), Capsig(*), &
+ Rmass(*), Aaa(*), Bbb(*), Csx(*), Epx(*), Ggx(*), Iex(*), &
+ Y2cccc(*), Dy2ccc(Nx,*), Wssmsc(*), Yyy1fb(*)
+!
DATA Big /1.5d0/, Small /1.0d-12/, Lost /0/
DATA Zero /0.0d0/, One /1.0d0/, Two/2.0d0/
@@ -367,13 +370,12 @@ C
character(len=80)::srcfile
interpType = "Mulsca_2fq"
srcfile = "mssm08.f"
-C
-C
-C *** Interpolate Sqfb to give Qfb at Total(E) (if doing edge-effects
-C *** correction to single-scattering)
+!
+!
+! *** Interpolate Sqfb to give Qfb at Total(E) (if doing edge-effects
+! *** correction to single-scattering)
IF (Idone.NE.3) THEN
- CALL Trptot_Quad (A(Ixtptv), A(Isqfb), A(Iqfb), A(Idvqfb),
- * Total, Nxtptvm, Em)
+ CALL Trptot_Quad (A(Ixtptv), A(Isqfb), A_Iqfb, A(Idvqfb), Total, Nxtptvm, Em)
if ( Total.lt.multScat%getLogSigmaTotMin() ) then
call multScat%setLogSigmaTotMin( Total )
@@ -383,16 +385,16 @@ C *** correction to single-scattering)
end if
END IF
-C
+!
CALL Zero2_2 (A, Sumw, Yyy1xx, Yyy2xx, Yyy2xq, Y2aaaa, Y2aaaq, Nx)
-C
-C *** Costhe (E') integration: first, find limits
-C
+!
+! *** Costhe (E') integration: first, find limits
+!
CALL Limit (Energb, E1, E2, Rmass(Iiso), I1, Nn, Imin)
-C *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
-C *** E2=E*((M-1)/(M+1))
-C *** I1=grid Number just above E1
-C
+! *** subprogram Limit finds E1=E*((M-1)/(M+1))**2
+! *** E2=E*((M-1)/(M+1))
+! *** I1=grid Number just above E1
+!
Ggg = Zero
Gggnew = Zero
Izero = 1
@@ -402,192 +404,187 @@ C
J1 = I1
J2 = 0
Ientrp = 0
-C
-C *** find Ggg for Costhe & Eb
+!
+! *** find Ggg for Costhe & Eb
IF (Idone.NE.3) THEN
- CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Eb, J1+1, Ientrp,
- * Kdatb, Nn, Idone, Not_Quad)
+ CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Eb, J1+1, Ientrp, Kdatb, Nn, Idone, Not_Quad)
CALL Getggg (Exp1, Ggg)
END IF
-C
+!
Cosold = Cosb
Cosp = Cosb
Kadd = 0
Kaddm = 0
call multScat%setNumThetaNearZero( 0 )
Ktheta = 0
-C
-C *** Do integrations from mu = -1 to mu = +1:
-C *** for Backward (E1 <E'<E1e) top
-C *** (E1e<E'<E2 ) edge
-C *** and Forward (E2 <E'<E2e) edge
-C *** (E2e<E'<Em ) bottom
-C *** (if assume beam goes from top to bottom)
+!
+! *** Do integrations from mu = -1 to mu = +1:
+! *** for Backward (E1 <E'<E1e) top
+! *** (E1e<E'<E2 ) edge
+! *** and Forward (E2 <E'<E2e) edge
+! *** (E2e<E'<Em ) bottom
+! *** (if assume beam goes from top to bottom)
DO 80 Jfbx=1,2
IF (Jfbx.EQ.1) THEN
-C Jfbx=1 => Backward (low E, high angle, Negative cosine)
+! Jfbx=1 => Backward (low E, high angle, Negative cosine)
Jfb = 2
Backward = .TRUE.
Forward = .FALSE.
ELSE
-C Jfbx=2 => Forward (high E, low angle, positive cosine)
+! Jfbx=2 => Forward (high E, low angle, positive cosine)
Jfb = 1
Backward = .FALSE.
Forward = .TRUE.
Cosb = Zero
Eb = E2
END IF
-C
+!
Jthxx = 0
-C ------ Loop over cosine(theta) (& therefore over E'=Ep)
+! ------ Loop over cosine(theta) (& therefore over E'=Ep)
DO Jthx=1,Jtheta
IF (Jthx.EQ.1) Jthxx = 1
Jth = Jthx
-C = 1 to Jtheta
+! = 1 to Jtheta
IF (Backward) Jth = Jtheta + 1 - Jthx
-C = Jtheta to 1
+! = Jtheta to 1
Cosa = Cosb
Ea = Eb
IF (Forward .AND.Jth.LT.Jtheta) Cosb = Ftheta(Jth+1)
IF (Backward.AND.Jth.GT.1 ) Cosb = - Ftheta(Jth-1)
Itntb = 1
- Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) )
- * /Bbb(Iiso) )**2
+ Eb = Em * ( ( Cosb + Dsqrt(Aaa(Iiso)-One+Cosb**2) ) / Bbb(Iiso) )**2
IF (Jth+1.EQ.Jtheta .AND. Forward) Eb = Em
-C
-C *** ----- Are there energy-points between Cosa & Cosb ?
+!
+! *** ----- Are there energy-points between Cosa & Cosb ?
CALL Pickee (Energb, Ea, Eb, J1, J2, Kdatb)
-C
+!
IF (Forward) THEN
IF (Jth+1.EQ.Jtheta) THEN
-C if (Forward & next point is last...)
+! if (Forward & next point is last...)
IF (J2.EQ.Nn) J2 = Nn - 1
ELSE IF (Jth.EQ.Jtheta) THEN
-C IF (Forward & this point is last...)
+! IF (Forward & this point is last...)
IF (J2.GE.Nn) J2 = Nn - 1
IF (J1.GE.Nn) J1 = Nn
END IF
END IF
-C
+!
Ep = Ea
Costhe = Cosa
J3 = J2 + 1
Ientrp = 0
Itntrp = 1
-C
-C --------- Loop on energy points between Cosa & Cosb
+!
+! --------- Loop on energy points between Cosa & Cosb
DO Jjj=J1,J3
Jj = Jjj
-C
+!
10 CONTINUE
-C *** -------- Find Gggnew for Costhe & Ep_new
- CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone, Not_Quad)
+! *** -------- Find Gggnew for Costhe & Ep_new
+ CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj, Ientrp, &
+ Kdatb, Nn, Idone, Not_Quad)
CALL Getggg (Exp1, Gggnew)
-C
+!
IF (Idone.EQ.3) GO TO 30
-C
-C ------------ Compare Gggnew to Ggg
+!
+! ------------ Compare Gggnew to Ggg
Ag = dABS(Gggnew-Ggg)
IF (Ggg+Ag.EQ.Ggg) GO TO 30
Bg = Ag/Gggnew
Ag = Ag/Ggg
IF (Ag.LT.Big .AND. Bg.LT.Big) GO TO 30
IF (Ggg.LT.Small .AND. Gggnew.LT.Small) GO TO 30
-C
-C ------------ Additional points are needed so store this one
+!
+! ------------ Additional points are needed so store this one
Kadd = Kadd + 1
Kaddm = Kaddm + 1
IF (Kadd.GT.Maxx) then
! Stop the program
call talk_kadd_gt_maxx(kadd,maxx,srcfile,interpType)
- CALL Talk (Kadd, Maxx, Em, Eb, Ea,
- * Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind,
- * Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar,
- * Nn, Iiso, 1)
+ CALL Talk (Kadd, Maxx, Em, Eb, Ea, &
+ Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, Ggx, Emind, &
+ Emins, Eminr, Energb, Totsig, Nnnsig, Niniso, Nnpar, &
+ Nn, Iiso, 1)
end if
-C
+!
IF (Lost.GT.20 .AND. Kadd.GT.20) then
! Stop the program
- call talk_kadd_and_lost_gt(kadd,lost,srcfile,
- * interpType)
- CALL Talk (Kadd, Maxx,
- * Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx,
- * Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig,
- * Niniso, Nnpar, Nn, Iiso, 2)
+ call talk_kadd_and_lost_gt(kadd,lost,srcfile,interpType)
+ CALL Talk (Kadd, Maxx, &
+ Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, J1, J3, Csx, Epx, &
+ Ggx, Emind, Emins, Eminr, Energb, Totsig, Nnnsig, &
+ Niniso, Nnpar, Nn, Iiso, 2)
end if
-C
+!
Csx(Kadd) = Costhe
Epx(Kadd) = Ep
Ggx(Kadd) = Gggnew
Iex(Kadd) = Ientrp
-C
+!
20 CONTINUE
-C ------------ Figure location of next possible point
+! ------------ Figure location of next possible point
Costhe = (Cosold+Costhe)/Two
- Ep = Em*((Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2))
- * /Bbb(Iiso))**2
+ Ep = Em*( ( Costhe+dSQRT(Aaa(Iiso)-One+Costhe**2) ) / Bbb(Iiso) )**2
Ientrp = 0
Itntrp = 0
GO TO 10
-C
+!
30 CONTINUE
-C ------------ This point is acceptable so add in the integral
-C ------------ from Cosold to Costhe
+! ------------ This point is acceptable so add in the integral
+! ------------ from Cosold to Costhe
W = Costhe - Cosold
Sumw = Sumw + W
-C
-C *** Add contributions from Eold (ie from Cosold)
+!
+! *** Add contributions from Eold (ie from Cosold)
IF (Jthxx.NE.1 .AND. Izero.EQ.1) THEN
IF (Idone.NE.3) THEN
Yyy1fb(Jfb) = Yyy1fb(Jfb) -Yyy1zz*W
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
- CALL Ssum_2 ( A(Idyyy2), A(Idyy2q), A(Idy2qq),
- * A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb),
- * A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq),
- * A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq,
- * Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
+ CALL Ssum_2 ( A(Idyyy2), A(Idyy2q), A(Idy2qq), &
+ A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb), &
+ A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq), &
+ A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq, &
+ Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
END IF
-C
-C ------------ Now, find values of everything for new point
- call multScat%setNumThetaNearZero(
- * multScat%getNumThetaNearZero() + 1 )
+!
+! ------------ Now, find values of everything for new point
+ call multScat%setNumThetaNearZero( multScat%getNumThetaNearZero() + 1 )
- CALL Finds_1fq (A, A(Ieb), A(Icccll), A(Idddll), Ftheta,
- * A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots),
- * A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Yyy1zz,
- * Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp,
- * Jfb, Jth, Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
- CALL Finds_2 (A(Ieb), A(Idelas), A(Idt), A(Idc),
- * A(Idtots), A(Idyy2x), A(Idy2xq), A(Idyxqq),
- * A(Idy2dd), A(Idy2dq), Y2cccc, Dy2ccc, A(Idy2aa),
- * A(Idy2aq), A(Idyaqq), Yyy2xx, Yyy2xq, Y2aaaa,
- * Y2aaaq, Ep, Ggg, Nx, Ientrp, Nn, Izero, Idone,
- * Not_Quad)
-C
+ CALL Finds_1fq (A, A(Ieb), A(Icccll), A(Idddll), Ftheta, &
+ A(Idelas), A(Idt), A(Idc), Totsig, Capsig, A(Idtots), &
+ A(Idcaps), Rmass, A(Idyy1x), Yyy1xx, Yyy1zz, &
+ Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp, &
+ Jfb, Jth, Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
+ CALL Finds_2 (A(Ieb), A(Idelas), A(Idt), A(Idc), &
+ A(Idtots), A(Idyy2x), A(Idy2xq), A(Idyxqq), &
+ A(Idy2dd), A(Idy2dq), Y2cccc, Dy2ccc, A(Idy2aa), &
+ A(Idy2aq), A(Idyaqq), Yyy2xx, Yyy2xq, Y2aaaa, &
+ Y2aaaq, Ep, Ggg, Nx, Ientrp, Nn, Izero, Idone, &
+ Not_Quad)
+!
IF (Jthxx.EQ.1) THEN
Jthxx = 0
GO TO 40
END IF
-C
-C *** Add contributions from Enew (ie from Costhe)
+!
+! *** Add contributions from Enew (ie from Costhe)
IF (Izero.EQ.1) THEN
IF (Idone.NE.3) THEN
Yyy1fb(Jfb) = Yyy1fb(Jfb) -Yyy1zz*W
CALL Ssum_1 (A(Idyyy1), A(Idyy1x), Yyy1, Yyy1xx, W)
END IF
- CALL Ssum_2 ( A(Idyyy2), A(Idyy2q), A(Idy2qq),
- * A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb),
- * A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq),
- * A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq,
- * Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
+ CALL Ssum_2 ( A(Idyyy2), A(Idyy2q), A(Idy2qq), &
+ A(Idyy2x), A(Idy2xq), A(Idyxqq), A(Idy2bb), &
+ A(Idy2bq), A(Idybqq), A(Idy2aa), A(Idy2aq), &
+ A(Idyaqq), Yyy2, Yyy2q, Yyy2xx, Yyy2xq, &
+ Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
END IF
-C
+!
Cosold = Costhe
IF (Idone.EQ.3) GO TO 40
IF (Kadd.EQ.0) GO TO 40
-C
+!
Ep = Epx(Kadd)
Costhe = Csx(Kadd)
Gggnew = Ggx(Kadd)
@@ -599,15 +596,15 @@ C
Ag = Ag/Ggg
IF (Ag.GT.Big .OR. Bg.GT.Big) GO TO 20
Kadd = Kadd - 1
- CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj,
- * Ientrp, Kdatb, Nn, Idone, Not_Quad)
+ CALL Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj, &
+ Ientrp, Kdatb, Nn, Idone, Not_Quad)
CALL Getggg (Exp1, Gggnew)
GO TO 30
-C
+!
40 CONTINUE
-C *** -------- Finished adding extra points for rapid changes in Ggg
-C
-C *** -------- Now pick next Ep & Cosp
+! *** -------- Finished adding extra points for rapid changes in Ggg
+!
+! *** -------- Now pick next Ep & Cosp
IF (Ep.NE.Em) THEN
IF (Jj.LE.J2) THEN
Ientrp = Jj
@@ -622,21 +619,22 @@ C *** -------- Now pick next Ep & Cosp
Itntrp = Itntb
END IF
END IF
-C
-C *** -------- Update cos(theta) and continue
+!
+! *** -------- Update cos(theta) and continue
Costhe = Cosp
END DO
-C *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
-C
+! *** ----- Finished loop on Jjj (on energies between Cosa & Cosb)
+!
END DO
-C *** -- Finished do-loop on Jtheta (ie on mu)
-C
+! *** -- Finished do-loop on Jtheta (ie on mu)
+!
80 CONTINUE
-C *** Finished do-loop on Jfb (ie on positive vs negative mu)
-C
- CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr,
- * Nn, I1)
+! *** Finished do-loop on Jfb (ie on positive vs negative mu)
+!
+ CALL Testx (Em, E1, E2, Energb(Nn), Sumw, Kaddm, Lost, Kountr, Nn, I1)
CALL W_Wssmsc (Yyy1, Dthick, Total, Wssmsc, Yyy1fb, Kwssms)
-C
+!
RETURN
END
+
+end module ssm_8_m
diff --git a/sammy/src/ssm/mssm09.f b/sammy/src/ssm/mssm09.f90
similarity index 72%
rename from sammy/src/ssm/mssm09.f
rename to sammy/src/ssm/mssm09.f90
index 88ffe9339..0c1531a3d 100644
--- a/sammy/src/ssm/mssm09.f
+++ b/sammy/src/ssm/mssm09.f90
@@ -1,39 +1,41 @@
-C
-C
-C -----------------------------------------------------------------
-C
+!
+module ssm_9_m
+ contains
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Limit (Energb, E1, E2, Rmass, I1, Iie, Imin)
-C
-C *** Purpose -- find limits E1=E*((M-1)/(M+1))**2
-C *** E2=E*((M-1)/(M+1))
-C *** I1=grid Number just above E1
-C *** I2=grid Number just below E2
-C
+!
+! *** Purpose -- find limits E1=E*((M-1)/(M+1))**2
+! *** E2=E*((M-1)/(M+1))
+! *** I1=grid Number just above E1
+! *** I2=grid Number just below E2
+!
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Energb(*)
DATA One /1.0d0/
-C
+!
E = Energb(Iie)
A = (Rmass-One) / (Rmass+One)
E2 = E*A
E1 = E2*A
-C
+!
Nnn = Iie - Imin + 1
CALL Findpr (Nnn, K)
CALL Where (Energb(Imin), E1, K, Nnn, Nwhere)
I1 = Imin + Nwhere - 1
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj, Ientrp,
- * Kdatb, Nn, Idone)
-C
-C *** Purpose -- Find total cross section Totalp at energy Ep
-C *** using linear interpolation only
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Get_Totalp_Lin (Energb, Totsig, Exp1, Ep, Jj, Ientrp, &
+ Kdatb, Nn, Idone)
+!
+! *** Purpose -- Find total cross section Totalp at energy Ep
+! *** using linear interpolation only
+!
use fixedi_m
use ifwrit_m
use ssssss_common_m
@@ -41,7 +43,7 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Totsig(*), Energb(*)
DATA Zero /0.0d0/
-C
+!
IF (Ientrp.NE.0) THEN
Ii = Ientrp
Intrp = 0
@@ -67,24 +69,23 @@ C
20 CONTINUE
END IF
Iep = Ii
-C
-C
+!
+!
IF (Intrp.EQ.0) THEN
-C
-C *** Here get cross sections when Ep=Energb(Iep) or when Iep=1 or
-C *** Iep=Nn, so must use constant value
+!
+! *** Here get cross sections when Ep=Energb(Iep) or when Iep=1 or
+! *** Iep=Nn, so must use constant value
Totalp = Totsig(Iep)
-C
+!
ELSE
IF (Iep.GT.0 .AND. Iep.LT.Kdatb) THEN
-C *** Here Energb(Iep) < Ep < Energb(Iep+1)
-C *** so get cross section at E'=Ep via linear interpolation
+! *** Here Energb(Iep) < Ep < Energb(Iep+1)
+! *** so get cross section at E'=Ep via linear interpolation
A = Energb(Iep+1) - Ep
B = Ep - Energb(Iep)
IF (A.LT.Zero .OR. B.LT.Zero) THEN
WRITE (6,10000) Iep, Energb(Iep), Ep, Energb(Iep+1)
-10000 FORMAT (' Interpolation problem in Get_Totalp_Lin', I5,
- * 1P3G14.7)
+10000 FORMAT (' Interpolation problem in Get_Totalp_Lin', I5, 1P3G14.7)
STOP '[STOP in Get_Totalp_Lin in ssm/mssm09.f]'
END IF
C = Energb(Iep+1) - Energb(Iep)
@@ -95,22 +96,22 @@ C *** so get cross section at E'=Ep via linear interpolation
Antrp2 = A
Antrp3 = B
Antrp4 = Zero
-C
+!
END IF
END IF
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj, Ientrp,
- * Kdatb, Nn, Idone, Not_Quad)
-C
-C *** Purpose -- Find total cross section Totalp at energy Ep using
-C *** quadratic interpolation wherever possible
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Get_Totalp_Quad (Energb, Totsig, Exp1, Ep, Jj, Ientrp, &
+ Kdatb, Nn, Idone, Not_Quad)
+!
+! *** Purpose -- Find total cross section Totalp at energy Ep using
+! *** quadratic interpolation wherever possible
+!
use fixedi_m
use ifwrit_m
use ssssss_common_m
@@ -118,7 +119,7 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Totsig(*), Energb(*)
DATA Zero /0.0d0/, Half /0.5d0/
-C
+!
Not_Quad = 0
IF (Ientrp.NE.0) THEN
Ii = Ientrp
@@ -145,20 +146,20 @@ C
20 CONTINUE
END IF
Iep = Ii
-C
-C
+!
+!
IF (Intrp.EQ.0) THEN
-C
-C *** Here get cross sections when Ep=Energb(Iep) or when Iep=1 or
-C *** Iep=Nn, so must use constant value
+!
+! *** Here get cross sections when Ep=Energb(Iep) or when Iep=1 or
+! *** Iep=Nn, so must use constant value
Totalp = Totsig(Iep)
-C
+!
ELSE
IF (Iep.GT.1 .AND. Iep.LT.Kdatb-1) THEN
-C ================================================================
-C *** Here Energb(Iep) < Ep < Energb(Iep+1) and 1<Iep<Kdatb-1
-C *** so get cross section at E'=Ep via two
-C *** quadratic interpolations
+! ================================================================
+! *** Here Energb(Iep) < Ep < Energb(Iep+1) and 1<Iep<Kdatb-1
+! *** so get cross section at E'=Ep via two
+! *** quadratic interpolations
A3 = Energb(Iep+2) - Ep
A2 = Energb(Iep+1) - Ep
A1 = Ep - Energb(Iep )
@@ -169,13 +170,13 @@ C *** quadratic interpolations
C20 = Energb(Iep+1) - Energb(Iep-1)
C10 = Energb(Iep ) - Energb(Iep-1)
B0 = - A2/C20 * A1/C10 * Half
- B1 = A2/C21 * A0/C10 * Half
- * + A3/C31 * A2/C21 * Half
- B2 = A1/C21 * A0/C20 * Half
- * + A3/C32 * A1/C21 * Half
+ B1 = A2/C21 * A0/C10 * Half &
+ + A3/C31 * A2/C21 * Half
+ B2 = A1/C21 * A0/C20 * Half &
+ + A3/C32 * A1/C21 * Half
B3 = - A2/C32 * A1/C31 * Half
- Totalp = B1*Totsig(Iep ) + B2*Totsig(Iep+1)
- * + B0*Totsig(Iep-1) + B3*Totsig(Iep+2)
+ Totalp = B1*Totsig(Iep ) + B2*Totsig(Iep+1) &
+ + B0*Totsig(Iep-1) + B3*Totsig(Iep+2)
Antrp1 = B0
Antrp2 = B1
Antrp3 = B2
@@ -193,16 +194,15 @@ C *** quadratic interpolations
Antrp3 = B
Antrp4 = Zero
END IF
-C ================================================================
+! ================================================================
ELSE
-C *** Here Energb(Iep) < Ep < Energb(Iep+1) and 1=Iep or Iep=Kdatb-1
-C *** so get cross section at E'=Ep via linear interpolation
+! *** Here Energb(Iep) < Ep < Energb(Iep+1) and 1=Iep or Iep=Kdatb-1
+! *** so get cross section at E'=Ep via linear interpolation
A = Energb(Iep+1) - Ep
B = Ep - Energb(Iep)
IF (A.LT.Zero .OR. B.LT.Zero) THEN
WRITE (6,10000) Iep, Energb(Iep), Ep, Energb(Iep+1)
-10000 FORMAT (' Interpolation problem in Get_Totalp_Quad', I5,
- * 1P3G14.7)
+10000 FORMAT (' Interpolation problem in Get_Totalp_Quad', I5, 1P3G14.7)
STOP '[STOP in Get_Totalp_Quad in ssm/mssm09.f]'
END IF
C = Energb(Iep+1) - Energb(Iep)
@@ -213,53 +213,53 @@ C *** so get cross section at E'=Ep via linear interpolation
Antrp2 = A
Antrp3 = B
Antrp4 = Zero
-C
+!
END IF
END IF
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Getggg (Exp1, Ggg)
-C
-C *** Purpose -- Find Ggg, which is the value of the exponential piece
-C *** of integrand when edge effects are neglected
-C *** Ggg = ( [1-e]/Total + [e-e']/[d] )
-C
+!
+! *** Purpose -- Find Ggg, which is the value of the exponential piece
+! *** of integrand when edge effects are neglected
+! *** Ggg = ( [1-e]/Total + [e-e']/[d] )
+!
use fixedi_m
use ifwrit_m
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Ggg = Zero
-C
-C *** exactly forward
+!
+! *** exactly forward
IF (Costhe.EQ.One) THEN
Ggg = ( One - Exp1*(1.0d0+Dthick*Total) ) /Total
-C
+!
ELSE
D = Total*Costhe - Totalp
Sn = Dthick*Total
-C
+!
IF (Sn.LT.0.3d0) THEN
Abc = Abcexp (-Sn, Ax, Bxxxxx, Cxxxxx, Dxxxxx, Ijklmn)
Ax = Ax*Dthick
ELSE
Ax = (One-Exp1)/Total
END IF
-C
+!
IF (Costhe.EQ.Zero) THEN
-C *** ----- sideways exactly
+! *** ----- sideways exactly
Ggg = Ax
ELSE
Dn = Dthick*D/Costhe
IF (Costhe.GT.Zero) THEN
-C *** -------- forward
+! *** -------- forward
IF (dABS(Dn).LT.0.3d0) THEN
Abc = Abcexp (Dn, Ay, By, Cxxxxx, Dxxxxx, Ijklmn)
Ay = - Exp1*Dthick*Ay
@@ -269,7 +269,7 @@ C *** -------- forward
END IF
Ggg = Ax + Ay
ELSE
-C *** -------- backward
+! *** -------- backward
IF (dABS(Dn).LT.0.3d0) THEN
Abc = Abcexp (-Dn, Ay, By, Cxxxxx, Dxxxxx, Ijklmn)
Ay = - Dthick*Ay
@@ -282,18 +282,18 @@ C *** -------- backward
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Pickee (Energb, Ea, Eb, J1, J2, Kdatb)
-C
-C *** Purpose -- Choose the next value of E' to be included in the
-C *** grid for integrating over mu
-C
+!
+! *** Purpose -- Choose the next value of E' to be included in the
+! *** grid for integrating over mu
+!
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Energb(*)
-C
+!
J2 = 0
Jj = J1
DO J=Jj,Kdatb
@@ -304,43 +304,43 @@ C
RETURN
20 CONTINUE
J1 = J
-C
-C *** now have Energb(J1-1) < ea < Energb(J1)
-C
-C
+!
+! *** now have Energb(J1-1) < ea < Energb(J1)
+!
+!
Jj = J1
DO J=Jj,Kdatb
IF (Energb(J).GT.Eb) GO TO 40
END DO
J2 = Kdatb
RETURN
-C
+!
40 CONTINUE
J2 = J - 1
-C
-C *** Now have Energb(J1-1) < Ea < Energb(J1 )
-C *** and Energb(J2 ) < Eb < Energb(J2+1)
-C *** and Ea < Eb
-C *** and J2+1.GE.J1 => J2+1 > J1-1 => J2 > J1-2
-C
-C *** Note that J2 = J1-1 means there are no points k such that
-C *** Energb(J1-1=J2) <Ea < Energb(k) < Eb < Energb(J2+1=J1)
-C *** J2 = J1 means "Energb(J1-1) <Ea< Energb(J1) = Energb(J2) <Eb< Energb(J2+1)
-C *** J2 > J1 means "Energb(J1-1) <Ea< Energb(J1) < Energb(J2) <Eb< Energb(J2+1)
-C
+!
+! *** Now have Energb(J1-1) < Ea < Energb(J1 )
+! *** and Energb(J2 ) < Eb < Energb(J2+1)
+! *** and Ea < Eb
+! *** and J2+1.GE.J1 => J2+1 > J1-1 => J2 > J1-2
+!
+! *** Note that J2 = J1-1 means there are no points k such that
+! *** Energb(J1-1=J2) <Ea < Energb(k) < Eb < Energb(J2+1=J1)
+! *** J2 = J1 means "Energb(J1-1) <Ea< Energb(J1) = Energb(J2) <Eb< Energb(J2+1)
+! *** J2 > J1 means "Energb(J1-1) <Ea< Energb(J1) < Energb(J2) <Eb< Energb(J2+1)
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C I'm going to add more information and call another print routine
-C before the "Talk" routine is called for several cases that are
-C repeated in mssm module
+!
+!
+! -----------------------------------------------------------------
+! I'm going to add more information and call another print routine
+! before the "Talk" routine is called for several cases that are
+! repeated in mssm module
subroutine talk_kadd_gt_maxx(Kadd,Maxx,srcfile,interpType)
implicit none
- integer (kind=4) Kadd,Maxx
+ integer ( kind=4 ) Kadd,Maxx
character(len=12)::interpType
character(len=80)::srcfile
@@ -355,7 +355,7 @@ C repeated in mssm module
subroutine talk_kadd_and_lost_gt(Kadd,Lost,srcfile,interpType)
implicit none
- integer (kind=4) Kadd,Lost
+ integer ( kind=4 ) Kadd,Lost
character(len=12)::interpType
character(len=80)::srcfile
@@ -367,17 +367,16 @@ C repeated in mssm module
return
end
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Talk (Kadd, Maxx, Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew,
- * J1, J3, Csx, Epx, Ggx, Emind, Emins, Eminr, Energb, Totsig,
- * Nnnsig, Niniso, Nnpar, N, Iso, Kwhich)
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Talk (Kadd, Maxx, Em, Eb, Ea, Cosb, Cosa, Ggg, Gggnew, &
+ J1, J3, Csx, Epx, Ggx, Emind, Emins, Eminr, Energb, Totsig, &
+ Nnnsig, Niniso, Nnpar, N, Iso, Kwhich)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Csx(*), Epx(*), Ggx(*), Energb(*), Totsig(*)
WRITE (6,10100) Kadd, Maxx, Kwhich
-10100 FORMAT (' Trouble in mulsca: too many points needed, Kadd,Maxx=',
- * 3i5)
+10100 FORMAT (' Trouble in mulsca: too many points needed, Kadd,Maxx=', 3i5)
WRITE (6,10200) Em, Eb, Ea
WRITE (6,10300) Cosb, Cosa
10200 FORMAT (' Em,Eb,Ea =', 1P6G14.6)
@@ -401,17 +400,17 @@ C
60010 FORMAT (' Nnnsig,Niniso,Nnpar,N,Iso=', 5I5)
STOP '[STOP in Talk in ssm/mssm09.f]'
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Ssum_1 (Dyyy1, Dyy1xx, Yyy1, Yyy1xx, W)
-C
+!
use fixedi_m
use ifwrit_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Dyyy1(*), Dyy1xx(*)
-C
+!
Yyy1 = Yyy1 + Yyy1xx*W
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
DO J=1,Nnpar
@@ -420,24 +419,24 @@ C
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ssum_2 (Dyyy2, Dyyy2q, Dyy2qq, Dyy2xx, Dyy2xq, Dy2xqq,
- * Dy2bbb, Dy2bbq, Dy2bqq, Dy2aaa, Dy2aaq, Dy2aqq, Yyy2, Yyy2q,
- * Yyy2xx, Yyy2xq, Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ssum_2 (Dyyy2, Dyyy2q, Dyy2qq, Dyy2xx, Dyy2xq, Dy2xqq, &
+ Dy2bbb, Dy2bbq, Dy2bqq, Dy2aaa, Dy2aaq, Dy2aqq, Yyy2, Yyy2q, &
+ Yyy2xx, Yyy2xq, Y2bbbb, Y2bbbq, Y2aaaa, Y2aaaq, W, Idone)
+!
use fixedi_m
use ifwrit_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Dyyy2(*), Dyyy2q(*), Dyy2qq(*), Dyy2xx(*), Dyy2xq(*),
- * Dy2xqq(*), Dy2bbb(*), Dy2bbq(*), Dy2bqq(*), Dy2aaa(*),
- * Dy2aaq(*), Dy2aqq(*)
+ DIMENSION Dyyy2(*), Dyyy2q(*), Dyy2qq(*), Dyy2xx(*), Dyy2xq(*), &
+ Dy2xqq(*), Dy2bbb(*), Dy2bbq(*), Dy2bqq(*), Dy2aaa(*), &
+ Dy2aaq(*), Dy2aqq(*)
DATA Zero /0.0d0/
-C
+!
IF (Idone.NE.3) THEN
-C *** Here if calculating Y2, not just pieces for it
+! *** Here if calculating Y2, not just pieces for it
Yyy2 = Yyy2 + Yyy2xx*W
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
DO J=1,Nnpar
@@ -454,8 +453,8 @@ C *** Here if calculating Y2, not just pieces for it
END IF
END IF
END IF
-C
-C *** Here we set up inner loop for second, third, fourth, ... scatter
+!
+! *** Here we set up inner loop for second, third, fourth, ... scatter
Y2bbbb = Y2bbbb + Y2aaaa*W
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
DO J=1,Nnpar
@@ -471,30 +470,32 @@ C *** Here we set up inner loop for second, third, fourth, ... scatter
END DO
END IF
END IF
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Testx (Em, E1, E2, Eb, Sumw, Kaddm, Lost, Kountr,Nn,I1)
use constn_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Two /2.0d0/
-C
+!
IF (Kaddm.GT.10) THEN
WRITE (6,30000) Em, Kaddm
30000 FORMAT (' Energy, Kaddm=', 1pg14.6, I10)
Lost = Lost + 1
END IF
-C
+!
IF (Dabs(Sumw-Two).GT.0.0002d0) THEN
Kountr = Kountr + 1
WRITE (6,50000) Kountr, I1, Nn, E1, E2, Eb, Sumw
50000 FORMAT (' Kountr, I1,N =', 3i5, /' E1,E2,E,Sumw=', 4F12.3)
END IF
IF (Kountr.GT.5) STOP '[STOP in Testx in ssm/mssm09.f]'
-C
+!
RETURN
END
+
+end module ssm_9_m
diff --git a/sammy/src/ssm/mssm10.f b/sammy/src/ssm/mssm10.f90
similarity index 55%
rename from sammy/src/ssm/mssm10.f
rename to sammy/src/ssm/mssm10.f90
index 641ead906..672e011c9 100644
--- a/sammy/src/ssm/mssm10.f
+++ b/sammy/src/ssm/mssm10.f90
@@ -1,39 +1,41 @@
-C
-C
-C -----------------------------------------------------------------
-C
+!
+module ssm_10_m
+ contains
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Trptot_Lin (Xtpt_V, Sqfb, Qfb, Dqfb, Vvv, Nxtptvm, Em)
-C
-C *** log-log interpolation on Sqfb(Jfb,Jsig_V,Ksig_W,Jth) to give
-C *** Qfb(Ksig_W,Jth,Jfb) at correct Vvv=Total
-C *** This version uses linear interpolation, not 4-point interpolation
-C
+!
+! *** log-log interpolation on Sqfb(Jfb,Jsig_V,Ksig_W,Jth) to give
+! *** Qfb(Ksig_W,Jth,Jfb) at correct Vvv=Total
+! *** This version uses linear interpolation, not 4-point interpolation
+!
use fixedi_m
use ifwrit_m
use MultScatPars_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Xtpt_V(*),
- * Sqfb(Nsqfb,Nxtptv,Nxtptw,Ntheta),
- * Qfb(Nxtptw,Ntheta,Nsqfb),
- * Dqfb(Nxtptw,Ntheta,2)
+ DIMENSION Xtpt_V(*), &
+ Sqfb(Nsqfb,Nxtptv,Nxtptw,Ntheta), &
+ Qfb(Nxtptw,Ntheta,Nsqfb), &
+ Dqfb(Nxtptw,Ntheta,2)
DATA One /1.0d0/
-C
+!
Tt = dLOG(Vvv)
CALL Where (Xtpt_V, Tt, Nxtptvm, Nxtptv, M)
-C *** Now we know that Xtpt_V(M) < log(Vvv) < Xtpt_V(M+1)
-C
+! *** Now we know that Xtpt_V(M) < log(Vvv) < Xtpt_V(M+1)
+!
Mm = M
A10 = Xtpt_V(Mm+1) - Xtpt_V(Mm)
D0a = (Xtpt_V(Mm+1)-Tt)/A10
D1a = (Tt-Xtpt_V(Mm ))/A10
-C
+!
DO Jfb=1,Nsqfb
DO Ltheta=1,multScat%getNumTheta()
DO Ksig=1,Nxtptw
- IF (Sqfb(Jfb,Mm ,Ksig,Ltheta).GT.-7999.9D0 .AND.
- * Sqfb(Jfb,Mm+1,Ksig,Ltheta).GT.-7999.9D0) THEN
- Q = D0a*Sqfb(Jfb,Mm ,Ksig,Ltheta)
- * + D1a*Sqfb(Jfb,Mm+1,Ksig,Ltheta)
+ IF (Sqfb(Jfb,Mm ,Ksig,Ltheta).GT.-7999.9D0 .AND. &
+ Sqfb(Jfb,Mm+1,Ksig,Ltheta).GT.-7999.9D0) THEN
+ Q = D0a*Sqfb(Jfb,Mm ,Ksig,Ltheta) &
+ + D1a*Sqfb(Jfb,Mm+1,Ksig,Ltheta)
ELSE
Q = -8000.0D0
END IF
@@ -41,20 +43,20 @@ C
END DO
END DO
END DO
-C
+!
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
D0a = -One/A10
D1a = One/A10
-C
-C *** Dqfb is logarithm of the negative of the derivative wrt v,
-C *** where v=sigma_total
+!
+! *** Dqfb is logarithm of the negative of the derivative wrt v,
+! *** where v=sigma_total
DO Jfb=1,2
DO Ltheta=1,multScat%getNumTheta()
DO Ksig=1,Nxtptw
- IF (Sqfb(Jfb,Mm ,Ksig,Ltheta).GT.-7999.9D0 .AND.
- * Sqfb(Jfb,Mm+1,Ksig,Ltheta).GT.-7999.9D0) THEN
- Q = D0a*Sqfb(Jfb,Mm ,Ksig,Ltheta)
- * + D1a*Sqfb(Jfb,Mm+1,Ksig,Ltheta)
+ IF (Sqfb(Jfb,Mm ,Ksig,Ltheta).GT.-7999.9D0 .AND. &
+ Sqfb(Jfb,Mm+1,Ksig,Ltheta).GT.-7999.9D0) THEN
+ Q = D0a*Sqfb(Jfb,Mm ,Ksig,Ltheta) &
+ + D1a*Sqfb(Jfb,Mm+1,Ksig,Ltheta)
Dqfb(Ksig,Ltheta,Jfb) = Q -Tt +Qfb(Ksig,Ltheta,Jfb)
ELSE
Dqfb(Ksig,Ltheta,Jfb) = -8000.0d0
@@ -65,74 +67,74 @@ C *** where v=sigma_total
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Trptot_Quad (Xtpt_V, Sqfb, Qfb, Dqfb, Vvv, Nxtptvm, Em)
-C
-C *** log-log interpolation on Sqfb(Jfb,Jsig_V,Ksig_W,Jth) to give
-C *** Qfb(Ksig_W,Jth,Jfb) at correct Vvv=Total
-C *** This version uses four-point interpolation scheme
-C *** (Takes more time, but should be more accurate)
-C
+!
+! *** log-log interpolation on Sqfb(Jfb,Jsig_V,Ksig_W,Jth) to give
+! *** Qfb(Ksig_W,Jth,Jfb) at correct Vvv=Total
+! *** This version uses four-point interpolation scheme
+! *** (Takes more time, but should be more accurate)
+!
use fixedi_m
use ifwrit_m
use MultScatPars_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Xtpt_V(*),
- * Sqfb(Nsqfb,Nxtptv,Nxtptw,Ntheta),
- * Qfb(Nxtptw,Ntheta,Nsqfb),
- * Dqfb(Nxtptw,Ntheta,2)
+ DIMENSION Xtpt_V(*), &
+ Sqfb(Nsqfb,Nxtptv,Nxtptw,Ntheta), &
+ Qfb(Nxtptw,Ntheta,Nsqfb), &
+ Dqfb(Nxtptw,Ntheta,2)
DATA Two /2.0d0/
-C
+!
Tt = dLOG(Vvv)
CALL Where (Xtpt_V, Tt, Nxtptvm, Nxtptv, M)
-C *** Now we know that Xtpt_V(M) < log(Vvv) < Xtpt_V(M+1)
-C
+! *** Now we know that Xtpt_V(M) < log(Vvv) < Xtpt_V(M+1)
+!
M = M - 1
IF (M.EQ.0) THEN
M = 1
ELSE IF (M.EQ.Nxtptv-2) THEN
M = Nxtptv - 3
END IF
-C *** Use four-point interpolation with M, M+1, M+2, and M+3
+! *** Use four-point interpolation with M, M+1, M+2, and M+3
Mm = M
A10 = Xtpt_V(Mm+1) - Xtpt_V(Mm)
A21 = Xtpt_V(Mm+2) - Xtpt_V(Mm+1)
A20 = Xtpt_V(Mm+2) - Xtpt_V(Mm)
A31 = Xtpt_V(Mm+3) - Xtpt_V(Mm+1)
A32 = Xtpt_V(Mm+3) - Xtpt_V(Mm+2)
-C
+!
D0a = ((Xtpt_V(Mm+2)-Tt)/A20) * ((Xtpt_V(Mm+1)-Tt)/A10)
D1a = ((Xtpt_V(Mm+2)-Tt)/A21) * ((Tt-Xtpt_V(Mm ))/A10)
D2a = ((Tt-Xtpt_V(Mm+1))/A21) * ((Tt-Xtpt_V(Mm ))/A20)
D1b = ((Xtpt_V(Mm+3)-Tt)/A31) * ((Xtpt_V(Mm+2)-Tt)/A21)
D2b = ((Xtpt_V(Mm+3)-Tt)/A32) * ((Tt-Xtpt_V(Mm+1))/A21)
D3b = ((Tt-Xtpt_V(Mm+2))/A32) * ((Tt-Xtpt_V(Mm+1))/A31)
-C
+!
DO Jfb=1,Nsqfb
DO Ltheta=1,multScat%getNumTheta()
DO Ksig=1,Nxtptw
- IF (Sqfb(Jfb,Mm ,Ksig,Ltheta).GT.-8000.0D0 .AND.
- * Sqfb(Jfb,Mm+1,Ksig,Ltheta).GT.-8000.0D0 .AND.
- * Sqfb(Jfb,Mm+2,Ksig,Ltheta).GT.-8000.0D0) THEN
- Q = D0a*Sqfb(Jfb,Mm ,Ksig,Ltheta)
- * + D1a*Sqfb(Jfb,Mm+1,Ksig,Ltheta)
- * + D2a*Sqfb(Jfb,Mm+2,Ksig,Ltheta)
+ IF (Sqfb(Jfb,Mm ,Ksig,Ltheta).GT.-8000.0D0 .AND. &
+ Sqfb(Jfb,Mm+1,Ksig,Ltheta).GT.-8000.0D0 .AND. &
+ Sqfb(Jfb,Mm+2,Ksig,Ltheta).GT.-8000.0D0) THEN
+ Q = D0a*Sqfb(Jfb,Mm ,Ksig,Ltheta) &
+ + D1a*Sqfb(Jfb,Mm+1,Ksig,Ltheta) &
+ + D2a*Sqfb(Jfb,Mm+2,Ksig,Ltheta)
IF (Sqfb(Jfb,Mm+3,Ksig,Ltheta).GT.-8000.0D0) THEN
- Q = Q + D1b*Sqfb(Jfb,Mm+1,Ksig,Ltheta)
- * + D2b*Sqfb(Jfb,Mm+2,Ksig,Ltheta)
- * + D3b*Sqfb(Jfb,Mm+3,Ksig,Ltheta)
+ Q = Q + D1b*Sqfb(Jfb,Mm+1,Ksig,Ltheta) &
+ + D2b*Sqfb(Jfb,Mm+2,Ksig,Ltheta) &
+ + D3b*Sqfb(Jfb,Mm+3,Ksig,Ltheta)
Q = Q/Two
ELSE
END IF
- ELSE IF (Sqfb(Jfb,Mm+1,Ksig,Ltheta).GT.-8000.0D0 .AND.
- * Sqfb(Jfb,Mm+2,Ksig,Ltheta).GT.-8000.0D0 .AND.
- * Sqfb(Jfb,Mm+3,Ksig,Ltheta).GT.-8000.0D0) THEN
- Q = D1b*Sqfb(Jfb,Mm+1,Ksig,Ltheta)
- * + D2b*Sqfb(Jfb,Mm+2,Ksig,Ltheta)
- * + D3b*Sqfb(Jfb,Mm+3,Ksig,Ltheta)
+ ELSE IF (Sqfb(Jfb,Mm+1,Ksig,Ltheta).GT.-8000.0D0 .AND. &
+ Sqfb(Jfb,Mm+2,Ksig,Ltheta).GT.-8000.0D0 .AND. &
+ Sqfb(Jfb,Mm+3,Ksig,Ltheta).GT.-8000.0D0) THEN
+ Q = D1b*Sqfb(Jfb,Mm+1,Ksig,Ltheta) &
+ + D2b*Sqfb(Jfb,Mm+2,Ksig,Ltheta) &
+ + D3b*Sqfb(Jfb,Mm+3,Ksig,Ltheta)
ELSE
Q = -8000.0D0
END IF
@@ -140,7 +142,7 @@ C
END DO
END DO
END DO
-C
+!
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
D0a = ( Two*Tt-Xtpt_V(Mm+2)-Xtpt_V(Mm+1))/(A10*A20)
D1a = (-Two*Tt+Xtpt_V(Mm+2)+Xtpt_V(Mm ))/(A10*A21)
@@ -148,32 +150,32 @@ C
D1b = ( Two*Tt-Xtpt_V(Mm+3)-Xtpt_V(Mm+2))/(A21*A31)
D2b = (-Two*Tt+Xtpt_V(Mm+3)+Xtpt_V(Mm+1))/(A21*A32)
D3b = ( Two*Tt-Xtpt_V(Mm+2)-Xtpt_V(Mm+1))/(A31*A32)
-C
-C *** Dqfb is logarithm of the negative of the derivative wrt v,
-C *** where v=sigma_total
+!
+! *** Dqfb is logarithm of the negative of the derivative wrt v,
+! *** where v=sigma_total
DO Jfb=1,2
DO Ltheta=1,multScat%getNumTheta()
DO Ksig=1,Nxtptw
- IF (Sqfb(Jfb,Mm ,Ksig,Ltheta).GT.-8000.0D0 .AND.
- * Sqfb(Jfb,Mm+1,Ksig,Ltheta).GT.-8000.0D0 .AND.
- * Sqfb(Jfb,Mm+2,Ksig,Ltheta).GT.-8000.0D0) THEN
- Q = D0a*Sqfb(Jfb,Mm ,Ksig,Ltheta)
- * + D1a*Sqfb(Jfb,Mm+1,Ksig,Ltheta)
- * + D2a*Sqfb(Jfb,Mm+2,Ksig,Ltheta)
+ IF (Sqfb(Jfb,Mm ,Ksig,Ltheta).GT.-8000.0D0 .AND. &
+ Sqfb(Jfb,Mm+1,Ksig,Ltheta).GT.-8000.0D0 .AND. &
+ Sqfb(Jfb,Mm+2,Ksig,Ltheta).GT.-8000.0D0) THEN
+ Q = D0a*Sqfb(Jfb,Mm ,Ksig,Ltheta) &
+ + D1a*Sqfb(Jfb,Mm+1,Ksig,Ltheta) &
+ + D2a*Sqfb(Jfb,Mm+2,Ksig,Ltheta)
IF (Sqfb(Jfb,Mm+3,Ksig,Ltheta).GT.-8000.0D0) THEN
- Q = Q + D1b*Sqfb(Jfb,Mm+1,Ksig,Ltheta)
- * + D2b*Sqfb(Jfb,Mm+2,Ksig,Ltheta)
- * + D3b*Sqfb(Jfb,Mm+3,Ksig,Ltheta)
+ Q = Q + D1b*Sqfb(Jfb,Mm+1,Ksig,Ltheta) &
+ + D2b*Sqfb(Jfb,Mm+2,Ksig,Ltheta) &
+ + D3b*Sqfb(Jfb,Mm+3,Ksig,Ltheta)
Q = Q/Two
ELSE
END IF
Dqfb(Ksig,Ltheta,Jfb) = Q -Tt +Qfb(Ksig,Ltheta,Jfb)
- ELSE IF (Sqfb(Jfb,Mm+1,Ksig,Ltheta).GT.-8000.0D0 .AND.
- * Sqfb(Jfb,Mm+2,Ksig,Ltheta).GT.-8000.0D0 .AND.
- * Sqfb(Jfb,Mm+3,Ksig,Ltheta).GT.-8000.0D0) THEN
- Q = D1b*Sqfb(Jfb,Mm+1,Ksig,Ltheta)
- * + D2b*Sqfb(Jfb,Mm+2,Ksig,Ltheta)
- * + D3b*Sqfb(Jfb,Mm+3,Ksig,Ltheta)
+ ELSE IF (Sqfb(Jfb,Mm+1,Ksig,Ltheta).GT.-8000.0D0 .AND. &
+ Sqfb(Jfb,Mm+2,Ksig,Ltheta).GT.-8000.0D0 .AND. &
+ Sqfb(Jfb,Mm+3,Ksig,Ltheta).GT.-8000.0D0) THEN
+ Q = D1b*Sqfb(Jfb,Mm+1,Ksig,Ltheta) &
+ + D2b*Sqfb(Jfb,Mm+2,Ksig,Ltheta) &
+ + D3b*Sqfb(Jfb,Mm+3,Ksig,Ltheta)
Dqfb(Ksig,Ltheta,Jfb) = Q -Tt +Qfb(Ksig,Ltheta,Jfb)
ELSE
Dqfb(Ksig,Ltheta,Jfb) = -8000.0d0
@@ -184,19 +186,21 @@ C *** where v=sigma_total
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE W_Wssmsc (Yyy1, Dthick, Total, Wssmsc, Yyy1fb, Kwssms)
use constn_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Wssmsc(*), Yyy1fb(*)
-C
+!
IF (Kwssms.EQ.1) THEN
Wssmsc(5) = Yyy1*Pi/Dthick + Wssmsc(5)
Wssmsc(6) = (Yyy1fb(1)+Yyy1fb(2))*Total*Pi/Dthick + Wssmsc(6)
END IF
-C
+!
RETURN
END
+
+end module ssm_10_m
diff --git a/sammy/src/ssm/mssm11.f b/sammy/src/ssm/mssm11.f90
similarity index 53%
rename from sammy/src/ssm/mssm11.f
rename to sammy/src/ssm/mssm11.f90
index 0c09e3038..776a7c77d 100644
--- a/sammy/src/ssm/mssm11.f
+++ b/sammy/src/ssm/mssm11.f90
@@ -1,144 +1,148 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Finds_1il (A, Energb, Ccclll, Dddlll, Ftheta, Delas,
- * Dt, Dc, Totsig, Capsig, Dtotsi, Dcapsi, Rmass, Dyy1xx, Yyy1xx,
- * Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth,
- * Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
-C
+!
+module ssm_11_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Finds_1il (A, Energb, Ccclll, Dddlll, Ftheta, Delas, &
+ Dt, Dc, Totsig, Capsig, Dtotsi, Dcapsi, Rmass, Dyy1xx, Yyy1xx, &
+ Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth, &
+ Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
+!
use oops_common_m
use fixedi_m
use ifwrit_m
use logic_ssm_common_m
use ssssss_common_m
use xsect_x_common_m
+ use ssm_9_m
+ use ssm_12_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION A(-Msize:Msize)
- DIMENSION Energb(*), Ccclll(*), Dddlll(*), Ftheta(*), Delas(*),
- * Dt(*), Dc(*), Totsig(*), Capsig(*), Dtotsi(Nx,*), Dcapsi(Nx,*),
- * Rmass(*), Dyy1xx(*)
-C
+ DIMENSION Energb(*), Ccclll(*), Dddlll(*), Ftheta(*), Delas(*), &
+ Dt(*), Dc(*), Totsig(*), Capsig(*), Dtotsi(Nx,*), Dcapsi(Nx,*), &
+ Rmass(*), Dyy1xx(*)
+!
DATA Zero /0.0d0/
-C
+!
Izero = 1
Kv = Kvthck - Nvadif
-C
-C *** Find differential elastic scattering cross section Elas and
-C *** derivatives Delas at Energy Em and angle Theta
- CALL Xsect (Delas, Ccclll, Dddlll, Rmass(Iiso), Costhe,
- * Elas, Iiso)
-C
-C *** At energy E'=Ep, find capture cross section (Capt) and total cross
-C *** section (Totalp) & derivatives
- CALL Xsect21_Lin (Energb, Totsig, Capsig, Dtotsi, Dcapsi, Dt, Dc,
- * Ep, Jj, Nx, Ientrp, Kdatb, Nn)
+!
+! *** Find differential elastic scattering cross section Elas and
+! *** derivatives Delas at Energy Em and angle Theta
+ CALL Xsect (Delas, Ccclll, Dddlll, Rmass(Iiso), Costhe, Elas, Iiso)
+!
+! *** At energy E'=Ep, find capture cross section (Capt) and total cross
+! *** section (Totalp) & derivatives
+ CALL Xsect21_Lin (Energb, Totsig, Capsig, Dtotsi, Dcapsi, Dt, Dc, &
+ Ep, Jj, Nx, Ientrp, Kdatb, Nn)
IF (Capt.EQ.Zero .OR. Elas.EQ.Zero) THEN
Izero = 0
RETURN
END IF
-C
-C *** Generate pieces of the integrand when there are no edge effects
+!
+! *** Generate pieces of the integrand when there are no edge effects
CALL Getggg (Exp1, Ggg)
Egt = Elas*Ggg/Totalp
-C
+!
Ec = Elas*Capt
Ect = Ec/Totalp
-C
+!
Yyy1xx = Ect*Ggg
-C
+!
IF (Nnpar.NE.0 .AND. Ksolve.NE.2) THEN
-C *** Calculate pieces to add to deriv
+! *** Calculate pieces to add to deriv
CALL Getg_Derivatives (Exp1)
Cgt = Capt*Ggg/Totalp
Dp = Ect* ( Dggbdp - Ggg/Totalp )
Ds = Ect* ( Dggads + Dggbds )
DO J=1,Nnpar
IF (J.NE.Kv) THEN
- Dyy1xx(J) = Delas(J) *Cgt + Dc(J)*Egt +
- * Dtotsi(J,Nn)*Ds + Dt(J)*Dp
+ Dyy1xx(J) = Delas(J) *Cgt + Dc(J)*Egt + &
+ Dtotsi(J,Nn)*Ds + Dt(J)*Dp
END IF
END DO
IF (Kvthck.GT.0) Dyy1xx(Kv) = Ect*(Dggadn+Dggbdn)
END IF
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Finds_1iq (A, Energb, Ccclll, Dddlll, Ftheta, Delas,
- * Dt, Dc, Totsig, Capsig, Dtotsi, Dcapsi, Rmass, Dyy1xx, Yyy1xx,
- * Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth,
- * Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Finds_1iq (A, Energb, Ccclll, Dddlll, Ftheta, Delas, &
+ Dt, Dc, Totsig, Capsig, Dtotsi, Dcapsi, Rmass, Dyy1xx, Yyy1xx, &
+ Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth, &
+ Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
+!
use oops_common_m
use fixedi_m
use ifwrit_m
use logic_ssm_common_m
use ssssss_common_m
use xsect_x_common_m
+ use ssm_9_m
+ use ssm_12_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION A(-Msize:Msize)
- DIMENSION Energb(*), Ccclll(*), Dddlll(*), Ftheta(*), Delas(*),
- * Dt(*), Dc(*), Totsig(*), Capsig(*), Dtotsi(Nx,*), Dcapsi(Nx,*),
- * Rmass(*), Dyy1xx(*)
-C
+ DIMENSION Energb(*), Ccclll(*), Dddlll(*), Ftheta(*), Delas(*), &
+ Dt(*), Dc(*), Totsig(*), Capsig(*), Dtotsi(Nx,*), Dcapsi(Nx,*), &
+ Rmass(*), Dyy1xx(*)
+!
DATA Zero /0.0d0/
-C
+!
Izero = 1
Kv = Kvthck - Nvadif
-C
-C *** Find differential elastic scattering cross section Elas and
-C *** derivatives Delas at Energy Em and angle Theta
- CALL Xsect (Delas, Ccclll, Dddlll, Rmass(Iiso), Costhe,
- * Elas, Iiso)
-C
-C *** At energy E'=Ep, find capture cross section (Capt) and total cross
-C *** section (Totalp) & derivatives
- CALL Xsect21_Quad (Energb, Totsig, Capsig, Dtotsi, Dcapsi, Dt, Dc,
- * Ep, Jj, Nx, Ientrp, Kdatb, Nn)
+!
+! *** Find differential elastic scattering cross section Elas and
+! *** derivatives Delas at Energy Em and angle Theta
+ CALL Xsect (Delas, Ccclll, Dddlll, Rmass(Iiso), Costhe, Elas, Iiso)
+!
+! *** At energy E'=Ep, find capture cross section (Capt) and total cross
+! *** section (Totalp) & derivatives
+ CALL Xsect21_Quad (Energb, Totsig, Capsig, Dtotsi, Dcapsi, Dt, Dc, &
+ Ep, Jj, Nx, Ientrp, Kdatb, Nn)
IF (Capt.EQ.Zero .OR. Elas.EQ.Zero) THEN
Izero = 0
RETURN
END IF
-C
-C *** Generate pieces of the integrand when there are no edge effects
+!
+! *** Generate pieces of the integrand when there are no edge effects
CALL Getggg (Exp1, Ggg)
Egt = Elas*Ggg/Totalp
-C
+!
Ec = Elas*Capt
Ect = Ec/Totalp
-C
+!
Yyy1xx = Ect*Ggg
-C
+!
IF (Nnpar.NE.0 .AND. Ksolve.NE.2) THEN
-C *** Calculate pieces to add to deriv
+! *** Calculate pieces to add to deriv
CALL Getg_Derivatives (Exp1)
Cgt = Capt*Ggg/Totalp
Dp = Ect* ( Dggbdp - Ggg/Totalp )
Ds = Ect* ( Dggads + Dggbds )
DO J=1,Nnpar
IF (J.NE.Kv) THEN
- Dyy1xx(J) = Delas(J) *Cgt + Dc(J)*Egt +
- * Dtotsi(J,Nn)*Ds + Dt(J)*Dp
+ Dyy1xx(J) = Delas(J) *Cgt + Dc(J)*Egt + &
+ Dtotsi(J,Nn)*Ds + Dt(J)*Dp
END IF
END DO
IF (Kvthck.GT.0) Dyy1xx(Kv) = Ect*(Dggadn+Dggbdn)
END IF
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Finds_1fl (A, Energb, Ccclll, Dddlll, Ftheta, Delas,
- * Dt, Dc, Totsig, Capsig, Dtotsi, Dcapsi, Rmass, Dyy1xx, Yyy1xx,
- * Yyy1zz, Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth,
- * Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Finds_1fl (A, Energb, Ccclll, Dddlll, Ftheta, Delas, &
+ Dt, Dc, Totsig, Capsig, Dtotsi, Dcapsi, Rmass, Dyy1xx, Yyy1xx, &
+ Yyy1zz, Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth, &
+ Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -146,66 +150,67 @@ C
use ssssss_common_m
use xsect_x_common_m
use MultScatPars_common_m
+ use ssm_utils_m
+ use ssm_9_m
+ use ssm_12_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION A(-Msize:Msize)
- DIMENSION Energb(*), Ccclll(*), Dddlll(*), Ftheta(*), Delas(*),
- * Dt(*), Dc(*), Totsig(*), Capsig(*), Dtotsi(Nx,*), Dcapsi(Nx,*),
- * Rmass(*), Dyy1xx(*)
-C
+ DIMENSION Energb(*), Ccclll(*), Dddlll(*), Ftheta(*), Delas(*), &
+ Dt(*), Dc(*), Totsig(*), Capsig(*), Dtotsi(Nx,*), Dcapsi(Nx,*), &
+ Rmass(*), Dyy1xx(*)
+!
DATA Zero /0.0d0/
-C
+!
Izero = 1
Kv = Kvthck - Nvadif
-C
-C *** Find differential elastic scattering cross section Elas and
-C *** derivatives Delas at Energy Em and angle Theta
- CALL Xsect (Delas, Ccclll, Dddlll, Rmass(Iiso), Costhe,
- * Elas, Iiso)
-C
-C *** At energy E'=Ep, find capture cross section (Capt) and total cross
-C *** section (Totalp) & derivatives
- CALL Xsect21_Lin (Energb, Totsig, Capsig, Dtotsi, Dcapsi, Dt, Dc,
- * Ep, Jj, Nx, Ientrp, Kdatb, Nn)
+!
+! *** Find differential elastic scattering cross section Elas and
+! *** derivatives Delas at Energy Em and angle Theta
+ CALL Xsect (Delas, Ccclll, Dddlll, Rmass(Iiso), Costhe, Elas, Iiso)
+!
+! *** At energy E'=Ep, find capture cross section (Capt) and total cross
+! *** section (Totalp) & derivatives
+ CALL Xsect21_Lin (Energb, Totsig, Capsig, Dtotsi, Dcapsi, Dt, Dc, &
+ Ep, Jj, Nx, Ientrp, Kdatb, Nn)
IF (Capt.EQ.Zero .OR. Elas.EQ.Zero) THEN
Izero = 0
RETURN
END IF
-C
-C *** Generate pieces of the integrand
+!
+! *** Generate pieces of the integrand
CALL Getggg (Exp1, Ggg)
Egt = Elas*Ggg/Totalp
-C
+!
Ec = Elas*Capt
Ect = Ec/Totalp
-C
+!
IF ( (Costhe.GE.Costh1) .OR. (Costhe.LE.-Costh1) ) THEN
-C *** Here for no edge effects
+! *** Here for no edge effects
Yyy1xx = Ect*Ggg
Yyy1zz = Zero
-C
+!
IF (Nnpar.NE.0 .AND. Ksolve.NE.2) THEN
-C *** Calculate pieces to add to deriv
+! *** Calculate pieces to add to deriv
CALL Getg_Derivatives (Exp1)
Cgt = Capt*Ggg/Totalp
Dp = Ect* ( Dggbdp - Ggg/Totalp )
Ds = Ect* ( Dggads + Dggbds )
DO J=1,Nnpar
IF (J.NE.Kv) THEN
- Dyy1xx(J) = Delas(J) *Cgt + Dc(J)*Egt +
- * Dtotsi(J,Nn)*Ds + Dt(J)*Dp
+ Dyy1xx(J) = Delas(J) *Cgt + Dc(J)*Egt + &
+ Dtotsi(J,Nn)*Ds + Dt(J)*Dp
END IF
END DO
IF (Kvthck.GT.0) Dyy1xx(Kv) = Ect*(Dggadn+Dggbdn)
END IF
-C
+!
ELSE
-C
-C *** Here do edge effects; numerical differentiation
-C *** Interpolate Costhe on Ftheta(Jth) and Totalp on Xtpt_W(Jsig)
-C *** to get Q = [Qfb at correct theta and E']
-C *** Intrp=0 => interpolate on Costhe; Intrp=1 => don't
- CALL X_Trpths_Lin (A, Ftheta, Knthet, Jfb, Jth, Itntrp, Nn,
- * Nxtptwn)
+!
+! *** Here do edge effects; numerical differentiation
+! *** Interpolate Costhe on Ftheta(Jth) and Totalp on Xtpt_W(Jsig)
+! *** to get Q = [Qfb at correct theta and E']
+! *** Intrp=0 => interpolate on Costhe; Intrp=1 => don't
+ CALL X_Trpths_Lin (A, Ftheta, Knthet, Jfb, Jth, Itntrp, Nn, Nxtptwn)
Gggb = Fz
if ( Totalp.lt.multScat%getLogSigmaTotMin() ) then
@@ -216,15 +221,15 @@ C *** Intrp=0 => interpolate on Costhe; Intrp=1 => don't
call multScat%setLogSigmaTotMax( Totalp )
Xtmax = Totalp ! remove
end if
-C
-C *** Figure piece to add to Yyy1; Note that Yyy1xx includes both
-C *** infinite-slab term AND edge effects correction term.
-C *** Variable Yyy1zz stores difference between infinite slab & edge
-C *** for use in array Yyy1fb, which is for debug purposes only.
+!
+! *** Figure piece to add to Yyy1; Note that Yyy1xx includes both
+! *** infinite-slab term AND edge effects correction term.
+! *** Variable Yyy1zz stores difference between infinite slab & edge
+! *** for use in array Yyy1fb, which is for debug purposes only.
Ggg_Ab = Gggb
Yyy1xx = Ect*Gggb
-cz Yyy1zz = Ect*(Ggg-Gggb)
-C
+!z Yyy1zz = Ect*(Ggg-Gggb)
+!
Egt = Elas*Ggg_Ab/Totalp
IF (Nnpar.NE.0 .AND. Ksolve.NE.2) THEN
Cgt = Capt*Ggg_Ab/Totalp
@@ -232,27 +237,27 @@ C
Ds = Ect* (Dfz )
DO J=1,Nnpar
IF (J.NE.Kv) THEN
- Dyy1xx(J) = Delas(J) *Cgt + Dc(J)*Egt +
- * Dtotsi(J,Nn)*Ds + Dt(J)*Dp
+ Dyy1xx(J) = Delas(J) *Cgt + Dc(J)*Egt + &
+ Dtotsi(J,Nn)*Ds + Dt(J)*Dp
END IF
END DO
IF (Kvthck.GT.0) Dyy1xx(Kv) = Ect*Dnfz
END IF
-C
-C *** finished edge-effects
+!
+! *** finished edge-effects
END IF
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Finds_1fq (A, Energb, Ccclll, Dddlll, Ftheta, Delas,
- * Dt, Dc, Totsig, Capsig, Dtotsi, Dcapsi, Rmass, Dyy1xx, Yyy1xx,
- * Yyy1zz, Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth,
- * Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Finds_1fq (A, Energb, Ccclll, Dddlll, Ftheta, Delas, &
+ Dt, Dc, Totsig, Capsig, Dtotsi, Dcapsi, Rmass, Dyy1xx, Yyy1xx, &
+ Yyy1zz, Exp1, Ep, Ggg, Iiso, Nx, Jj, Ientrp, Itntrp, Jfb, Jth, &
+ Knthet, Nn, Kdatb, Izero, Idone, Nxtptwn)
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -260,66 +265,67 @@ C
use ssssss_common_m
use xsect_x_common_m
use MultScatPars_common_m
+ use ssm_utils_m
+ use ssm_9_m
+ use ssm_12_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION A(-Msize:Msize)
- DIMENSION Energb(*), Ccclll(*), Dddlll(*), Ftheta(*), Delas(*),
- * Dt(*), Dc(*), Totsig(*), Capsig(*), Dtotsi(Nx,*), Dcapsi(Nx,*),
- * Rmass(*), Dyy1xx(*)
-C
+ DIMENSION Energb(*), Ccclll(*), Dddlll(*), Ftheta(*), Delas(*), &
+ Dt(*), Dc(*), Totsig(*), Capsig(*), Dtotsi(Nx,*), Dcapsi(Nx,*), &
+ Rmass(*), Dyy1xx(*)
+!
DATA Zero /0.0d0/
-C
+!
Izero = 1
Kv = Kvthck - Nvadif
-C
-C *** Find differential elastic scattering cross section Elas and
-C *** derivatives Delas at Energy Em and angle Theta
- CALL Xsect (Delas, Ccclll, Dddlll, Rmass(Iiso), Costhe,
- * Elas, Iiso)
-C
-C *** At energy E'=Ep, find capture cross section (Capt) and total cross
-C *** section (Totalp) & derivatives
- CALL Xsect21_Quad (Energb, Totsig, Capsig, Dtotsi, Dcapsi, Dt, Dc,
- * Ep, Jj, Nx, Ientrp, Kdatb, Nn)
+!
+! *** Find differential elastic scattering cross section Elas and
+! *** derivatives Delas at Energy Em and angle Theta
+ CALL Xsect (Delas, Ccclll, Dddlll, Rmass(Iiso), Costhe, Elas, Iiso)
+!
+! *** At energy E'=Ep, find capture cross section (Capt) and total cross
+! *** section (Totalp) & derivatives
+ CALL Xsect21_Quad (Energb, Totsig, Capsig, Dtotsi, Dcapsi, Dt, Dc, &
+ Ep, Jj, Nx, Ientrp, Kdatb, Nn)
IF (Capt.EQ.Zero .OR. Elas.EQ.Zero) THEN
Izero = 0
RETURN
END IF
-C
-C *** Generate pieces of the integrand
+!
+! *** Generate pieces of the integrand
CALL Getggg (Exp1, Ggg)
Egt = Elas*Ggg/Totalp
-C
+!
Ec = Elas*Capt
Ect = Ec/Totalp
-C
+!
IF ( (Costhe.GE.Costh1) .OR. (Costhe.LE.-Costh1) ) THEN
-C *** Here for no edge effects
+! *** Here for no edge effects
Yyy1xx = Ect*Ggg
Yyy1zz = Zero
-C
+!
IF (Nnpar.NE.0 .AND. Ksolve.NE.2) THEN
-C *** Calculate pieces to add to deriv
+! *** Calculate pieces to add to deriv
CALL Getg_Derivatives (Exp1)
Cgt = Capt*Ggg/Totalp
Dp = Ect* ( Dggbdp - Ggg/Totalp )
Ds = Ect* ( Dggads + Dggbds )
DO J=1,Nnpar
IF (J.NE.Kv) THEN
- Dyy1xx(J) = Delas(J) *Cgt + Dc(J)*Egt +
- * Dtotsi(J,Nn)*Ds + Dt(J)*Dp
+ Dyy1xx(J) = Delas(J) *Cgt + Dc(J)*Egt + &
+ Dtotsi(J,Nn)*Ds + Dt(J)*Dp
END IF
END DO
IF (Kvthck.GT.0) Dyy1xx(Kv) = Ect*(Dggadn+Dggbdn)
END IF
-C
+!
ELSE
-C
-C *** Here do edge effects; numerical differentiation
-C *** Interpolate Costhe on Ftheta(Jth) and Totalp on Xtpt_W(Jsig)
-C *** to get Q = [Qfb at correct theta and E']
-C *** Intrp=0 => interpolate on Costhe; Intrp=1 => don't
- CALL X_Trpths_Quad (A, Ftheta, Knthet, Jfb, Jth, Itntrp, Nn,
- * Nxtptwn)
+!
+! *** Here do edge effects; numerical differentiation
+! *** Interpolate Costhe on Ftheta(Jth) and Totalp on Xtpt_W(Jsig)
+! *** to get Q = [Qfb at correct theta and E']
+! *** Intrp=0 => interpolate on Costhe; Intrp=1 => don't
+ CALL X_Trpths_Quad (A, Ftheta, Knthet, Jfb, Jth, Itntrp, Nn, Nxtptwn)
Gggb = Fz
if ( Totalp.lt.multScat%getLogSigmaTotMin() ) then
@@ -330,15 +336,15 @@ C *** Intrp=0 => interpolate on Costhe; Intrp=1 => don't
call multScat%setLogSigmaTotMax( Totalp )
Xtmax = Totalp ! remove
end if
-C
-C *** Figure piece to add to Yyy1; Note that Yyy1xx includes both
-C *** infinite-slab term AND edge effects correction term.
-C *** Variable Yyy1zz stores difference between infinite slab & edge
-C *** for use in array Yyy1fb, which is for debug purposes only.
+!
+! *** Figure piece to add to Yyy1; Note that Yyy1xx includes both
+! *** infinite-slab term AND edge effects correction term.
+! *** Variable Yyy1zz stores difference between infinite slab & edge
+! *** for use in array Yyy1fb, which is for debug purposes only.
Ggg_Ab = Gggb
Yyy1xx = Ect*Gggb
-cz Yyy1zz = Ect*(Ggg-Gggb)
-C
+!z Yyy1zz = Ect*(Ggg-Gggb)
+!
Egt = Elas*Ggg_Ab/Totalp
IF (Nnpar.NE.0 .AND. Ksolve.NE.2) THEN
Cgt = Capt*Ggg_Ab/Totalp
@@ -346,15 +352,17 @@ C
Ds = Ect* (Dfz )
DO J=1,Nnpar
IF (J.NE.Kv) THEN
- Dyy1xx(J) = Delas(J) *Cgt + Dc(J)*Egt +
- * Dtotsi(J,Nn)*Ds + Dt(J)*Dp
+ Dyy1xx(J) = Delas(J) *Cgt + Dc(J)*Egt + &
+ Dtotsi(J,Nn)*Ds + Dt(J)*Dp
END IF
END DO
IF (Kvthck.GT.0) Dyy1xx(Kv) = Ect*Dnfz
END IF
-C
-C *** finished edge-effects
+!
+! *** finished edge-effects
END IF
-C
+!
RETURN
END
+
+end module ssm_11_m
\ No newline at end of file
diff --git a/sammy/src/ssm/mssm12.f b/sammy/src/ssm/mssm12.f90
similarity index 62%
rename from sammy/src/ssm/mssm12.f
rename to sammy/src/ssm/mssm12.f90
index a0bdec299..caf1ccd27 100644
--- a/sammy/src/ssm/mssm12.f
+++ b/sammy/src/ssm/mssm12.f90
@@ -1,33 +1,35 @@
-C
-C
-C -----------------------------------------------------------------
-C
+!
+module ssm_12_m
+ contains
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Xsect (Delas, Ccclll, Dddlll, Rmass, Costhe, Elas, Iso)
-C
-C *** Purpose -- Generate center-of-mass differential elastic cross
-C *** section for a fixed lab angle Theta (equivalent to
-C *** com angle Alpha), and convert the diff. el. cross
-C *** section to the lab
-C
+!
+! *** Purpose -- Generate center-of-mass differential elastic cross
+! *** section for a fixed lab angle Theta (equivalent to
+! *** com angle Alpha), and convert the diff. el. cross
+! *** section to the lab
+!
use fixedi_m
use ifwrit_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Ccclll(Nnnsig,*), Dddlll(Nnnsig,Nnparx,*), Delas(*)
DIMENSION Poly(20)
DATA Zero /0.0d0/, One /1.0D0/, Two /2.0D0/
-C
-C *** convert from theta to center-of-mass angle Cosalf=cos(Alpha)
+!
+! *** convert from theta to center-of-mass angle Cosalf=cos(Alpha)
Sinth2 = One - Costhe**2
A = Rmass**2 - Sinth2
B = DSQRT(A)
Cosalf = (Costhe*B-Sinth2)/Rmass
A = (Costhe**2+A)/B
Dadmu = (Two*Costhe+A)/Rmass
-C *** Double-checked December 2001; same formulae but different
-C *** programming for cosalf and dadmu as in mang1.f
-C
-C *** generate differential elastic cross section in c-o-m
-C *** first: the Legendre polynomials
+! *** Double-checked December 2001; same formulae but different
+! *** programming for cosalf and dadmu as in mang1.f
+!
+! *** generate differential elastic cross section in c-o-m
+! *** first: the Legendre polynomials
Poly(1) = One
IF (Lllmax.GT.1) THEN
Poly(2) = Cosalf
@@ -35,21 +37,20 @@ C *** first: the Legendre polynomials
DO LL=2,Lllmax-1
EL = dFLOAT(LL-1)
Twoel1 = Two*EL + One
- Poly(LL+1) = (Cosalf*Twoel1*Poly(LL) - EL*Poly(LL-1))/
- * (EL + One)
+ Poly(LL+1) = (Cosalf*Twoel1*Poly(LL) - EL*Poly(LL-1)) / (EL + One)
END DO
END IF
END IF
-C *** now: add them up
+! *** now: add them up
S = Zero
DO LL=1,Lllmax
S = S + Ccclll(LL,Iso)*Poly(LL)
END DO
-C
-C *** convert to lab ...
+!
+! *** convert to lab ...
Elas = S*Dadmu
-C
-C *** derivatives...
+!
+! *** derivatives...
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
DO J=1,Nnpar
Delas(J) = Zero
@@ -61,28 +62,28 @@ C *** derivatives...
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Xsect21_Lin (Energb, Totsig, Capsig, Dtotsi, Dcapsi,
- * Dt, Dc, Ep, Jj, Nx, Ientrp, Kdatb, Nn)
-C
-C *** Purpose -- Find total and capture cross sections & derivatives at
-C *** scattered energy Ep using linear interpolation.
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Xsect21_Lin (Energb, Totsig, Capsig, Dtotsi, Dcapsi, &
+ Dt, Dc, Ep, Jj, Nx, Ientrp, Kdatb, Nn)
+!
+! *** Purpose -- Find total and capture cross sections & derivatives at
+! *** scattered energy Ep using linear interpolation.
+!
use fixedi_m
use ifwrit_m
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Energb(*), Totsig(*), Capsig(*), Dtotsi(Nx,*),
- * Dcapsi(Nx,*), Dt(*), Dc(*)
-C
-C
+ DIMENSION Energb(*), Totsig(*), Capsig(*), Dtotsi(Nx,*), &
+ Dcapsi(Nx,*), Dt(*), Dc(*)
+!
+!
IF (Intrp.EQ.0) THEN
-C *** Here get cross sections and derivatives when Ep=Energb(Iep)
-C *** (Intrp=0), or when Iep=1, so must use constant value
+! *** Here get cross sections and derivatives when Ep=Energb(Iep)
+! *** (Intrp=0), or when Iep=1, so must use constant value
Totalp = Totsig(Iep)
Capt = Capsig(Iep)
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
@@ -93,16 +94,16 @@ C *** (Intrp=0), or when Iep=1, so must use constant value
Dc(J) = Dcapsi(J,Iep)
END DO
END IF
-C
+!
ELSE
-C
-C *** Here Energb(Iep) < Ep < Energb(Iep+1)
-C *** so get cross section at E'=Ep via linear interpolation
+!
+! *** Here Energb(Iep) < Ep < Energb(Iep+1)
+! *** so get cross section at E'=Ep via linear interpolation
A = Antrp2
B = Antrp3
Totalp = A*Totsig(Iep) + B*Totsig(Iep+1)
Capt = A*Capsig(Iep) + B*Capsig(Iep+1)
-C
+!
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
DO J=1,Nnpar
Dt(J) = A*Dtotsi(J,Iep) + B*Dtotsi(J,Iep+1)
@@ -111,129 +112,129 @@ C
Dc(J) = A*Dcapsi(J,Iep) + B*Dcapsi(J,Iep+1)
END DO
END IF
-C
+!
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Getg_Derivatives (Exp1)
-C
-C *** Purpose -- Generate pieces (Ggga and Gggb) of the integrand and
-C *** derivatives thereof for the infinite-slab situation.
-C *** This routine used only when derivatives are needed
-C
+!
+! *** Purpose -- Generate pieces (Ggga and Gggb) of the integrand and
+! *** derivatives thereof for the infinite-slab situation.
+! *** This routine used only when derivatives are needed
+!
use fixedi_m
use ifwrit_m
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/
-C
-C *** -- Calculate F_{zRphi}^(0) for all values of Costhe
+!
+! *** -- Calculate F_{zRphi}^(0) for all values of Costhe
Vv = Dthick*Total
IF (Vv.LT.0.3d0) THEN
-C *** *** Ggga = F_{zRphi}^(0) from Equation (D.12-14) in ssm manual
+! *** *** Ggga = F_{zRphi}^(0) from Equation (D.12-14) in ssm manual
Abc = Abcexp (-Vv, Ax, Bx, Cxxxxx, Dxxxxx, Ijklmn)
Ggga = Ax*Dthick
Dggads = (Bx-Ax)*Dthick**2
Dggadn = Abc
ELSE
-C *** *** Ggga = F_{zRphi}^(0) from Equation (D.7-9) in ssm manual
+! *** *** Ggga = F_{zRphi}^(0) from Equation (D.7-9) in ssm manual
Ggga = (One-Exp1)/Total
Dggads =(Dthick*Exp1-Ggga)/Total
Dggadn = Exp1
END IF
-C
-C *** -- Calculate F_{zRphi}^(1) for all values of Costhe (infinite-slab)
+!
+! *** -- Calculate F_{zRphi}^(1) for all values of Costhe (infinite-slab)
Gggb = Zero
Dggbds = Zero
Dggbdp = Zero
Dggbdn = Zero
D = Total*Costhe - Totalp
-C
+!
IF (Costhe.EQ.One) THEN
-C *** ----- exactly forward
-C *** *** Gggb = F_{zRphi}^(1) from Equations (D.30-33)
+! *** ----- exactly forward
+! *** *** Gggb = F_{zRphi}^(1) from Equations (D.30-33)
Gggb = - Exp1*Dthick
Dggbds = Dthick**2*Exp1/Two
Dggbdp = Dthick**2*Exp1/Two
Dggbdn = (Vv-One)*Exp1
-C
+!
ELSE IF (Costhe.EQ.Zero) THEN
-C *** ----- sideways exactly
+! *** ----- sideways exactly
Gggb = Zero
Dggbds = Zero
Dggbdp = Zero
Dggbdn = Zero
-C
+!
ELSE IF (Costhe.GT.Zero) THEN
-C *** ----- forward
+! *** ----- forward
Dn = Dthick*D/Costhe
Ww = Dthick*Totalp/Costhe
IF (dABS(Dn).LT.0.3d0) THEN
-C *** *** Gggb = F_{zRphi}^(1) from Equation (D.24) (plus 27-29)
+! *** *** Gggb = F_{zRphi}^(1) from Equation (D.24) (plus 27-29)
Abc = Abcexp (Dn, Ax, Bx, Cxxxxx, Dxxxxx, Ijklmn)
Gggb = -Exp1*Dthick * Ax
Dggbds = Exp1*Dthick**2* Bx
Dggbdp = Exp1*Dthick**2*(Ax-Bx)/Costhe
Dggbdn = Exp1*((Ww-One)*Ax-Dn*Bx)
ELSE
-C *** *** Gggb = F_{zRphi}^(1) from Eq. (D.16) (with D.21,D.22,D.20)
+! *** *** Gggb = F_{zRphi}^(1) from Eq. (D.16) (with D.21,D.22,D.20)
Exp2 = dEXP(-Ww)
Gggb = Costhe*(Exp1-Exp2)/D
Dggbds = -Costhe*(Gggb+Dthick*Exp1)/D
Dggbdp = (Gggb+Dthick*Exp2)/D
Dggbdn = (-Total*Exp1*Costhe+Totalp*Exp2)/D
END IF
-C
+!
ELSE
-C
-C *** ----- backward
+!
+! *** ----- backward
Dn = Dthick*D/Costhe
Exp2 = dEXP(-Dn)
IF (dABS(Dn).LT.0.3d0) THEN
-C *** *** Gggb = F_{zRphi}^(1) from Eqs. (E.19,21,22,20)
+! *** *** Gggb = F_{zRphi}^(1) from Eqs. (E.19,21,22,20)
Abc = Abcexp (-Dn, Ax, Bx, Cxxxxx, Dxxxxx, Ijklmn)
Gggb = - Dthick * Ax
Dggbds = Dthick**2*(Ax-Bx)
Dggbdp = - Dthick**2*(Ax-Bx)/Costhe
Dggbdn = - Abc
ELSE
-C *** *** Gggb = F_{zRphi}^(1) from Equation (E.11,16,17,15)
+! *** *** Gggb = F_{zRphi}^(1) from Equation (E.11,16,17,15)
Gggb = Costhe*(Exp2-One)/D
Dggbds = - Costhe*(Gggb+Dthick*Exp2)/D
Dggbdp = (Gggb+Dthick*Exp2)/D
Dggbdn = - Exp2
END IF
END IF
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Xsect21_Quad (Energb, Totsig, Capsig, Dtotsi, Dcapsi,
- * Dt, Dc, Ep, Jj, Nx, Ientrp, Kdatb, Nn)
-C
-C *** Purpose -- Find total and capture cross sections & derivatives at
-C *** scattered energy Ep using quadratic interpolation
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Xsect21_Quad (Energb, Totsig, Capsig, Dtotsi, Dcapsi, &
+ Dt, Dc, Ep, Jj, Nx, Ientrp, Kdatb, Nn)
+!
+! *** Purpose -- Find total and capture cross sections & derivatives at
+! *** scattered energy Ep using quadratic interpolation
+!
use fixedi_m
use ifwrit_m
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Energb(*), Totsig(*), Capsig(*), Dtotsi(Nx,*),
- * Dcapsi(Nx,*), Dt(*), Dc(*)
-C
-C
+ DIMENSION Energb(*), Totsig(*), Capsig(*), Dtotsi(Nx,*), &
+ Dcapsi(Nx,*), Dt(*), Dc(*)
+!
+!
IF (Intrp.EQ.0) THEN
-C *** Here get cross sections and derivatives when Ep=Energb(Iep)
-C *** (Intrp=0), or when Iep=1, so must use constant value
+! *** Here get cross sections and derivatives when Ep=Energb(Iep)
+! *** (Intrp=0), or when Iep=1, so must use constant value
Totalp = Totsig(Iep)
Capt = Capsig(Iep)
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
@@ -244,44 +245,44 @@ C *** (Intrp=0), or when Iep=1, so must use constant value
Dc(J) = Dcapsi(J,Iep)
END DO
END IF
-C
-C
+!
+!
ELSE
-C
-C
+!
+!
IF (Iep.GT.1 .AND. Iep.LT.Kdatb-1) THEN
-C ================================================================
-C *** Here Energb(Iep) < Ep < Energb(Iep+1) and 1<Iep<Kdatb-1
-C *** so get cross section at E'=Ep via two
-C *** quadratic interpolations
+! ================================================================
+! *** Here Energb(Iep) < Ep < Energb(Iep+1) and 1<Iep<Kdatb-1
+! *** so get cross section at E'=Ep via two
+! *** quadratic interpolations
B0 = Antrp1
B1 = Antrp2
B2 = Antrp3
B3 = Antrp4
- Totalp = B1*Totsig(Iep ) + B2*Totsig(Iep+1)
- * + B0*Totsig(Iep-1) + B3*Totsig(Iep+2)
- Capt = B1*Capsig(Iep ) + B2*Capsig(Iep+1)
- * + B0*Capsig(Iep-1) + B3*Capsig(Iep+2)
-C
+ Totalp = B1*Totsig(Iep ) + B2*Totsig(Iep+1) &
+ + B0*Totsig(Iep-1) + B3*Totsig(Iep+2)
+ Capt = B1*Capsig(Iep ) + B2*Capsig(Iep+1) &
+ + B0*Capsig(Iep-1) + B3*Capsig(Iep+2)
+!
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
DO J=1,Nnpar
- Dt(J) = B1*Dtotsi(J,Iep ) + B2*Dtotsi(J,Iep+1)
- * + B0*Dtotsi(J,Iep-1) + B3*Dtotsi(J,Iep+2)
+ Dt(J) = B1*Dtotsi(J,Iep ) + B2*Dtotsi(J,Iep+1) &
+ + B0*Dtotsi(J,Iep-1) + B3*Dtotsi(J,Iep+2)
END DO
DO J=1,Nnpar
- Dc(J) = B1*Dcapsi(J,Iep ) + B2*Dcapsi(J,Iep+1)
- * + B0*Dcapsi(J,Iep-1) + B3*Dcapsi(J,Iep+2)
+ Dc(J) = B1*Dcapsi(J,Iep ) + B2*Dcapsi(J,Iep+1) &
+ + B0*Dcapsi(J,Iep-1) + B3*Dcapsi(J,Iep+2)
END DO
END IF
-C ================================================================
+! ================================================================
ELSE
-C *** Here Energb(Iep) < Ep < Energb(Iep+1) and 1=Iep or Iep=Kdatb-1
-C *** so get cross section at E'=Ep via linear interpolation
+! *** Here Energb(Iep) < Ep < Energb(Iep+1) and 1=Iep or Iep=Kdatb-1
+! *** so get cross section at E'=Ep via linear interpolation
A = Antrp2
B = Antrp3
Totalp = A*Totsig(Iep) + B*Totsig(Iep+1)
Capt = A*Capsig(Iep) + B*Capsig(Iep+1)
-C
+!
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
DO J=1,Nnpar
Dt(J) = A*Dtotsi(J,Iep) + B*Dtotsi(J,Iep+1)
@@ -290,8 +291,10 @@ C
Dc(J) = A*Dcapsi(J,Iep) + B*Dcapsi(J,Iep+1)
END DO
END IF
-C
+!
END IF
END IF
RETURN
END
+
+end module ssm_12_m
\ No newline at end of file
diff --git a/sammy/src/ssm/mssm13.f b/sammy/src/ssm/mssm13.f90
similarity index 52%
rename from sammy/src/ssm/mssm13.f
rename to sammy/src/ssm/mssm13.f90
index 8719d8d54..f10418043 100644
--- a/sammy/src/ssm/mssm13.f
+++ b/sammy/src/ssm/mssm13.f90
@@ -1,19 +1,21 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Trpths1_Lin (Xtpt_W, Ftheta, Qfb, Dqfb, Knthet, Ifb,
- * Jth, Itntrp, Nn, Nxtptwn)
-C
-C *** This version uses linear interpolation
-C *** Interpolate on Qfb(Jsig,Jth,Ifb) to give
-C *** Fz=Q((Total),Totalp,Costhe)
-C *** where Total is already fixed via earlier interpolation
-C *** Also evaluate Dfz = deriv (Qfb) wrt (Total)
-C *** and Dpfz = deriv (Qfb) wrt (Totalp)
-C *** and Dnfz = deriv (Qfb) wrt (Thickness)
-C *** Note that all terms require interp over Totalp & Costhe
-C
+!
+module ssm_13_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Trpths1_Lin (Xtpt_W, Ftheta, Qfb, Dqfb, Knthet, Ifb, &
+ Jth, Itntrp, Nn, Nxtptwn)
+!
+! *** This version uses linear interpolation
+! *** Interpolate on Qfb(Jsig,Jth,Ifb) to give
+! *** Fz=Q((Total),Totalp,Costhe)
+! *** where Total is already fixed via earlier interpolation
+! *** Also evaluate Dfz = deriv (Qfb) wrt (Total)
+! *** and Dpfz = deriv (Qfb) wrt (Totalp)
+! *** and Dnfz = deriv (Qfb) wrt (Thickness)
+! *** Note that all terms require interp over Totalp & Costhe
+!
use fixedi_m
use ifwrit_m
use logic_ssm_common_m
@@ -21,29 +23,29 @@ C
use xsect_x_common_m
use MultScatPars_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-cx CHARACTER*1 Cha
- DIMENSION Xtpt_W(Nxtptw), Ftheta(Ntheta),
- * Qfb(Nxtptw,Ntheta,Nsqfb), Dqfb(Nxtptw,Ntheta,2)
+!x CHARACTER*1 Cha
+ DIMENSION Xtpt_W(Nxtptw), Ftheta(Ntheta), &
+ Qfb(Nxtptw,Ntheta,Nsqfb), Dqfb(Nxtptw,Ntheta,2)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Iwhich = Ifb
L = Nsqfb
Ith = Jth
Ccc = Costhe
IF (Costhe.LT.Zero) Ccc = -Costhe
-C
+!
V = Total
U = Totalp
Tt = dLOG(U)
-C
+!
IF (Tt.LT.Xtpt_W(1) .OR. Tt.GT.Xtpt_W(Nxtptw)) THEN
Msig = 0
Interp_Small_Times = Interp_Small_Times + 1
IF (Interp_Small_Times.LE.10) THEN
WRITE (6,10100) Tt, Xtpt_W(1), Xtpt_W(Nxtptw)
WRITE (21,10100) Tt, Xtpt_W(1), Xtpt_W(Nxtptw)
-10100 FORMAT (' Trying to interpolate outside the range',
- * /, ' dlog(Totalp) =', 1PG14.6, ', Limits are', 1P2G14.6)
+10100 FORMAT (' Trying to interpolate outside the range', &
+ /, ' dlog(Totalp) =', 1PG14.6, ', Limits are', 1P2G14.6)
END IF
Fz = Zero
Dfz = Zero
@@ -51,21 +53,21 @@ C
Dnfz = Zero
RETURN
END IF
-C
-C
-C **********************************************************************
-C *** Find interpolator on Totalp wrt Xtpt_W
-C **********************************************************************
+!
+!
+! **********************************************************************
+! *** Find interpolator on Totalp wrt Xtpt_W
+! **********************************************************************
CALL Where (Xtpt_W, Tt, Nxtptwn, Nxtptw, M)
-C *** Xtpt_W(m) < tt < Xtpt_W(m+1)
+! *** Xtpt_W(m) < tt < Xtpt_W(m+1)
CALL Get_W_Coef_2 (Xtpt_W, Tt, Nxtptw, M, C0a, C1a, D0a, D1a)
Mm = M
-C
-C
+!
+!
IF (Itntrp.NE.0) THEN
-C
-C *******************************************************************
-C *** First, when no interpolation on Ftheta is needed:
+!
+! *******************************************************************
+! *** First, when no interpolation on Ftheta is needed:
IF (Ftheta(Ith).EQ.One) THEN
Fz = Zero
IF (Ksolvx.NE.2) THEN
@@ -77,34 +79,34 @@ C *** First, when no interpolation on Ftheta is needed:
CALL Get_Ffz_2 (Qfb, Ffz, Dnfzz, C0a, C1a, Mm, Ith,Iwhich,L)
Fz = Get_Exp (Ffz)
IF (Nsqfb.EQ.4) Dnfz = Get_Exp (Dnfzz)
-cx cha='c'
+!x cha='c'
IF (Ksolvx.NE.2) THEN
CALL Get_Ffz_2 (Dqfb, Dfv, X, C0a, C1a, Mm, Ith,Iwhich,2)
Dfv = - Get_Exp (Dfv)
-C *** Dfv is deriv (e^Qfb) wrt Total, interpolated on Totalp
+! *** Dfv is deriv (e^Qfb) wrt Total, interpolated on Totalp
CALL Get_Ffz_2 (Qfb, Dfw, X, D0a, D1a, Mm, Ith, Iwhich,2)
IF (Dfw.EQ.-8000.0D0) THEN
Dfw = Zero
ELSE
Dfw = Dfw*Fz/Totalp
-C *** Dfw = d(e^Q)/d(U) = dQ/d(Tt) e^Q d(Tt)/d(Totalp)
-C *** where Fz=e^Q and d(Tt)/d(Totalp) = 1/Totalp
-C *** dQ/d(Tt) is found from deriv of interpolation
+! *** Dfw = d(e^Q)/d(U) = dQ/d(Tt) e^Q d(Tt)/d(Totalp)
+! *** where Fz=e^Q and d(Tt)/d(Totalp) = 1/Totalp
+! *** dQ/d(Tt) is found from deriv of interpolation
END IF
END IF
END IF
-C
-C *******************************************************************
+!
+! *******************************************************************
ELSE
-C *******************************************************************
-C
-C *** Here have to interpolate on Costhe as well as Totalp
+! *******************************************************************
+!
+! *** Here have to interpolate on Costhe as well as Totalp
CALL Where (Ftheta, Ccc, Knthet, multScat%getNumTheta(), Mth)
-C *** Now we know that Ftheta(mth) < Ccc < Ftheta(mth+1)
-C
-C ****************************************************************
+! *** Now we know that Ftheta(mth) < Ccc < Ftheta(mth+1)
+!
+! ****************************************************************
IF (Mth.LT.multScat%getNumTheta()-1) THEN
-C ****************************************************************
+! ****************************************************************
Ith = Mth
C10 = Ftheta(Mth+1) - Ftheta(Mth )
D0 = (Ftheta(Mth+1)-Ccc)/C10
@@ -115,47 +117,47 @@ C ****************************************************************
IF (L.EQ.4) THEN
Dnfz = Get_Exp_X_2 (Dnfzz, An, Bn, D0, D1)
END IF
-cx cha='d'
-C
+!x cha='d'
+!
IF (Ksolvx.NE.2) THEN
CALL Get_Ffz_2 (Dqfb, Aa, X, C0a, C1a, Mm,Mth ,Iwhich,2)
CALL Get_Ffz_2 (Dqfb, Bb, X, C0a, C1a, Mm,Mth+1,Iwhich,2)
Dfv = - Get_Exp_X_2 (Dfv, Aa, Bb, D0, D1)
-C
+!
CALL Get_Ffz_2 (Qfb, Aa, X, D0a, D1a, Mm, Mth ,Iwhich,2)
CALL Get_Ffz_2 (Qfb, Bb, X, D0a, D1a, Mm, Mth+1,Iwhich,2)
Dfw = D0*Aa + D1*Bb
Dfw = Dfw*Fz/Totalp
-C *** Dfw = d(e^Q)/d(Totalp) = dQ/d(Tt) e^Q d(Tt)/D(Total)
-C *** where Fz=e^Q; note that d(Tt)/d(Total) = 1/Total
+! *** Dfw = d(e^Q)/d(Totalp) = dQ/d(Tt) e^Q d(Tt)/D(Total)
+! *** where Fz=e^Q; note that d(Tt)/d(Total) = 1/Total
END IF
-C
-C ****************************************************************
+!
+! ****************************************************************
ELSE
-C ELSE IF (Mth.GE.Ntheta-1) THEN
-C ****************************************************************
-C jmb - Ntheta = multScat%getNumTheta()
-C
-C *** Interpolate on Ntheta-1 and Ntheta, using proportionality
-C *** to tan(theta)
-C *** Remember that the Ntheta value of Q is really calculated at
-C *** Costhe = 0.9d0 + Ftheta(Ntheta-1)*0.1d0
-C *** That is, if G = e^(-Q)/tan(Theta), then interpolate on G
-C *** and then set Fz = G_interpolated * tan(Theta)
- Fth = 0.9d0*Ftheta(multScat%getNumTheta()) +
- * Ftheta(multScat%getNumTheta()-1)*0.1d0
+! ELSE IF (Mth.GE.Ntheta-1) THEN
+! ****************************************************************
+! jmb - Ntheta = multScat%getNumTheta()
+!
+! *** Interpolate on Ntheta-1 and Ntheta, using proportionality
+! *** to tan(theta)
+! *** Remember that the Ntheta value of Q is really calculated at
+! *** Costhe = 0.9d0 + Ftheta(Ntheta-1)*0.1d0
+! *** That is, if G = e^(-Q)/tan(Theta), then interpolate on G
+! *** and then set Fz = G_interpolated * tan(Theta)
+ Fth = 0.9d0*Ftheta(multScat%getNumTheta()) + &
+ Ftheta(multScat%getNumTheta()-1)*0.1d0
C0 = Fth - Ftheta(multScat%getNumTheta()-1)
D0 = (Fth-Ccc)/C0
D1 = (Ccc-Ftheta(multScat%getNumTheta()-1))/C0
Tta = dSQRT(One-Fth**2)/Fth
- Ttb = dSQRT(One-Ftheta(multScat%getNumTheta()-1)**2) /
- * Ftheta(multScat%getNumTheta()-1)
+ Ttb = dSQRT(One-Ftheta(multScat%getNumTheta()-1)**2) / &
+ Ftheta(multScat%getNumTheta()-1)
Ttt = dSQRT(One-Ccc**2)/Ccc
-C
- CALL Get_Ffz_2 (Qfb, Aa, An, C0a, C1a, Mm,
- * multScat%getNumTheta() ,Iwhich,L)
- CALL Get_Ffz_2 (Qfb, Bb, Bn, C0a, C1a, Mm,
- * multScat%getNumTheta()-1,Iwhich,L)
+!
+ CALL Get_Ffz_2 (Qfb, Aa, An, C0a, C1a, Mm, &
+ multScat%getNumTheta() ,Iwhich,L)
+ CALL Get_Ffz_2 (Qfb, Bb, Bn, C0a, C1a, Mm, &
+ multScat%getNumTheta()-1,Iwhich,L)
Aa = Get_Exp (Aa) /Tta
Bb = Get_Exp (Bb) /Ttb
Fz = D1*Aa + D0*Bb
@@ -166,65 +168,65 @@ C
Dnfz = D1*An + D0*Bn
DnFz = Dnfz*Ttt
END IF
-cx cha='f'
-C
+!x cha='f'
+!
IF (Ksolvx.NE.2) THEN
- CALL Get_Ffz_2 (Dqfb, Daa, X, C0a, C1a, Mm,
- * multScat%getNumTheta(), Iwhich, 2)
- CALL Get_Ffz_2 (Dqfb, Dbb, X, C0a, C1a, Mm,
- * multScat%getNumTheta()-1, Iwhich, 2)
+ CALL Get_Ffz_2 (Dqfb, Daa, X, C0a, C1a, Mm, &
+ multScat%getNumTheta(), Iwhich, 2)
+ CALL Get_Ffz_2 (Dqfb, Dbb, X, C0a, C1a, Mm, &
+ multScat%getNumTheta()-1, Iwhich, 2)
Daa = Get_Exp (Daa) /Tta
Dbb = Get_Exp (Dbb) /Ttb
Dfv = D1*Daa + D0*Dbb
Dfv = - Dfv*Ttt
-c???????????????? negative is correct, methinks
-C
- CALL Get_Ffz_2 (Qfb, Daa, X, D0a, D1a, Mm,
- * multScat%getNumTheta() , Iwhich, 2)
- CALL Get_Ffz_2 (Qfb, Dbb, X, D0a, D1a, Mm,
- * multScat%getNumTheta()-1, Iwhich, 2)
+!???????????????? negative is correct, methinks
+!
+ CALL Get_Ffz_2 (Qfb, Daa, X, D0a, D1a, Mm, &
+ multScat%getNumTheta() , Iwhich, 2)
+ CALL Get_Ffz_2 (Qfb, Dbb, X, D0a, D1a, Mm, &
+ multScat%getNumTheta()-1, Iwhich, 2)
Daa = Get_Exp (Daa)
Dbb = Get_Exp (Dbb)
Dfw = D1*Daa*Aa + D0*Dbb*Bb
Dfw = Dfw /Totalp * Ttt
-C *** Dfw = d(e^Q)/d(Totalp) = dQ/d(Tt) e^Q d(Tt)/D(Totalp)
-C *** where Fz=e^Q and d(Tt)/d(U) = 1/Totalp
+! *** Dfw = d(e^Q)/d(Totalp) = dQ/d(Tt) e^Q d(Tt)/D(Totalp)
+! *** where Fz=e^Q and d(Tt)/d(U) = 1/Totalp
END IF
-C ****************************************************************
+! ****************************************************************
END IF
-C *******************************************************************
+! *******************************************************************
END IF
-C **********************************************************************
-C
-C
-C *** OK, now we have Fz = contribution from integrals #4 & 5 of Eq. (35),
-C *** for a given mu [ergo, given Total =Sigma_Total(E ),
-C *** Totalp=Sigma_Total(E'), &
-C *** cos(theta) which corresponds to E']
-C
+! **********************************************************************
+!
+!
+! *** OK, now we have Fz = contribution from integrals #4 & 5 of Eq. (35),
+! *** for a given mu [ergo, given Total =Sigma_Total(E ),
+! *** Totalp=Sigma_Total(E'), &
+! *** cos(theta) which corresponds to E']
+!
IF (Ksolvx.NE.2) THEN
Dfz = Dfv
Dpfz = Dfw
IF (Kvthck.GT.0) THEN
IF (Iwhich.EQ.1) THEN
Dnfz = Dnfz - Total*Fz
-CC ELSE
-CC Dnfz = Dnfz
+!C ELSE
+!C Dnfz = Dnfz
END IF
END IF
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Get_W_Coef_2 (Xtpt_W, Tt, Nxtptw, M, C0a, C1a, D0a,D1a)
-C *** Purpose -- Figure coefficients for interpolation
+! *** Purpose -- Figure coefficients for interpolation
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION Xtpt_W(Nxtptw)
DATA One /1.0d0/
-C *** Use linear interpolation
+! *** Use linear interpolation
Mm = M
A10 = Xtpt_W(Mm+1) - Xtpt_W(Mm)
C0a = (Xtpt_W(Mm+1)-Tt)/A10
@@ -233,36 +235,36 @@ C *** Use linear interpolation
D1a = One/A10
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Get_Ffz_2 (Qfb, Ffz, Fnz, D0a, D1a, Mm, Ith,Iwhich,Nxx)
use fixedi_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Qfb(Nxtptw,Ntheta,*)
- IF (Qfb(Mm ,Ith,Iwhich).GT.-8000.0D0 .AND.
- * Qfb(Mm+1,Ith,Iwhich).GT.-8000.0D0) THEN
- Ffz = D0a*Qfb(Mm ,Ith,Iwhich)
- * + D1a*Qfb(Mm+1,Ith,Iwhich)
+ IF (Qfb(Mm ,Ith,Iwhich).GT.-8000.0D0 .AND. &
+ Qfb(Mm+1,Ith,Iwhich).GT.-8000.0D0) THEN
+ Ffz = D0a*Qfb(Mm ,Ith,Iwhich) &
+ + D1a*Qfb(Mm+1,Ith,Iwhich)
ELSE
Ffz = -8000.
END IF
IF (Nxx.EQ.4) THEN
- IF (Qfb(Mm ,Ith,Iwhich+2).GT.-8000.0D0 .AND.
- * Qfb(Mm+1,Ith,Iwhich+2).GT.-8000.0D0) THEN
- Fnz = D0a*Qfb(Mm ,Ith,Iwhich+2)
- * + D1a*Qfb(Mm+1,Ith,Iwhich+2)
+ IF (Qfb(Mm ,Ith,Iwhich+2).GT.-8000.0D0 .AND. &
+ Qfb(Mm+1,Ith,Iwhich+2).GT.-8000.0D0) THEN
+ Fnz = D0a*Qfb(Mm ,Ith,Iwhich+2) &
+ + D1a*Qfb(Mm+1,Ith,Iwhich+2)
ELSE
Fnz = -8000.
END IF
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
DOUBLE PRECISION FUNCTION Get_Exp (Ffz)
IMPLICIT REAL*8 (A-H,O-Z)
DATA Zero /0.0d0/
@@ -274,10 +276,10 @@ C
Get_Exp = Fz
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
DOUBLE PRECISION FUNCTION Get_Exp_X_2 (Ffz, Aa, Bb, D0, D1)
IMPLICIT REAL*8 (A-H,O-Z)
DATA Zero /0.0d0/
@@ -290,3 +292,5 @@ C
Get_Exp_X_2 = Fz
RETURN
END
+
+end module ssm_13_m
\ No newline at end of file
diff --git a/sammy/src/ssm/mssm14.f b/sammy/src/ssm/mssm14.f90
similarity index 55%
rename from sammy/src/ssm/mssm14.f
rename to sammy/src/ssm/mssm14.f90
index 5e01699a8..12b8eb3f3 100644
--- a/sammy/src/ssm/mssm14.f
+++ b/sammy/src/ssm/mssm14.f90
@@ -1,52 +1,55 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Trpths1_Quad (Xtpt_W, Ftheta, Qfb, Dqfb, Knthet, Ifb,
- * Jth, Itntrp, Nn, Nxtptwn)
-C
-C *** Quadratic interpolate on Qfb(Jsig,Jth,Ifb) to give
-C *** Fz=Q((Total),Totalp,Costhe)
-C *** where Total is already fixed via earlier interpolation
-C *** Also evaluate Dfz = deriv (Qfb) wrt (Total)
-C *** and Dpfz = deriv (Qfb) wrt (Totalp)
-C *** and Dnfz = deriv (Qfb) wrt (Thickness)
-C *** Note that all terms require interp over Totalp & Costhe
-C
+!
+module ssm_14_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Trpths1_Quad (Xtpt_W, Ftheta, Qfb, Dqfb, Knthet, Ifb, &
+ Jth, Itntrp, Nn, Nxtptwn)
+!
+! *** Quadratic interpolate on Qfb(Jsig,Jth,Ifb) to give
+! *** Fz=Q((Total),Totalp,Costhe)
+! *** where Total is already fixed via earlier interpolation
+! *** Also evaluate Dfz = deriv (Qfb) wrt (Total)
+! *** and Dpfz = deriv (Qfb) wrt (Totalp)
+! *** and Dnfz = deriv (Qfb) wrt (Thickness)
+! *** Note that all terms require interp over Totalp & Costhe
+!
use fixedi_m
use ifwrit_m
use logic_ssm_common_m
use ssssss_common_m
use xsect_x_common_m
use MultScatPars_common_m
+ use ssm_13_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Xtpt_W(Nxtptw), Ftheta(Ntheta),
- * Qfb(Nxtptw,Ntheta,Nsqfb), Dqfb(Nxtptw,Ntheta,2)
+ DIMENSION Xtpt_W(Nxtptw), Ftheta(Ntheta), &
+ Qfb(Nxtptw,Ntheta,Nsqfb), Dqfb(Nxtptw,Ntheta,2)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Fz = Zero
Dfz = Zero
Dpfz = Zero
Dnfz = Zero
-C
+!
L = Nsqfb
Iwhich = Ifb
Ith = Jth
Ccc = Costhe
IF (Costhe.LT.Zero) Ccc = -Costhe
-C
+!
V = Total
U = Totalp
Tt = dLOG(U)
-C
+!
IF (Tt.LT.Xtpt_W(1) .OR. Tt.GT.Xtpt_W(Nxtptw)) THEN
Msig = 0
Interp_Small_Times = Interp_Small_Times + 1
IF (Interp_Small_Times.LE.10) THEN
WRITE (6,10100) Tt, Xtpt_W(1), Xtpt_W(Nxtptw)
WRITE (21,10100) Tt, Xtpt_W(1), Xtpt_W(Nxtptw)
-10100 FORMAT (' Trying to interpolate outside the range',
- * /, ' dlog(Totalp) =', 1PG14.6, ', Limits are', 1P2G14.6)
+10100 FORMAT (' Trying to interpolate outside the range', &
+ /, ' dlog(Totalp) =', 1PG14.6, ', Limits are', 1P2G14.6)
END IF
Fz = Zero
Dfz = Zero
@@ -54,42 +57,42 @@ C
Dnfz = Zero
RETURN
END IF
-C
-C
-C **********************************************************************
-C *** Find interpolator on Totalp wrt Xtpt_W
-C **********************************************************************
+!
+!
+! **********************************************************************
+! *** Find interpolator on Totalp wrt Xtpt_W
+! **********************************************************************
CALL Where (Xtpt_W, Tt, Nxtptwn, Nxtptw, M)
-C *** Xtpt_W(m) < tt < Xtpt_W(m+1)
- CALL Get_W_Coef (Xtpt_W, Tt, Nxtptw, M, C0a, C1a,
- * C2a, C1b, C2b, C3b, D0a, D1a, D2a, D1b, D2b, D3b)
+! *** Xtpt_W(m) < tt < Xtpt_W(m+1)
+ CALL Get_W_Coef (Xtpt_W, Tt, Nxtptw, M, C0a, C1a, &
+ C2a, C1b, C2b, C3b, D0a, D1a, D2a, D1b, D2b, D3b)
Mm = M
-C
-C
+!
+!
IF (Itntrp.NE.0) THEN
-C
-C *******************************************************************
-C *** First, when no interpolation on Ftheta is needed:
+!
+! *******************************************************************
+! *** First, when no interpolation on Ftheta is needed:
IF (Ftheta(Ith).NE.One) THEN
- CALL Get_Ffz (Qfb, Ffz, Dnfzz, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Ith, Iwhich, L)
+ CALL Get_Ffz (Qfb, Ffz, Dnfzz, C0a, C1a, C2a, C1b, C2b, C3b, &
+ Mm, Ith, Iwhich, L)
Fz = Get_Exp (Ffz)
IF (Kvthck.GT.0) Dnfz = Get_Exp (Dnfzz)
-C
+!
IF (Ksolvx.NE.2) THEN
- CALL Get_Ffz (Dqfb, Dfv, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Ith, Iwhich, 2)
+ CALL Get_Ffz (Dqfb, Dfv, X, C0a, C1a, C2a, C1b, C2b, C3b, &
+ Mm, Ith, Iwhich, 2)
Dfv = - Get_Exp (Dfv)
-C *** Dfv is deriv (e^Qfb) wrt Total, interpolated on Totalp
- CALL Get_Ffz (Qfb, Dfw, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, Ith, Iwhich, 2)
+! *** Dfv is deriv (e^Qfb) wrt Total, interpolated on Totalp
+ CALL Get_Ffz (Qfb, Dfw, X, D0a, D1a, D2a, D1b, D2b, D3b, &
+ Mm, Ith, Iwhich, 2)
IF (Dfw.EQ.-8000.0D0) THEN
Dfw = Zero
ELSE
Dfw = Dfw*Fz/Totalp
-C *** Dfw = d(e^Q)/d(U) = dQ/d(Tt) e^Q d(Tt)/d(Totalp)
-C *** where Fz=e^Q and d(Tt)/d(Totalp) = 1/Totalp
-C *** dQ/d(Tt) is found from deriv of interpolation
+! *** Dfw = d(e^Q)/d(U) = dQ/d(Tt) e^Q d(Tt)/d(Totalp)
+! *** where Fz=e^Q and d(Tt)/d(Totalp) = 1/Totalp
+! *** dQ/d(Tt) is found from deriv of interpolation
END IF
END IF
ELSE
@@ -97,20 +100,20 @@ C *** dQ/d(Tt) is found from deriv of interpolation
Dfw = Zero
Dfv = Zero
END IF
-C
-C *******************************************************************
+!
+! *******************************************************************
ELSE
-C *******************************************************************
-C
-C *** Here have to interpolate on Costhe as well as Totalp
+! *******************************************************************
+!
+! *** Here have to interpolate on Costhe as well as Totalp
CALL Where (Ftheta, Ccc, Knthet, multScat%getNumTheta(), Mth)
-C *** Now we know that Ftheta(mth) < Ccc < Ftheta(mth+1)
-C *** We'll (usually) do quadratic interpolation, not always
-C
-C ****************************************************************
+! *** Now we know that Ftheta(mth) < Ccc < Ftheta(mth+1)
+! *** We'll (usually) do quadratic interpolation, not always
+!
+! ****************************************************************
IF (Mth.EQ.1) THEN
-C ****************************************************************
-C *** Here Ftheta(1) = Zero and curve is very sharp
+! ****************************************************************
+! *** Here Ftheta(1) = Zero and curve is very sharp
Ith = Mth
C10 = Ftheta(Mth+1) - Ftheta(Mth )
C21 = Ftheta(Mth+2) - Ftheta(Mth+1)
@@ -119,46 +122,46 @@ C *** Here Ftheta(1) = Zero and curve is very sharp
D0 = (Ftheta(Mth+2)-Ccc)/C20 * (Ftheta(Mth+1)-Ccc)/C10
D1 = (Ftheta(Mth+2)-Ccc)/C21 * (Ccc-Ftheta(Mth ))/C10
D2 = (Ccc-Ftheta(Mth+1))/C21 * (Ccc-Ftheta(Mth ))/C20
- CALL Get_Ffz (Qfb, Aa, An, C0a, C1a, C2a, C1b, C2b, C3b, Mm,
- * Mth , Iwhich, L)
- CALL Get_Ffz (Qfb, Bb, Bn, C0a, C1a, C2a, C1b, C2b, C3b, Mm,
- * Mth+1, Iwhich, L)
- CALL Get_Ffz (Qfb, Dd, Dn, C0a, C1a, C2a, C1b, C2b, C3b, Mm,
- * Mth+2, Iwhich, L)
+ CALL Get_Ffz (Qfb, Aa, An, C0a, C1a, C2a, C1b, C2b, C3b, Mm, &
+ Mth , Iwhich, L)
+ CALL Get_Ffz (Qfb, Bb, Bn, C0a, C1a, C2a, C1b, C2b, C3b, Mm, &
+ Mth+1, Iwhich, L)
+ CALL Get_Ffz (Qfb, Dd, Dn, C0a, C1a, C2a, C1b, C2b, C3b, Mm, &
+ Mth+2, Iwhich, L)
Ffz = D0*Aa + D1*Bb + D2*Dd
Fz = Get_Exp_X (Ffz, Aa, Bb, Dd)
IF (Kvthck.GT.0) THEN
Dnfzz = D0*An + D1*Bn + D2*Dn
Dnfz = Get_Exp_X (Dnfzz, An, Bn, Dn)
END IF
-C
+!
IF (Ksolvx.NE.2) THEN
- CALL Get_Ffz (Dqfb, Aa, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth, Iwhich, 2)
- CALL Get_Ffz (Dqfb, Bb, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth+1, Iwhich, 2)
- CALL Get_Ffz (Dqfb, Dd, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth+2, Iwhich, 2)
+ CALL Get_Ffz (Dqfb, Aa, X, C0a, C1a, C2a, C1b, C2b, C3b, &
+ Mm, Mth, Iwhich, 2)
+ CALL Get_Ffz (Dqfb, Bb, X, C0a, C1a, C2a, C1b, C2b, C3b, &
+ Mm, Mth+1, Iwhich, 2)
+ CALL Get_Ffz (Dqfb, Dd, X, C0a, C1a, C2a, C1b, C2b, C3b, &
+ Mm, Mth+2, Iwhich, 2)
Dfv = D0*Aa + D1*Bb + D2*Dd
Dfv = - Get_Exp_X (Dfv, Aa, Bb, Dd)
-C
- CALL Get_Ffz (Qfb, Aa, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, Mth, Iwhich, 2)
- CALL Get_Ffz (Qfb, Bb, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, Mth+1, Iwhich, 2)
- CALL Get_Ffz (Qfb, Dd, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, Mth+2, Iwhich, 2)
+!
+ CALL Get_Ffz (Qfb, Aa, X, D0a, D1a, D2a, D1b, D2b, D3b, &
+ Mm, Mth, Iwhich, 2)
+ CALL Get_Ffz (Qfb, Bb, X, D0a, D1a, D2a, D1b, D2b, D3b, &
+ Mm, Mth+1, Iwhich, 2)
+ CALL Get_Ffz (Qfb, Dd, X, D0a, D1a, D2a, D1b, D2b, D3b, &
+ Mm, Mth+2, Iwhich, 2)
Dfw = D0*Aa + D1*Bb + D2*Dd
Dfw = Dfw*Fz/Totalp
-C *** Dfw = d(e^Q)/d(Totalp) = dQ/d(Tt) e^Q d(Tt)/D(Total)
-C *** where Fz=e^Q; note that d(Tt)/d(Total) = 1/Total
+! *** Dfw = d(e^Q)/d(Totalp) = dQ/d(Tt) e^Q d(Tt)/D(Total)
+! *** where Fz=e^Q; note that d(Tt)/d(Total) = 1/Total
END IF
-C
-C ****************************************************************
+!
+! ****************************************************************
ELSE IF (Mth.LT.multScat%getNumTheta()-2) THEN
-C ****************************************************************
-C
-C *** Here we can use the general quadratic formula
+! ****************************************************************
+!
+! *** Here we can use the general quadratic formula
C0m = Ftheta(Mth ) - Ftheta(Mth-1)
C10 = Ftheta(Mth+1) - Ftheta(Mth )
C1m = Ftheta(Mth+1) - Ftheta(Mth-1)
@@ -170,58 +173,42 @@ C *** Here we can use the general quadratic formula
A0b = (Ftheta(Mth+2)-Ccc)/C20*(Ftheta(Mth+1)-Ccc)/C10
A1b = (Ftheta(Mth+2)-Ccc)/C21*(Ccc-Ftheta(Mth ))/C10
A2b = (Ccc-Ftheta(Mth+1))/C21*(Ccc-Ftheta(Mth ))/C20
-C
- CALL Get_Ffz (Qfb, Cc, Cn, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth-1, Iwhich, L)
- CALL Get_Ffz (Qfb, Aa, An, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth , Iwhich, L)
- CALL Get_Ffz (Qfb, Bb, Bn, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth+1, Iwhich, L)
- CALL Get_Ffz (Qfb, Dd, Dn, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth+2, Iwhich, L)
- CALL Get_Ffz_1 (Fz, Cc, Aa, Bb, Dd, Ama, A0a, A1a,
- * A0b, A1b, A2b)
- IF (Kvthck.GT.0) CALL Get_Ffz_1 (Dnfz, Cn, An, Bn, Dn, Ama,
- * A0a, A1a, A0b, A1b, A2b)
-C
+!
+ CALL Get_Ffz (Qfb, Cc, Cn, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth-1, Iwhich, L)
+ CALL Get_Ffz (Qfb, Aa, An, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth , Iwhich, L)
+ CALL Get_Ffz (Qfb, Bb, Bn, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth+1, Iwhich, L)
+ CALL Get_Ffz (Qfb, Dd, Dn, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth+2, Iwhich, L)
+ CALL Get_Ffz_1 (Fz, Cc, Aa, Bb, Dd, Ama, A0a, A1a, A0b, A1b, A2b)
+ IF (Kvthck.GT.0) CALL Get_Ffz_1 (Dnfz, Cn, An, Bn, Dn, Ama, A0a, A1a, A0b, A1b, A2b)
+!
IF (Ksolvx.NE.2) THEN
- CALL Get_Ffz (Dqfb, Cc, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth-1, Iwhich, 2)
- CALL Get_Ffz (Dqfb, Aa, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth , Iwhich, 2)
- CALL Get_Ffz (Dqfb, Bb, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth+1, Iwhich, 2)
- CALL Get_Ffz (Dqfb, Dd, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth+2, Iwhich, 2)
- CALL Get_Ffz_1 (Dfv, Cc, Aa, Bb, Dd, Ama, A0a, A1a,
- * A0b, A1b, A2b)
+ CALL Get_Ffz (Dqfb, Cc, X, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth-1, Iwhich, 2)
+ CALL Get_Ffz (Dqfb, Aa, X, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth , Iwhich, 2)
+ CALL Get_Ffz (Dqfb, Bb, X, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth+1, Iwhich, 2)
+ CALL Get_Ffz (Dqfb, Dd, X, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth+2, Iwhich, 2)
+ CALL Get_Ffz_1 (Dfv, Cc, Aa, Bb, Dd, Ama, A0a, A1a, A0b, A1b, A2b)
Dfv = - Dfv
-C
- CALL Get_Ffz (Qfb, Cc, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, Mth-1, Iwhich, 2)
- CALL Get_Ffz (Qfb, Aa, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, Mth , Iwhich, 2)
- CALL Get_Ffz (Qfb, Bb, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, Mth+1, Iwhich, 2)
- CALL Get_Ffz (Qfb, Dd, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, Mth+2, Iwhich, 2)
- CALL Get_Ffz_3 (Dfw, Cc, Aa, Bb, Dd, Ama, A0a, A1a,
- * A0b, A1b, A2b)
+!
+ CALL Get_Ffz (Qfb, Cc, X, D0a, D1a, D2a, D1b, D2b, D3b, Mm, Mth-1, Iwhich, 2)
+ CALL Get_Ffz (Qfb, Aa, X, D0a, D1a, D2a, D1b, D2b, D3b, Mm, Mth , Iwhich, 2)
+ CALL Get_Ffz (Qfb, Bb, X, D0a, D1a, D2a, D1b, D2b, D3b, Mm, Mth+1, Iwhich, 2)
+ CALL Get_Ffz (Qfb, Dd, X, D0a, D1a, D2a, D1b, D2b, D3b, Mm, Mth+2, Iwhich, 2)
+ CALL Get_Ffz_3 (Dfw, Cc, Aa, Bb, Dd, Ama, A0a, A1a, A0b, A1b, A2b)
Dfw = Dfw*Fz/Totalp
-C *** Dfw = d(e^Q)/d(Totalp) = dQ/d(Tt) e^Q d(Tt)/d(U)
-C *** where Fz=e^Q and d(Tt)/d(Totalp) = 1/Totalp
+! *** Dfw = d(e^Q)/d(Totalp) = dQ/d(Tt) e^Q d(Tt)/d(U)
+! *** where Fz=e^Q and d(Tt)/d(Totalp) = 1/Totalp
END IF
-C
-C ****************************************************************
+!
+! ****************************************************************
ELSE IF (Mth.GE.multScat%getNumTheta()-2) THEN
-C ****************************************************************
-C
+! ****************************************************************
+!
IF (Mth.GT.multScat%getNumTheta()-2) then
Mth = multScat%getNumTheta() - 2
end if
-C *** Here we can use the quadratic formula with different last point
- Fth = 0.9d0*Ftheta(multScat%getNumTheta()) +
- * Ftheta(multScat%getNumTheta()-1)*0.1d0
+! *** Here we can use the quadratic formula with different last point
+ Fth = 0.9d0*Ftheta(multScat%getNumTheta()) + &
+ Ftheta(multScat%getNumTheta()-1)*0.1d0
C0m = Ftheta(Mth ) - Ftheta(Mth-1)
C10 = Ftheta(Mth+1) - Ftheta(Mth )
C1m = Ftheta(Mth+1) - Ftheta(Mth-1)
@@ -233,73 +220,55 @@ C *** Here we can use the quadratic formula with different last point
A0b = (Fth -Ccc)/C20*(Ftheta(Mth+1)-Ccc)/C10
A1b = (Fth -Ccc)/C21*(Ccc-Ftheta(Mth ))/C10
A2b = (Ccc-Ftheta(Mth+1))/C21*(Ccc-Ftheta(Mth ))/C20
-C
- CALL Get_Ffz (Qfb, Cc, Cn, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth-1, Iwhich, L)
- CALL Get_Ffz (Qfb, Aa, An, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth , Iwhich, L)
- CALL Get_Ffz (Qfb, Bb, Bn, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth+1, Iwhich, L)
- CALL Get_Ffz (Qfb, Dd, Dn, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth+2, Iwhich, L)
- CALL Get_Ffz_1 (Fz, Cc, Aa, Bb, Dd, Ama, A0a, A1a,
- * A0b, A1b, A2b)
- IF (Kvthck.GT.0) CALL Get_Ffz_1 (Dnfz, Cn, An, Bn, Dn, Ama,
- * A0a, A1a, A0b, A1b, A2b)
-C
+!
+ CALL Get_Ffz (Qfb, Cc, Cn, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth-1, Iwhich, L)
+ CALL Get_Ffz (Qfb, Aa, An, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth , Iwhich, L)
+ CALL Get_Ffz (Qfb, Bb, Bn, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth+1, Iwhich, L)
+ CALL Get_Ffz (Qfb, Dd, Dn, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth+2, Iwhich, L)
+ CALL Get_Ffz_1 (Fz, Cc, Aa, Bb, Dd, Ama, A0a, A1a, A0b, A1b, A2b)
+ IF (Kvthck.GT.0) CALL Get_Ffz_1 (Dnfz, Cn, An, Bn, Dn, Ama, A0a, A1a, A0b, A1b, A2b)
+!
IF (Ksolvx.NE.2) THEN
- CALL Get_Ffz (Dqfb, Cc, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth-1, Iwhich, 2)
- CALL Get_Ffz (Dqfb, Aa, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth , Iwhich, 2)
- CALL Get_Ffz (Dqfb, Bb, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth+1, Iwhich, 2)
- CALL Get_Ffz (Dqfb, Dd, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, Mth+2, Iwhich, 2)
- CALL Get_Ffz_1 (Dfv, Cc, Aa, Bb, Dd, Ama, A0a, A1a,
- * A0b, A1b, A2b)
+ CALL Get_Ffz (Dqfb, Cc, X, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth-1, Iwhich, 2)
+ CALL Get_Ffz (Dqfb, Aa, X, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth , Iwhich, 2)
+ CALL Get_Ffz (Dqfb, Bb, X, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth+1, Iwhich, 2)
+ CALL Get_Ffz (Dqfb, Dd, X, C0a, C1a, C2a, C1b, C2b, C3b, Mm, Mth+2, Iwhich, 2)
+ CALL Get_Ffz_1 (Dfv, Cc, Aa, Bb, Dd, Ama, A0a, A1a, A0b, A1b, A2b)
Dfv = - Dfv
-C
- CALL Get_Ffz (Qfb, Cc, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, Mth-1, Iwhich, 2)
- CALL Get_Ffz (Qfb, Aa, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, Mth , Iwhich, 2)
- CALL Get_Ffz (Qfb, Bb, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, Mth+1, Iwhich, 2)
- CALL Get_Ffz (Qfb, Dd, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, Mth+2, Iwhich, 2)
- CALL Get_Ffz_3 (Dfw, Cc, Aa, Bb, Dd, Ama, A0a, A1a,
- * A0b, A1b, A2b)
+!
+ CALL Get_Ffz (Qfb, Cc, X, D0a, D1a, D2a, D1b, D2b, D3b, Mm, Mth-1, Iwhich, 2)
+ CALL Get_Ffz (Qfb, Aa, X, D0a, D1a, D2a, D1b, D2b, D3b, Mm, Mth , Iwhich, 2)
+ CALL Get_Ffz (Qfb, Bb, X, D0a, D1a, D2a, D1b, D2b, D3b, Mm, Mth+1, Iwhich, 2)
+ CALL Get_Ffz (Qfb, Dd, X, D0a, D1a, D2a, D1b, D2b, D3b, Mm, Mth+2, Iwhich, 2)
+ CALL Get_Ffz_3 (Dfw, Cc, Aa, Bb, Dd, Ama, A0a, A1a, A0b, A1b, A2b)
Dfw = Dfw*Fz/Totalp
-C *** Dfw = d(e^Q)/d(Totalp) = dQ/d(Tt) e^Q d(Tt)/d(U)
-C *** where Fz=e^Q and d(Tt)/d(Totalp) = 1/Totalp
+! *** Dfw = d(e^Q)/d(Totalp) = dQ/d(Tt) e^Q d(Tt)/d(U)
+! *** where Fz=e^Q and d(Tt)/d(Totalp) = 1/Totalp
END IF
-C
-C ****************************************************************
+!
+! ****************************************************************
ELSE IF (Mth.GT.multScat%getNumTheta()-2) THEN
-C ****************************************************************
-C jmb - Ntheta = multScat%getNumTheta()
-C
-C *** Interpolate on Ntheta-1 and Ntheta, using proportionality
-C *** to tan(theta)
-C *** Remember that the Ntheta value of Q is really calculated at
-C *** Costhe = 0.9d0 + Ftheta(Ntheta-1)*0.1d0
-C *** That is, if G = e^(-Q)/tan(Theta), then interpolate on G
-C *** and then set Fz = G_interpolated * tan(Theta)
- Fth = 0.9d0*Ftheta(multScat%getNumTheta()) +
- * Ftheta(multScat%getNumTheta()-1)*0.1d0
+! ****************************************************************
+! jmb - Ntheta = multScat%getNumTheta()
+!
+! *** Interpolate on Ntheta-1 and Ntheta, using proportionality
+! *** to tan(theta)
+! *** Remember that the Ntheta value of Q is really calculated at
+! *** Costhe = 0.9d0 + Ftheta(Ntheta-1)*0.1d0
+! *** That is, if G = e^(-Q)/tan(Theta), then interpolate on G
+! *** and then set Fz = G_interpolated * tan(Theta)
+ Fth = 0.9d0*Ftheta(multScat%getNumTheta()) + &
+ Ftheta(multScat%getNumTheta()-1)*0.1d0
C0 = Fth - Ftheta(multScat%getNumTheta()-1)
D0 = (Fth-Ccc)/C0
D1 = (Ccc-Ftheta(multScat%getNumTheta()-1))/C0
Tta = dSQRT(One-Fth**2)/Fth
- Ttb = dSQRT(One-Ftheta(multScat%getNumTheta()-1)**2) /
- * Ftheta(multScat%getNumTheta()-1)
+ Ttb = dSQRT(One-Ftheta(multScat%getNumTheta()-1)**2) / &
+ Ftheta(multScat%getNumTheta()-1)
Ttt = dSQRT(One-Ccc**2)/Ccc
-C
- CALL Get_Ffz (Qfb, Aa, An, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, multScat%getNumTheta(), Iwhich, L)
- CALL Get_Ffz (Qfb, Bb, Bn, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, multScat%getNumTheta()-1, Iwhich, L)
+!
+ CALL Get_Ffz (Qfb, Aa, An, C0a, C1a, C2a, C1b, C2b, C3b, Mm, multScat%getNumTheta(), Iwhich, L)
+ CALL Get_Ffz (Qfb, Bb, Bn, C0a, C1a, C2a, C1b, C2b, C3b, Mm, multScat%getNumTheta()-1, Iwhich, L)
Aa = Get_Exp (Aa) /Tta
Bb = Get_Exp (Bb) /Ttb
Fz = D1*Aa + D0*Bb
@@ -310,60 +279,56 @@ C
Dnfz = D1*An + D0*Bn
Dnfz = Dnfz*Ttt
END IF
-C
+!
IF (Ksolvx.NE.2) THEN
- CALL Get_Ffz (Dqfb, Daa, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, multScat%getNumTheta(), Iwhich, 2)
- CALL Get_Ffz (Dqfb, Dbb, X, C0a, C1a, C2a, C1b, C2b, C3b,
- * Mm, multScat%getNumTheta()-1, Iwhich, 2)
+ CALL Get_Ffz (Dqfb, Daa, X, C0a, C1a, C2a, C1b, C2b, C3b, Mm, multScat%getNumTheta(), Iwhich, 2)
+ CALL Get_Ffz (Dqfb, Dbb, X, C0a, C1a, C2a, C1b, C2b, C3b, Mm, multScat%getNumTheta()-1, Iwhich, 2)
Daa = Get_Exp (Daa) /Tta
Dbb = Get_Exp (Dbb) /Ttb
Dfv = D1*Daa + D0*Dbb
Dfv = Dfv*Ttt
-C
- CALL Get_Ffz (Qfb, Daa, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, multScat%getNumTheta(), Iwhich, 2)
- CALL Get_Ffz (Qfb, Dbb, X, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, multScat%getNumTheta()-1, Iwhich, 2)
+!
+ CALL Get_Ffz (Qfb, Daa, X, D0a, D1a, D2a, D1b, D2b, D3b, Mm, multScat%getNumTheta(), Iwhich, 2)
+ CALL Get_Ffz (Qfb, Dbb, X, D0a, D1a, D2a, D1b, D2b, D3b, Mm, multScat%getNumTheta()-1, Iwhich, 2)
Daa = Get_Exp (Daa)
Dbb = Get_Exp (Dbb)
Dfw = D1*Daa*Aa + D0*Dbb*Bb
Dfw = Dfw /Totalp * Ttt
-C *** Dfw = d(e^Q)/d(Totalp) = dQ/d(Tt) e^Q d(Tt)/D(Totalp)
-C *** where Fz=e^Q and d(Tt)/d(U) = 1/Totalp
+! *** Dfw = d(e^Q)/d(Totalp) = dQ/d(Tt) e^Q d(Tt)/D(Totalp)
+! *** where Fz=e^Q and d(Tt)/d(U) = 1/Totalp
END IF
-C ****************************************************************
+! ****************************************************************
END IF
-C *******************************************************************
+! *******************************************************************
END IF
-C **********************************************************************
-C
-C
-C *** OK, now we have Fz = contribution from integrals #4 & 5 of Eq. (35),
-C *** for a given mu [ergo, given Total =Sigma_Total(E ),
-C *** Totalp=Sigma_Total(E'), &
-C *** cos(theta) which corresponds to E']
-C
+! **********************************************************************
+!
+!
+! *** OK, now we have Fz = contribution from integrals #4 & 5 of Eq. (35),
+! *** for a given mu [ergo, given Total =Sigma_Total(E ),
+! *** Totalp=Sigma_Total(E'), &
+! *** cos(theta) which corresponds to E']
+!
IF (Ksolvx.NE.2) THEN
Dfz = Dfv
Dpfz = Dfw
IF (Kvthck.GT.0) THEN
IF (Iwhich.EQ.1) THEN
Dnfz = Dnfz - Total*Fz
-CC ELSE
-CC Dnfz = Dnfz
+!C ELSE
+!C Dnfz = Dnfz
END IF
END IF
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Get_W_Coef (Xtpt_W, Tt, Nxtptw, M, C0a, C1a,
- * C2a, C1b, C2b, C3b, D0a, D1a, D2a, D1b, D2b, D3b)
-C *** Purpose -- Figure coefficients for interpolation
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Get_W_Coef (Xtpt_W, Tt, Nxtptw, M, C0a, C1a, &
+ C2a, C1b, C2b, C3b, D0a, D1a, D2a, D1b, D2b, D3b)
+! *** Purpose -- Figure coefficients for interpolation
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION Xtpt_W(Nxtptw)
DATA Two /2.0d0/
@@ -373,104 +338,103 @@ C *** Purpose -- Figure coefficients for interpolation
ELSE IF (M.EQ.Nxtptw-2) THEN
M = Nxtptw - 3
END IF
-C *** Use four-point interpolation with M, M+1, M+2, and M+3
+! *** Use four-point interpolation with M, M+1, M+2, and M+3
Mm = M
A10 = Xtpt_W(Mm+1) - Xtpt_W(Mm)
A20 = Xtpt_W(Mm+2) - Xtpt_W(Mm)
A21 = Xtpt_W(Mm+2) - Xtpt_W(Mm+1)
A31 = Xtpt_W(Mm+3) - Xtpt_W(Mm+1)
A32 = Xtpt_W(Mm+3) - Xtpt_W(Mm+2)
-C
+!
C0a = ((Xtpt_W(Mm+2)-Tt)/A20) * ((Xtpt_W(Mm+1)-Tt)/A10)
C1a = ((Xtpt_W(Mm+2)-Tt)/A21) * ((Tt-Xtpt_W(Mm ))/A10)
C2a = ((Tt-Xtpt_W(Mm+1))/A21) * ((Tt-Xtpt_W(Mm ))/A20)
C1b = ((Xtpt_W(Mm+3)-Tt)/A31) * ((Xtpt_W(Mm+2)-Tt)/A21)
C2b = ((Xtpt_W(Mm+3)-Tt)/A32) * ((Tt-Xtpt_W(Mm+1))/A21)
C3b = ((Tt-Xtpt_W(Mm+2))/A32) * ((Tt-Xtpt_W(Mm+1))/A31)
-C
+!
D0a = ( Two*Tt-Xtpt_W(Mm+2)-Xtpt_W(Mm+1))/(A10*A20)
D1a = (-Two*Tt+Xtpt_W(Mm+2)+Xtpt_W(Mm ))/(A10*A21)
D2a = ( Two*Tt-Xtpt_W(Mm+1)-Xtpt_W(Mm ))/(A20*A21)
D1b = ( Two*Tt-Xtpt_W(Mm+3)-Xtpt_W(Mm+2))/(A21*A31)
D2b = (-Two*Tt+Xtpt_W(Mm+3)+Xtpt_W(Mm+1))/(A21*A32)
D3b = ( Two*Tt-Xtpt_W(Mm+2)-Xtpt_W(Mm+1))/(A31*A32)
-C
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Get_Ffz (Qfb, Ffz, Dffz, D0a, D1a, D2a, D1b, D2b, D3b,
- * Mm, Ith, Iwhich, L)
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Get_Ffz (Qfb, Ffz, Dffz, D0a, D1a, D2a, D1b, D2b, D3b, &
+ Mm, Ith, Iwhich, L)
use fixedi_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Qfb(Nxtptw,Ntheta,2)
DATA Half /0.5d0/
Ffz = -8000.0d0
- IF (Qfb(Mm ,Ith,Iwhich).GT.-8000.0D0 .AND.
- * Qfb(Mm+1,Ith,Iwhich).GT.-8000.0D0 .AND.
- * Qfb(Mm+2,Ith,Iwhich).GT.-8000.0D0) THEN
- Ffz = D0a*Qfb(Mm ,Ith,Iwhich)
- * + D1a*Qfb(Mm+1,Ith,Iwhich)
- * + D2a*Qfb(Mm+2,Ith,Iwhich)
+ IF (Qfb(Mm ,Ith,Iwhich).GT.-8000.0D0 .AND. &
+ Qfb(Mm+1,Ith,Iwhich).GT.-8000.0D0 .AND. &
+ Qfb(Mm+2,Ith,Iwhich).GT.-8000.0D0) THEN
+ Ffz = D0a*Qfb(Mm ,Ith,Iwhich) &
+ + D1a*Qfb(Mm+1,Ith,Iwhich) &
+ + D2a*Qfb(Mm+2,Ith,Iwhich)
IF (Qfb(Mm+3,Ith,Iwhich).GT.-8000.0D0) THEN
- Ffz = Ffz + D1b*Qfb(Mm+1,Ith,Iwhich)
- * + D2b*Qfb(Mm+2,Ith,Iwhich)
- * + D3b*Qfb(Mm+3,Ith,Iwhich)
+ Ffz = Ffz + D1b*Qfb(Mm+1,Ith,Iwhich) &
+ + D2b*Qfb(Mm+2,Ith,Iwhich) &
+ + D3b*Qfb(Mm+3,Ith,Iwhich)
Ffz = Ffz*Half
END IF
- ELSE IF (Qfb(Mm+1,Ith,Iwhich).GT.-8000.0D0 .AND.
- * Qfb(Mm+2,Ith,Iwhich).GT.-8000.0D0 .AND.
- * Qfb(Mm+3,Ith,Iwhich).GT.-8000.0D0) THEN
- Ffz = D1b*Qfb(Mm+1,Ith,Iwhich)
- * + D2b*Qfb(Mm+2,Ith,Iwhich)
- * + D3b*Qfb(Mm+3,Ith,Iwhich)
+ ELSE IF (Qfb(Mm+1,Ith,Iwhich).GT.-8000.0D0 .AND. &
+ Qfb(Mm+2,Ith,Iwhich).GT.-8000.0D0 .AND. &
+ Qfb(Mm+3,Ith,Iwhich).GT.-8000.0D0) THEN
+ Ffz = D1b*Qfb(Mm+1,Ith,Iwhich) &
+ + D2b*Qfb(Mm+2,Ith,Iwhich) &
+ + D3b*Qfb(Mm+3,Ith,Iwhich)
END IF
-C
+!
IF (L.EQ.4) THEN
Dffz = -8000.
- IF (Qfb(Mm ,Ith,Iwhich+2).GT.-8000.0D0 .AND.
- * Qfb(Mm+1,Ith,Iwhich+2).GT.-8000.0D0 .AND.
- * Qfb(Mm+2,Ith,Iwhich+2).GT.-8000.0D0) THEN
- Dffz = D0a*Qfb(Mm ,Ith,Iwhich+2)
- * + D1a*Qfb(Mm+1,Ith,Iwhich+2)
- * + D2a*Qfb(Mm+2,Ith,Iwhich+2)
+ IF (Qfb(Mm ,Ith,Iwhich+2).GT.-8000.0D0 .AND. &
+ Qfb(Mm+1,Ith,Iwhich+2).GT.-8000.0D0 .AND. &
+ Qfb(Mm+2,Ith,Iwhich+2).GT.-8000.0D0) THEN
+ Dffz = D0a*Qfb(Mm ,Ith,Iwhich+2) &
+ + D1a*Qfb(Mm+1,Ith,Iwhich+2) &
+ + D2a*Qfb(Mm+2,Ith,Iwhich+2)
IF (Qfb(Mm+3,Ith,Iwhich+2).GT.-8000.0D0) THEN
- Dffz = Dffz + D1b*Qfb(Mm+1,Ith,Iwhich+2)
- * + D2b*Qfb(Mm+2,Ith,Iwhich+2)
- * + D3b*Qfb(Mm+3,Ith,Iwhich+2)
+ Dffz = Dffz + D1b*Qfb(Mm+1,Ith,Iwhich+2) &
+ + D2b*Qfb(Mm+2,Ith,Iwhich+2) &
+ + D3b*Qfb(Mm+3,Ith,Iwhich+2)
Dffz = Dffz*Half
END IF
- ELSE IF (Qfb(Mm+1,Ith,Iwhich+2).GT.-8000.0D0 .AND.
- * Qfb(Mm+2,Ith,Iwhich+2).GT.-8000.0D0 .AND.
- * Qfb(Mm+3,Ith,Iwhich+2).GT.-8000.0D0) THEN
- Dffz = D1b*Qfb(Mm+1,Ith,Iwhich+2)
- * + D2b*Qfb(Mm+2,Ith,Iwhich+2)
- * + D3b*Qfb(Mm+3,Ith,Iwhich+2)
+ ELSE IF (Qfb(Mm+1,Ith,Iwhich+2).GT.-8000.0D0 .AND. &
+ Qfb(Mm+2,Ith,Iwhich+2).GT.-8000.0D0 .AND. &
+ Qfb(Mm+3,Ith,Iwhich+2).GT.-8000.0D0) THEN
+ Dffz = D1b*Qfb(Mm+1,Ith,Iwhich+2) &
+ + D2b*Qfb(Mm+2,Ith,Iwhich+2) &
+ + D3b*Qfb(Mm+3,Ith,Iwhich+2)
END IF
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Get_Ffz_1 (Ans, Cc, Aa, Bb, Dd, Ama, A0a, A1a,
- * A0b, A1b, A2b)
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Get_Ffz_1 (Ans, Cc, Aa, Bb, Dd, Ama, A0a, A1a, A0b, A1b, A2b)
use fixedi_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Zero /0.0d0/, Half /0.5d0/
- IF (Aa.NE.-8000.d0 .AND. Bb.NE.-8000.d0 .AND.
- * Cc.NE.-8000.d0) THEN
+ IF (Aa.NE.-8000.d0 .AND. Bb.NE.-8000.d0 .AND. &
+ Cc.NE.-8000.d0) THEN
Ffz = Ama*Cc + A0a*Aa + A1a*Bb
IF (Dd.NE.-8000.d0) THEN
Ffz = Ffz + A0b*Aa + A1b*Bb + A2b*Dd
Ffz = Ffz*Half
END IF
Fz = dEXP(Ffz)
- ELSE IF (Aa.NE.-8000.d0 .AND. Bb.NE.-8000.d0 .AND.
- * Dd.NE.-8000.d0) THEN
+ ELSE IF (Aa.NE.-8000.d0 .AND. Bb.NE.-8000.d0 .AND. &
+ Dd.NE.-8000.d0) THEN
Ffz = A0b*Aa + A1b*Bb + A2b*Dd
Fz = dEXP(Ffz)
ELSE
@@ -479,24 +443,23 @@ C
Ans = Fz
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Get_Ffz_3 (Ans, Cc, Aa, Bb, Dd, Ama, A0a, A1a,
- * A0b, A1b, A2b)
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Get_Ffz_3 (Ans, Cc, Aa, Bb, Dd, Ama, A0a, A1a, A0b, A1b, A2b)
use fixedi_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Half /0.5d0/
- IF (Aa.NE.-8000.d0 .AND. Bb.NE.-8000.d0 .AND.
- * Cc.NE.-8000.d0) THEN
+ IF (Aa.NE.-8000.d0 .AND. Bb.NE.-8000.d0 .AND. &
+ Cc.NE.-8000.d0) THEN
Ffz = Ama*Cc + A0a*Aa + A1a*Bb
IF (Dd.NE.-8000.d0) THEN
Ffz = Ffz + A0b*Aa + A1b*Bb + A2b*Dd
Ffz = Ffz*Half
END IF
- ELSE IF (Aa.NE.-8000.d0 .AND. Bb.NE.-8000.d0 .AND.
- * Dd.NE.-8000.d0) THEN
+ ELSE IF (Aa.NE.-8000.d0 .AND. Bb.NE.-8000.d0 .AND. &
+ Dd.NE.-8000.d0) THEN
Ffz = A0b*Aa + A1b*Bb + A2b*Dd
ELSE
Ffz = -8000.0d0
@@ -504,15 +467,15 @@ C
Ans = Ffz
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
DOUBLE PRECISION FUNCTION Get_Exp_X (Ffz, Aa, Bb, Dd)
IMPLICIT REAL*8 (A-H,O-Z)
DATA Zero /0.0d0/
- IF (Ffz.NE.-8000.d0 .AND. Aa.NE.-8000.0d0 .AND. Bb.NE.-8000.0d0
- * .AND. Dd.NE.-8000.0D0) THEN
+ IF (Ffz.NE.-8000.d0 .AND. Aa.NE.-8000.0d0 .AND. Bb.NE.-8000.0d0 &
+ .AND. Dd.NE.-8000.0D0) THEN
Fz = dEXP(Ffz)
ELSE
Fz = Zero
@@ -520,3 +483,5 @@ C
Get_Exp_X = Fz
RETURN
END
+
+end module ssm_14_m
diff --git a/sammy/src/ssm/mssm15.f b/sammy/src/ssm/mssm15.f90
similarity index 56%
rename from sammy/src/ssm/mssm15.f
rename to sammy/src/ssm/mssm15.f90
index 55388afd1..2cacd4945 100644
--- a/sammy/src/ssm/mssm15.f
+++ b/sammy/src/ssm/mssm15.f90
@@ -1,73 +1,77 @@
-C
-C
-C -----------------------------------------------------------------
-C
+!
+module ssm_15_m
+ contains
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Trpths2
-C
-C *** Purpose -- Add contribution from terms 1 through 3 in Eq. (36)
-C *** Normalization: Do not include 2 pi
-C
+!
+! *** Purpose -- Add contribution from terms 1 through 3 in Eq. (36)
+! *** Normalization: Do not include 2 pi
+!
use fixedi_m
use ifwrit_m
use ssssss_common_m
use xsect_x_common_m
+ use ssm_16_m
+ use ssm_17_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
IF (Costhe.NE.Zero) THEN
CALL Trpths2_Initialize
-C
+!
IF (Costhe.EQ.One) THEN
-C *** ----- F_{zRphi}^(1) from (D.24)ff + (D.34) through (D.37)
+! *** ----- F_{zRphi}^(1) from (D.24)ff + (D.34) through (D.37)
CALL Forward_One
-C
+!
ELSE IF (Costhe.GT.Zero) THEN
-C *** ----- Forward, mu = Costhe > 0
-C
+! *** ----- Forward, mu = Costhe > 0
+!
IF (Fffmu.LE.Rrr*Costhe) THEN
-C *** -------- F_{zRphi}^(1), Equations (D.7) thru (D.33) in ssm manual
-C *** valid for mu_f < mu < 1
+! *** -------- F_{zRphi}^(1), Equations (D.7) thru (D.33) in ssm manual
+! *** valid for mu_f < mu < 1
CALL Forward_1
-C
+!
ELSE IF (Fffmu.LE.Rs*Costhe) THEN
-C *** ---------F_{zRphi}^(2+3), Equations (D.45) and (D.60) in ssm manual
-C *** valid for 0 < mu < mu_s = cos(invtan(Rs/tanthe))
+! *** ---------F_{zRphi}^(2+3), Equations (D.45) and (D.60) in ssm manual
+! *** valid for 0 < mu < mu_s = cos(invtan(Rs/tanthe))
CALL Forward_2p3
-C
+!
ELSE
-C ELSE IF (Fffmu.GT.Rs*Costhe) THEN
-C *** -------- F_{zRphi}^(2+4), Equations (D.80) and (D.87) in ssm
-C *** valid for mu_s < mu < mu_f = cos(invtan([Rs-R0]/tanthe))
+! ELSE IF (Fffmu.GT.Rs*Costhe) THEN
+! *** -------- F_{zRphi}^(2+4), Equations (D.80) and (D.87) in ssm
+! *** valid for mu_s < mu < mu_f = cos(invtan([Rs-R0]/tanthe))
CALL Forward_2p4
END IF
-C
-C *** ----- finished with forward
-C
+!
+! *** ----- finished with forward
+!
ELSE
-C *** ----- backward, mu = Costhe < 0
-C
+! *** ----- backward, mu = Costhe < 0
+!
Costhp = - Costhe
IF (Fffmu.LE.Rrr*Costhp) THEN
-C *** -------- B_{zRphi}^(1) = Equations (E.4) thru (E.24) in ssm manual
+! *** -------- B_{zRphi}^(1) = Equations (E.4) thru (E.24) in ssm manual
CALL Backward_1
-C
+!
ELSE IF (Fffmu.LE.Rs*Costhp) THEN
-C *** -------- B_{zRphi}^(2+3), Eqs. (E.39) and (E.46) in ssm manual
+! *** -------- B_{zRphi}^(2+3), Eqs. (E.39) and (E.46) in ssm manual
CALL Backward_2p3
-C
+!
ELSE
-C ELSE IF (Fffmu.GT.Rs*Costhp) THEN
-C *** -------- B_{zRphi}^(2+4), Equations (E.59) and (E.63) in ssm manual
+! ELSE IF (Fffmu.GT.Rs*Costhp) THEN
+! *** -------- B_{zRphi}^(2+4), Equations (E.59) and (E.63) in ssm manual
CALL Backward_2p4
END IF
-C
-C *** ----- finished with backward
-C
+!
+! *** ----- finished with backward
+!
END IF
-C *** -- end of forward/backward if
-C
+! *** -- end of forward/backward if
+!
ELSE
-C *** Here when Costhe = Zero
+! *** Here when Costhe = Zero
Fz = Zero
Dfz = Zero
Dpfz = Zero
@@ -75,21 +79,21 @@ C *** Here when Costhe = Zero
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Trpths2_Initialize
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Fz = Zero
Dfz = Zero
Dpfz = Zero
Dnfz = Zero
-C
+!
Xnml = 0.3d0
Rrr = Rs - R0
Vv = Dthick*Total
@@ -98,7 +102,7 @@ C
Ww = Wwmu/Costhe
Xxxmu = Dthick*(Total*Costhe-Totalp)
Xxx = Xxxmu/Costhe
-C = X in Appendix D & E notes
+! = X in Appendix D & E notes
IF (Costhe.LE.-One .OR. Costhe.GE.One) THEN
Fffmu = Zero
Fff = Zero
@@ -112,15 +116,15 @@ C = X in Appendix D & E notes
Rzf = Rrr*Costhe/Sinthe
Fffmu = Sthick*Sinthe
Fff = Fffmu/Costhe
-C f = Fffmu/Costhe = Z tan(Theta)
+! f = Fffmu/Costhe = Z tan(Theta)
Yyv = Rrr*Vv*Costhe/Fffmu
Yyy = Rrr*Xxxmu/Fffmu
-C = rX/f in Appendix D
-C = -rX/f in Appendix E
+! = rX/f in Appendix D
+! = -rX/f in Appendix E
Zzv = Rs*Vv*Costhe/Fffmu
Zzz = Rs *Xxxmu/Fffmu
-C = R_s X/f in Appendix D
-C = -R_s X/f in Appendix E
+! = R_s X/f in Appendix D
+! = -R_s X/f in Appendix E
END IF
Fz = Zero
IF (Ksolvx.NE.2) THEN
@@ -130,3 +134,5 @@ C = -R_s X/f in Appendix E
END IF
RETURN
END
+
+end module ssm_15_m
\ No newline at end of file
diff --git a/sammy/src/ssm/mssm16.f b/sammy/src/ssm/mssm16.f90
similarity index 55%
rename from sammy/src/ssm/mssm16.f
rename to sammy/src/ssm/mssm16.f90
index fa3e99fc7..eb5ff6e56 100644
--- a/sammy/src/ssm/mssm16.f
+++ b/sammy/src/ssm/mssm16.f90
@@ -1,86 +1,88 @@
-C
-C
-C -----------------------------------------------------------------
-C
+!
+module ssm_16_m
+ contains
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Forward_One
-C *** Pupose -- Calculate F_{zRphi}^(1) when Costhe = 1.0
-C *** Equations (D.34) through (D.37) in the ssm manual.
+! *** Pupose -- Calculate F_{zRphi}^(1) when Costhe = 1.0
+! *** Equations (D.34) through (D.37) in the ssm manual.
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/
IF (Vv.GT.Xnml) THEN
-C *** Eq. (D.10)
+! *** Eq. (D.10)
Ev = dEXP(-Vv)
Av = (One-Ev)/Vv
IF (Ksolvx.NE.2) THEN
Dpav = Zero
-C *** Eq. (D.30)
+! *** Eq. (D.30)
Dav = (Ev-Av)*Dthick/Total
-C *** Eq. (D.14)
+! *** Eq. (D.14)
END IF
Ax = Ev
ELSE
-C *** Eq. (D.24)
+! *** Eq. (D.24)
Ev = Abcexp (-Vv, Aaz, Bbz, Ccz, Ddz, Ijklmn)
Av = Aaz
IF (Ksolvx.NE.2) THEN
Dpav = Zero
-C *** Eq. (D.30)
+! *** Eq. (D.30)
Dav = Dthick**2*(Bbz-Aaz)
-C *** Eq. (D.28)
+! *** Eq. (D.28)
END IF
END IF
Ax = Ev
-C *** Eq. (D.34)
+! *** Eq. (D.34)
A = Dthick*(Av-Ax)
Fz = A
IF (Ksolvx.NE.2) THEN
Dax = - Dthick**2*Ev/Two
-C *** Eq. (D.35)
+! *** Eq. (D.35)
Dpax = Dax
-C *** Eq. (D.36)
+! *** Eq. (D.36)
Dfz = Dav - Dax
Dpfz = - Dpax
Dnfz = Ev*Vv
-C *** Eqs. (D.18) + (D.37)
+! *** Eqs. (D.18) + (D.37)
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Forward_1
-C *** Pupose -- Calculate F_{zRphi}^(1), Eq. (D.7-33) in ssm manual.
-C *** Large Costhe so that the neutron cannot exit
-C *** through the curved edge.
+! *** Pupose -- Calculate F_{zRphi}^(1), Eq. (D.7-33) in ssm manual.
+! *** Large Costhe so that the neutron cannot exit
+! *** through the curved edge.
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Zero /0.0d0/ One /1.0d0/
-C
+!
IF (Vv.GT.Xnml) THEN
Ev = dEXP(-Vv)
Av = (One-Ev)/Vv
-C *** F_{zRphi}^(1a) Eq. (D.10)
+! *** F_{zRphi}^(1a) Eq. (D.10)
ELSE
Ev = Abcexp (-Vv, Aaz, Bbz, Ccz, Ddz, Ijklmn)
Av = Aaz
-C *** F_{zRphi}^(1a) Eq. (D.24)
+! *** F_{zRphi}^(1a) Eq. (D.24)
END IF
IF (Ksolvx.NE.2) THEN
Dav = Dthick*(Ev-Av)/Total
-C *** Eq. (D.14)
+! *** Eq. (D.14)
Dnav = Ev
-C *** Eq. (D.18)
+! *** Eq. (D.18)
Dpav = Zero
-C *** Eq. (D.16)
+! *** Eq. (D.16)
END IF
-C
+!
IF (Xxx.GT.Xnml .OR. Xxx.LT.-Xnml) THEN
-C (X is not small)
-C *** -- F_{zRphi}^(1b), Equation (D.11) in ssm manual.
+! (X is not small)
+! *** -- F_{zRphi}^(1b), Equation (D.11) in ssm manual.
Ex = dEXP (Xxx)
T = (Ex-One)*Costhe/Xxxmu
Ax = Ev*T
@@ -88,31 +90,31 @@ C *** -- F_{zRphi}^(1b), Equation (D.11) in ssm manual.
IF (Ksolvx.NE.2) THEN
Dadx = Ev*(Ex-T)
Dadx = Dadx/Xxxmu * Dthick**2
-C = dA/d(X) /Costhe, (D.13)
+! = dA/d(X) /Costhe, (D.13)
Dpax = - Dadx
-C = dA/d(totalp), Eq.(D.17)
+! = dA/d(totalp), Eq.(D.17)
Dax = Dadx*Costhe - Ax*Dthick**2
-C = dA/d(total), Eq. (D.15)
+! = dA/d(total), Eq. (D.15)
Ew = dEXP (-Ww)
Dnax = Total*Costhe*Ev - Totalp*Ew
Dnax = Dnax/Xxxmu*Dthick
-C = dA/d(thick), Eq. (D.19)
+! = dA/d(thick), Eq. (D.19)
END IF
ELSE
-C (X is small)
-C *** -- F_{zRphi}^(1b), Equation (D.25-33) in ssm manual.
+! (X is small)
+! *** -- F_{zRphi}^(1b), Equation (D.25-33) in ssm manual.
Abc = Abcexp (Xxx, Aaz, Bbz, Ccz, Ddz, Ijklmn)
Ax = Ev*Aaz
-C *** Eq. (D.25)
+! *** Eq. (D.25)
IF (Ksolvx.NE.2) THEN
Dadx = Ev*(Aaz-Bbz)
-C *** Eq. (D.27)
+! *** Eq. (D.27)
Dax = - Dthick**2*Ev*Bbz
-C *** Eq. (D.29)
+! *** Eq. (D.29)
Dpax = - Dthick**2*Dadx/Costhe
-C *** Eq. (D.31)
+! *** Eq. (D.31)
Dnax = Ev*(One-Ww*Aaz)
-C *** Eq. (D.33)
+! *** Eq. (D.33)
END IF
END IF
Fz = Dthick*(Av-Ax)
@@ -123,26 +125,26 @@ C *** Eq. (D.33)
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Forward_2p3
-C
-C *** Purpose -- Calculate F_{zRphi}^(2+3), Equations (D.38) through
-C *** (D.77) in ssm manual
-C *** Costhe is small and positive, so that the neutron may
-C *** exit through the curved edge.
-C *** The value of (Z-Rs/tan(Theta)) is negative so the
-C *** lower limit of the integration over z is zero.
-C
+!
+! *** Purpose -- Calculate F_{zRphi}^(2+3), Equations (D.38) through
+! *** (D.77) in ssm manual
+! *** Costhe is small and positive, so that the neutron may
+! *** exit through the curved edge.
+! *** The value of (Z-Rs/tan(Theta)) is negative so the
+! *** lower limit of the integration over z is zero.
+!
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA One /1.0d0/, Two /2.0d0/, Three /3.0d0/
Rsf = Rs - Fff
IF (Yyv.GT.Xnml .OR. Yyv.LT.-Xnml) THEN
-C *** F_{zRphi}^(2a+3a) from Eq. (D.45)
+! *** F_{zRphi}^(2a+3a) from Eq. (D.45)
Eyv = dEXP (Yyv)
Twofx = Two *(Fff/Vv)
Twofxs = Twofx*(Fff/Vv)
@@ -152,13 +154,13 @@ C *** F_{zRphi}^(2a+3a) from Eq. (D.45)
Av = Ccz/Vv
IF (Ksolvx.NE.2) THEN
Dnav = - Rsf*Twofx - Twofxs + Ev*Eyv*Bbz + Ev*R0**2
-C *** dF_{zRphi}^(2a+3a)/dn from Eq.(D.47)
+! *** dF_{zRphi}^(2a+3a)/dn from Eq.(D.47)
Ddz = Rsf**2 + Two*Rsf*Twofx + Three*Twofxs
Ddz = - Ddz/Vv + Ev*R0**2*(One+One/Vv)
Ccz = Two*R0*Twofx + Three*Twofxs
Ccz = Ccz/Vv + Bbz*(One-Rrr/Fff)
Dav = (Ddz+Ev*Eyv*Ccz)*Dthick/Total
-C *** dF_{zRphi}^(2a+3a)/dtotal from Eq.(D.46)
+! *** dF_{zRphi}^(2a+3a)/dtotal from Eq.(D.46)
END IF
ELSE
Abcx = Abcexp (Vv , Aax, Bbx, Ccx, Ddx, Ijklmn)
@@ -166,90 +168,90 @@ C *** dF_{zRphi}^(2a+3a)/dtotal from Eq.(D.46)
Aaz = Two*Rsf*Fff*Bbx + Two*Fff**2*Ccx + Rsf**2*Aax
Bbz =(Two*R0 *Rrr*Bby + Two*Rrr**2*Ccy) * (Rrr/Fff)
Av = Ev * (Aaz-Bbz)
-C *** F_{zRphi}^(2a+3a) from Eq. (D.53)
+! *** F_{zRphi}^(2a+3a) from Eq. (D.53)
IF (Ksolvx.NE.2) THEN
- Aaz = Two*Rsf*Fff*(Bbx-Two *Ccx)
- * + Two*Fff**2 *(Ccx-Three*Ddx)
- * + Rsf**2 *(Aax- Bbx)
- Bbz = (Two*R0 *Rrr*(Bby-Two *Ccy)
- * + Two*Rrr**2 *(Ccy-Three*Ddy) )* (Rrr/Fff)**2
+ Aaz = Two*Rsf*Fff*(Bbx-Two *Ccx) &
+ + Two*Fff**2 *(Ccx-Three*Ddx) &
+ + Rsf**2 *(Aax- Bbx)
+ Bbz = (Two*R0 *Rrr*(Bby-Two *Ccy) &
+ + Two*Rrr**2 *(Ccy-Three*Ddy) )* (Rrr/Fff)**2
Dadx = Ev * (Aaz-Bbz)
Dadx = Dadx * Dthick
Dav = Dthick*(Dadx-Av*Dthick)
-C *** dF_{zRphi}^(2a+3a)/dTotal from Eq. (D.55)
- Dnav = - Fff*(Rsf*Aax+Fff*Bbx)
- * + Rrr*(R0 *Aay+Rrr*Bby)
+! *** dF_{zRphi}^(2a+3a)/dTotal from Eq. (D.55)
+ Dnav = - Fff*(Rsf*Aax+Fff*Bbx) &
+ + Rrr*(R0 *Aay+Rrr*Bby)
Dnav = R0**2 + Two*Dnav
Dnav = Dnav*Ev
-C *** dF_{zRphi}^(2a+3a)/dn from Eq. (D.56) or (D.57)
-C Dpav = Zero
+! *** dF_{zRphi}^(2a+3a)/dn from Eq. (D.56) or (D.57)
+! Dpav = Zero
END IF
END IF
-C
+!
IF (Xxx.GT.Xnml .OR. Xxx.LT.-Xnml) THEN
-C (X is not small)
-C *** -- F_{zRphi}^(2b+3b), Equation (D.61) in ssm
+! (X is not small)
+! *** -- F_{zRphi}^(2b+3b), Equation (D.61) in ssm
Ex = dEXP (Xxx)
Ey = dEXP (Yyy)
Twofx = Two *(Fffmu/Xxxmu)
Twofxs = Twofx*(Fffmu/Xxxmu)
Aaz = Rsf**2 + Rsf*Twofx + Twofxs
-C Aaz=T1 in (D.62)
+! Aaz=T1 in (D.62)
Bbz = R0 *Twofx + Twofxs
-C Bbz=T2 in (D.62)
+! Bbz=T2 in (D.62)
Ccz = Ex*Aaz - Ey*Bbz - R0**2
-C Ccz={} in (D.61)
+! Ccz={} in (D.61)
Ax = Ev*Ccz/Xxx
-C F in (D.61) without Dthick/R0^2
+! F in (D.61) without Dthick/R0^2
IF (Ksolvx.NE.2) THEN
Dnax = Wwmu*Rsf**2 + (Rsf*Twofx+Twofxs)*Vv*Costhe
Dnax = - Ex*Dnax/Xxxmu + Vv*(Ey*Bbz+R0**2)/Xxx
Dnax = Ev*Dnax
-C ~ dF/d(thick) in (D.68)
- Ddz = Ex*( Aaz - (Rsf*Twofx+Two*Twofxs)/Xxx )
- * - Ey*( Bbz*(Rrr/Fff)
- * - (R0 *Twofx+Two*Twofxs)/Xxx )
+! ~ dF/d(thick) in (D.68)
+ Ddz = Ex*( Aaz - (Rsf*Twofx+Two*Twofxs)/Xxx ) &
+ - Ey*( Bbz*(Rrr/Fff) &
+ - (R0 *Twofx+Two*Twofxs)/Xxx )
Ddz = Ddz*Ev - Ax
Dadxmu = Dthick**2 * Ddz/Xxxmu
-C = dA/d(X) /Costhe * R_0**2 in (D.63)
+! = dA/d(X) /Costhe * R_0**2 in (D.63)
Dpax = - Dadxmu
-C ~ dA/d(totalp) in (D.66)
+! ~ dA/d(totalp) in (D.66)
Dax = Dadxmu*Costhe - Ax*Dthick**2
-C ~ dA/d(total) in (D.65)
+! ~ dA/d(total) in (D.65)
END IF
-C
+!
ELSE
-C (Xxx is small)
-C *** -- F_{zRphi}^(2b+3b), Equation (D.71) in ssm manual
+! (Xxx is small)
+! *** -- F_{zRphi}^(2b+3b), Equation (D.71) in ssm manual
Abcx = Abcexp (Xxx, Aax, Bbx, Ccx, Ddx, Ijklmn)
Abcy = Abcexp (Yyy, Aay, Bby, Ccy, Ddy, Ijklmn)
Aaz = Two*Rsf*Fff*Bbx + Two*Fff**2*Ccx + Rsf**2*Aax
Bbz =(Two*R0 *Rrr*Bby + Two*Rrr**2*Ccy) * (Rrr/Fff)
Ax = Ev * (Aaz-Bbz)
-C F = Ax*Dthick/R0^2 in (D.71)
+! F = Ax*Dthick/R0^2 in (D.71)
IF (Ksolvx.NE.2) THEN
- Aaz = Two*Rsf*Fff*(Bbx-Two *Ccx)
- * + Two*Fff**2 *(Ccx-Three*Ddx)
- * + Rsf**2 *(Aax- Bbx)
- Bbz = (Two*R0 *Rrr*(Bby-Two *Ccy)
- * + Two*Rrr**2 *(Ccy-Three*Ddy) )* (Rrr/Fff)**2
+ Aaz = Two*Rsf*Fff*(Bbx-Two *Ccx) &
+ + Two*Fff**2 *(Ccx-Three*Ddx) &
+ + Rsf**2 *(Aax- Bbx)
+ Bbz = (Two*R0 *Rrr*(Bby-Two *Ccy) &
+ + Two*Rrr**2 *(Ccy-Three*Ddy) )* (Rrr/Fff)**2
Dadx = Ev * (Aaz-Bbz)
-C = dA/d(X) / Dthick in (D.74)
+! = dA/d(X) / Dthick in (D.74)
Dadx = Dadx * Dthick
Dax = Dthick*(Dadx-Ax*Dthick)
-C = dA/d(total) in (D.75)
+! = dA/d(total) in (D.75)
Dpax = - Dthick*Dadx/Costhe
-C = dA/d(totalp) in (D.76)
- Dnax = - Fff *(Rsf*Bbx+Fff*Ccx)
- * + Rrr**2*(R0 *Bby+Rrr*Ccy)/Fff
+! = dA/d(totalp) in (D.76)
+ Dnax = - Fff *(Rsf*Bbx+Fff*Ccx) &
+ + Rrr**2*(R0 *Bby+Rrr*Ccy)/Fff
Dnax = Dnax*Two*Vv + Rsf**2*(One-Ww*Aax)
Dnax = Dnax*Ev
-C = dA/d(thick) in (D.77)
+! = dA/d(thick) in (D.77)
END IF
END IF
A = (Av-Ax)*Dthick
Fz = A /(R0**2) + Fz
-C
+!
IF (Ksolvx.NE.2) THEN
Da = Dav - Dax
Dpa = - Dpax
@@ -260,24 +262,24 @@ C
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Forward_2p4
-C *** Pupose -- Calculate F_{zRphi}^(2+4), Equations (D.78) thru (D.98)
-C *** in the ssm manual.
-C *** Costhe is small and positive and so that the neutron may
-C *** exit through the curved edge.
-C *** The value of (Z-Rs/tan(Theta)) is > zero, so the lower
-C *** limit of the integration over z is (Z-Rs/tan(Theta)).
+! *** Pupose -- Calculate F_{zRphi}^(2+4), Equations (D.78) thru (D.98)
+! *** in the ssm manual.
+! *** Costhe is small and positive and so that the neutron may
+! *** exit through the curved edge.
+! *** The value of (Z-Rs/tan(Theta)) is > zero, so the lower
+! *** limit of the integration over z is (Z-Rs/tan(Theta)).
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Two /2.0d0/, Three /3.0d0/
-C
+!
IF (Zzv.GT.Xnml .OR. Zzv.LT.-Xnml) THEN
-C *** Here for relatively large exponentials (small Fff)
+! *** Here for relatively large exponentials (small Fff)
Eyv = dEXP (Yyv)
Ezv = dEXP (Zzv)
Aaz = Two*Fff/Vv
@@ -285,7 +287,7 @@ C *** Here for relatively large exponentials (small Fff)
Aaz = Aaz*Fff/Vv
Aay = Bby + Aaz
Av = Ev*(Ezv*Aaz-Eyv*Aay-R0**2)/Vv
-C *** -- F_{zRphi}^(2a+4a), Equation (D.82) in ssm manual
+! *** -- F_{zRphi}^(2a+4a), Equation (D.82) in ssm manual
IF (Ksolvx.NE.2) THEN
Dnav = - Vv*Av
Ddz = - Two*Aaz/Vv
@@ -295,26 +297,26 @@ C *** -- F_{zRphi}^(2a+4a), Equation (D.82) in ssm manual
Dav = (Ddx-Av)*Dthick**2
END IF
ELSE
-C *** Here for relatively small exponentials (large Fff)
+! *** Here for relatively small exponentials (large Fff)
Abc = Abcexp (Zzv, Aaz, Bbz, Ccz, Ddz, Ijklmn)
Abc = Abcexp (Yyv, Aay, Bby, Ccy, Ddy, Ijklmn)
Aax = Rs**3*Ccz - Rrr**2*(Rrr*Ccy+R0*Bby)
Aax = Two*Aax/Fffmu
Av = Ev*Aax*Costhe
-C *** -- F_{zRphi}^(2a+4a), Equation (???)
+! *** -- F_{zRphi}^(2a+4a), Equation (???)
IF (Ksolvx.NE.2) THEN
- Ddx = Rs**3*(Ccz-Three*Ddz)*Rs
- * - Rrr**3*(Ccy-Three*Ddy)*Rrr
- * - R0*Rrr**2*(Bby-Two*Ccy)*Rrr
+ Ddx = Rs**3*(Ccz-Three*Ddz)*Rs &
+ - Rrr**3*(Ccy-Three*Ddy)*Rrr &
+ - R0*Rrr**2*(Bby-Two*Ccy)*Rrr
Ddx = Two*Ev*Ddx*(Costhe/Fffmu)**2
Dnav = -Vv*Av
Dav = (Ddx-Av)*Dthick**2
END IF
END IF
-C
+!
IF (Xxx.GT.Xnml .OR. Xxx.LT.-Xnml) THEN
-C (Xxx is not small)
-C *** -- F_{zRphi}^(2b+4b), Equation (D.80) in ssm manual
+! (Xxx is not small)
+! *** -- F_{zRphi}^(2b+4b), Equation (D.80) in ssm manual
Ey = dEXP (Yyy)
Ez = dEXP (Zzz)
Aaz = Two*Fffmu/Xxxmu
@@ -323,54 +325,54 @@ C *** -- F_{zRphi}^(2b+4b), Equation (D.80) in ssm manual
Aay = Bby + Aaz
Aax = Ev*(Ez*Aaz-Ey*Aay-R0**2)/Xxxmu
Ax = Aax*Costhe
-C F = Ax*Dthick/R0^2 in (D.80)
+! F = Ax*Dthick/R0^2 in (D.80)
IF (Ksolvx.NE.2) THEN
Ddz = - Two*Aaz/Xxxmu
-C d(Aaz)/dX = Costhe*Ddz
+! d(Aaz)/dX = Costhe*Ddz
Ddy = Ddz - Bby/Xxxmu
-C d(Aay)/dX = Costhe*Ddy
+! d(Aay)/dX = Costhe*Ddy
Ddx = Ez*(Ddz+Aaz*Rs/Fffmu) - Ey*(Ddy+Aay*Rrr/Fffmu)
Ddx = (Ev*Ddx-Aax)/Xxxmu
-C d(Aax)/dX = Costhe*dF/dX in (D.84)
+! d(Aax)/dX = Costhe*dF/dX in (D.84)
Dnax = - Vv*Ax
-C dF/d(thick) in (D.89)
+! dF/d(thick) in (D.89)
Ddx = Ddx * Dthick**2
Dpax = - Ddx*Costhe
-C dF/d(totalp) in (D.84+85)
+! dF/d(totalp) in (D.84+85)
Dax = - Dpax*Costhe - Ax*Dthick**2
-C dF/d(total) in (D.84+85)
+! dF/d(total) in (D.84+85)
END IF
-C
+!
ELSE
-C (Xxx is small)
-C
+! (Xxx is small)
+!
IF (Zzz.LT.Xnml .AND. Zzz.GT.-Xnml) THEN
-C (Zzz=Rs*X/f is small)
-C *** ----- F_{zRphi}^(2b+4b), Equation (D.92) in ssm manual
+! (Zzz=Rs*X/f is small)
+! *** ----- F_{zRphi}^(2b+4b), Equation (D.92) in ssm manual
Abc = Abcexp (Zzz, Aaz, Bbz, Ccz, Ddz, Ijklmn)
Abc = Abcexp (Yyy, Aay, Bby, Ccy, Ddy, Ijklmn)
Aax = Rs**3*Ccz - Rrr**2*(Rrr*Ccy+R0*Bby)
Aax = Two*Aax/Fffmu
Ax = Ev*Aax*Costhe
-C F = A*Dthick/R0^2 in (D.92)
+! F = A*Dthick/R0^2 in (D.92)
IF (Ksolvx.NE.2) THEN
- Ddx = Rs**3*(Ccz-Three*Ddz)*Rs
- * - Rrr**3*(Ccy-Three*Ddy)*Rrr
- * - R0*Rrr**2*(Bby-Two*Ccy)*Rrr
+ Ddx = Rs**3*(Ccz-Three*Ddz)*Rs &
+ - Rrr**3*(Ccy-Three*Ddy)*Rrr &
+ - R0*Rrr**2*(Bby-Two*Ccy)*Rrr
Ddx = Two*Ev*Ddx/Fffmu**2 * Costhe
-C dA/dX / Costhe in (D.94)
+! dA/dX / Costhe in (D.94)
Dnax = -Vv*Ax
-C dF/d(thick) in (D.89)
+! dF/d(thick) in (D.89)
Ddx = Ddx * Dthick**2
Dpax = - Ddx
-C dF/d(totalp) in (D.94+85)
+! dF/d(totalp) in (D.94+85)
Dax = - Dpax*Costhe - Dthick**2*Ax
-C dF/d(total) in (D.94+85)
+! dF/d(total) in (D.94+85)
END IF
ELSE
-C (Zzz=Rs*X/f is large)
-C *** ----- F_{zRphi}^(2+4), Equation (D.99) in ssm manual
-C *** This one hasn't been well checked; not sure we ever get here
+! (Zzz=Rs*X/f is large)
+! *** ----- F_{zRphi}^(2+4), Equation (D.99) in ssm manual
+! *** This one hasn't been well checked; not sure we ever get here
Ez = dEXP (Zzz)
Yzz = -R0*Xxxmu/Fffmu
Abc = Abcexp (Zzz, Aaz, Bbz, Ccz, Ddz, Ijklmn)
@@ -379,20 +381,20 @@ C *** This one hasn't been well checked; not sure we ever get here
Aax = Bbx + Rs*Aaz
Aax = Aax/Fffmu
Ax = Ev*Aax*Costhe
-C F = A*Dthick in (D.99)
+! F = A*Dthick in (D.99)
IF (Ksolvx.NE.2) THEN
Ddx = Three*Ccy - Three*Ddy - Bby
Ddx = Ez*Two*R0**2*Ddx + Rs**2*(Aaz-Bbz)
Ddx = (Bbx*Rs+Ddx)/Fffmu
Ddx = Ev*Ddx*R0**2/Fffmu * Costhe
-C dF/dX = Ddx*Costhe*Dthick in (D.102)
+! dF/dX = Ddx*Costhe*Dthick in (D.102)
Dna = Ddx*Xxxmu - Vv*Ax
-C dF/d(thick) in (D.102+85)
+! dF/d(thick) in (D.102+85)
Ddx = Ddx*Dthick**2
Dax = Ddx*Costhe - Ax*Dthick**2
-C dF/d(total) in (D.75+66)
+! dF/d(total) in (D.75+66)
Dpax = - Ddx
-C dF/d(totalp) in (D.75+66)
+! dF/d(totalp) in (D.75+66)
END IF
END IF
END IF
@@ -408,3 +410,5 @@ C dF/d(totalp) in (D.75+66)
END IF
RETURN
END
+
+end module ssm_16_m
diff --git a/sammy/src/ssm/mssm17.f b/sammy/src/ssm/mssm17.f90
similarity index 53%
rename from sammy/src/ssm/mssm17.f
rename to sammy/src/ssm/mssm17.f90
index e1db99706..aed574b4e 100644
--- a/sammy/src/ssm/mssm17.f
+++ b/sammy/src/ssm/mssm17.f90
@@ -1,53 +1,55 @@
-C
-C
-C -----------------------------------------------------------------
-C
+!
+module ssm_17_m
+ contains
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Backward_1
-C *** Pupose -- Calculate B_{zRphi}^(1) = Equation (E.6-7) in ssm manual.
-C *** Costhe is near -1.0 so the neutron may not exit through
-C *** the curved edge.
+! *** Pupose -- Calculate B_{zRphi}^(1) = Equation (E.6-7) in ssm manual.
+! *** Costhe is near -1.0 so the neutron may not exit through
+! *** the curved edge.
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA One /1.0d0/
-C
+!
Fpf = - Fff
Costhp= - Costhe
IF (Vv.GT.Xnml) THEN
Av = (One-Ev)/Vv
-C *** -- B_{zRphi}^(1a) = Equation (E.6) in ssm manual.
+! *** -- B_{zRphi}^(1a) = Equation (E.6) in ssm manual.
ELSE
Ev = Abcexp (-Vv, Aaz, Bbz, Ccz, Ddz, Ijklmn)
Av = Aaz
-C *** -- B_{zRphi}^(1a) = Equation (E.17) in ssm manual.
+! *** -- B_{zRphi}^(1a) = Equation (E.17) in ssm manual.
END IF
IF (Ksolvx.NE.2) THEN
Dav = Dthick*(Ev-Av)/Total
-C *** -- dB_{zRphi}^(1a)/dTotal = Equation (E.11) in ssm manual.
+! *** -- dB_{zRphi}^(1a)/dTotal = Equation (E.11) in ssm manual.
Dnav = Ev
-C *** -- dB_{zRphi}^(1a)/dThick = Equation (E.10) in ssm manual.
+! *** -- dB_{zRphi}^(1a)/dThick = Equation (E.10) in ssm manual.
END IF
-C
+!
IF (Xxx.GT.Xnml .OR. Xxx.LT.-Xnml) THEN
-C (Xxx is not small)
+! (Xxx is not small)
Ex = dEXP(-Xxx)
Ax = (One-Ex)*Costhe/Xxxmu
-C *** -- B_{zRphi}^(1b) = Equation (E.7) in ssm manual.
+! *** -- B_{zRphi}^(1b) = Equation (E.7) in ssm manual.
IF (Ksolvx.NE.2) THEN
Dadxmu = (Ex-Ax)/Xxxmu
-C = dA/d(X) /Costhe
+! = dA/d(X) /Costhe
Dpax = - Dthick**2*Dadxmu
-C = dA/d(totalp) in (E.15)
+! = dA/d(totalp) in (E.15)
Dax = - Dpax*Costhe
-C = dA/d(total) in (E.14)
+! = dA/d(total) in (E.14)
Dnax = Ex
-C = dA/d(thick) in (E.13)
+! = dA/d(thick) in (E.13)
END IF
-C
+!
ELSE
-C
-C (Xxx is small)
-C *** -- B_{zRphi}^(1b) = Equation (E.21) in ssm manual.
+!
+! (Xxx is small)
+! *** -- B_{zRphi}^(1b) = Equation (E.21) in ssm manual.
Abc = Abcexp (-Xxx, Aaz, Bbz, Ccz, Ddz, Ijklmn)
Ax = Aaz
IF (Ksolvx.NE.2) THEN
@@ -55,7 +57,7 @@ C *** -- B_{zRphi}^(1b) = Equation (E.21) in ssm manual.
Dax = Dthick**2*Dadx
Dpax= - Dax/Costhe
Dnax = One - Aaz*Xxx
-C (E.23), (E.24), (E.22)
+! (E.23), (E.24), (E.22)
END IF
END IF
Fz = Dthick*(Av-Ax)
@@ -66,17 +68,17 @@ C (E.23), (E.24), (E.22)
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Backward_2p3
-C *** Pupose -- Calculate B_{zRphi}^(2+3), Eqs. (E.46) and (E.39) in
-C *** ssm manual.
-C *** Costhp is small so that the neutron may exit
-C *** through the curved edge.
-C *** The value of (Z-Rs/|tan(Theta)|) is negative so the
-C *** lower limit of the integration over z is zero.
+! *** Pupose -- Calculate B_{zRphi}^(2+3), Eqs. (E.46) and (E.39) in
+! *** ssm manual.
+! *** Costhp is small so that the neutron may exit
+! *** through the curved edge.
+! *** The value of (Z-Rs/|tan(Theta)|) is negative so the
+! *** lower limit of the integration over z is zero.
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
@@ -85,9 +87,9 @@ C *** lower limit of the integration over z is zero.
Costhp= - Costhe
Ex = dEXP (-Xxx)
Rsf = Rs - Fpf
-C
+!
IF (Yyv.GT.Xnml .OR. Yyv.LT.-Xnml) THEN
-C *** -- B_{zRphi}^(2a+3a) from Eq. (E.46) plus (47-51)
+! *** -- B_{zRphi}^(2a+3a) from Eq. (E.46) plus (47-51)
Eyv = dEXP (Yyv)
Twofx = Two *(Fpf/Vv)
Twofxs = Twofx*(Fpf/Vv)
@@ -97,88 +99,88 @@ C *** -- B_{zRphi}^(2a+3a) from Eq. (E.46) plus (47-51)
Av = Ccz/Vv
IF (Ksolvx.NE.2) THEN
Dnav = Ev * Rsf**2
- Ddz = Ev *( Aaz-(Rsf*Twofx-Two*Twofxs)/Vv )
- * + Eyv*(-Bbz*(Rrr/Fpf)
- * + (R0 *Twofx-Two*Twofxs)/Vv )
+ Ddz = Ev *( Aaz-(Rsf*Twofx-Two*Twofxs)/Vv ) &
+ + Eyv*(-Bbz*(Rrr/Fpf) &
+ + (R0 *Twofx-Two*Twofxs)/Vv )
Dadx = (Ddz-Av)/Vv
Dav = Dthick**2*Dadx
END IF
ELSE
-C *** -- B_{zRphi}^(2a+3a) from Eq. (E.54) with X->v
+! *** -- B_{zRphi}^(2a+3a) from Eq. (E.54) with X->v
Abc = Abcexp (-Vv , Aax, Bbx, Ccx, Ddx, Ijklmn)
Abc = Abcexp ( Yyv, Aay, Bby, Ccy, Ddy, Ijklmn)
Aaz = Two*Fpf*(Rsf*Bbx+Fpf*Ccx) + Rsf**2*Aax
Bbz = Two*Rrr*(R0 *Bby+Rrr*Ccy) * (Rrr/Fpf)
Av = Aaz - Bbz
IF (Ksolvx.NE.2) THEN
- Aaz = Two*Rsf*Fpf*(Bbx-Two *Ccx)
- * + Two*Fpf**2 *(Ccx-Three*Ddx)
- * + Rsf**2 *(Aax- Bbx)
- Bbz = (Two*R0 *Rrr*(Bby-Two *Ccy)
- * + Two*Rrr**2 *(Ccy-Three*Ddy) )* (Rrr/Fpf)**2
+ Aaz = Two*Rsf*Fpf*(Bbx-Two *Ccx) &
+ + Two*Fpf**2 *(Ccx-Three*Ddx) &
+ + Rsf**2 *(Aax- Bbx)
+ Bbz = (Two*R0 *Rrr*(Bby-Two *Ccy) &
+ + Two*Rrr**2 *(Ccy-Three*Ddy) )* (Rrr/Fpf)**2
Dadx= Bbz - Aaz
Dav = Dthick**2*Dadx
- Aaz = Two*Rsf*Fpf*(Aax-Bbx)
- * + Two*Fpf**2 *(Bbx-Ccx*Two)
- * + Rsf**2 *(One-Aax)
- Bbz = (R0*Bby + Ccy*Rrr)*Rrr/Fpf
- * + (Aay-Two*Bby)*R0 + (Bby-Three*Ccy)
+ Aaz = Two*Rsf*Fpf*(Aax-Bbx) &
+ + Two*Fpf**2 *(Bbx-Ccx*Two) &
+ + Rsf**2 *(One-Aax)
+ Bbz = (R0*Bby + Ccy*Rrr)*Rrr/Fpf &
+ + (Aay-Two*Bby)*R0 + (Bby-Three*Ccy)
Bbz = Two*Bbz * (Rrr**2/Fpf)
Dnav= Ev*Rsf**2
END IF
END IF
-C
+!
IF (Xxx.GT.Xnml .OR. Xxx.LT.-Xnml) THEN
-C (Xxx is not small)
-C *** -- B_{zRphi}^(2b+3b), Equation (E.39) in ssm manual.
+! (Xxx is not small)
+! *** -- B_{zRphi}^(2b+3b), Equation (E.39) in ssm manual.
Ex = dEXP(-Xxx)
Ey = dEXP (Yyy)
Twofx = Two *(Fffmu/Xxxmu)
-C Twofx = - 2f/X = 2fmu/Xmu
+! Twofx = - 2f/X = 2fmu/Xmu
Twofxs = Twofx*(Fffmu/Xxxmu)
Aaz = Rsf**2 + Rsf*Twofx + Twofxs
Bbz = + R0 *Twofx + Twofxs
Ccz = - Ex*Aaz + Ey*Bbz + R0**2
Ax = Ccz/Xxx
-C B/Dthick in (E.39)
+! B/Dthick in (E.39)
IF (Ksolvx.NE.2) THEN
- Ddz = Ex*( Aaz + (Rsf*Twofx+Two*Twofxs)/Xxx )
- * + Ey*(-Bbz*(Rrr/Fpf) - (R0 *Twofx+Two*Twofxs)/Xxx )
+ Ddz = Ex*( Aaz + (Rsf*Twofx+Two*Twofxs)/Xxx ) &
+ + Ey*(-Bbz*(Rrr/Fpf) - (R0 *Twofx+Two*Twofxs)/Xxx )
Dadxmu = (Ddz-Ax)/Xxxmu
-C = dA/d(X) /Costhe in (E.42)
+! = dA/d(X) /Costhe in (E.42)
Dpax = - Dthick**2*Dadxmu
-C = dA/d(totalp) in (E.44)
+! = dA/d(totalp) in (E.44)
Dax = - Dpax*Costhe
-C = dA/d(total) in (E.43)
+! = dA/d(total) in (E.43)
Dnax = Ex*Rsf**2
-C = dA/d(thick) in (E.45)
+! = dA/d(thick) in (E.45)
END IF
-C
+!
ELSE
-C
-C (Xxx is small)
-C *** -- B_{zRphi}^(2b+3b), Equation (E.54) in ssm manual.
+!
+! (Xxx is small)
+! *** -- B_{zRphi}^(2b+3b), Equation (E.54) in ssm manual.
Abc = Abcexp (-Xxx, Aax, Bbx, Ccx, Ddx, Ijklmn)
Abc = Abcexp ( Yyy, Aay, Bby, Ccy, Ddy, Ijklmn)
Aaz = Two*Fpf*(Rsf*Bbx+Fpf*Ccx) + Rsf**2*Aax
Bbz = Two*Rrr*(R0 *Bby+Rrr*Ccy)*(Rrr/Fpf)
Ax = Aaz - Bbz
-C in (E.54)
+! in (E.54)
IF (Ksolvx.NE.2) THEN
- Aaz = Two*Rsf*Fpf*(Bbx-Two *Ccx)
- * + Two*Fpf**2 *(Ccx-Three*Ddx)
- * + Rsf**2 *(Aax- Bbx)
- Bbz = (Two*R0 *Rrr*(Bby-Two *Ccy)
- * + Two*Rrr**2 *(Ccy-Three*Ddy) )* (Rrr/Fpf)**2
+ Aaz = Two*Rsf*Fpf*(Bbx-Two *Ccx) &
+ + Two*Fpf**2 *(Ccx-Three*Ddx) &
+ + Rsf**2 *(Aax- Bbx)
+ Bbz = (Two*R0 *Rrr*(Bby-Two *Ccy) &
+ + Two*Rrr**2 *(Ccy-Three*Ddy) )* (Rrr/Fpf)**2
Dadx= Bbz - Aaz
-C in (E.55)
+! in (E.55)
Dax = Dthick**2*Dadx
Dpax = - Dax/Costhe
Dnax = Ex*Rsf**2
-C = dA/d(thick) in (E.56)
+! = dA/d(thick) in (E.56)
END IF
END IF
-C
+!
A = Dthick*(Av-Ax)
Fz = A /(R0**2) + Fz
IF (Ksolvx.NE.2) THEN
@@ -191,27 +193,27 @@ C
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Backward_2p4
-C *** Pupose -- Calculate B_{zRphi}^(2+4), Equations (E.63) and (E.59) in
-C *** the ssm manual.
-C *** Costhp is small and positive so that the neutron may exit
-C *** through the curved edge.
-C *** The value of (Z-Rs/|tan(Theta)|) is > zero, so the lower
-C *** limit of the integration over z is (Z-Rs/|tan(Theta)|).
+! *** Pupose -- Calculate B_{zRphi}^(2+4), Equations (E.63) and (E.59) in
+! *** the ssm manual.
+! *** Costhp is small and positive so that the neutron may exit
+! *** through the curved edge.
+! *** The value of (Z-Rs/|tan(Theta)|) is > zero, so the lower
+! *** limit of the integration over z is (Z-Rs/|tan(Theta)|).
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Zero /0.0d0/, Two /2.0d0/, Three /3.0d0/
-C
+!
Fpf = - Fff
Costhp= - Costhe
IF (Yyv.GT.Xnml .OR. Zzv.GT.Xnml) THEN
-C ??? what's the correct IF-test here?
-C *** -- B_{zRphi}^(2a+4a), Equation (E.63) in ssm manual.
+! ??? what's the correct IF-test here?
+! *** -- B_{zRphi}^(2a+4a), Equation (E.63) in ssm manual.
Eyv = dEXP (Yyv)
Ezv = dEXP (Zzv)
Twofx = - Two *(Fff/Vv)
@@ -221,33 +223,33 @@ C *** -- B_{zRphi}^(2a+4a), Equation (E.63) in ssm manual.
Ccz = - Ezv*Aaz + Eyv*Bbz + R0**2
Av = Ccz/Vv
IF (Ksolvx.NE.2) THEN
- Ddz = Ezv*( Aaz*(Rs /Fpf) + Two*Twofxs /Vv )
- * + Eyv*(-Bbz*(Rrr/Fpf)
- * + (R0 *Twofx-Two*Twofxs)/Vv )
+ Ddz = Ezv*( Aaz*(Rs /Fpf) + Two*Twofxs /Vv ) &
+ + Eyv*(-Bbz*(Rrr/Fpf) &
+ + (R0 *Twofx-Two*Twofxs)/Vv )
Dadx = (Ddz-Av)/Vv
Dav = Dthick**2*Dadx
END IF
ELSE
-C *** -- B_{zRphi}^(2a+4a), Equation (E.68) with X -> v
+! *** -- B_{zRphi}^(2a+4a), Equation (E.68) with X -> v
Abc = Abcexp (Zzv, Aaz, Bbz, Ccz, Ddz, Ijklmn)
Abc = Abcexp (Yyv, Aay, Bby, Ccy, Ddy, Ijklmn)
Aax = Rs**3*Ccz - Rrr**2*(Rrr*Ccy+R0*Bby)
Aax = Two*Aax/Fffmu
Av = Aax*Costhp
IF (Ksolvx.NE.2) THEN
- Ddx = Rs**3*(Ccz-Three*Ddz)*Rs
- * - Rrr**3*(Ccy-Three*Ddy)*Rrr
- * - R0*Rrr**2*(Bby-Two*Ccy)*Rrr
+ Ddx = Rs**3*(Ccz-Three*Ddz)*Rs &
+ - Rrr**3*(Ccy-Three*Ddy)*Rrr &
+ - R0*Rrr**2*(Bby-Two*Ccy)*Rrr
Ddx = Two*Ddx*(Dthick*Costhe/Fffmu)**2
Dav = - Ddx
END IF
END IF
-C
+!
IF (Xxx.GT.Xnml .OR. Xxx.LT.-Xnml) THEN
-C *** -- B_{zRphi}^(2b+4b), Equation (E.59) in ssm manual.
-C *** Remember that Yyy and Zzz are negative since fff < 0
-C *** (except, of course, that Xxx can be negative so Yyy
-C *** and Zzz would then be positive)
+! *** -- B_{zRphi}^(2b+4b), Equation (E.59) in ssm manual.
+! *** Remember that Yyy and Zzz are negative since fff < 0
+! *** (except, of course, that Xxx can be negative so Yyy
+! *** and Zzz would then be positive)
Ey = dEXP (Yyy)
Ez = dEXP (Zzz)
Twofx = - Two *(Fffmu/Xxxmu)
@@ -257,36 +259,36 @@ C *** and Zzz would then be positive)
Ccz = - Ez*Aaz + Ey*Bbz + R0**2
Aax = Ccz/Xxxmu
Ax = Aax*Costhe
-C (E.59)
+! (E.59)
IF (Ksolvx.NE.2) THEN
- Ddz = Ez*( Aaz*(Rs /Fpf) + Two*Twofxs /Xxx )
- * + Ey*(-Bbz*(Rrr/Fpf)
- * + (R0 *Twofx-Two*Twofxs)/Xxx )
+ Ddz = Ez*( Aaz*(Rs /Fpf) + Two*Twofxs /Xxx ) &
+ + Ey*(-Bbz*(Rrr/Fpf) &
+ + (R0 *Twofx-Two*Twofxs)/Xxx )
Dadxmu = (Ddz-Ax)/Xxxmu
-C = dA/d(X) /Costhe (E.61)
+! = dA/d(X) /Costhe (E.61)
Dpax = - Dthick**2*Dadxmu
-C = dA/d(totalp)
+! = dA/d(totalp)
Dax = - Dpax*Costhe
-C = dA/d(total)
-C Dnax = Zero
-C = dA/d(thick)
+! = dA/d(total)
+! Dnax = Zero
+! = dA/d(thick)
END IF
-C
+!
ELSE
-C
-C *** -- B_{zRphi}^(2b+4b), Equation (E.68) in ssm manual.
+!
+! *** -- B_{zRphi}^(2b+4b), Equation (E.68) in ssm manual.
Abc = Abcexp (Zzz, Aaz, Bbz, Ccz, Ddz, Ijklmn)
Abc = Abcexp (Yyy, Aay, Bby, Ccy, Ddy, Ijklmn)
Aax = Rs**3*Ccz - Rrr**2*(Rrr*Ccy+R0*Bby)
Aax = Two*Aax/Fffmu
Ax = Aax*Costhp
-C (E.68)
+! (E.68)
IF (Ksolvx.NE.2) THEN
- Ddx = Rs**3*(Ccz-Three*Ddz)*Rs
- * - Rrr**3*(Ccy-Three*Ddy)*Rrr
- * - R0*Rrr**2*(Bby-Two*Ccy)*Rrr
+ Ddx = Rs**3*(Ccz-Three*Ddz)*Rs &
+ - Rrr**3*(Ccy-Three*Ddy)*Rrr &
+ - R0*Rrr**2*(Bby-Two*Ccy)*Rrr
Ddx = Two*Ddx/Fffmu**2 * Costhe
-C d(A)/dX = Ddx*Costhp (E.69)
+! d(A)/dX = Ddx*Costhp (E.69)
Dpax = Ddx*Dthick**2
Dax = - Dpax*Costhe
END IF
@@ -299,7 +301,9 @@ C d(A)/dX = Ddx*Costhp (E.69)
Dna = Zero
Dfz = Da /(R0**2) + Dfz
Dpfz = Dpa/(R0**2) + Dpfz
-C Dnfz = Dnfz
+! Dnfz = Dnfz
END IF
RETURN
END
+
+end module ssm_17_m
\ No newline at end of file
diff --git a/sammy/src/ssm/mssm18.f b/sammy/src/ssm/mssm18.f90
similarity index 68%
rename from sammy/src/ssm/mssm18.f
rename to sammy/src/ssm/mssm18.f90
index 9563e1a0f..bdd00e93a 100644
--- a/sammy/src/ssm/mssm18.f
+++ b/sammy/src/ssm/mssm18.f90
@@ -1,30 +1,32 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Finds_2 (Energb, Delas, Dt, Dc, Dtotsi, Dyy2xx, Dyy2xq,
- * Dy2xqq, Dy2ddd, Dy2ddq, Y2cccc, Dy2ccc, Dy2aaa, Dy2aaq, Dy2aqq,
- * Yyy2xx, Yyy2xq, Y2aaaa, Y2aaaq, Ep, Ggg, Nx, Ientrp, Nn, Izero,
- * Idone, Non_Quad)
-C
+!
+module ssm_18_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Finds_2 (Energb, Delas, Dt, Dc, Dtotsi, Dyy2xx, Dyy2xq,&
+ Dy2xqq, Dy2ddd, Dy2ddq, Y2cccc, Dy2ccc, Dy2aaa, Dy2aaq, Dy2aqq,&
+ Yyy2xx, Yyy2xq, Y2aaaa, Y2aaaq, Ep, Ggg, Nx, Ientrp, Nn, Izero,&
+ Idone, Non_Quad)
+!
use fixedi_m
use ifwrit_m
use logic_ssm_common_m
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Energb(*), Delas(*), Dt(*), Dc(*), Dtotsi(Nx,*),
- * Dyy2xx(*), Dyy2xq(*), Dy2xqq(*), Dy2ddd(*), Dy2ddq(*),
- * Y2cccc(*), Dy2ccc(Nx,*), Dy2aaa(*), Dy2aaq(*), Dy2aqq(*)
-C
+ DIMENSION Energb(*), Delas(*), Dt(*), Dc(*), Dtotsi(Nx,*), &
+ Dyy2xx(*), Dyy2xq(*), Dy2xqq(*), Dy2ddd(*), Dy2ddq(*), &
+ Y2cccc(*), Dy2ccc(Nx,*), Dy2aaa(*), Dy2aaq(*), Dy2aqq(*)
+!
DATA Zero /0.0d0/, Half /0.5d0/, One /1.0d0/
-C
+!
Kv = Kvthck - Nvadif
- tttppp=totalp
- CALL Xsect22 (Energb, Dy2ddd, Dy2ddq, Y2cccc, Dy2ccc, Y2dddd,
- * Y2dddq, Ep, Nx, Ientrp, Nn, Non_Quad)
-C
-C *** Set Y2aaaa at energy Ep
+ tttppp=totalp
+ CALL Xsect22 (Energb, Dy2ddd, Dy2ddq, Y2cccc, Dy2ccc, Y2dddd, &
+ Y2dddq, Ep, Nx, Ientrp, Nn, Non_Quad)
+!
+! *** Set Y2aaaa at energy Ep
Dn = Dthick*Totalp
Pp = Hmez3x (Dn, Number, Dhmez3)
Aa = (Half+Dn)/(Half+Dn/Fffdbl)
@@ -33,11 +35,11 @@ C *** Set Y2aaaa at energy Ep
Ebt= Elas*Bb/Totalp
Y2aaaa = Ebt*Cy
IF (Y2dddq.NE.Zero) Y2aaaq = Ebt*Y2dddq
-C
-C *** Now, are we doing derivatives?
+!
+! *** Now, are we doing derivatives?
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
Dbb = - Aa*Dhmez3 - Pp*(One-Aa/Fffdbl)/(Half+Dn/Fffdbl)
-C *** Note that Dbb is derivative of Bb wrt (Dn=Thick*Totalp)
+! *** Note that Dbb is derivative of Bb wrt (Dn=Thick*Totalp)
Ec = Elas*Cy
Ect = Ec/Totalp
Cbt = Cy*Bb/Totalp
@@ -59,10 +61,10 @@ C *** Note that Dbb is derivative of Bb wrt (Dn=Thick*Totalp)
IF (Kvthck.GT.0) Dy2aqq(Kv) = Elas*Y2dddq*Dbb+Dy2aqq(Kv)
END IF
END IF
-C
+!
IF (Idone.NE.3) THEN
-C *** Now set Yyy2xx which will be added up in sbroutine Ssum to
-C *** give double(etc)-scattering term
+! *** Now set Yyy2xx which will be added up in sbroutine Ssum to
+! *** give double(etc)-scattering term
Yyy2xx = Egt*Y2dddd
IF (Y2dddq.NE.Zero) Yyy2xq = Egt*Y2dddq
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
@@ -72,11 +74,11 @@ C *** give double(etc)-scattering term
Dp = Eyt * ( Dggbdp - Ggg/Totalp )
Ds = Eyt * ( Dggads + Dggbds )
DO J=1,Nnpar
- Dyy2xx(J) = Delas(J )*Ygt + Dy2ddd(J)*Egt +
- * Dtotsi(j,Nn)*Ds + Dt(J)*Dp
+ Dyy2xx(J) = Delas(J )*Ygt + Dy2ddd(J)*Egt + &
+ Dtotsi(j,Nn)*Ds + Dt(J)*Dp
END DO
- IF (Kvthck.GT.0) Dyy2xx(Kv) = ( Egt*Dy2ddd(Kv) +
- * Elas*Y2dddd*(Dggadn+Dggbdn)/Totalp)
+ IF (Kvthck.GT.0) Dyy2xx(Kv) = ( Egt*Dy2ddd(Kv) + &
+ Elas*Y2dddd*(Dggadn+Dggbdn)/Totalp)
IF (Y2dddq.NE.Zero) THEN
Ey = Elas*Y2dddq
Eyt = Ey/Totalp
@@ -86,8 +88,8 @@ C *** give double(etc)-scattering term
DO J=1,Nnpar
IF (J.NE.Kv) THEN
Dyy2xq(J) = + Dy2ddq(J)*Egt
- Dy2xqq(J) = Delas (J )*Ygt +
- * Dtotsi(J,Nn)*Ds + Dt(J)*Dp
+ Dy2xqq(J) = Delas (J )*Ygt + &
+ Dtotsi(J,Nn)*Ds + Dt(J)*Dp
END IF
END DO
IF (Kvthck.GT.0) THEN
@@ -97,38 +99,38 @@ C *** give double(etc)-scattering term
END IF
END IF
END IF
-C
+!
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
DOUBLE PRECISION FUNCTION Hmez3x (Alfa, Number, Dhmez3)
-C
-C *** Purpose -- Evaluate Hmez3x = Alpha^-1 { 0.5 - integ from 1 to inf
-C *** [ z^(-3) e^(-Alpha*z) dz ] }
-C
-C *** This function is used in double-scattering approximation, to
-C *** calculate the escape probability assuming uniform distribution
-C *** of (1) neutron positions and (2) directions of motion
-C
-C *** See Abromowitz and Stegun, page 228, Eq. (5.1.4), for the function
-C *** E_3(Alpha). Equation (5.1.14) is used twice to give E_3 in
-C *** terms of E_1, and Equation (5.1.11) is used to evaluate E_1.
-C
+!
+! *** Purpose -- Evaluate Hmez3x = Alpha^-1 { 0.5 - integ from 1 to inf
+! *** [ z^(-3) e^(-Alpha*z) dz ] }
+!
+! *** This function is used in double-scattering approximation, to
+! *** calculate the escape probability assuming uniform distribution
+! *** of (1) neutron positions and (2) directions of motion
+!
+! *** See Abromowitz and Stegun, page 228, Eq. (5.1.4), for the function
+! *** E_3(Alpha). Equation (5.1.14) is used twice to give E_3 in
+! *** terms of E_1, and Equation (5.1.11) is used to evaluate E_1.
+!
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Kntr /0/, Zero /0.0d0/, Half /0.5d0/, One /1.0d0/, Two/2.0d0/
DATA Gamma /0.577215664901532860606512d0/
-C *** Gamma is Euler's constant, value on page 3 of Abramowitz &
-C *** Stegun
-C
+! *** Gamma is Euler's constant, value on page 3 of Abramowitz &
+! *** Stegun
+!
Alpha = Alfa
IF (Alpha.LE.20.0d0) THEN
C = Zero
IF (Alpha.LT.0.3d0) THEN
Abc = Abcexp (-Alpha, Aa, Bb, Cc, Dxxxxx, Ijklmn)
-C *** Aa = (One-Abc)/Alpha
+! *** Aa = (One-Abc)/Alpha
C = Half * (One+Aa*(One-Alpha))
ELSE
Abc = dEXP(-Alpha)
@@ -137,8 +139,8 @@ C *** Aa = (One-Abc)/Alpha
END IF
B = (Gamma+dLOG(Alpha))*Alpha/Two
A = C + B
-cx bb=b
-cx cc=c
+!x bb=b
+!x cc=c
B = - Alpha**2/Two
DO N=1,5000
C = B/dFLOAT(N)
@@ -148,33 +150,32 @@ cx cc=c
END DO
WRITE (6,10000) Alpha, Dhmez3, A, C
Kntr = Kntr + 1
-10000 FORMAT(' no convergence in Hmez3x; Alfa,Dhmez3,a,c=',
- * 1P4G14.6)
+10000 FORMAT(' no convergence in Hmez3x; Alfa,Dhmez3,a,c=', 1P4G14.6)
IF (Kntr.GE.10) STOP '[STOP in Hmez3x in ssm/mssm18.f]'
-cx IF (Kntr.GT.200) STOP '[STOP in Hmez3x in ssm/mssm18.f]'
-C
+!x IF (Kntr.GT.200) STOP '[STOP in Hmez3x in ssm/mssm18.f]'
+!
20 CONTINUE
Number = N
Hmez3x = A
Dhmez3 = (Hmez3x-Aa)/Alpha
-C
+!
ELSE
Hmez3x = Half/Alpha
Dhmez3 = Zero
Number = 0
-C
+!
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Xsect22 (Energb, Dy2ddd, Dy2ddq, Y2cccc, Dy2ccc,
- * Y2dddd, Y2dddq, Ep, Nx, Ientrp, Nn, Non_Quad)
-C
-C *** Purpose -- Find Y2cccc(Ep) and derivatives thereof.
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Xsect22 (Energb, Dy2ddd, Dy2ddq, Y2cccc, Dy2ccc, &
+ Y2dddd, Y2dddq, Ep, Nx, Ientrp, Nn, Non_Quad)
+!
+! *** Purpose -- Find Y2cccc(Ep) and derivatives thereof.
+!
use fixedi_m
use ifwrit_m
use ssssss_common_m
@@ -182,7 +183,7 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Energb(*), Dy2ddd(*), Dy2ddq(*), Y2cccc(*), Dy2ccc(Nx,*)
DATA Zero /0.0d0/, One /1.0d0/
-C
+!
Y2dddd = Zero
Y2dddq = Zero
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
@@ -191,10 +192,10 @@ C
Dy2ddq(J) = Zero
END DO
END IF
-C
+!
IF (Intrp.EQ.0) THEN
-C *** Here get values when Ep=Energb(Iep)
-C *** (Intrp=0), or when Iep=1, so must use constant value
+! *** Here get values when Ep=Energb(Iep)
+! *** (Intrp=0), or when Iep=1, so must use constant value
Y2dddd = Y2cccc(Iep)
IF (Y2dddd.NE.Zero) THEN
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
@@ -204,11 +205,11 @@ C *** (Intrp=0), or when Iep=1, so must use constant value
END IF
ELSE
IF (Iep.NE.Nn) THEN
-C *** Here when Y2cccc(Iep)=0 and Iep.NE.Nn, so we are below
-C *** the minimum value for which y's can be generated
+! *** Here when Y2cccc(Iep)=0 and Iep.NE.Nn, so we are below
+! *** the minimum value for which y's can be generated
ELSE
-C *** Here when Y2cccc(Iep)=0 and Iep=Nn, so we need to figure
-C *** the "q" terms -- coefficient of y(Nn) and dy(Nn)
+! *** Here when Y2cccc(Iep)=0 and Iep=Nn, so we need to figure
+! *** the "q" terms -- coefficient of y(Nn) and dy(Nn)
Y2dddq = One
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
DO J=1,Nnpar
@@ -217,32 +218,32 @@ C *** the "q" terms -- coefficient of y(Nn) and dy(Nn)
END IF
END IF
END IF
-C
+!
ELSE
-C
-C *** Here Energb(Iep) < Ep < Energb(Iep+1) so get values
-C *** at E'=Ep via interpolation
-C
+!
+! *** Here Energb(Iep) < Ep < Energb(Iep+1) so get values
+! *** at E'=Ep via interpolation
+!
IF (Iep.GT.1 .AND. Iep.LT.Nn-2 .AND. Non_Quad.EQ.0) THEN
-C *** Here can use quadratic form for interpolation, since
-C *** all needed Y2cccc are known
+! *** Here can use quadratic form for interpolation, since
+! *** all needed Y2cccc are known
B0 = Antrp1
B1 = Antrp2
B2 = Antrp3
B3 = Antrp4
- Y2dddd = B1*Y2cccc(Iep ) + B2*Y2cccc(Iep+1)
- * + B0*Y2cccc(Iep-1) + B3*Y2cccc(Iep+2)
+ Y2dddd = B1*Y2cccc(Iep ) + B2*Y2cccc(Iep+1) &
+ + B0*Y2cccc(Iep-1) + B3*Y2cccc(Iep+2)
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
DO J=1,Nnpar
- Dy2ddd(J) = B1*Dy2ccc(J,Iep ) + B2*Dy2ccc(J,Iep+1)
- * + B0*Dy2ccc(J,Iep-1) + B3*Dy2ccc(J,Iep+2)
+ Dy2ddd(J) = B1*Dy2ccc(J,Iep ) + B2*Dy2ccc(J,Iep+1) &
+ + B0*Dy2ccc(J,Iep-1) + B3*Dy2ccc(J,Iep+2)
END DO
END IF
-C
+!
ELSE IF (Iep.GT.1 .AND. Iep.EQ.Nn-1) THEN
-C *** Here we cannot do quadratic because we would need Nn+1,
-C *** and that Y2cccc is not known yet; hence, use linear
-C *** and save the Y2dddq piece
+! *** Here we cannot do quadratic because we would need Nn+1,
+! *** and that Y2cccc is not known yet; hence, use linear
+! *** and save the Y2dddq piece
C = Energb(Iep+1) - Energb(Iep)
A = (Energb(Iep+1)-Ep)/C
B = (Ep-Energb(Iep ))/C
@@ -254,17 +255,17 @@ C *** and save the Y2dddq piece
Dy2ddq(J) = B
END DO
END IF
-C
-cx ELSE IF (Iep.GE.Nn-1) THEN
+!
+!x ELSE IF (Iep.GE.Nn-1) THEN
ELSE IF (Iep.GE.Nn) THEN
-C *** This is above the current energy value; should not get here.
+! *** This is above the current energy value; should not get here.
WRITE (6,*) Iep, Nn
STOP '[STOP in Xsect22 in mssm18.f]'
-C
+!
ELSE
-C *** Here do linear because we're at the ends of the energy region
+! *** Here do linear because we're at the ends of the energy region
IF (Y2cccc(Iep+1).NE.Zero) THEN
-C *** Here Y2cccc(Iep+1).NE.0
+! *** Here Y2cccc(Iep+1).NE.0
A = Energb(Iep+1) - Ep
B = Ep - Energb(Iep)
C = Energb(Iep+1) - Energb(Iep)
@@ -281,18 +282,18 @@ C *** Here Y2cccc(Iep+1).NE.0
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Reorder_Energy (Energy, We, Wsigxx, Wdasig, Wdbsig,
- * Theory, Kdatmn, Kdatmx, Kkkdat)
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Reorder_Energy (Energy, We, Wsigxx, Wdasig, Wdbsig, &
+ Theory, Kdatmn, Kdatmx, Kkkdat)
use fixedi_m
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- DIMENSION Energy(*), We(*), Wsigxx(*), Wdasig(Ndaxxx,*),
- * Wdbsig(Ndbxxx,*), Theory(*)
+ DIMENSION Energy(*), We(*), Wsigxx(*), Wdasig(Ndaxxx,*), &
+ Wdbsig(Ndbxxx,*), Theory(*)
DATA Thous /1000.0d0/
-C
+!
Jj = 1
Em = Energy(jj)
Kk = 0
@@ -315,7 +316,7 @@ C
Jj = Jj + 1
Em = Energy(Jj)
ELSE IF (We(k).GT.Em) THEN
-C *** Here have to interpolate between last and next point
+! *** Here have to interpolate between last and next point
D = We(K) - We(K-1)
A = We(K) - Em
B = Em - We(K-1)
@@ -325,14 +326,14 @@ C *** Here have to interpolate between last and next point
Theory(Jj) = Wsigxx(Jj)
IF (Ndasig.GT.0) THEN
DO Iipar=1,Ndasig
- Wdasig(Iipar,Jj) = Wdasig(Iipar,Kk )*B +
- * Wdasig(Iipar,Kk-1)*A
+ Wdasig(Iipar,Jj) = Wdasig(Iipar,Kk )*B + &
+ Wdasig(Iipar,Kk-1)*A
END DO
END IF
IF (Ndbsig.GT.0) THEN
DO Iipar=1,Ndbsig
- Wdbsig(Iipar,Jj) = Wdbsig(Iipar,Kk )*B +
- * Wdbsig(Iipar,Kk-1)*A
+ Wdbsig(Iipar,Jj) = Wdbsig(Iipar,Kk )*B + &
+ Wdbsig(Iipar,Kk-1)*A
END DO
Jj = Jj + 1
Em = Energy(Jj)
@@ -344,10 +345,10 @@ C *** Here have to interpolate between last and next point
Kkkdat = Jj - 1
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Gety2zzz (Emy2_a, Emy2_b, Y2tab_a, Y2tab_b)
use namfil_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
@@ -357,12 +358,11 @@ C
10000 FORMAT (2F20.10)
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Gety2tab (Em, Y2tab, Emy2_a, Emy2_b,
- * Y2tab_a, Y2tab_b)
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Gety2tab (Em, Y2tab, Emy2_a, Emy2_b, Y2tab_a, Y2tab_b)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
10 CONTINUE
IF (Em.LT.Emy2_b) THEN
@@ -387,3 +387,5 @@ C
Y2tab = A*Y2tab_a + B*Y2tab_b
RETURN
END
+
+end module ssm_18_m
diff --git a/sammy/src/ssm/mssm19.f b/sammy/src/ssm/mssm19.f
deleted file mode 100644
index 897e245d1..000000000
--- a/sammy/src/ssm/mssm19.f
+++ /dev/null
@@ -1,160 +0,0 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ynrm_0 (Capsig, Dtotsi, Dcapsi, Sigxxx, Dasigx,
- * Dbsigx, Y0, Dthick, Total, Exp1, Em, Dddyy0, Asensn, Nn)
-
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use logic_ssm_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Capsig(*), Dtotsi(Nnparx,*), Dcapsi(Nnparx,*),
- * Sigxxx(*), Dasigx(*), Dbsigx(*)
- DATA Zero /0.0d0/, One /1.0d0/
-C
-C *** Default normalization is such that Y0 = (1-e)Capture /(n Total)
-C *** which corresponds to Kyield=1 ("cross section", not "yield")
-C
- IF (Noyzer.NE.0) Y0 = Zero
-C
- Cap = Capsig(Nn)
- IF (Kyield.EQ.0) THEN
- Y0 = Y0*Dthick
- ELSE IF (Kyield.EQ.1) THEN
- ELSE IF (Kyield.EQ.2) THEN
- Y0 = Y0*Total*Dthick
- END IF
-C
- Sigxxx(1) = Y0
-C
-C If the gamma attenuation factor C1 is not zero
- IF (Gam_att_C1.NE.0.0) THEN
- C1 = Gam_att_C1
- dC1 = dGam_att_C1
- Td = Total*Dthick
-C Sigxxx(1) is the place we store the output to ODF/LST files
- Sigxxx(1) = Sigxxx(1) * Gamma_attenuation_corr(C1,Td)
- END IF
-C
-C
- IF (Kssmpr.EQ.1) THEN
- Y1 = Zero
- Y2 = Zero
- WRITE (60,12000) Em, Y0, Y1, Y2, Sigxxx(1)
-12000 FORMAT (1X, F15.8, 1P5E15.6)
- END IF
-C
- IF (Ksolve.EQ.2) RETURN
-C
- IF (Ndasig.GT.0) CALL Ynrm_0_Derivative (Cap, Dtotsi, Dcapsi,
- * Dasigx, Y0, Dthick, Total, Exp1, Dddyy0, Nn, Ndasig, 0)
- IF (Ndbsig.GT.0) CALL Ynrm_0_Derivative (Cap, Dtotsi, Dcapsi,
- * Dbsigx, Y0, Dthick, Total, Exp1, Dddyy0, Nn, Ndbsig, Ndasig)
-C
- IF (Kvthck.GT.0) THEN
-C *** Add deriv of Y0 wrt Thickness
- Kv = Kvthck - Nvadif - Ndasig
- IF (Kyield.EQ.0) THEN
- IF (Noyzer.EQ.0) THEN
- Dbsigx(Kv) = Exp1*Cap + Dbsigx(Kv)
-C ELSE
-C disabling Y0 portion of calculation
- END IF
- ELSE IF (Kyield.EQ.1) THEN
- Sn = Dthick*Total
- IF (Noyzer.EQ.0) THEN
- IF (Sn.LT.0.3d0) THEN
- Abc = Abcexp (-Sn, A, B, C, Dxxxxx, Ijklmn)
- F = Cap*Total*(B-A)
- ELSE
- F = Cap*(Exp1-(One-Exp1)/Sn)/Dthick
- END IF
- ELSE
-C disabling Y0 portion of calculation
- F = Zero
- END IF
- Dbsigx(Kv) = F + Dbsigx(Kv)
- ELSE IF (Kyield.EQ.2) THEN
- IF (Noyzer.EQ.0) Dbsigx(Kv)= Exp1*Cap*Total + Dbsigx(Kv)
- END IF
- END IF
-C
- IF (Sensin.NE.Zero .AND. Ksensc.GT.0) THEN
- IF (Kyield.EQ.0) Asensn = Asensn * Dthick
- IF (Kyield.EQ.2) Asensn = Asensn * Dthick * Total
-C *** Add deriv of Y0 wrt neutron sensitivity multiplier
- Kv = Ksensc - Nvadif - Ndasig
- Dbsigx(Kv) = Asensn
- END IF
- RETURN
- END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ynrm_0_Derivative (Cap, Dtotsi, Dcapsi, Ds,
- * Y0, Dthick, Total, Exp1, Dddyy0, Nn, Nd, Na)
- use fixedi_m
- use ifwrit_m
- use logic_ssm_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Dtotsi(Nnparx,*), Dcapsi(Nnparx,*), Ds(*)
- DATA One /1.0d0/
-C
-C Dthick = N [at/b]
-C Cap = sigma_gamma
-C Total = sigma_tot
-C Exp1 = e^(-N*sigma_tot)
-C
- DO Ipar=1,Nd
- Iipar = Ipar + Na
-C
- IF (Noyzer.EQ.0) THEN
-C *** First, the derivative of Y0 wrt u(Iipar)
-C *** (Nn=Energy) JMB
- IF (Kyield.EQ.0) THEN
- Ds(Ipar) = Ds(Ipar) +
- * Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total)
- * + Dtotsi(Iipar,Nn)*Exp1*Cap/Total * Dthick
- ELSE IF (Kyield.EQ.1) THEN
- Ds(Ipar) = Ds(Ipar) +
- * Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total)
- * + Dtotsi(Iipar,Nn)*Exp1*Cap/Total
- IF (Iipar.EQ.1) Dddyy0 = Dddyy0 +
- * Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total)
- * + Dtotsi(Iipar,Nn)*Exp1*Cap/Total
- ELSE IF (Kyield.EQ.2) THEN
- Ds(Ipar) = Ds(Ipar) + (One-Exp1)*Dcapsi(Iipar,Nn)
- * + Dtotsi(Iipar,Nn)*Exp1*Cap*Dthick
- END IF
- END IF
-C ------------------------------------------------------------------
-C *** If gamma attenuation is being used, add the derivative for the
-C *** attenuated yield
-C
-C *** d/du(k_a Y) = d(k_a)/dsig_t * d(sig_t)/du * Y +
-C *** d(Y)/du * k_a
- IF (Gam_att_C1.GT.0) THEN
-C
-C d(k_a)/dsig_t =
- Dka = Gamma_atten_corr_deriv(Gam_att_C1,Dthick,Total)
-C
-C d(k_a)/du =
- Dkadu = Dka*Dtotsi(Iipar,Nn)
-C
-C corr_ka is correction factor k_a
- corr_ka = Gamma_attenuation_corr(Gam_att_C1,Dthick*Total)
-C
-C -----------------------------------------
- Ds(Ipar) = Dkadu*(Y0) + Ds(Ipar)*corr_ka
-C -----------------------------------------
-
- END IF
-C ------------------------------------------------------------------
-C
-C
- END DO
- RETURN
- END
diff --git a/sammy/src/ssm/mssm19.f90 b/sammy/src/ssm/mssm19.f90
new file mode 100644
index 000000000..7449e786a
--- /dev/null
+++ b/sammy/src/ssm/mssm19.f90
@@ -0,0 +1,158 @@
+!
+module ssm_19_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ynrm_0 (Capsig, Dtotsi, Dcapsi, Sigxxx, Dasigx, &
+ Dbsigx, Y0, Dthick, Total, Exp1, Em, Dddyy0, Asensn, Nn)
+
+ use fixedi_m
+ use ifwrit_m
+ use fixedr_m
+ use logic_ssm_common_m
+ use CapYCorrections_common_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ DIMENSION Capsig(*), Dtotsi(Nnparx,*), Dcapsi(Nnparx,*), Sigxxx(*), Dasigx(*), Dbsigx(*)
+ DATA Zero /0.0d0/, One /1.0d0/
+
+ call capYieldCor%initialize()
+!
+! *** Default normalization is such that Y0 = (1-e)Capture /(n Total)
+! *** which corresponds to Kyield=1 ("cross section", not "yield")
+!
+ IF (Noyzer.NE.0) Y0 = Zero
+!
+ Cap = Capsig(Nn)
+ IF (Kyield.EQ.0) THEN
+ Y0 = Y0*Dthick
+ ELSE IF (Kyield.EQ.1) THEN
+ ELSE IF (Kyield.EQ.2) THEN
+ Y0 = Y0*Total*Dthick
+ END IF
+!
+ Sigxxx(1) = Y0
+!
+! If the gamma attenuation factor C1 is not zero
+ IF (Gam_att_C1.NE.0.0) THEN
+ dC1 = dGam_att_C1
+ Td = Total*Dthick
+! Sigxxx(1) is the place we store the output to ODF/LST files
+! -- Here we are modifying Sigxxx(1) with the gamma attenuation
+! -- correction
+ call capYieldCor%gammaAttenCorr( Dthick,Total,Gam_att_C1,Sigxxx(1) )
+ END IF
+!
+!
+ IF (Kssmpr.EQ.1) THEN
+ Y1 = Zero
+ Y2 = Zero
+ WRITE (60,12000) Em, Y0, Y1, Y2, Sigxxx(1)
+12000 FORMAT (1X, F15.8, 1P5E15.6)
+ END IF
+!
+ IF (Ksolve.EQ.2) RETURN
+!
+ IF (Ndasig.GT.0) CALL Ynrm_0_Derivative (Cap, Dtotsi, Dcapsi, &
+ Dasigx, Y0, Dthick, Total, Exp1, Dddyy0, Nn, Ndasig, 0)
+ IF (Ndbsig.GT.0) CALL Ynrm_0_Derivative (Cap, Dtotsi, Dcapsi, &
+ Dbsigx, Y0, Dthick, Total, Exp1, Dddyy0, Nn, Ndbsig, Ndasig)
+!
+ IF (Kvthck.GT.0) THEN
+! *** Add deriv of Y0 wrt Thickness
+ Kv = Kvthck - Nvadif - Ndasig
+ IF (Kyield.EQ.0) THEN
+ IF (Noyzer.EQ.0) THEN
+ Dbsigx(Kv) = Exp1*Cap + Dbsigx(Kv)
+! ELSE
+! disabling Y0 portion of calculation
+ END IF
+ ELSE IF (Kyield.EQ.1) THEN
+ Sn = Dthick*Total
+ IF (Noyzer.EQ.0) THEN
+ IF (Sn.LT.0.3d0) THEN
+ Abc = Abcexp (-Sn, A, B, C, Dxxxxx, Ijklmn)
+ F = Cap*Total*(B-A)
+ ELSE
+ F = Cap*(Exp1-(One-Exp1)/Sn)/Dthick
+ END IF
+ ELSE
+! disabling Y0 portion of calculation
+ F = Zero
+ END IF
+ Dbsigx(Kv) = F + Dbsigx(Kv)
+ ELSE IF (Kyield.EQ.2) THEN
+ IF (Noyzer.EQ.0) Dbsigx(Kv)= Exp1*Cap*Total + Dbsigx(Kv)
+ END IF
+ END IF
+!
+ IF (Sensin.NE.Zero .AND. Ksensc.GT.0) THEN
+ IF (Kyield.EQ.0) Asensn = Asensn * Dthick
+ IF (Kyield.EQ.2) Asensn = Asensn * Dthick * Total
+! *** Add deriv of Y0 wrt neutron sensitivity multiplier
+ Kv = Ksensc - Nvadif - Ndasig
+ Dbsigx(Kv) = Asensn
+ END IF
+ RETURN
+ END
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ynrm_0_Derivative (Cap, Dtotsi, Dcapsi, Ds, &
+ Y0, Dthick, Total, Exp1, Dddyy0, Nn, Nd, Na)
+ use fixedi_m
+ use ifwrit_m
+ use logic_ssm_common_m
+ use CapYCorrections_common_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ DIMENSION Dtotsi(Nnparx,*), Dcapsi(Nnparx,*), Ds(*)
+ DATA One /1.0d0/
+!
+! Dthick = N [at/b]
+! Cap = sigma_gamma
+! Total = sigma_tot
+! Exp1 = e^(-N*sigma_tot)
+!
+ DO Ipar=1,Nd
+ Iipar = Ipar + Na
+!
+ IF (Noyzer.EQ.0) THEN
+! *** First, the derivative of Y0 wrt u(Iipar)
+! *** (Nn=Energy) JMB
+ IF (Kyield.EQ.0) THEN
+ Ds(Ipar) = Ds(Ipar) + &
+ Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total) &
+ + Dtotsi(Iipar,Nn)*Exp1*Cap/Total * Dthick
+ ELSE IF (Kyield.EQ.1) THEN
+ Ds(Ipar) = Ds(Ipar) + &
+ Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total) &
+ + Dtotsi(Iipar,Nn)*Exp1*Cap/Total
+ IF (Iipar.EQ.1) Dddyy0 = Dddyy0 + &
+ Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total) &
+ + Dtotsi(Iipar,Nn)*Exp1*Cap/Total
+ ELSE IF (Kyield.EQ.2) THEN
+ Ds(Ipar) = Ds(Ipar) + (One-Exp1)*Dcapsi(Iipar,Nn) &
+ + Dtotsi(Iipar,Nn)*Exp1*Cap*Dthick
+ END IF
+ END IF
+! ------------------------------------------------------------------
+! *** If gamma attenuation is being used, add the derivative for the
+! *** attenuated yield
+!
+! *** d/du(k_a Y) = d(k_a)/dsig_t * d(sig_t)/du * Y +
+! *** d(Y)/du * k_a
+ IF (Gam_att_C1.GT.0) THEN
+
+ call capYieldCor%derivGammaAttenCorr(Dthick, Total, &
+ Gam_att_C1, Dtotsi(Iipar,Nn), &
+ Y0, Ds(Ipar) )
+ END IF
+! ------------------------------------------------------------------
+!
+!
+ END DO
+ RETURN
+ END
+
+end module ssm_19_m
diff --git a/sammy/src/ssm/mssm20.f b/sammy/src/ssm/mssm20.f90
similarity index 59%
rename from sammy/src/ssm/mssm20.f
rename to sammy/src/ssm/mssm20.f90
index 51ccc8169..8ce787e29 100644
--- a/sammy/src/ssm/mssm20.f
+++ b/sammy/src/ssm/mssm20.f90
@@ -1,22 +1,24 @@
-C
-C
-C -----------------------------------------------------------------
-C
+!
+module ssm_20_m
+ contains
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Fixy_1i (Dyyy1, Yyy1)
-C
-C *** Normalization: factor-of-2 is from "wrong" Weights for integration
-C *** over mu (cuz Sumw = 2.0*2 but really we want Sumw = 1.0*2)
-C *** Then Multiply by 2 Pi (for integ over d-phi).
-C
+!
+! *** Normalization: factor-of-2 is from "wrong" Weights for integration
+! *** over mu (cuz Sumw = 2.0*2 but really we want Sumw = 1.0*2)
+! *** Then Multiply by 2 Pi (for integ over d-phi).
+!
use fixedi_m
use ifwrit_m
use constn_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Dyyy1(*)
-C
-C
+!
+!
Yyy1 = Yyy1*Pi
-C
+!
IF (Ksolve.NE.2) THEN
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
DO J=1,Nnpar
@@ -26,28 +28,28 @@ C
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Fixy_1f (Dyyy1, Yyy1, Yyy1fb)
-C
-C *** Normalization: factor-of-2 is from "wrong" Weights for integration
-C *** over mu (cuz Sumw = 2.0*2 but really we want Sumw = 1.0*2)
-C *** Then Multiply by 2 Pi (for integ over d-phi).
-C
+!
+! *** Normalization: factor-of-2 is from "wrong" Weights for integration
+! *** over mu (cuz Sumw = 2.0*2 but really we want Sumw = 1.0*2)
+! *** Then Multiply by 2 Pi (for integ over d-phi).
+!
use fixedi_m
use ifwrit_m
use constn_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Dyyy1(*), Yyy1fb(2)
-C
-C
+!
+!
Yyy1 = Yyy1*Pi
-C
+!
Yyy1fb(1) = Yyy1fb(1)*Pi
Yyy1fb(2) = Yyy1fb(2)*Pi
-C
+!
IF (Ksolve.NE.2) THEN
IF (Nnpar.GT.0 .AND. Ksolve.NE.2) THEN
DO J=1,Nnpar
@@ -57,10 +59,10 @@ C
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Non_Uniform_Thickness (Znonu, Rnonu, Td, Exxxx, Nonu)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Znonu(*), Rnonu(*)
@@ -72,7 +74,7 @@ C
IF (dABS(Epsiln).GT.0.3d0) THEN
Eepsil = dEXP(Epsiln)
B = (Rnonu(J)-Rnonu(J-1))/ Epsiln
- C = Eepsil*Rnonu(J-1) - Rnonu(J)
+ ! = Eepsil*Rnonu(J-1) - Rnonu(J)
D = Eepsil - 1.0d0
Qnonu = Qnonu + Enonu*(C+D*B)*B
ELSE IF (dABS(Epsiln).GT.0.0d0) THEN
@@ -87,23 +89,23 @@ C
Exxxx = 2.0d0*Qnonu
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Get_Ratio_Sensin (Em, Ratio_Sensin, Nsen, Itimes)
-C
-C *** Purpose -- Use log-log interpolation to obtain ratio of neutron
-C *** sensitivity to capture sensitivity, as function of E
-C
+!
+! *** Purpose -- Use log-log interpolation to obtain ratio of neutron
+! *** sensitivity to capture sensitivity, as function of E
+!
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION Esn(16), Rsn(16), Esnl(16), Rsnl(16)
- DATA Esn /1.0d3 , 2.0d3 , 3.0d3 , 4.0d3 , 5.0d3 , 7.0d3 , 8.0d3 ,
- * 1.0d4 , 2.0d4 , 3.0d4 , 4.0d4 , 6.0d4 , 8.0d4 , 2.0d5 , 7.0d5 ,
- * 1.0d8 /
- DATA Rsn /3.2d-4, 2.7d-4, 2.7d-4, 2.4d-4, 2.2d-4, 2.8d-4, 7.5d-4,
- * 4.0d-4, 2.5d-4, 4.0d-4, 6.3d-4, 4.2d-4, 2.1d-4, 1.8d-4, 1.1d-4,
- * 7.5d-5/
+ DATA Esn /1.0d3 , 2.0d3 , 3.0d3 , 4.0d3 , 5.0d3 , 7.0d3 , 8.0d3 , &
+ 1.0d4 , 2.0d4 , 3.0d4 , 4.0d4 , 6.0d4 , 8.0d4 , 2.0d5 , 7.0d5 , &
+ 1.0d8 /
+ DATA Rsn /3.2d-4, 2.7d-4, 2.7d-4, 2.4d-4, 2.2d-4, 2.8d-4, 7.5d-4, &
+ 4.0d-4, 2.5d-4, 4.0d-4, 6.3d-4, 4.2d-4, 2.1d-4, 1.8d-4, 1.1d-4, &
+ 7.5d-5/
DATA BE_Gold /31.1411/
DATA Nsen_Max /16/
Bel = dLOG(Be_Gold)
@@ -114,8 +116,8 @@ C
END DO
Itimes = 2
WRITE (21,10100)
-10100 FORMAT (/, ' Neutron sensitivity ratio to capture sensitivity',
- * /, ' Energy (eV) Ratio')
+10100 FORMAT (/, ' Neutron sensitivity ratio to capture sensitivity', &
+ /, ' Energy (eV) Ratio')
WRITE (21,10200) (I, Esn(I), Rsn(I), I=1,Nsen_Max)
10200 FORMAT (I5, F11.0, F12.6)
END IF
@@ -126,9 +128,9 @@ C
IF (Em.LT.Esn(I+1)) THEN
El = dLOG(Em)
Nsen = I
- Ratio_Sensin_Log = ( Rsnl(Nsen )*(Esnl(Nsen+1)-El)+
- * Rsnl(Nsen+1)*(El-Esnl(Nsen)) )
- * /(Esnl(Nsen+1)-Esnl(Nsen))
+ Ratio_Sensin_Log = ( Rsnl(Nsen )*(Esnl(Nsen+1)-El)+ &
+ Rsnl(Nsen+1)*(El-Esnl(Nsen)) ) &
+ /(Esnl(Nsen+1)-Esnl(Nsen))
Ratio_Sensin = dEXP(Ratio_Sensin_Log)
END IF
END DO
@@ -137,26 +139,29 @@ C
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ynrm_1 (Capsig, Dtotsi, Dcapsi, Sigxxx, Dasigx, Dbsigx,
- * Dy1, Y0, Y1, Dthick, Total, Exp1, Em, Dddyy0, Asensn, Nn)
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ynrm_1 (Capsig, Dtotsi, Dcapsi, Sigxxx, Dasigx, Dbsigx, &
+ Dy1, Y0, Y1, Dthick, Total, Exp1, Em, Dddyy0, Asensn, Nn)
use fixedi_m
use ifwrit_m
use fixedr_m
use logic_ssm_common_m
+ use CapYCorrections_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Capsig(*), Dtotsi(Nnparx,*), Dcapsi(Nnparx,*), Dy1(*),
- * Sigxxx(*), Dasigx(*), Dbsigx(*)
+ DIMENSION Capsig(*), Dtotsi(Nnparx,*), Dcapsi(Nnparx,*), Dy1(*), &
+ Sigxxx(*), Dasigx(*), Dbsigx(*)
DATA Zero /0.0d0/, One /1.0d0/
-C
-C *** Default normalization is such that Y0 = (1-e)Capture /(n Total)
-C *** which corresponds to Kyield=1 ("cross section", not "yield")
-C
+
+ call capYieldCor%initialize()
+!
+! *** Default normalization is such that Y0 = (1-e)Capture /(n Total)
+! *** which corresponds to Kyield=1 ("cross section", not "yield")
+!
IF (Noyzer.NE.0) Y0 = Zero
-C
+!
Cap = Capsig(Nn)
IF (Kyield.EQ.0) THEN
Y0 = Y0*Dthick
@@ -176,42 +181,43 @@ C
END DO
END IF
END IF
-C
-C
+!
+!
Sigxxx(1) = Y0
Sigxxx(1) = Sigxxx(1) + Y1
-C
-C If the gamma attenuation factor C1 is not zero
+!
+! If the gamma attenuation factor C1 is not zero
IF (Gam_att_C1.NE.0.0) THEN
- C1 = Gam_att_C1
dC1 = dGam_att_C1
Td = Total*Dthick
-C Sigxxx(1) is the place we store the output to ODF/LST files
- Sigxxx(1) = Sigxxx(1) * Gamma_attenuation_corr(C1,Td)
+! Sigxxx(1) is the place we store the output to ODF/LST files
+! -- Here we are modifying Sigxxx(1) with the gamma attenuation
+! -- correction
+ call capYieldCor%gammaAttenCorr( Dthick,Total,Gam_att_C1,Sigxxx(1) )
END IF
-C
-C
+!
+!
IF (Kssmpr.EQ.1) THEN
WRITE (60,12000) Em, Y0, Y1, Sigxxx(1)
12000 FORMAT (1X, f15.8, 1P5E15.6)
END IF
-C
+!
IF (Ksolve.EQ.2) RETURN
-C
- IF (Ndasig.GT.0) CALL Ynrm_1_Derivative (Cap, Dtotsi, Dcapsi,
- * Dasigx, Dy1, Y0, Y1, Dthick, Total, Exp1, Dddyy0, Nn, Ndasig,0)
- IF (Ndbsig.GT.0) CALL Ynrm_1_Derivative (Cap, Dtotsi, Dcapsi,
- * Dbsigx, Dy1, Y0, Y1, Dthick, Total, Exp1, Dddyy0, Nn, Ndbsig,
- * Ndasig)
-C
+!
+ IF (Ndasig.GT.0) CALL Ynrm_1_Derivative (Cap, Dtotsi, Dcapsi, &
+ Dasigx, Dy1, Y0, Y1, Dthick, Total, Exp1, Dddyy0, Nn, Ndasig,0)
+ IF (Ndbsig.GT.0) CALL Ynrm_1_Derivative (Cap, Dtotsi, Dcapsi, &
+ Dbsigx, Dy1, Y0, Y1, Dthick, Total, Exp1, Dddyy0, Nn, Ndbsig, &
+ Ndasig)
+!
IF (Kvthck.GT.0) THEN
-C *** Add deriv of Y0 wrt Thickness; modify deriv of Y1 & Y2 wrt Thick
+! *** Add deriv of Y0 wrt Thickness; modify deriv of Y1 & Y2 wrt Thick
Kv = Kvthck - Nvadif - Ndasig
IF (Kyield.EQ.0) THEN
IF (Noyzer.EQ.0) THEN
Dbsigx(Kv) = Exp1*Cap + Dbsigx(Kv)
-C ELSE
-C disabling Y0 portion of calculation
+! ELSE
+! disabling Y0 portion of calculation
END IF
ELSE IF (Kyield.EQ.1) THEN
Sn = Dthick*Total
@@ -223,7 +229,7 @@ C disabling Y0 portion of calculation
F = Cap*(Exp1-(One-Exp1)/Sn)/Dthick
END IF
ELSE
-C disabling Y0 portion of calculation
+! disabling Y0 portion of calculation
F = Zero
END IF
Dbsigx(Kv) = F + Dbsigx(Kv) - Y1/Dthick
@@ -231,109 +237,99 @@ C disabling Y0 portion of calculation
IF (Noyzer.EQ.0) Dbsigx(Kv)= Exp1*Cap*Total + Dbsigx(Kv)
END IF
END IF
-C
+!
IF (Sensin.NE.Zero .AND. Ksensc.GT.0) THEN
IF (Kyield.EQ.0) Asensn = Asensn * Dthick
IF (Kyield.EQ.2) Asensn = Asensn * Dthick * Total
-C *** Add deriv of Y0 wrt neutron sensitivity multiplier
+! *** Add deriv of Y0 wrt neutron sensitivity multiplier
Kv = Ksensc - Nvadif - Ndasig
Dbsigx(Kv) = Asensn
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ynrm_1_Derivative (Cap, Dtotsi, Dcapsi, Ds, Dy1,
- * Y0, Y1, Dthick, Total, Exp1, Dddyy0, Nn, Nd, Na)
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ynrm_1_Derivative (Cap, Dtotsi, Dcapsi, Ds, Dy1, &
+ Y0, Y1, Dthick, Total, Exp1, Dddyy0, Nn, Nd, Na)
use fixedi_m
use ifwrit_m
use logic_ssm_common_m
+ use CapYCorrections_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Dtotsi(Nnparx,*), Dcapsi(Nnparx,*), Dy1(*), Ds(*)
DATA One /1.0d0/
-C
-C Dthick = N [at/b]
-C Cap = sigma_gamma
-C Total = sigma_tot
-C Exp1 = e^(-N*sigma_tot)
-C
+!
+! Dthick = N [at/b]
+! Cap = sigma_gamma
+! Total = sigma_tot
+! Exp1 = e^(-N*sigma_tot)
+!
DO Ipar=1,Nd
Iipar = Ipar + Na
-C
+!
IF (Noyzer.EQ.0) THEN
-C *** First, the derivative of Y0 wrt u(Iipar)
-C *** (Nn=Energy) JMB
+! *** First, the derivative of Y0 wrt u(Iipar)
+! *** (Nn=Energy) JMB
IF (Kyield.EQ.0) THEN
- Ds(Ipar) = Ds(Ipar) +
- * Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total)
- * + Dtotsi(Iipar,Nn)*Exp1*Cap/Total * Dthick
+ Ds(Ipar) = Ds(Ipar) + &
+ Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total) &
+ + Dtotsi(Iipar,Nn)*Exp1*Cap/Total * Dthick
ELSE IF (Kyield.EQ.1) THEN
- Ds(Ipar) = Ds(Ipar) +
- * Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total)
- * + Dtotsi(Iipar,Nn)*Exp1*Cap/Total
- IF (Iipar.EQ.1) Dddyy0 = Dddyy0 +
- * Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total)
- * + Dtotsi(Iipar,Nn)*Exp1*Cap/Total
+ Ds(Ipar) = Ds(Ipar) + &
+ Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total) &
+ + Dtotsi(Iipar,Nn)*Exp1*Cap/Total
+ IF (Iipar.EQ.1) Dddyy0 = Dddyy0 + &
+ Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total) &
+ + Dtotsi(Iipar,Nn)*Exp1*Cap/Total
ELSE IF (Kyield.EQ.2) THEN
- Ds(Ipar) = Ds(Ipar) + (One-Exp1)*Dcapsi(Iipar,Nn)
- * + Dtotsi(Iipar,Nn)*Exp1*Cap*Dthick
+ Ds(Ipar) = Ds(Ipar) + (One-Exp1)*Dcapsi(Iipar,Nn) &
+ + Dtotsi(Iipar,Nn)*Exp1*Cap*Dthick
END IF
END IF
-C
-C *** Next, the derivative of Y1 wrt u(Iipar)
+!
+! *** Next, the derivative of Y1 wrt u(Iipar)
IF (Kyield.EQ.0) THEN
Ds(Ipar) = Ds(Ipar) + Dy1(Iipar)
ELSE IF (Kyield.EQ.1) THEN
Ds(Ipar) = Ds(Ipar) + Dy1(Iipar)
ELSE IF (Kyield.EQ.2) THEN
- Ds(Ipar) = Ds(Ipar) + Dy1(Iipar) +
- * Y1*Dtotsi(Iipar,Nn)/Total
+ Ds(Ipar) = Ds(Ipar) + Dy1(Iipar) + &
+ Y1*Dtotsi(Iipar,Nn)/Total
END IF
-C ------------------------------------------------------------------
-C *** If gamma attenuation is being used, add the derivative for the
-C *** attenuated yield
-C
-C *** d/du(k_a Y) = d(k_a)/dsig_t * d(sig_t)/du * Y +
-C *** d(Y)/du * k_a
+! ------------------------------------------------------------------
+! *** If gamma attenuation is being used, add the derivative for the
+! *** attenuated yield
+!
+! *** d/du(k_a Y) = d(k_a)/dsig_t * d(sig_t)/du * Y +
+! *** d(Y)/du * k_a
IF (Gam_att_C1.GT.0) THEN
-C
-C d(k_a)/dsig_t =
- Dka = Gamma_atten_corr_deriv(Gam_att_C1,Dthick,Total)
-C
-C d(k_a)/du =
- Dkadu = Dka*Dtotsi(Iipar,Nn)
-C
-C corr_ka is correction factor k_a
- corr_ka = Gamma_attenuation_corr(Gam_att_C1,Dthick*Total)
-C
-C -----------------------------------------
- Ds(Ipar) = Dkadu*(Y0+Y1) + Ds(Ipar)*corr_ka
-C -----------------------------------------
+ call capYieldCor%derivGammaAttenCorr(Dthick, Total, &
+ Gam_att_C1, Dtotsi(Iipar,Nn), &
+ Y0+Y1, Ds(Ipar) )
END IF
-C ------------------------------------------------------------------
-C
-C
+! ------------------------------------------------------------------
+!
+!
END DO
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Selfin (Sigxxx, Dasigx, Dbsigx, Vsigsi, Vdasis, Vdbsis,
- * Dtotsi, Total, Nn)
-C *** Self-Indication Experiment
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Selfin (Sigxxx, Dasigx, Dbsigx, Vsigsi, Vdasis, Vdbsis, Dtotsi, Total, Nn)
+! *** Self-Indication Experiment
use fixedi_m
use ifwrit_m
use fixedr_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Sigxxx(*), Dasigx(*), Dbsigx(*), Vsigsi(*),
- * Vdasis(Ndaxxx,*), Vdbsis(Ndbxxx,*), Dtotsi(Nnpar,*)
+ DIMENSION Sigxxx(*), Dasigx(*), Dbsigx(*), Vsigsi(*), &
+ Vdasis(Ndaxxx,*), Vdbsis(Ndbxxx,*), Dtotsi(Nnpar,*)
DATA Zero /0.0d0/
-C
+!
Total2 = Total
IF (Ksindi.GT.0 .OR. (Ksitmp.GT.0 .AND. Kbrd.EQ.1)) THEN
Total2 = Vsigsi(Nn)
@@ -348,43 +344,45 @@ C
Exp2 = Thick2*Total2
Exp2 = Dexp(-Exp2)
Sigxxx(1) = Exp2*Sigxxx(1)
-C
+!
IF (Ksolve.EQ.2) RETURN ! We're done if Bayes solve isn't wanted
IF (Ksindi.GT.0 .OR. (Kbrd.EQ.1 .AND. Ksitmp.GT.0)) THEN
-C *** Here cross sections for trans sample & capture smp are different
+! *** Here cross sections for trans sample & capture smp are different
IF (Ndasig.GT.0) THEN
DO Ipar=1,Ndasig
- Dasigx(Ipar) = Dasigx(Ipar)*Exp2 -
- * Sigxxx(1)*Thick2*Vdasis(Ipar,Nn)
+ Dasigx(Ipar) = Dasigx(Ipar)*Exp2 - &
+ Sigxxx(1)*Thick2*Vdasis(Ipar,Nn)
END DO
END IF
IF (Ndbsig.GT.0) THEN
DO Ipar=1,Ndbsig
- Dbsigx(Ipar) = Dbsigx(Ipar)*Exp2 -
- * Sigxxx(1)*Thick2*Vdbsis(Ipar,Nn)
+ Dbsigx(Ipar) = Dbsigx(Ipar)*Exp2 - &
+ Sigxxx(1)*Thick2*Vdbsis(Ipar,Nn)
END DO
END IF
ELSE
-C *** Here cross sections are the same for trans sample as for
-C *** capture sample
+! *** Here cross sections are the same for trans sample as for
+! *** capture sample
IF (Ndasig.GT.0) THEN
DO Ipar=1,Ndasig
- Dasigx(Ipar) = Dasigx(Ipar)*Exp2 -
- * Sigxxx(1)*Thick2*Dtotsi(Ipar,Nn)
+ Dasigx(Ipar) = Dasigx(Ipar)*Exp2 - &
+ Sigxxx(1)*Thick2*Dtotsi(Ipar,Nn)
END DO
END IF
IF (Ndbsig.GT.0) THEN
DO Ipar=1,Ndbsig
- Dbsigx(Ipar) = Dbsigx(Ipar)*Exp2 -
- * Sigxxx(1)*Thick2*Dtotsi(Ipar+Ndasig,Nn)
+ Dbsigx(Ipar) = Dbsigx(Ipar)*Exp2 - &
+ Sigxxx(1)*Thick2*Dtotsi(Ipar+Ndasig,Nn)
END DO
END IF
END IF
-C
+!
IF (Kv.GT.0) THEN
-C *** Add deriv of Y0 wrt Thickness of transmission sample
+! *** Add deriv of Y0 wrt Thickness of transmission sample
Kv = Kv - Nvadif - Ndasig
Dbsigx(Kv) = Dbsigx(Kv) - Sigxxx(1)*Total2
END IF
RETURN
END
+
+end module ssm_20_m
diff --git a/sammy/src/ssm/mssm21.f b/sammy/src/ssm/mssm21.f90
similarity index 53%
rename from sammy/src/ssm/mssm21.f
rename to sammy/src/ssm/mssm21.f90
index 53dcf0ff6..49047ddeb 100644
--- a/sammy/src/ssm/mssm21.f
+++ b/sammy/src/ssm/mssm21.f90
@@ -1,22 +1,24 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Fixy_2 (Dyyy2, Dyyy2q, Dyy2qq, Y2cccc, Dy2ccc, Dy2bbb,
- * Dy2bbq, Dy2bqq, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Idone, Nn, Su)
-C
-C *** Purpose -- Solve for Y2cccc, now that we know "c=pi*[b+bq*c]"
-C *** Then finish setting Y2
-C
+!
+module ssm_21_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Fixy_2 (Dyyy2, Dyyy2q, Dyy2qq, Y2cccc, Dy2ccc, Dy2bbb,&
+ Dy2bbq, Dy2bqq, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Idone, Nn, Su)
+!
+! *** Purpose -- Solve for Y2cccc, now that we know "c=pi*[b+bq*c]"
+! *** Then finish setting Y2
+!
use fixedi_m
use ifwrit_m
use constn_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Dyyy2(*), Dyyy2q(*), Dyy2qq(*), Dy2ccc(*), Dy2bbb(*),
- * Dy2bbq(*), Dy2bqq(*)
+ DIMENSION Dyyy2(*), Dyyy2q(*), Dyy2qq(*), Dy2ccc(*), Dy2bbb(*),&
+ Dy2bbq(*), Dy2bqq(*)
DATA One /1.0d0/
-C
-C
+!
+!
Y2cccc = Y2bbbb/(One/Pi-Y2bbbq)
Yyy2 = (Yyy2+Yyy2q*Y2cccc)*Pi
IF (Ksolve.NE.2) THEN
@@ -29,35 +31,40 @@ C
IF (Idone.EQ.3) RETURN
IF (Nnpar.GT.0) THEN
DO j=1,Nnpar
- Dyyy2(J) = Pi*( Dyyy2(J) + Dyyy2q(J)*Dy2ccc(J) +
- * Dyy2qq(J)*Y2cccc )
+ Dyyy2(J) = Pi*( Dyyy2(J) + Dyyy2q(J)*Dy2ccc(J) + &
+ Dyy2qq(J)*Y2cccc )
END DO
END IF
-C
+!
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ynrm_2 (Capsig, Dtotsi, Dcapsi, Sigxxx, Dasigx, Dbsigx,
- * Dy1, Dy2, Y0, Y1, Y2, Dthick, Total, Exp1, Em, Dddyy0, Asensn,
- * Y2tab, Nn)
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ynrm_2 (Capsig, Dtotsi, Dcapsi, Sigxxx, Dasigx,Dbsigx,&
+ Dy1, Dy2, Y0, Y1, Y2, Dthick, Total, Exp1, Em, Dddyy0, Asensn,&
+ Y2tab, Nn)
use fixedi_m
use ifwrit_m
use fixedr_m
+ use CapYCorrections_common_m
use logic_ssm_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Capsig(*), Dtotsi(Nnparx,*), Dcapsi(Nnparx,*), Dy1(*),
- * Dy2(*), Sigxxx(*), Dasigx(*), Dbsigx(*)
+ DIMENSION Capsig(*), Dtotsi(Nnparx,*), Dcapsi(Nnparx,*), Dy1(*),&
+ Dy2(*), Sigxxx(*), Dasigx(*), Dbsigx(*)
DATA Zero /0.0d0/, One /1.0d0/
-C
-C *** Default normalization is such that Y0 = (1-e)Capture /(n Total)
-C *** which corresponds to Kyield=1 ("cross section", not "yield")
-C
+
+ !type(CapYieldCorrections)::capYieldCor
+
+ call capYieldCor%initialize()
+!
+! *** Default normalization is such that Y0 = (1-e)Capture /(n Total)
+! *** which corresponds to Kyield=1 ("cross section", not "yield")
+!
IF (Noyzer.NE.0) Y0 = Zero
-C
+!
Cap = Capsig(Nn)
IF (Kyield.EQ.0) THEN
Y0 = Y0*Dthick
@@ -86,44 +93,45 @@ C
END IF
END IF
IF (Mcy2.NE.0) Y2 = Y2tab
-C
+!
Sigxxx(1) = Y0 + Y1 + Y2
-C
-C If the gamma attenuation factor C1 is not zero
+!
+! If the gamma attenuation factor C1 is not zero
IF (Gam_att_C1.NE.0.0) THEN
- C1 = Gam_att_C1
dC1 = dGam_att_C1
Td = Total*Dthick
-C Sigxxx(1) is the place we store the output to ODF/LST files
- Sigxxx(1) = Sigxxx(1) * Gamma_attenuation_corr(C1,Td)
+! Sigxxx(1) is the place we store the output to ODF/LST files
+! -- Here we are modifying Sigxxx(1) with the gamma attenuation
+! -- correction
+ call capYieldCor%gammaAttenCorr( Dthick,Total,Gam_att_C1,Sigxxx(1) )
END IF
-C
-C
+!
+!
IF (Kssmpr.EQ.1) THEN
WRITE (60,12000) Em, Y0, Y1, Y2, Sigxxx(1)
12000 FORMAT (1X, f15.8, 1P5E15.6)
END IF
-C
+!
IF (Ksolve.EQ.2) RETURN
-C ######################################
-C It seems that Ndasig is a subset of varied parameters and that
-C Ndbsig is the total number of varied parameters minus Ndasig
-C ######################################
- IF (Ndasig.GT.0) CALL Ynrm_2_Derivative (Cap, Dtotsi, Dcapsi,
- * Dasigx, Dy1, Dy2, Y0, Y1, Y2, Dthick, Total, Exp1, Dddyy0,
- * Nn, Ndasig, 0)
- IF (Ndbsig.GT.0) CALL Ynrm_2_Derivative (Cap, Dtotsi, Dcapsi,
- * Dbsigx, Dy1, Dy2, Y0, Y1, Y2, Dthick, Total, Exp1, Dddyy0,
- * Nn, Ndbsig, Ndasig)
-C
+! ######################################
+! It seems that Ndasig is a subset of varied parameters and that
+! Ndbsig is the total number of varied parameters minus Ndasig
+! ######################################
+ IF (Ndasig.GT.0) CALL Ynrm_2_Derivative (Cap, Dtotsi, Dcapsi, &
+ Dasigx, Dy1, Dy2, Y0, Y1, Y2, Dthick, Total, Exp1, Dddyy0, &
+ Nn, Ndasig, 0)
+ IF (Ndbsig.GT.0) CALL Ynrm_2_Derivative (Cap, Dtotsi, Dcapsi, &
+ Dbsigx, Dy1, Dy2, Y0, Y1, Y2, Dthick, Total, Exp1, Dddyy0, &
+ Nn, Ndbsig, Ndasig)
+!
IF (Kvthck.GT.0) THEN
-C *** Add deriv of Y0 wrt Thickness; modify deriv of Y1 & Y2 wrt Thick
+! *** Add deriv of Y0 wrt Thickness; modify deriv of Y1 & Y2 wrt Thick
Kv = Kvthck - Nvadif - Ndasig
IF (Kyield.EQ.0) THEN
IF (Noyzer.EQ.0) THEN
Dbsigx(Kv) = Exp1*Cap + Dbsigx(Kv)
-C ELSE
-C disabling Y0 portion of calculation
+! ELSE
+! disabling Y0 portion of calculation
END IF
ELSE IF (Kyield.EQ.1) THEN
Sn = Dthick*Total
@@ -135,7 +143,7 @@ C disabling Y0 portion of calculation
F = Cap*(Exp1-(One-Exp1)/Sn)/Dthick
END IF
ELSE
-C disabling Y0 portion of calculation
+! disabling Y0 portion of calculation
F = Zero
END IF
Dbsigx(Kv) = F + Dbsigx(Kv) - Y1/Dthick
@@ -144,106 +152,98 @@ C disabling Y0 portion of calculation
IF (Noyzer.EQ.0) Dbsigx(Kv)= Exp1*Cap*Total + Dbsigx(Kv)
END IF
END IF
-C
+!
IF (Sensin.NE.Zero .AND. Ksensc.GT.0) THEN
IF (Kyield.EQ.0) Asensn = Asensn * Dthick
IF (Kyield.EQ.2) Asensn = Asensn * Dthick * Total
-C *** Add deriv of Y0 wrt neutron sensitivity multiplier
+! *** Add deriv of Y0 wrt neutron sensitivity multiplier
Kv = Ksensc - Nvadif - Ndasig
Dbsigx(Kv) = Asensn
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Ynrm_2_Derivative (Cap, Dtotsi, Dcapsi, Ds, Dy1,
- * Dy2, Y0, Y1, Y2, Dthick, Total, Exp1, Dddyy0, Nn, Nd, Na)
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Ynrm_2_Derivative (Cap, Dtotsi, Dcapsi, Ds, Dy1, &
+ Dy2, Y0, Y1, Y2, Dthick, Total, Exp1, Dddyy0, Nn, Nd, Na)
use fixedi_m
use ifwrit_m
use logic_ssm_common_m
+ use CapYCorrections_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Dtotsi(Nnparx,*), Dcapsi(Nnparx,*), Dy1(*), Dy2(*),Ds(*)
DATA One /1.0d0/
-C
-C Dthick = N [at/b]
-C Cap = sigma_gamma
-C Total = sigma_tot
-C Exp1 = e^(-N*sigma_tot)
-C
+!
+! Dthick = N [at/b]
+! Cap = sigma_gamma
+! Total = sigma_tot
+! Exp1 = e^(-N*sigma_tot)
+!
DO Ipar=1,Nd
Iipar = Ipar + Na
-C
+!
IF (Noyzer.EQ.0) THEN
-C *** First, the derivative of Y0 wrt u(Iipar)
-C *** (Nn=Energy) JMB
+! *** First, the derivative of Y0 wrt u(Iipar)
+! *** (Nn=Energy) JMB
IF (Kyield.EQ.0) THEN
- Ds(Ipar) = Ds(Ipar) +
- * Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total)
- * + Dtotsi(Iipar,Nn)*Exp1*Cap/Total * Dthick
+ Ds(Ipar) = Ds(Ipar) + &
+ Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total) &
+ + Dtotsi(Iipar,Nn)*Exp1*Cap/Total * Dthick
ELSE IF (Kyield.EQ.1) THEN
- Ds(Ipar) = Ds(Ipar) +
- * Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total)
- * + Dtotsi(Iipar,Nn)*Exp1*Cap/Total
- IF (Iipar.EQ.1) Dddyy0 = Dddyy0 +
- * Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total)
- * + Dtotsi(Iipar,Nn)*Exp1*Cap/Total
+ Ds(Ipar) = Ds(Ipar) + &
+ Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total) &
+ + Dtotsi(Iipar,Nn)*Exp1*Cap/Total
+ IF (Iipar.EQ.1) Dddyy0 = Dddyy0 + &
+ Y0* (Dcapsi(Iipar,Nn)/Cap-Dtotsi(Iipar,Nn)/Total) &
+ + Dtotsi(Iipar,Nn)*Exp1*Cap/Total
ELSE IF (Kyield.EQ.2) THEN
- Ds(Ipar) = Ds(Ipar) + (One-Exp1)*Dcapsi(Iipar,Nn)
- * + Dtotsi(Iipar,Nn)*Exp1*Cap*Dthick
+ Ds(Ipar) = Ds(Ipar) + (One-Exp1)*Dcapsi(Iipar,Nn) &
+ + Dtotsi(Iipar,Nn)*Exp1*Cap*Dthick
END IF
END IF
-C
-C *** Next, the derivative of Y1 wrt u(Iipar)
+!
+! *** Next, the derivative of Y1 wrt u(Iipar)
IF (Kyield.EQ.0) THEN
Ds(Ipar) = Ds(Ipar) + Dy1(Iipar)
ELSE IF (Kyield.EQ.1) THEN
Ds(Ipar) = Ds(Ipar) + Dy1(Iipar)
ELSE IF (Kyield.EQ.2) THEN
- Ds(Ipar) = Ds(Ipar) + Dy1(Iipar) +
- * Y1*Dtotsi(Iipar,Nn)/Total
+ Ds(Ipar) = Ds(Ipar) + Dy1(Iipar) + &
+ Y1*Dtotsi(Iipar,Nn)/Total
END IF
-C
-C *** Finally, the derivative of Y2 wrt u(Iipar)
+!
+! *** Finally, the derivative of Y2 wrt u(Iipar)
IF (Kyield.EQ.0) THEN
Ds(Ipar) = Ds(Ipar) + Dy2(Iipar)
ELSE IF (Kyield.EQ.1) THEN
Ds(Ipar) = Ds(Ipar) + Dy2(Iipar)
ELSE IF (Kyield.EQ.2) THEN
- Ds(Ipar) = Ds(Ipar) + Dy2(Iipar)
- * + Y2*Dtotsi(Iipar,Nn)/Total
+ Ds(Ipar) = Ds(Ipar) + Dy2(Iipar) &
+ + Y2*Dtotsi(Iipar,Nn)/Total
END IF
-C
-C ------------------------------------------------------------------
-C *** If gamma attenuation is being used, add the derivative for the
-C *** attenuated yield
-C
-C *** d/du(k_a Y) = d(k_a)/dsig_t * d(sig_t)/du * Y +
-C *** d(Y)/du * k_a
+!
+! ------------------------------------------------------------------
+! *** If gamma attenuation is being used, add the derivative for the
+! *** attenuated yield
+!
+! *** d/du(k_a Y) = d(k_a)/dsig_t * d(sig_t)/du * Y +
+! *** d(Y)/du * k_a
IF (Gam_att_C1.GT.0) THEN
-C
-C d(k_a)/dsig_t =
- Dka = Gamma_atten_corr_deriv(Gam_att_C1,Dthick,Total)
-C
-C d(k_a)/du =
- Dkadu = Dka*Dtotsi(Iipar,Nn)
-C
-C corr_ka is correction factor k_a
- corr_ka = Gamma_attenuation_corr(Gam_att_C1,Dthick*Total)
-C
-C -----------------------------------------
- Ds(Ipar) = Dkadu*(Y0+Y1+Y2) + Ds(Ipar)*corr_ka
-C -----------------------------------------
+
+ call capYieldCor%derivGammaAttenCorr(Dthick, Total, &
+ Gam_att_C1, Dtotsi(Iipar,Nn), &
+ Y0+Y1+Y2, Ds(Ipar) )
END IF
-C ----------------------------------------------------------------------
-C
+! ----------------------------------------------------------------------
+!
END DO
RETURN
END
-C
-
+!
+end module ssm_21_m
diff --git a/sammy/src/ssm/mssm21a.f b/sammy/src/ssm/mssm21a.f
deleted file mode 100644
index dfbc438cd..000000000
--- a/sammy/src/ssm/mssm21a.f
+++ /dev/null
@@ -1,146 +0,0 @@
-C
- FUNCTION Gamma_attenuation_corr(C1,N_sigtot)
-C ----------------------------------------------------------------------
-C ----------------------------------------------------------------------
-C *** Function to correct for the attenuation of capture gammas in a
-C *** thick capture sample. Functional form is found from
-C *** Y_atten / Y
-C
-C *** Parameters
-C ----------
-C
-C C1 : double
-C C1 is a parameter fitted to the gamma attenuation correction
-C function by Monte Carlo calculation for gammas exiting a
-C sample. It is specific to the experimental geometry.
-C N_sigtot : double
-C The total cross section multiplied by the thickness in atoms/b
-C
-C *** Returns
-C -------
-C
-C Gamma_attenuation_corr : double
-C A correction to be applied to yield, including the singly and
-C multiply scattered yield.
-C (Y0+Y1+Y2...) * Gamma_attenuation_corr
-C ----------------------------------------------------------------------
-C ----------------------------------------------------------------------
-C
- IMPLICIT NONE
- DOUBLE PRECISION :: C1
- DOUBLE PRECISION :: N_sigtot
- DOUBLE PRECISION :: Gamma_attenuation_corr
- Gamma_attenuation_corr = (1.0d0-dexp(-N_sigtot-C1))/
- * (1.0d0-dexp(-N_sigtot))*
- * (1.0d0/(1.0d0+C1/N_sigtot))
-C
- RETURN
- END FUNCTION
-C
-C ----------------------------------------------------------------------
-C
- FUNCTION Gamma_atten_corr_deriv(C1,N,sigtot)
-C ----------------------------------------------------------------------
-C ----------------------------------------------------------------------
-C *** Derivative of the gamma attenuation correction function w.r.t. the
-C *** total cross section
-C
-C *** Parameters
-C ----------
-C
-C C1 : double
-C C1 is a parameter fitted to the gamma attenuation correction
-C function by Monte Carlo calculation for gammas exiting a
-C sample. It is specific to the experimental geometry.
-C N : double
-C N is the sample thickness [atoms/barn]
-C sigtot : double
-C The total neutron cross section of the sample
-C
-C *** Returns
-C -------
-C
-C Gamma_atten_corr_deriv : double
-C The derivative of the gamma attenuation correction w.r.t. the
-C total cross section
-C ----------------------------------------------------------------------
-C ----------------------------------------------------------------------
-C
- IMPLICIT NONE
- DOUBLE PRECISION :: C1
- DOUBLE PRECISION :: N
- DOUBLE PRECISION :: sigtot
- DOUBLE PRECISION :: Gamma_atten_corr_deriv
-C
-C ---------------------------------
- Gamma_atten_corr_deriv = ((1-exp(-N*sigtot)) * (exp(-C1-N*sigtot)*
- * N*(1+C1/(N*sigtot)) + C1/(N*sigtot**2) *
- * (1-exp(-C1-N*sigtot))) / (1+C1/(N*sigtot))**2 -
- * exp(-N*sigtot)*(1-exp(-C1-N*sigtot)) * N /
- * (1+C1/(N*sigtot))) / (1-exp(-N*sigtot))**2
-C
- RETURN
- END FUNCTION
-C
-C ----------------------------------------------------------------------
-C
- FUNCTION Test_gam_atten_corr(C1,N_sigtot) BIND(C,
- * name="Test_gam_atten_corr")
-C
-C *** Function to be called by the C++ testing program
-C
-C *** Just returns the function Gamma_atten_corr, but in a format
-C *** the C++ language can appreciate.
-C
- use,intrinsic :: ISO_C_BINDING
-C
- IMPLICIT NONE
-C
- DOUBLE PRECISION :: C1
- DOUBLE PRECISION :: N_sigtot
- DOUBLE PRECISION :: Test_gam_atten_corr
- DOUBLE PRECISION :: Gamma_attenuation_corr
-C
- Test_gam_atten_corr = Gamma_attenuation_corr(C1,N_sigtot)
-C
- RETURN
- END FUNCTION
-C
-C ----------------------------------------------------------------------
-C
- FUNCTION Test_gam_atten_corr_deriv(C1,N,sigtot) BIND(C,
- * name="Test_gam_atten_corr_deriv")
-C
-C *** Function to be called by the C++ testing program
-C
-C *** Just returns the function Gamma_atten_corr_deriv, but in a format
-C *** the C++ language can appreciate.
-C
- use,intrinsic :: ISO_C_BINDING
-
- IMPLICIT NONE
-
- DOUBLE PRECISION :: C1
- DOUBLE PRECISION :: N
- DOUBLE PRECISION :: sigtot
- DOUBLE PRECISION :: Test_gam_atten_corr_deriv
- DOUBLE PRECISION :: Gamma_atten_corr_deriv
-
- Test_gam_atten_corr_deriv = Gamma_atten_corr_deriv(C1,N,sigtot)
-
- RETURN
- END FUNCTION
-C
-C ----------------------------------------------------------------------
-C
-
-
-
-
-
-
-
-
-
-
-
diff --git a/sammy/src/ssm/mssm22.f b/sammy/src/ssm/mssm22.f90
similarity index 63%
rename from sammy/src/ssm/mssm22.f
rename to sammy/src/ssm/mssm22.f90
index 9c9d5190e..2a718f128 100644
--- a/sammy/src/ssm/mssm22.f
+++ b/sammy/src/ssm/mssm22.f90
@@ -1,7 +1,7 @@
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Finish_01 (A, Ee, Wssmsc, Em, Y0, Kdatb, Kkkdat, N)
use oops_common_m
use fixedi_m
@@ -13,38 +13,38 @@ C
use lbro_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION A(-Msize:Msize)
-C
+!
DIMENSION Wssmsc(10)
IF (Kwssms.EQ.1) THEN
Wssmsc(4) = Y0
WRITE (15) Wssmsc
END IF
-C
+!
Nnnxxx = 1000
Nnn = N/Nnnxxx
IF (Nnn*Nnnxxx.EQ.N) THEN
WRITE (6,20000) N, Kdatb, Ee, A(Isigxx), Y0
20000 FORMAT(' Completing E #', I6, ' of', I6,' = ', F18.8, 1P2G13.6)
END IF
-C
+!
IF (Another_Process_Will_Happen) THEN
- CALL Store_W (A(Iwsigx), A(Iwdasi), A(Iwdbsi),
- * A(Isigxx), A(Idasig), A(Idbsig), 1, 1, Kkkdat)
+ CALL Store_W (A(Iwsigx), A(Iwdasi), A(Iwdbsi), &
+ A(Isigxx), A(Idasig), A(Idbsig), 1, 1, Kkkdat)
ELSE
- IF (Numnbk.GT.0) CALL Norm (A_Iprnbk , I_Iflnbk ,
- * A(Isigxx), A(Idasig), A(Idbsig), Em, 1)
- IF (Numbgf.GT.0) CALL Bgfrpi (A_Iprbgf , I_Iflbgf , A_Indbgf ,
- * A_Ibgfmi , A_Ibgfma , A_Itexbg , A_Iteabg , A(Isigxx),
- * A(Idbsig), Em, 1)
- CALL Store_W (A(Iwsigx), A(Iwdasi), A(Iwdbsi),
- * A(Isigxx), A(Idasig), A(Idbsig), 1, 1, Kkkdat)
+ IF (Numnbk.GT.0) CALL Norm (A_Iprnbk , I_Iflnbk , &
+ A(Isigxx), A(Idasig), A(Idbsig), Em, 1)
+ IF (Numbgf.GT.0) CALL Bgfrpi (A_Iprbgf , I_Iflbgf , A_Indbgf , &
+ A_Ibgfmi , A_Ibgfma , A_Itexbg , A_Iteabg , A(Isigxx), &
+ A(Idbsig), Em, 1)
+ CALL Store_W (A(Iwsigx), A(Iwdasi), A(Iwdbsi), &
+ A(Isigxx), A(Idasig), A(Idbsig), 1, 1, Kkkdat)
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Finish_02 (A, Energy, Energb, Kkkdat, Kdatmn)
use oops_common_m
use fixedi_m
@@ -56,29 +56,29 @@ C
use logic_ssm_common_m
use lbro_common_m
use constn_common_m
+ use ssm_18_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION A(-Msize:Msize)
DIMENSION Energy(*), Energb(*)
-C
+!
Kdatmx = Kkkdat + Kdatmn - 1
Ndatmn = Ndatmn + Kdatmn - 1
IF (Another_Process_Will_Happen) THEN
Kkkmin = Kdatmn - 1
Iw = 0
- CALL Write_Cross_Sections (Energb, A(Iwsigx), A(Iwdasi),
- * A(Iwdbsi), A(Iwe), A(Iwe), A(Iwe), 1, Kkkdat, Kkkmin, Iw)
-C
+ CALL Write_Cross_Sections (Energb, A(Iwsigx), A(Iwdasi), &
+ A(Iwdbsi), A(Iwe), A(Iwe), A(Iwe), 1, Kkkdat, Kkkmin, Iw)
+!
ELSE
-C ELSE IF (.NOT.Another_Process_Will_Happen) THEN
-C *** need to reorder such that keep only the energies in the
-C *** experimental grid; may need to interpolate
- CALL Reorder_Energy (Energy, Energb, A(Iwsigx), A(Iwdasi),
- * A(Iwdbsi), A(Ith), Kdatmn, Kdatmx, Kkkdat)
- IF (Ksolve.NE.2) CALL Write_W_48 (A(Iwdasi), A(Iwdbsi),
- * 1, Kkkdat)
+! ELSE IF (.NOT.Another_Process_Will_Happen) THEN
+! *** need to reorder such that keep only the energies in the
+! *** experimental grid; may need to interpolate
+ CALL Reorder_Energy (Energy, Energb, A(Iwsigx), A(Iwdasi), &
+ A(Iwdbsi), A(Ith), Kdatmn, Kdatmx, Kkkdat)
+ IF (Ksolve.NE.2) CALL Write_W_48 (A(Iwdasi), A(Iwdbsi), 1, Kkkdat)
END IF
Ndatmx = Kkkdat
-C
+!
IF (Kwssms.EQ.1) CLOSE (UNIT=15)
IF (Mcy2.EQ.1) CLOSE (UNIT=1)
RETURN
diff --git a/sammy/src/ssm/ssm_utils.f90 b/sammy/src/ssm/ssm_utils.f90
new file mode 100644
index 000000000..504e555f3
--- /dev/null
+++ b/sammy/src/ssm/ssm_utils.f90
@@ -0,0 +1,203 @@
+
+module ssm_utils_m
+ contains
+
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Zero0_1f (A, Yyy1fb, Y0, Yyy1, Nx)
+ use oops_common_m
+ use fixedi_m
+ use ifwrit_m
+ use array_sizes_common_m
+ use logic_ssm_common_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ DIMENSION A(-Msize:Msize), Yyy1fb(*)
+ DATA Zero /0.0d0/
+!
+ Y0 = Zero
+ Yyy1 = Zero
+ Yyy1fb(1) = Zero
+ Yyy1fb(2) = Zero
+ IF (Ksolve.NE.2) CALL Zero_Array (A(Idyyy1), Nx)
+!
+ RETURN
+ END
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Zero0_2i (A, Y0, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx)
+ use oops_common_m
+ use fixedi_m
+ use ifwrit_m
+ use array_sizes_common_m
+ use logic_ssm_common_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ DIMENSION A(-Msize:Msize)
+ DATA Zero /0.0d0/
+!
+ Y0 = Zero
+ Yyy1 = Zero
+!
+ IF (Ksolve.NE.2) CALL Zero_Array (A(Idyyy1), Nx)
+!
+ Yyy2 = Zero
+ Y2bbbb = Zero
+ IF (Double_Plus) THEN
+ Yyy2q = Zero
+ Y2cccc = Zero
+ Y2bbbq = Zero
+!
+ IF (Ksolve.NE.2) THEN
+ CALL Zero_Array (A(Idyyy2), Nx)
+ CALL Zero_Array (A(Idyy2q), Nx)
+ CALL Zero_Array (A(Idy2qq), Nx)
+ CALL Zero_Array (A(Idy2cc), Nx)
+ CALL Zero_Array (A(Idy2bb), Nx)
+ CALL Zero_Array (A(Idy2bq), Nx)
+ CALL Zero_Array (A(Idybqq), Nx)
+ END IF
+ END IF
+ RETURN
+ END
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Zero0_2f (A, Yyy1fb, Y0, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx)
+ use oops_common_m
+ use fixedi_m
+ use ifwrit_m
+ use array_sizes_common_m
+ use logic_ssm_common_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ DIMENSION A(-Msize:Msize), Yyy1fb(*)
+ DATA Zero /0.0d0/
+!
+ Y0 = Zero
+ Yyy1 = Zero
+ Yyy1fb(1) = Zero
+ Yyy1fb(2) = Zero
+!
+ IF (Ksolve.NE.2) CALL Zero_Array (A(Idyyy1), Nx)
+!
+ Yyy2 = Zero
+ Y2bbbb = Zero
+ IF (Double_Plus) THEN
+ Yyy2q = Zero
+ Y2cccc = Zero
+ Y2bbbq = Zero
+!
+ IF (Ksolve.NE.2) THEN
+ CALL Zero_Array (A(Idyyy2), Nx)
+ CALL Zero_Array (A(Idyy2q), Nx)
+ CALL Zero_Array (A(Idy2qq), Nx)
+ CALL Zero_Array (A(Idy2cc), Nx)
+ CALL Zero_Array (A(Idy2bb), Nx)
+ CALL Zero_Array (A(Idy2bq), Nx)
+ CALL Zero_Array (A(Idybqq), Nx)
+ END IF
+ END IF
+ RETURN
+ END
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Tell_Finite (A)
+ use oops_common_m
+ use fixedi_m
+ use logic_ssm_common_m
+ use MultScatPars_common_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ DIMENSION A(-Msize:Msize)
+ DATA Zero /0.0d0/
+ IF (multScat%getLogSigmaTotMax().GT.Zero) THEN
+ call multScat%setLogSigmaTotMin( dLOG(multScat%getLogSigmaTotMin()) )
+ Xtmin = dLOG(multScat%getLogSigmaTotMin())
+ call multScat%setLogSigmaTotMax( dLOG(multScat%getLogSigmaTotMax()) )
+ Xtmax = dLOG(multScat%getLogSigmaTotMax())
+ WRITE ( 6,10200) multScat%getLogSigmaTotMin(), multScat%getLogSigmaTotMax()
+ WRITE (21,10200) multScat%getLogSigmaTotMin(), multScat%getLogSigmaTotMax()
+ WRITE ( 6,10300) A(Ixtptv), A(Ixtptv-1+Nxtptv)
+ WRITE (21,10300) A(Ixtptv), A(Ixtptv-1+Nxtptv)
+10200 FORMAT ('Interpolation limits needed: Xtmin, Xtmax=', 1P5G14.6)
+10300 FORMAT ('Interpolation limits used: Xtmin, Xtmax=', 1P5G14.6)
+ END IF
+ IF (Interp_Small_Times.GT.0) THEN
+ WRITE ( 6,10400)
+ WRITE (21,10400)
+10400 FORMAT (' Expand interpolation limits and try again.')
+ STOP
+ END IF
+ RETURN
+ END
+
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE X_Trpths_Lin (A, Ftheta, Knthet, Jfb, Jth, Itntrp, Nn, Nxtptwn)
+ use oops_common_m
+ use ifwrit_m
+ use logic_ssm_common_m
+ use ssssss_common_m
+ use xsect_x_common_m
+ use ssm_13_m
+ use ssm_15_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ DIMENSION A(-Msize:Msize), Ftheta(*)
+!
+ CALL Trpths1_Lin (A_Ixtptw, Ftheta, A_Iqfb, A(Idvqfb), Knthet, &
+ Jfb, Jth, Itntrp, Nn, Nxtptwn)
+ Fz1 = Fz
+ IF (Ksolvx.NE.2) THEN
+ Dfz1 = Dfz
+ Dpfz1 = Dpfz
+ Dnfz1 = Dnfz
+ END IF
+ CALL Trpths2
+ Fz = Fz1 + Fz
+ IF (Ksolvx.NE.2) THEN
+ Dfz = Dfz1 + Dfz
+ Dpfz = Dpfz1 + Dpfz
+ Dnfz = Dnfz1 + Dnfz
+ END IF
+ RETURN
+ END
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE X_Trpths_Quad (A, Ftheta, Knthet, Jfb, Jth, Itntrp, Nn, Nxtptwn)
+ use oops_common_m
+ use ifwrit_m
+ use logic_ssm_common_m
+ use ssssss_common_m
+ use xsect_x_common_m
+ use ssm_14_m
+ use ssm_15_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ DIMENSION A(-Msize:Msize), Ftheta(*)
+!
+ CALL Trpths1_Quad (A_Ixtptw, Ftheta, A_Iqfb, A(Idvqfb), Knthet, &
+ Jfb, Jth, Itntrp, Nn, Nxtptwn)
+ Fz1 = Fz
+ IF (Ksolvx.NE.2) THEN
+ Dfz1 = Dfz
+ Dpfz1 = Dpfz
+ Dnfz1 = Dnfz
+ END IF
+ CALL Trpths2
+ Fz = Fz1 + Fz
+ IF (Ksolvx.NE.2) THEN
+ Dfz = Dfz1 + Dfz
+ Dpfz = Dpfz1 + Dpfz
+ Dnfz = Dnfz1 + Dnfz
+ END IF
+ RETURN
+ END
+
+end module ssm_utils_m
\ No newline at end of file
--
GitLab