From 52bf15f8638c00a153f5f4d5ca4d747b959b563c Mon Sep 17 00:00:00 2001
From: Brown <2mx@ornl.gov>
Date: Mon, 9 Nov 2020 17:00:54 -0500
Subject: [PATCH] rpi f -> f90 move rst -> f90 move par -> f90 fix circular
dependency make new xerfcx.f90 fnc file
---
sammy/src/acs/macs0.f | 158 ------
sammy/src/acs/macs0.f90 | 162 ++++++
sammy/src/acs/macs1.f | 221 --------
sammy/src/acs/macs1.f90 | 227 ++++++++
sammy/src/acs/{macs2.f => macs2.f90} | 120 ++---
sammy/src/acs/{macs3.f => macs3.f90} | 428 ++++++++-------
sammy/src/dat/mdat1.f90 | 2 +
sammy/src/fnc/fexq.f90 | 32 ++
sammy/src/fnc/xerfcx.f90 | 24 +
sammy/src/inp/minp01.f | 1 +
sammy/src/inp/minp02.f | 1 +
sammy/src/inp/minp03.f | 9 +
sammy/src/ort/mort.f | 1 +
sammy/src/par/{mpar0.f => mpar0.f90} | 383 +++++++-------
sammy/src/par/{mpar01.f => mpar01.f90} | 143 ++---
sammy/src/par/mpar02.f | 339 ------------
sammy/src/par/mpar02.f90 | 346 +++++++++++++
sammy/src/par/{mpar03.f => mpar03.f90} | 350 +++++++------
sammy/src/par/{mpar04.f => mpar04.f90} | 344 ++++++-------
sammy/src/par/{mpar05.f => mpar05.f90} | 226 ++++----
sammy/src/par/{mpar06.f => mpar06.f90} | 627 +++++++++++-----------
sammy/src/par/{mpar07.f => mpar07.f90} | 279 +++++-----
sammy/src/par/{mpar08.f => mpar08.f90} | 420 ++++++++-------
sammy/src/par/{mpar09.f => mpar09.f90} | 133 +++--
sammy/src/par/{mpar10.f => mpar10.f90} | 364 +++++++------
sammy/src/par/{mpar11.f => mpar11.f90} | 232 +++++----
sammy/src/par/{mpar13.f => mpar13.f90} | 63 +--
sammy/src/par/{mpar14.f => mpar14.f90} | 271 +++++-----
sammy/src/par/{mpar15.f => mpar15.f90} | 355 ++++++-------
sammy/src/par/{mpar16.f => mpar16.f90} | 183 +++----
sammy/src/par/{mpar17.f => mpar17.f90} | 373 +++++++-------
sammy/src/par/{mpar18.f => mpar18.f90} | 277 +++++-----
sammy/src/par/{mpar19.f => mpar19.f90} | 91 ++--
sammy/src/ref/mcon.F | 1 +
sammy/src/rpi/{mrpi0.f => mrpi0.f90} | 95 ++--
sammy/src/rpi/mrpi1.f | 208 --------
sammy/src/rpi/mrpi1.f90 | 212 ++++++++
sammy/src/rpi/{mrpi2.f => mrpi2.f90} | 282 +++++-----
sammy/src/rpi/{mrpi3.f => mrpi3.f90} | 261 +++++-----
sammy/src/rpi/mrpi4.f | 58 ---
sammy/src/rpi/mrpi4.f90 | 61 +++
sammy/src/rpi/mrpi5.f90 | 59 +--
sammy/src/rpi/{mrpi6.f => mrpi6.f90} | 436 ++++++++--------
sammy/src/rpi/{mrpi7.f => mrpi7.f90} | 688 ++++++++++++-------------
sammy/src/rpi/{mrpi8.f => mrpi8.f90} | 187 +++----
sammy/src/rpi/{mrpi9.f => mrpi9.f90} | 363 +++++++------
sammy/src/rpt/mrpt.f | 5 +-
sammy/src/rpt/mrpt1.f | 1 +
sammy/src/rst/{mrst0.f => mrst0.f90} | 40 +-
sammy/src/rst/{mrst1.f => mrst1.f90} | 156 +++---
sammy/src/rst/{mrst2.f => mrst2.f90} | 19 +-
sammy/src/rst/{mrst3.f => mrst3.f90} | 98 ++--
sammy/src/sam/msam.F | 4 +
sammy/src/sammy/CMakeLists.txt | 74 +--
54 files changed, 5296 insertions(+), 5197 deletions(-)
delete mode 100644 sammy/src/acs/macs0.f
create mode 100644 sammy/src/acs/macs0.f90
delete mode 100644 sammy/src/acs/macs1.f
create mode 100644 sammy/src/acs/macs1.f90
rename sammy/src/acs/{macs2.f => macs2.f90} (75%)
rename sammy/src/acs/{macs3.f => macs3.f90} (56%)
create mode 100644 sammy/src/fnc/fexq.f90
create mode 100644 sammy/src/fnc/xerfcx.f90
rename sammy/src/par/{mpar0.f => mpar0.f90} (55%)
rename sammy/src/par/{mpar01.f => mpar01.f90} (69%)
delete mode 100644 sammy/src/par/mpar02.f
create mode 100644 sammy/src/par/mpar02.f90
rename sammy/src/par/{mpar03.f => mpar03.f90} (71%)
rename sammy/src/par/{mpar04.f => mpar04.f90} (76%)
rename sammy/src/par/{mpar05.f => mpar05.f90} (78%)
rename sammy/src/par/{mpar06.f => mpar06.f90} (72%)
rename sammy/src/par/{mpar07.f => mpar07.f90} (73%)
rename sammy/src/par/{mpar08.f => mpar08.f90} (75%)
rename sammy/src/par/{mpar09.f => mpar09.f90} (70%)
rename sammy/src/par/{mpar10.f => mpar10.f90} (68%)
rename sammy/src/par/{mpar11.f => mpar11.f90} (73%)
rename sammy/src/par/{mpar13.f => mpar13.f90} (75%)
rename sammy/src/par/{mpar14.f => mpar14.f90} (50%)
rename sammy/src/par/{mpar15.f => mpar15.f90} (55%)
rename sammy/src/par/{mpar16.f => mpar16.f90} (69%)
rename sammy/src/par/{mpar17.f => mpar17.f90} (55%)
rename sammy/src/par/{mpar18.f => mpar18.f90} (64%)
rename sammy/src/par/{mpar19.f => mpar19.f90} (65%)
rename sammy/src/rpi/{mrpi0.f => mrpi0.f90} (69%)
delete mode 100644 sammy/src/rpi/mrpi1.f
create mode 100644 sammy/src/rpi/mrpi1.f90
rename sammy/src/rpi/{mrpi2.f => mrpi2.f90} (89%)
rename sammy/src/rpi/{mrpi3.f => mrpi3.f90} (58%)
delete mode 100644 sammy/src/rpi/mrpi4.f
create mode 100644 sammy/src/rpi/mrpi4.f90
rename sammy/src/rpi/{mrpi6.f => mrpi6.f90} (79%)
rename sammy/src/rpi/{mrpi7.f => mrpi7.f90} (74%)
rename sammy/src/rpi/{mrpi8.f => mrpi8.f90} (81%)
rename sammy/src/rpi/{mrpi9.f => mrpi9.f90} (81%)
rename sammy/src/rst/{mrst0.f => mrst0.f90} (75%)
rename sammy/src/rst/{mrst1.f => mrst1.f90} (71%)
rename sammy/src/rst/{mrst2.f => mrst2.f90} (88%)
rename sammy/src/rst/{mrst3.f => mrst3.f90} (63%)
diff --git a/sammy/src/acs/macs0.f b/sammy/src/acs/macs0.f
deleted file mode 100644
index 066aef21a..000000000
--- a/sammy/src/acs/macs0.f
+++ /dev/null
@@ -1,158 +0,0 @@
-C
-C
-C ______________________________________________________________________
-C
- SUBROUTINE Samacs_0
-C
-C FITACS MAIN PROGRAM (VERSION FEBRUARY 1991)
-C Modified for inclusion in SAMMY May 1997 NML
-C Corrections for inaccurate derivatives January 1999
-C Changed constants to agree with ENDF-prefered values Dec 2004
-C Worked more on Dresner integral Dec 2004; option to calc accurately
-C
-C FITACS IS A GENERALIZED (BAYESIAN) LEAST-SQUARES FITTING PROGRAM
-C FOR THE EXTRACTION OF LEVEL-STATISTICAL PARAMETERS
-C (STRENGTH FUNCTIONS, DISTANT-LEVEL PARAMETERS, AVERAGE RADIATION
-C AND FISSION WIDTHS, FOR GIVEN LEVEL DENSITY) FROM MEASURED
-C RESONANCE-AVERAGED NEUTRON CROSS SECTIONS (TOTAL, INELASTIC
-C SCATTERING, CAPTURE AND FISSION). IT CAN ALSO BE USED FOR THE
-C COHERENT GENERATION OF CROSS SECTIONS AND THEIR UNCERTAINTIES
-C FOR ALL OPEN REACTION CHANNELS FROM GIVEN PARAMETERS.
-C
-C FORMALISM: HAUSER-FESHBACH THEORY WITH WIDTH FLUCTUATIONS
-C (MOLDAUER 1980), WITH
-C - E-DEPENDENT NEUTRON STRENGTH FUNCTIONS AND DISTANT-LEVEL PARA-
-C METERS,
-C - GILBERT-CAMERON COMPOSITE LEVEL DENSITIES,
-C - GIANT-DIPOLE RESONANCE MODEL FOR PHOTON TRANSMISSION
-C COEFFICIENTS,
-C - SINGLE-HUMP HILL-WHEELER FISSION TRANSMISSION COEFFICIENTS.
-C
-C LIMITATIONS:
-C - THE Original VERSION USEd ONLY THE S-, P-, D- AND F-WAVE
-C NEUTRON CHANNELS, HENCE IT was APPLICABLE WHENEVER NO HIGHER-
-C ORDER PARTIAL WAVES ARE IMPORTANT (FOR INSTANCE BELOW ABOUT
-C 500 KEV FOR ACTINIDES). SAMMY, however, has no limitations
-C and includes all possible L-values.
-C - FISSION CROSS SECTIONS ARE CALCULATED FROM THE INPUT HILL-
-C WHEELER PARAMETERS, BUT THOSE ARE NOT YET ADJUSTabLE.
-C - UNCERTAINTIES OF A-PRIORI (INPUT) AVERAGE LEVEL-STATISTICAL
-C PARAMETERS AND OF INPUT CROSS SECTIONS ARE UTILIZED IN THE
-C GENERALIZED LEAST-SQUARES FIT, BUT CORRELATIONS AMONG THEM
-C ARE NEGLECTED.
-C
- use oops_common_m
- use fixedi_m
- use ifwrit_m
- use oopsch_common_m
- use fixedr_m
- use exploc_urr_common_m
- use z00001_common_m
- use AllocateFunctions_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- real(kind=8),allocatable,dimension(:)::A_Idm
-C
-C
- WRITE (6,99999)
-99999 FORMAT (' *** SAMMY-ACS 2 Jan 08 ***')
- Segmen(1) = 'A'
- Segmen(2) = 'C'
- Segmen(3) = 'S'
- Nowwww = 0
-C
- CALL Initil
- K = Idimen (0, 0, '0, 0')
-C
- N = (Nvpall*(Nvpall+1))/2
- call allocate_real_data(A_Idelpa, Nvpall)
- call allocate_real_data(A_Iyyyyy, Nvpall)
- call allocate_real_data(A_Iwwwww, N)
-C *** Initialize for each iteration
- CALL Begin_Iteration ( A_Kkanrm , A_Istren , A_Idistn , A_Kkkkgg ,
- * A_Kkkkgf , I_Kkkjnl , I_Kkkjxl , A_Kchisq , A_Kkktab , A_Kktabf ,
- * A_Kktabn , A_Idelpa , A_Iyyyyy , A_Iwwwww )
-C
-C --------------------------------------------------------------------- <
- call allocate_real_data(A_Idth, Nvpall)
- call allocate_real_data(A_Icl, Numelv)
- IF (Kdresn.EQ.0) THEN
- Jhxxxx = 101
- ELSE
- Jhxxxx = 1001
- END IF
- Ajhxxx = Jhxxxx
-C *** Calculate theoretical cross sections and derivatives thereof
- call allocate_real_data(A_Kkelas, 7*Nkelas)
- call allocate_real_data(A_Kkinel, 7*Nkinel)
- ! the two integer arrays double in Msize
- ! as they are now allocated as integers
- call allocate_integer_data(I_Kkkela, 2*Nkelas)
- call allocate_integer_data(I_Kkkine, 2*Nkinel)
- CALL Calthe ( A_Kkanrm , I_Kkknrm , I_Kkktyp , I_Kkkknt ,
- * A_Keeset , A_Kssset , A_Kwwset , A_Kktheo , A_Kkthel ,
- * A_Kkdthe , A_Kkksiz )
- deallocate(A_Idth)
- deallocate(A_Icl)
-C --------------------------------------------------------------------- >
-C
- IF (Kpntws.EQ.0 .AND. Ktheou.EQ.1) THEN
-C *** Print experimental and calculated cross sections
- CALL Acsout (A_Kkanrm , A_Kkdnrm , I_Kkktyp , I_Kkkknt ,
- * A_Kkkkex , A_Keeset , A_Kssset , A_Kuuset , A_Kchisq ,
- * A_Kktheo , A_Kkthel , A_Kkdthe , A_Kkksiz )
-C
- ELSE IF (Kpntws.NE.0) THEN
- CALL Make_File_3_Urr (I_Kkktyp , I_Kkkknt , A_Keeset ,
- * A_Kktheo )
- WRITE (6,10100)
-10100 FORMAT ('Normal end of SAMMY-URR')
- STOP
- END IF
-C
-C
- IF (Kendf.EQ.0 .AND. (Iterat.EQ.Itmax .OR. Iterat.EQ.0)) THEN
-C *** Prepare the plot files
- If_Odf = 1
- I = Kntmax
- call allocate_real_data(A_Idm, I)
- CALL Plott2 (I_Kkkknt , A_Keeset , A_Kktheo , A_Idm, Iterp1,
- * Kntmax, Kdtset)
- deallocate(A_Idm)
- END IF
-C
-C
- IF (Ksolve.NE.2) CALL Wrt30 (A_Iwwwww , A_Iyyyyy , Nvpall)
- deallocate(A_Idelpa)
- deallocate(A_Iwwwww)
- deallocate(A_Iyyyyy)
- if( allocated(A_Kkelas)) deallocate(A_Kkelas)
- if( allocated(A_Kkinel)) deallocate(A_Kkinel)
- if( allocated(I_Kkkela)) deallocate(I_Kkkela)
- if( allocated(I_Kkkine)) deallocate(I_Kkkine)
-C
- CALL Write_Commons_Few
- CALL RUN ('sammpw')
- RETURN
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Wrt30 (Www, Xxx, Nvpall)
-C
- use samxxx_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Www(*), Xxx(*)
-C N = (Nvpall*(Nvpall+1))/2*8
-C
-C removed the factor 8 from the expression for N above; this factor seems to have no purpose
-C because when reading this file SAM30.DAT in SUBROUTINE Readwx, there N is 8x smaller
-C causing SAMMY to crash on Windows/ifort... The results are otherwise identical.
-C
- N = (Nvpall*(Nvpall+1))/2
- CALL Newopn (30, Sam30x, 1)
- WRITE (30) (Www(I),I=1,N)
- WRITE (30) (Xxx(I),I=1,Nvpall)
- CLOSE (UNIT=30)
- RETURN
- END
diff --git a/sammy/src/acs/macs0.f90 b/sammy/src/acs/macs0.f90
new file mode 100644
index 000000000..f715e7020
--- /dev/null
+++ b/sammy/src/acs/macs0.f90
@@ -0,0 +1,162 @@
+!
+module acs_m
+ contains
+!
+! ______________________________________________________________________
+!
+ SUBROUTINE Samacs_0
+!
+! FITACS MAIN PROGRAM (VERSION FEBRUARY 1991)
+! Modified for inclusion in SAMMY May 1997 NML
+! Corrections for inaccurate derivatives January 1999
+! Changed constants to agree with ENDF-prefered values Dec 2004
+! Worked more on Dresner integral Dec 2004; option to calc accurately
+!
+! FITACS IS A GENERALIZED (BAYESIAN) LEAST-SQUARES FITTING PROGRAM
+! FOR THE EXTRACTION OF LEVEL-STATISTICAL PARAMETERS
+! (STRENGTH FUNCTIONS, DISTANT-LEVEL PARAMETERS, AVERAGE RADIATION
+! AND FISSION WIDTHS, FOR GIVEN LEVEL DENSITY) FROM MEASURED
+! RESONANCE-AVERAGED NEUTRON CROSS SECTIONS (TOTAL, INELASTIC
+! SCATTERING, CAPTURE AND FISSION). IT CAN ALSO BE USED FOR THE
+! COHERENT GENERATION OF CROSS SECTIONS AND THEIR UNCERTAINTIES
+! FOR ALL OPEN REACTION CHANNELS FROM GIVEN PARAMETERS.
+!
+! FORMALISM: HAUSER-FESHBACH THEORY WITH WIDTH FLUCTUATIONS
+! (MOLDAUER 1980), WITH
+! - E-DEPENDENT NEUTRON STRENGTH FUNCTIONS AND DISTANT-LEVEL PARA-
+! METERS,
+! - GILBERT-CAMERON COMPOSITE LEVEL DENSITIES,
+! - GIANT-DIPOLE RESONANCE MODEL FOR PHOTON TRANSMISSION
+! COEFFICIENTS,
+! - SINGLE-HUMP HILL-WHEELER FISSION TRANSMISSION COEFFICIENTS.
+!
+! LIMITATIONS:
+! - THE Original VERSION USEd ONLY THE S-, P-, D- AND F-WAVE
+! NEUTRON CHANNELS, HENCE IT was APPLICABLE WHENEVER NO HIGHER-
+! ORDER PARTIAL WAVES ARE IMPORTANT (FOR INSTANCE BELOW ABOUT
+! 500 KEV FOR ACTINIDES). SAMMY, however, has no limitations
+! and includes all possible L-values.
+! - FISSION CROSS SECTIONS ARE CALCULATED FROM THE INPUT HILL-
+! WHEELER PARAMETERS, BUT THOSE ARE NOT YET ADJUSTabLE.
+! - UNCERTAINTIES OF A-PRIORI (INPUT) AVERAGE LEVEL-STATISTICAL
+! PARAMETERS AND OF INPUT CROSS SECTIONS ARE UTILIZED IN THE
+! GENERALIZED LEAST-SQUARES FIT, BUT CORRELATIONS AMONG THEM
+! ARE NEGLECTED.
+!
+ use oops_common_m
+ use fixedi_m
+ use ifwrit_m
+ use oopsch_common_m
+ use fixedr_m
+ use exploc_urr_common_m
+ use z00001_common_m
+ use AllocateFunctions_m
+ use acs1_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ real(kind=8),allocatable,dimension(:)::A_Idm
+!
+!
+ WRITE (6,99999)
+99999 FORMAT (' *** SAMMY-ACS 2 Jan 08 ***')
+ Segmen(1) = 'A'
+ Segmen(2) = 'C'
+ Segmen(3) = 'S'
+ Nowwww = 0
+!
+ CALL Initil
+ K = Idimen (0, 0, '0, 0')
+!
+ N = (Nvpall*(Nvpall+1))/2
+ call allocate_real_data(A_Idelpa, Nvpall)
+ call allocate_real_data(A_Iyyyyy, Nvpall)
+ call allocate_real_data(A_Iwwwww, N)
+! *** Initialize for each iteration
+ CALL Begin_Iteration ( A_Kkanrm , A_Istren , A_Idistn , A_Kkkkgg , &
+ A_Kkkkgf , I_Kkkjnl , I_Kkkjxl , A_Kchisq , A_Kkktab , A_Kktabf , &
+ A_Kktabn , A_Idelpa , A_Iyyyyy , A_Iwwwww )
+!
+! --------------------------------------------------------------------- <
+ call allocate_real_data(A_Idth, Nvpall)
+ call allocate_real_data(A_Icl, Numelv)
+ IF (Kdresn.EQ.0) THEN
+ Jhxxxx = 101
+ ELSE
+ Jhxxxx = 1001
+ END IF
+ Ajhxxx = Jhxxxx
+! *** Calculate theoretical cross sections and derivatives thereof
+ call allocate_real_data(A_Kkelas, 7*Nkelas)
+ call allocate_real_data(A_Kkinel, 7*Nkinel)
+ ! the two integer arrays double in Msize
+ ! as they are now allocated as integers
+ call allocate_integer_data(I_Kkkela, 2*Nkelas)
+ call allocate_integer_data(I_Kkkine, 2*Nkinel)
+ CALL Calthe ( A_Kkanrm , I_Kkknrm , I_Kkktyp , I_Kkkknt , &
+ A_Keeset , A_Kssset , A_Kwwset , A_Kktheo , A_Kkthel , &
+ A_Kkdthe , A_Kkksiz )
+ deallocate(A_Idth)
+ deallocate(A_Icl)
+! --------------------------------------------------------------------- >
+!
+ IF (Kpntws.EQ.0 .AND. Ktheou.EQ.1) THEN
+! *** Print experimental and calculated cross sections
+ CALL Acsout (A_Kkanrm , A_Kkdnrm , I_Kkktyp , I_Kkkknt , &
+ A_Kkkkex , A_Keeset , A_Kssset , A_Kuuset , A_Kchisq , &
+ A_Kktheo , A_Kkthel , A_Kkdthe , A_Kkksiz )
+!
+ ELSE IF (Kpntws.NE.0) THEN
+ CALL Make_File_3_Urr (I_Kkktyp , I_Kkkknt , A_Keeset , A_Kktheo )
+ WRITE (6,10100)
+10100 FORMAT ('Normal end of SAMMY-URR')
+ STOP
+ END IF
+!
+!
+ IF (Kendf.EQ.0 .AND. (Iterat.EQ.Itmax .OR. Iterat.EQ.0)) THEN
+! *** Prepare the plot files
+ If_Odf = 1
+ I = Kntmax
+ call allocate_real_data(A_Idm, I)
+ CALL Plott2 (I_Kkkknt , A_Keeset , A_Kktheo , A_Idm, Iterp1, Kntmax, &
+ Kdtset)
+ deallocate(A_Idm)
+ END IF
+!
+!
+ IF (Ksolve.NE.2) CALL Wrt30 (A_Iwwwww , A_Iyyyyy , Nvpall)
+ deallocate(A_Idelpa)
+ deallocate(A_Iwwwww)
+ deallocate(A_Iyyyyy)
+ if( allocated(A_Kkelas)) deallocate(A_Kkelas)
+ if( allocated(A_Kkinel)) deallocate(A_Kkinel)
+ if( allocated(I_Kkkela)) deallocate(I_Kkkela)
+ if( allocated(I_Kkkine)) deallocate(I_Kkkine)
+!
+ CALL Write_Commons_Few
+ CALL RUN ('sammpw')
+ RETURN
+ END
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Wrt30 (Www, Xxx, Nvpall)
+!
+ use samxxx_common_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ DIMENSION Www(*), Xxx(*)
+! N = (Nvpall*(Nvpall+1))/2*8
+!
+! removed the factor 8 from the expression for N above; this factor seems to have no purpose
+! because when reading this file SAM30.DAT in SUBROUTINE Readwx, there N is 8x smaller
+! causing SAMMY to crash on Windows/ifort... The results are otherwise identical.
+!
+ N = (Nvpall*(Nvpall+1))/2
+ CALL Newopn (30, Sam30x, 1)
+ WRITE (30) (Www(I),I=1,N)
+ WRITE (30) (Xxx(I),I=1,Nvpall)
+ CLOSE (UNIT=30)
+ RETURN
+ END
+end module acs_m
+
diff --git a/sammy/src/acs/macs1.f b/sammy/src/acs/macs1.f
deleted file mode 100644
index c0451c335..000000000
--- a/sammy/src/acs/macs1.f
+++ /dev/null
@@ -1,221 +0,0 @@
-C
-C
-C ______________________________________________________________________
-C
- SUBROUTINE Begin_Iteration (Anrm, Streng, Distnt, Gg, Gf,
- * Jnl, Jxl, Chisq, Tab, Tabf, Tabn, Delpar, Yyy, Www)
-C
-C INITIALIZATION FOR EACH ITERATIVE STEP
-C
- use fixedi_m
- use samxxx_common_m
- use fixedr_m
- use EndfData_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Anrm(3,*), Chisq(*), Streng(Numelv,*), Distnt(Numelv,*),
- * Gg(Numelv,*), Gf(Numelv,Numjjv,*), Jnl(*), Jxl(*),
- * Tab(Numelv,4,Numurr,*), Tabf(Numelv,Numjjv,Numurr,*),
- * Tabn(3,Kdtset,*), Delpar(*), Yyy(*), Www(*)
-C
- DATA Zero /0.0d0/
-C
-C
- Chisq(Iterp1) = Zero
- Chisqo = Zero
- IF (Iterp1.GT.1) Chisqo = Chisq(Iterp1-1)
-C
-C
- IF (Nvpall.GT.0) THEN
- Nvpall_tr = ((Nvpall+1)*Nvpall)/2
- CALL Zero_Array (Yyy, Nvpall)
- CALL Zero_Array (Www, Nvpall_tr)
- IF (Iterp1.EQ.1) THEN
- do i = 1, Nvpall
- call covData%setFitStep(i, 0.0d0)
- CALL Zero_Array (Delpar, Nvpall)
- end do
- else
- do i = 1, Nvpall
- Delpar(i) = covData%getFitStep(i)
- end do
- END IF
- END IF
-C
-C
- IF (Iterp1.GT.1) RETURN
-C
-C
- DO Kumurr=1,Numurr
- DO L=1,Numelv
- Tab(L,1,Kumurr,1) = Streng(L,Kumurr)
- Tab(L,2,Kumurr,1) = Distnt(L,Kumurr)
- Tab(L,3,Kumurr,1) = Gg(L,Kumurr)
- END DO
- DO L=1,Numelv
- Jlo = Jnl(L)
- Jhi = Jxl(L)
- DO J=Jlo,Jhi
- Tabf(L,J,Kumurr,1) = Gf(L,J,Kumurr)
- END DO
- END DO
- END DO
- DO I=1,Kdtset
- DO J=1,3
- Tabn(J,I,1) = Anrm(J,I)
- END DO
- END DO
- RETURN
- END
-C
-C
-C ______________________________________________________________________
-C
- SUBROUTINE Calthe (Anrm, Knrm, Kktype, Kkkntx, Eeeset, Sssset,
- * Wwwset, Theory, Theorl, Dtheor, Siz)
-C
-C *** Call the routines to calculate theoretical cross sections and
-C derivatives thereof
-C
- use oops_common_m
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use exploc_urr_common_m
- use constn_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Anrm(3,*), Knrm(3,*), Kktype(*), Kkkntx(*),
- * Eeeset(Kntmax,*), Sssset(Kntmax,*), Wwwset(Kntmax,*),
- * Theory(Kntmax,Kdtset,*), Theorl(Numelv,Kntmax,*),
- * Dtheor(Nvpall,Kntmax,*), Siz (Kntmax,Numexc,*)
-C
-C *** Set constants etc
- CALL Define_Constants (A_Kkspin , A_Kkkkgj )
-C
-C *** Zero arrays
- CALL Zero_Array (Theory(1,1,Iterp1), Kntmax*Kdtset)
- CALL Zero_Array (Theorl, Kntmax*Numelv*Kdtset)
- CALL Zero_Array (Dtheor, Kntmax*Nvpall*Kdtset)
-C
-C *** Generate cross sections
- DO Iset=1,Kdtset
- Ktype = Kktype(Iset)
-C
- IF (Ktype.EQ.1) THEN
- CALL Caltot (Kkkntx(Iset), A_Kdirei , A_Kdirsi , A_Kdirec ,
- * A_Kdirsc , A_Istren , A_Idistn , I_Iflstr , I_Ifldst ,
- * I_Iflggg , A_Iengur , Eeeset(1,Iset),
- * Theory(1,Iset,Iterp1), Theorl(1,1,Iset),
- * Dtheor(1,1,Iset), A_Idth , A_Icl , Iset)
-C
- ELSE IF (Ktype.EQ.5) THEN
- CALL Elastic_Urr (Kkkntx(Iset), Eeeset(1,Iset),
- * Theory(1,Iset,Iterp1), Theorl(1,1,Iset),
- * Dtheor(1,1,Iset), Siz(1,1,Iset), Iset)
- ELSE
- CALL Calpar ( Ktype, Kkkntx(Iset),
- * A_Kdirei , A_Kdirsi , A_Kdirec , A_Kdirsc ,
- * Theory(1,Iset,Iterp1),Theorl(1,1,Iset),
- * Dtheor(1,1,Iset), Siz(1,1,Iset), A_Istren , A_Idistn ,
- * A_Kkkkgg , A_Kkkkgf , A_Kkkfnu , A_Kkethr , A_Kkwthr ,
- * A_Kkkkex , A_Kkspin , A_Kkkpty , I_Kkkjnl , I_Kkkjxl ,
- * I_Iflstr , I_Ifldst , I_Iflggg , I_Iflgff ,
- * A_Kbinde , A_Kpaire , A_Iengur , A_Ibethj , A_Ialevl ,
- * Eeeset(1,Iset), A_Kkkkgj , A_Idth ,
- * A_Kkelas , A_Kkinel , I_Kkkela , I_Kkkine , Iset)
- END IF
-C
- IF (Kpntws.EQ.0) THEN
-C *** Normalize, and set up Www & Yyy
- CALL Find_Www_Yyy (Anrm (1,Iset), Knrm(1,Iset),
- * Kktype( Iset), Kkkntx( Iset), A_Kkkkex ,
- * Eeeset(1,Iset), Sssset(1,Iset), Wwwset(1,Iset),
- * A_Kchisq , Theory(1,Iset,Iterp1), Dtheor(1,1,Iset),
- * A_Idelpa , A_Iyyyyy , A_Iwwwww , Iset)
- END IF
- END DO
-C
- RETURN
- END
-C
-C
-C ______________________________________________________________________
-C
- SUBROUTINE Elastic_Urr (Ktmax, Eeeset, Theory, Theorl, Dtheor,
- * Siz, Iset)
-C
-C *** Purpose -- calculate elastic cross section as (total - others)
-C
- use oops_common_m
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use exploc_urr_common_m
- use lbro_common_m
- use constn_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Eeeset(*), Theory(*), Theorl(Numelv,*),
- * Dtheor(Nvpall,*), Siz(Kntmax,*)
-C
-C *** Calculate total cross section
- CALL Caltot (Ktmax, A_Kdirei , A_Kdirsi , A_Kdirec ,
- * A_Kdirsc , A_Istren , A_Idistn , I_Iflstr , I_Ifldst ,
- * I_Iflggg , A_Iengur , Eeeset, Theory, Theorl, Dtheor,
- * A_Idth , A_Icl , Iset)
-C
-C *** Set to negative
- DO Ie=1,Ktmax
- Theory(Ie) = - Theory(Ie)
- DO L=1,Numelv
- Theorl(L,Ie) = - Theorl(L,Ie)
- END DO
- IF (Ksolve.NE.2) THEN
- DO Ipar=1,Nvpall
- Dtheor(Ipar,Ie) = - Dtheor(Ipar,Ie)
- END DO
- END IF
- END DO
-C
-C *** Add other cross sections
- DO I=1,2
- IF (I.EQ.1) Ktype = 4
- IF (I.EQ.2) Ktype = 3
- CALL Calpar ( Ktype , Ktmax , A_Kdirei , A_Kdirsi ,
- * A_Kdirec , A_Kdirsc , Theory , Theorl , Dtheor ,
- * Siz , A_Istren , A_Idistn , A_Kkkkgg , A_Kkkkgf ,
- * A_Kkkfnu , A_Kkethr , A_Kkwthr , A_Kkkkex , A_Kkspin ,
- * A_Kkkpty , I_Kkkjnl , I_Kkkjxl , I_Iflstr , I_Ifldst ,
- * I_Iflggg , I_Iflgff , A_Kbinde , A_Kpaire , A_Iengur ,
- * A_Ibethj , A_Ialevl , Eeeset , A_Kkkkgj , A_Idth ,
- * A_Kkelas , A_Kkinel , I_Kkkela , I_Kkkine , Iset)
- END DO
- Ktype = 2
- IF (Numexc.GT.1) THEN
- CALL Calpar ( Ktype , Ktmax , A_Kdirei , A_Kdirsi ,
- * A_Kdirec , A_Kdirsc , Theory , Theorl , Dtheor ,
- * Siz , A_Istren , A_Idistn , A_Kkkkgg , A_Kkkkgf ,
- * A_Kkkfnu , A_Kkethr , A_Kkwthr , A_Kkkkex , A_Kkspin ,
- * A_Kkkpty , I_Kkkjnl , I_Kkkjxl , I_Iflstr , I_Ifldst ,
- * I_Iflggg , I_Iflgff , A_Kbinde , A_Kpaire , A_Iengur ,
- * A_Ibethj , A_Ialevl , Eeeset , A_Kkkkgj , A_Idth ,
- * A_Kkelas , A_Kkinel , I_Kkkela , I_Kkkine , Iset)
- END IF
-C
-C *** Set to negative (Otherwise, have "others-total" instead of
-C *** "total-others")
- DO Ie=1,Ktmax
- Theory(Ie) = - Theory(Ie)
- DO L=1,Numelv
- Theorl(L,Ie) = - Theorl(L,Ie)
- END DO
- IF (Ksolve.NE.2) THEN
- DO Ipar=1,Nvpall
- Dtheor(Ipar,Ie) = - Dtheor(Ipar,Ie)
- END DO
- END IF
- END DO
-C
- RETURN
- END
diff --git a/sammy/src/acs/macs1.f90 b/sammy/src/acs/macs1.f90
new file mode 100644
index 000000000..9878605ca
--- /dev/null
+++ b/sammy/src/acs/macs1.f90
@@ -0,0 +1,227 @@
+!
+module acs1_m
+ contains
+!
+! ______________________________________________________________________
+!
+ SUBROUTINE Begin_Iteration (Anrm, Streng, Distnt, Gg, Gf, &
+ Jnl, Jxl, Chisq, Tab, Tabf, Tabn, Delpar, Yyy, Www)
+!
+! INITIALIZATION FOR EACH ITERATIVE STEP
+!
+ use fixedi_m
+ use samxxx_common_m
+ use fixedr_m
+ use EndfData_common_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+!
+ DIMENSION Anrm(3,*), Chisq(*), Streng(Numelv,*), Distnt(Numelv,*), &
+ Gg(Numelv,*), Gf(Numelv,Numjjv,*), Jnl(*), Jxl(*), &
+ Tab(Numelv,4,Numurr,*), Tabf(Numelv,Numjjv,Numurr,*), &
+ Tabn(3,Kdtset,*), Delpar(*), Yyy(*), Www(*)
+!
+ DATA Zero /0.0d0/
+!
+!
+ Chisq(Iterp1) = Zero
+ Chisqo = Zero
+ IF (Iterp1.GT.1) Chisqo = Chisq(Iterp1-1)
+!
+!
+ IF (Nvpall.GT.0) THEN
+ Nvpall_tr = ((Nvpall+1)*Nvpall)/2
+ CALL Zero_Array (Yyy, Nvpall)
+ CALL Zero_Array (Www, Nvpall_tr)
+ IF (Iterp1.EQ.1) THEN
+ do i = 1, Nvpall
+ call covData%setFitStep(i, 0.0d0)
+ CALL Zero_Array (Delpar, Nvpall)
+ end do
+ else
+ do i = 1, Nvpall
+ Delpar(i) = covData%getFitStep(i)
+ end do
+ END IF
+ END IF
+!
+!
+ IF (Iterp1.GT.1) RETURN
+!
+!
+ DO Kumurr=1,Numurr
+ DO L=1,Numelv
+ Tab(L,1,Kumurr,1) = Streng(L,Kumurr)
+ Tab(L,2,Kumurr,1) = Distnt(L,Kumurr)
+ Tab(L,3,Kumurr,1) = Gg(L,Kumurr)
+ END DO
+ DO L=1,Numelv
+ Jlo = Jnl(L)
+ Jhi = Jxl(L)
+ DO J=Jlo,Jhi
+ Tabf(L,J,Kumurr,1) = Gf(L,J,Kumurr)
+ END DO
+ END DO
+ END DO
+ DO I=1,Kdtset
+ DO J=1,3
+ Tabn(J,I,1) = Anrm(J,I)
+ END DO
+ END DO
+ RETURN
+ END
+!
+!
+! ______________________________________________________________________
+!
+ SUBROUTINE Calthe (Anrm, Knrm, Kktype, Kkkntx, Eeeset, Sssset, &
+ Wwwset, Theory, Theorl, Dtheor, Siz)
+!
+! *** Call the routines to calculate theoretical cross sections and
+! derivatives thereof
+!
+ use oops_common_m
+ use fixedi_m
+ use ifwrit_m
+ use fixedr_m
+ use exploc_urr_common_m
+ use constn_common_m
+ use acs2_m
+ use acs3_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+!
+ DIMENSION Anrm(3,*), Knrm(3,*), Kktype(*), Kkkntx(*), &
+ Eeeset(Kntmax,*), Sssset(Kntmax,*), Wwwset(Kntmax,*), &
+ Theory(Kntmax,Kdtset,*), Theorl(Numelv,Kntmax,*), &
+ Dtheor(Nvpall,Kntmax,*), Siz (Kntmax,Numexc,*)
+!
+! *** Set constants etc
+ CALL Define_Constants (A_Kkspin , A_Kkkkgj )
+!
+! *** Zero arrays
+ CALL Zero_Array (Theory(1,1,Iterp1), Kntmax*Kdtset)
+ CALL Zero_Array (Theorl, Kntmax*Numelv*Kdtset)
+ CALL Zero_Array (Dtheor, Kntmax*Nvpall*Kdtset)
+!
+! *** Generate cross sections
+ DO Iset=1,Kdtset
+ Ktype = Kktype(Iset)
+!
+ IF (Ktype.EQ.1) THEN
+ CALL Caltot (Kkkntx(Iset), A_Kdirei , A_Kdirsi , A_Kdirec , &
+ A_Kdirsc , A_Istren , A_Idistn , I_Iflstr , I_Ifldst , &
+ I_Iflggg , A_Iengur , Eeeset(1,Iset), &
+ Theory(1,Iset,Iterp1), Theorl(1,1,Iset), &
+ Dtheor(1,1,Iset), A_Idth , A_Icl , Iset)
+!
+ ELSE IF (Ktype.EQ.5) THEN
+ CALL Elastic_Urr (Kkkntx(Iset), Eeeset(1,Iset), &
+ Theory(1,Iset,Iterp1), Theorl(1,1,Iset), &
+ Dtheor(1,1,Iset), Siz(1,1,Iset), Iset)
+ ELSE
+ CALL Calpar ( Ktype, Kkkntx(Iset), &
+ A_Kdirei , A_Kdirsi , A_Kdirec , A_Kdirsc , &
+ Theory(1,Iset,Iterp1),Theorl(1,1,Iset), &
+ Dtheor(1,1,Iset), Siz(1,1,Iset), A_Istren , A_Idistn , &
+ A_Kkkkgg , A_Kkkkgf , A_Kkkfnu , A_Kkethr , A_Kkwthr , &
+ A_Kkkkex , A_Kkspin , A_Kkkpty , I_Kkkjnl , I_Kkkjxl , &
+ I_Iflstr , I_Ifldst , I_Iflggg , I_Iflgff , &
+ A_Kbinde , A_Kpaire , A_Iengur , A_Ibethj , A_Ialevl , &
+ Eeeset(1,Iset), A_Kkkkgj , A_Idth , &
+ A_Kkelas , A_Kkinel , I_Kkkela , I_Kkkine , Iset)
+ END IF
+!
+ IF (Kpntws.EQ.0) THEN
+! *** Normalize, and set up Www & Yyy
+ CALL Find_Www_Yyy (Anrm (1,Iset), Knrm(1,Iset), &
+ Kktype( Iset), Kkkntx( Iset), A_Kkkkex , &
+ Eeeset(1,Iset), Sssset(1,Iset), Wwwset(1,Iset), &
+ A_Kchisq , Theory(1,Iset,Iterp1), Dtheor(1,1,Iset), &
+ A_Idelpa , A_Iyyyyy , A_Iwwwww , Iset)
+ END IF
+ END DO
+!
+ RETURN
+ END
+!
+!
+! ______________________________________________________________________
+!
+ SUBROUTINE Elastic_Urr (Ktmax, Eeeset, Theory, Theorl, Dtheor, Siz, Iset)
+!
+! *** Purpose -- calculate elastic cross section as (total - others)
+!
+ use oops_common_m
+ use fixedi_m
+ use ifwrit_m
+ use fixedr_m
+ use exploc_urr_common_m
+ use lbro_common_m
+ use constn_common_m
+ use acs2_m
+ use acs3_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+!
+ DIMENSION Eeeset(*), Theory(*), Theorl(Numelv,*), &
+ Dtheor(Nvpall,*), Siz(Kntmax,*)
+!
+! *** Calculate total cross section
+ CALL Caltot (Ktmax, A_Kdirei , A_Kdirsi , A_Kdirec , &
+ A_Kdirsc , A_Istren , A_Idistn , I_Iflstr , I_Ifldst , &
+ I_Iflggg , A_Iengur , Eeeset, Theory, Theorl, Dtheor, &
+ A_Idth , A_Icl , Iset)
+!
+! *** Set to negative
+ DO Ie=1,Ktmax
+ Theory(Ie) = - Theory(Ie)
+ DO L=1,Numelv
+ Theorl(L,Ie) = - Theorl(L,Ie)
+ END DO
+ IF (Ksolve.NE.2) THEN
+ DO Ipar=1,Nvpall
+ Dtheor(Ipar,Ie) = - Dtheor(Ipar,Ie)
+ END DO
+ END IF
+ END DO
+!
+! *** Add other cross sections
+ DO I=1,2
+ IF (I.EQ.1) Ktype = 4
+ IF (I.EQ.2) Ktype = 3
+ CALL Calpar ( Ktype , Ktmax , A_Kdirei , A_Kdirsi , &
+ A_Kdirec , A_Kdirsc , Theory , Theorl , Dtheor , &
+ Siz , A_Istren , A_Idistn , A_Kkkkgg , A_Kkkkgf , &
+ A_Kkkfnu , A_Kkethr , A_Kkwthr , A_Kkkkex , A_Kkspin , &
+ A_Kkkpty , I_Kkkjnl , I_Kkkjxl , I_Iflstr , I_Ifldst , &
+ I_Iflggg , I_Iflgff , A_Kbinde , A_Kpaire , A_Iengur , &
+ A_Ibethj , A_Ialevl , Eeeset , A_Kkkkgj , A_Idth , &
+ A_Kkelas , A_Kkinel , I_Kkkela , I_Kkkine , Iset)
+ END DO
+ Ktype = 2
+ IF (Numexc.GT.1) THEN
+ CALL Calpar ( Ktype , Ktmax , A_Kdirei , A_Kdirsi , &
+ A_Kdirec , A_Kdirsc , Theory , Theorl , Dtheor , &
+ Siz , A_Istren , A_Idistn , A_Kkkkgg , A_Kkkkgf , &
+ A_Kkkfnu , A_Kkethr , A_Kkwthr , A_Kkkkex , A_Kkspin , &
+ A_Kkkpty , I_Kkkjnl , I_Kkkjxl , I_Iflstr , I_Ifldst , &
+ I_Iflggg , I_Iflgff , A_Kbinde , A_Kpaire , A_Iengur , &
+ A_Ibethj , A_Ialevl , Eeeset , A_Kkkkgj , A_Idth , &
+ A_Kkelas , A_Kkinel , I_Kkkela , I_Kkkine , Iset)
+ END IF
+!
+! *** Set to negative (Otherwise, have "others-total" instead of
+! *** "total-others")
+ DO Ie=1,Ktmax
+ Theory(Ie) = - Theory(Ie)
+ DO L=1,Numelv
+ Theorl(L,Ie) = - Theorl(L,Ie)
+ END DO
+ IF (Ksolve.NE.2) THEN
+ DO Ipar=1,Nvpall
+ Dtheor(Ipar,Ie) = - Dtheor(Ipar,Ie)
+ END DO
+ END IF
+ END DO
+!
+ RETURN
+ END
+end module acs1_m
\ No newline at end of file
diff --git a/sammy/src/acs/macs2.f b/sammy/src/acs/macs2.f90
similarity index 75%
rename from sammy/src/acs/macs2.f
rename to sammy/src/acs/macs2.f90
index f298ee07e..20650c6ec 100644
--- a/sammy/src/acs/macs2.f
+++ b/sammy/src/acs/macs2.f90
@@ -1,77 +1,79 @@
-C
-C
-C ______________________________________________________________________
-C
- SUBROUTINE Caltot (Ktmax, Edirin, Sdirin, Edircp, Sdircp,
- * Streng, Distnt, Iflstr, Ifldst, Iflggg, Engurr, Eeeset,
- * Theory, Theorl, Dtheor, Dth, Cl, Iset)
-C
-C CALTOT CALCULATES THEORETICAL TOTAL CROSS SECTIONS
-C AND THEIR DERIVATIVES.
-C
+!
+module acs2_m
+ contains
+!
+! ______________________________________________________________________
+!
+ SUBROUTINE Caltot (Ktmax, Edirin, Sdirin, Edircp, Sdircp, &
+ Streng, Distnt, Iflstr, Ifldst, Iflggg, Engurr, Eeeset, &
+ Theory, Theorl, Dtheor, Dth, Cl, Iset)
+!
+! CALTOT CALCULATES THEORETICAL TOTAL CROSS SECTIONS
+! AND THEIR DERIVATIVES.
+!
use fixedi_m
use ifwrit_m
use fixedr_m
use lbro_common_m
use constn_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Edirin(*), Sdirin(*), Edircp(*), Sdircp(*),
- * Streng(Numelv,*), Distnt(Numelv,*), Iflstr(Numelv,*),
- * Ifldst(Numelv,*), Iflggg(Numelv,*), Engurr(*), Eeeset(*),
- * Theory(*), Theorl(Numelv,*), Dtheor(Nvpall,*), Dth(*), Cl(*)
+!
+ DIMENSION Edirin(*), Sdirin(*), Edircp(*), Sdircp(*), &
+ Streng(Numelv,*), Distnt(Numelv,*), Iflstr(Numelv,*), &
+ Ifldst(Numelv,*), Iflggg(Numelv,*), Engurr(*), Eeeset(*), &
+ Theory(*), Theorl(Numelv,*), Dtheor(Nvpall,*), Dth(*), Cl(*)
DIMENSION Dsde(5), Drde(5)
-C
+!
EXTERNAL Sf, Pf
DATA Dsde /-2.2d-11, 2.0d-11, -2.8d-11, 1.8d-11, 0.0d0/
DATA Drde / 1.8E-07, 0.0d0 , 2.0d-07, 0.0d0 , 0.0d0/
DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/
-C
-C
+!
+!
C0x = Twopi/Twomhb**2/100.d0
IF (Ktmax.EQ.0) RETURN
-C
-C *** Note that Rk1 is the conversion factor from E to Rho=ka
-C *** (a=radius=Crfn),
-C *** so Rk1 is what we call Zkte elsewhere in the code
-C
+!
+! *** Note that Rk1 is the conversion factor from E to Rho=ka
+! *** (a=radius=Crfn),
+! *** so Rk1 is what we call Zkte elsewhere in the code
+!
Rk1 = Twomhb*Crfn/Rrrmas
-C *** Rrrmas = One + A_Mass_Small/Aaawww
+! *** Rrrmas = One + A_Mass_Small/Aaawww
DO L=1,Numelv
Cl(L) = dFLOAT(2*L-1)*C0x*Rrrmas**2
END DO
-C
+!
Kumurr = 0
-C *** BEGIN ENERGY LOOP
+! *** BEGIN ENERGY LOOP
DO Ienerg=1,Ktmax
Energy = Eeeset(Ienerg)
CALL Find_Urr (Engurr, Energy, Kumurr, Numurr, Iset)
Rho = Rk1*dSQRT(Energy)
IF (Ksolve.NE.2) CALL Zero_Array (Dth, Nvpall)
-C
+!
Ipar = 0
-C *** Sum OVER PARTIAL WAVES
+! *** Sum OVER PARTIAL WAVES
DO L=1,Numelv
Ce = CL(L)/Energy
PL = Pf (Rho, L-1)
Bnd = -dFLOAT(L-1)
SL = Sf (Rho, L-1, Bnd)
-C
+!
Rbarr = Distnt(L,Kumurr)
Rbari = Halfpi*Streng(L,Kumurr)/Rk1
IF (Aaawww.GT.220.0d0) THEN
Rbarr = Rbarr + Energy*Drde(L)
Rbari = Rbari + Energy*Halfpi*Dsde(L)/Rk1
END IF
-C
+!
RL0r = Rbarr*SL - Rbari*PL
RL0i = Rbarr*PL + Rbari*SL
Denom = (One-RL0r)**2 + (RL0i)**2
-C *** = denominator of equation (VJ1.7) Pg 98t.2 SAMMY manual
+! *** = denominator of equation (VJ1.7) Pg 98t.2 SAMMY manual
Cinvr = (One-RL0r)/Denom
Cinvi = RL0i/Denom
-C
-C *** COLLISION FUNCTION:
+!
+! *** COLLISION FUNCTION:
Rcr = Rbarr*Cinvr - Rbari*Cinvi
Rci = Rbarr*Cinvi + Rbari*Cinvr
Aar = One - Two*PL*Rci
@@ -80,35 +82,34 @@ C *** COLLISION FUNCTION:
Ur = Cosphi*Aar + Sinphi*Aai
TheorL(L,Ienerg) = Ce*(One-Ur)
Theory(Ienerg) = Theory(Ienerg) + TheorL(L,Ienerg)
-C
+!
Aar = Cinvr**2 - Cinvi**2
Aai = Two*Cinvr*Cinvi
Bbr = Cosphi*Aar + Sinphi*Aai
Bbi = Cosphi*Aai - Sinphi*Aar
-C
+!
IF (Ksolve.NE.2 .AND. Iflstr(L,Kumurr).NE.0) THEN
Ipar = Iflstr(L,Kumurr)
Dth(Ipar) = Ce*PL*Bbr*PI*(Streng(L,Kumurr)/Rk1)
-C *** Remember that it is ln(Streng) which is the
-C *** "u-parameter"; hence use Dth=Streng(L,Kumurr)*whatever
+! *** Remember that it is ln(Streng) which is the
+! *** "u-parameter"; hence use Dth=Streng(L,Kumurr)*whatever
END IF
-C
+!
IF (Ksolve.NE.2 .AND. Ifldst(L,Kumurr).NE.0) THEN
Ipar = Ifldst(L,Kumurr)
Dth(Ipar) = Two * Ce*PL*Bbi
END IF
-C
- IF (Ksolve.NE.2 .AND. L.LE.2 .AND. Iflggg(L,Kumurr).NE.0)
- * THEN
+!
+ IF (Ksolve.NE.2 .AND. L.LE.2 .AND. Iflggg(L,Kumurr).NE.0) THEN
Ipar = Iflggg(L,Kumurr)
Dth(Ipar) = Zero
END IF
-C
+!
END DO
-C *** PARTIAL-WAVE LOOP COMPLETE
-C
-C
-C *** Add direct inelastic component
+! *** PARTIAL-WAVE LOOP COMPLETE
+!
+!
+! *** Add direct inelastic component
IF (Ndirin.GT.1) THEN
DO Nd=1,Ndirin
IF (Energy.LT.Edirin(Nd)) THEN
@@ -131,8 +132,8 @@ C *** Add direct inelastic component
Dtheor(Ipar,Ienerg) = Dth(Ipar)
END DO
END IF
-C
-C *** Add direct capture component
+!
+! *** Add direct capture component
IF (Ndircp.GT.1) THEN
DO Nd=1,Ndircp
IF (Energy.LT.Edircp(Nd)) THEN
@@ -155,14 +156,14 @@ C *** Add direct capture component
Dtheor(Ipar,Ienerg) = Dth(Ipar)
END DO
END IF
-C
+!
END DO
RETURN
END
-C
-C
-C ______________________________________________________________________
-C
+!
+!
+! ______________________________________________________________________
+!
SUBROUTINE Find_Urr (Engurr, Energy, Kumurr, Numurr, Iset)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
Dimension Engurr(*)
@@ -181,16 +182,16 @@ C
RETURN
END IF
END DO
-C
+!
WRITE (21,10100)
WRITE (6,10100)
10100 FORMAT ('#######################################################')
WRITE (21,10200) Energy, Iset
WRITE (6,10200) Energy, Iset, Numurr
-10200 FORMAT ('Energy', 1PG12.4, ' in Data Set #', I2,
- * ' is greater than the highest energy for', /,
- * ' which these parameters are applicable. The', I3,
- * ' energy limits are')
+10200 FORMAT ('Energy', 1PG12.4, ' in Data Set #', I2, &
+ ' is greater than the highest energy for', /, &
+ ' which these parameters are applicable. The', I3, &
+ ' energy limits are')
WRITE (21,10300) (Engurr(K),K=1,Numurr)
WRITE (6,10300) (Engurr(K),K=1,Numurr)
10300 FORMAT (1P5G14.6)
@@ -200,3 +201,4 @@ C
WRITE (6,10100)
STOP '[STOP in Find_Urr in acs/macs2.f]'
END
+end module acs2_m
diff --git a/sammy/src/acs/macs3.f b/sammy/src/acs/macs3.f90
similarity index 56%
rename from sammy/src/acs/macs3.f
rename to sammy/src/acs/macs3.f90
index 3662fc1c7..b3bfa0e8b 100644
--- a/sammy/src/acs/macs3.f
+++ b/sammy/src/acs/macs3.f90
@@ -1,50 +1,53 @@
-C
-C
-C ______________________________________________________________________
-C
- SUBROUTINE Calpar (Ktype, Khmax, Edirin, Sdirin, Edircp, Sdircp,
- * Theory, Theorl, Dtheor, Siz, Streng, Distnt, Gg, Gf, Fnu, Ethr,
- * Wthr, Ex, Spin, Pty, Jnl, Jxl, Iflstr, Ifldst, Iflggg, Iflgff,
- * Bindee, Pairee, Engurr, Bethdj, Alevel, Ee, Gj, Dth,
- * Aelast, Ainela, Melast, Minela, Iset)
-C
-C *** CALCULATION OF PARTIAL CROSS SECTIONS AND OF THEIR DERIVATIVES
-C *** for a given type of data (Inelastic, Fission, or Capture)
-C
+!
+module acs3_m
+ contains
+!
+! ______________________________________________________________________
+!
+ SUBROUTINE Calpar (Ktype, Khmax, Edirin, Sdirin, Edircp, Sdircp, &
+ Theory, Theorl, Dtheor, Siz, Streng, Distnt, Gg, Gf, Fnu, Ethr, &
+ Wthr, Ex, Spin, Pty, Jnl, Jxl, Iflstr, Ifldst, Iflggg, Iflgff, &
+ Bindee, Pairee, Engurr, Bethdj, Alevel, Ee, Gj, Dth, &
+ Aelast, Ainela, Melast, Minela, Iset)
+!
+! *** CALCULATION OF PARTIAL CROSS SECTIONS AND OF THEIR DERIVATIVES
+! *** for a given type of data (Inelastic, Fission, or Capture)
+!
use fixedi_m
use ifwrit_m
use fixedr_m
use z00001_common_m
use constn_common_m
use Endepx_common_m
+ use acs2_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
CHARACTER*4 Type(5)
CHARACTER*1 Pm
-C
- DIMENSION Edirin(*), Sdirin(*), Edircp(*), Sdircp(*),
- * Theory(Kntmax), Theorl(Numelv,*), Dtheor(Nvpall,*),
- * Siz(Kntmax,*), Streng(Numelv,*), Distnt(Numelv,*),
- * Gg(Numelv,*), Gf(Numelv,Numjjv,*), Fnu(Numelv,*),
- * Ethr(Numelv,Numjjv,*), Wthr(Numelv,Numjjv,*),
- * Ex(*), Spin(*), Pty(*), Jnl(*), Jxl(*),
- * Iflstr(Numelv,*), Ifldst(Numelv,*), Iflggg(Numelv,*),
- * Iflgff(Numelv,Numjjv,*), Bindee(*), Pairee(*), Engurr(*),
- * Bethdj(Numjjv,*), Alevel(*), Ee(*), Gj(*), Dth(*),
- * Aelast(7,*), Ainela(7,*), Melast(2,*), Minela(2,*)
-C
+!
+ DIMENSION Edirin(*), Sdirin(*), Edircp(*), Sdircp(*), &
+ Theory(Kntmax), Theorl(Numelv,*), Dtheor(Nvpall,*), &
+ Siz(Kntmax,*), Streng(Numelv,*), Distnt(Numelv,*), &
+ Gg(Numelv,*), Gf(Numelv,Numjjv,*), Fnu(Numelv,*), &
+ Ethr(Numelv,Numjjv,*), Wthr(Numelv,Numjjv,*), &
+ Ex(*), Spin(*), Pty(*), Jnl(*), Jxl(*), &
+ Iflstr(Numelv,*), Ifldst(Numelv,*), Iflggg(Numelv,*), &
+ Iflgff(Numelv,Numjjv,*), Bindee(*), Pairee(*), Engurr(*), &
+ Bethdj(Numjjv,*), Alevel(*), Ee(*), Gj(*), Dth(*), &
+ Aelast(7,*), Ainela(7,*), Melast(2,*), Minela(2,*)
+!
real(kind=8)::Wff
DATA Type /'TOTA', 'INEL', 'FISS', 'CAPT', 'ELAS'/
DATA Zero /0.0d0/
-C
+!
IF (Khmax.EQ.0) RETURN
-C
+!
WRITE (21,10100) Type(Ktype)
-10100 FORMAT (' Width fluctuation factor for cross section type <<', A4,
- * '>> is --')
+10100 FORMAT (' Width fluctuation factor for cross section type <<', A4, &
+ '>> is --')
Kumurr = 0
Kumur0 = 0
Wff = 0.0d0
-C *** BEGIN ENERGY LOOP
+! *** BEGIN ENERGY LOOP
DO Ienerg=1,Khmax
IF (Ienerg.EQ.1 .OR. Ienerg.EQ.Khmax) THEN
Iwff = 1
@@ -52,111 +55,110 @@ C *** BEGIN ENERGY LOOP
Iwff = 0
END IF
Energy = Ee(Ienerg)
-C
+!
IF (Ktype.NE.2 .OR. Energy.GT.Ex(2)) THEN
-C *** IF (this is not inelastic, or if it is elastic and we are above
-C the lowest inelastic threshold) then do this calculation
-C
-C *** Find the applicable energy region Kumurr
+! *** IF (this is not inelastic, or if it is elastic and we are above
+! the lowest inelastic threshold) then do this calculation
+!
+! *** Find the applicable energy region Kumurr
CALL Find_Urr (Engurr, Energy, Kumurr, Numurr, Iset)
-C
+!
IF (Ktype.EQ.2 .AND. Numexc.GT.1) THEN
DO Kumexc=1,Numexc-1
Siz(Ienerg,Kumexc) = Zero
END DO
END IF
-C
+!
IF (Ksolve.NE.2) CALL Zero_Array (Dth, Nvpall)
-C
+!
Ce = Ca/Energy
Rho = Rk1*dSQRT(Energy)
-C [ Rho = ka where k = momentum and a = radius ]
-C
-C *** CALCULATE ENERGY DEPENDENCES OF LEVEL SPACINGS AND RADIATION
-C *** WIDTHS
- CALL Endep (Bindee(Kumurr), Pairee(Kumurr), Alevel(Kumurr),
- * Energy, Edgg, Kumurr)
-C
-C
-C *** Note that Density_1 & Density_2 are level densities at
-C *** different energies
- Density_1 = Get_Density (Bindee(Kumurr),
- * Pairee(Kumurr), Alevel(Kumurr))
- Density_2 = Get_Density (Bindee(Kumurr)+Energy,
- * Pairee(Kumurr), Alevel(Kumurr))
+! [ Rho = ka where k = momentum and a = radius ]
+!
+! *** CALCULATE ENERGY DEPENDENCES OF LEVEL SPACINGS AND RADIATION
+! *** WIDTHS
+ CALL Endep (Bindee(Kumurr), Pairee(Kumurr), Alevel(Kumurr), &
+ Energy, Edgg, Kumurr)
+!
+!
+! *** Note that Density_1 & Density_2 are level densities at
+! *** different energies
+ Density_1 = Get_Density (Bindee(Kumurr), &
+ Pairee(Kumurr), Alevel(Kumurr))
+ Density_2 = Get_Density (Bindee(Kumurr)+Energy, &
+ Pairee(Kumurr), Alevel(Kumurr))
Density_Ratio = Density_1/Density_2
-C
-C *** LOOP OF RESONANCE SPINS for entrance channels:
+!
+! *** LOOP OF RESONANCE SPINS for entrance channels:
Kumjjv = 0
Fj1b = Zero
Fj2b = Zero
DO J2=J2mn,J2mx,2
Kumjjv = Kumjjv + 1
IF (Kumjjv.LE.Numjjv) THEN
-C
- Fj = Fjrat (Fj1a, Fj1b, Fj2a, Fj2b, Energy, J2,
- * Bindee, Pairee, Alevel, Kumurr)
+!
+ Fj = Fjrat (Fj1a, Fj1b, Fj2a, Fj2b, Energy, J2, &
+ Bindee, Pairee, Alevel, Kumurr)
Edd = Fj * Density_Ratio
Bedd = Bethdj(Kumjjv,Kumurr)*Edd
Edgd = Edgg/Bedd
Tedd = Twopi/Bedd
-C
-C *** LOOP OF RESONANCE PARITIES, for entrance channels:
+!
+! *** LOOP OF RESONANCE PARITIES, for entrance channels:
DO Kparit=1,2
IF (Kparit.LE.Numelv) THEN
Pm = '-'
IF (Kparit.EQ.2) Pm = '+'
-C
-C *** capture : First of four outgoing channel types
+!
+! *** capture : First of four outgoing channel types
Tg = Twopi*Gg(Kparit,Kumurr)*Edgd
-C
-C *** elastic : Second outgoing channel type is elastic
- CALL Zelast (Streng(1,Kumurr), Distnt(1,Kumurr),
- * Aelast, Melast, Energy, Rho, Kparit, J2,
- * Jelast)
-C
+!
+! *** elastic : Second outgoing channel type is elastic
+ CALL Zelast (Streng(1,Kumurr), Distnt(1,Kumurr), &
+ Aelast, Melast, Energy, Rho, Kparit, J2, Jelast)
+!
IF (Jelast.NE.0) THEN
-C # IF (there are elastic channels with these quantum
-C # numbers J_pi) THEN calculation can proceed
-C
-C *** Inelastic : Third outgoing channel type
- IF (Numexc.GT.1) CALL Zinela (
- * Streng(1,Kumurr), Distnt(1,Kumurr),
- * Ex, Spin, Pty, Ainela, Minela,
- * Energy, J2, Kparit, Inelas)
-C
-C *** Fission : Fourth outgoing channel type
- CALL Zfissi (Gf(1,Kumjjv,Kumurr),
- * Fnu (1,Kumjjv), Ethr(1,Kumjjv,Kumurr),
- * Wthr (1,Kumjjv,Kumurr), Jnl, Jxl,
- * Iflgff(1,Kumjjv,Kumurr), Energy, Tedd,
- * Kparit, Kumjjv, Jdf, Jdfx,
- * Dof_Fis, Trc_Fis)
-C
-C *** Calculate effective DOF (Moldauer 1980)
- CALL Eff_Dof (Aelast, Ainela, Dof_Fis,
- * Trc_Fis, Bbb_Fis, Tg, Jelast, Inelas)
-C
- CALL Wav (Ktype, Aelast, Ainela, Melast,
- * Minela, Dof_Fis, Bbb_Fis, Der_Fis,
- * Wff, Qsum, Jdfx, Jelast, Inelas)
-C *** Wav calculates Qsum and derivs
+! # IF (there are elastic channels with these quantum
+! # numbers J_pi) THEN calculation can proceed
+!
+! *** Inelastic : Third outgoing channel type
+ IF (Numexc.GT.1) CALL Zinela ( &
+ Streng(1,Kumurr), Distnt(1,Kumurr), &
+ Ex, Spin, Pty, Ainela, Minela, &
+ Energy, J2, Kparit, Inelas)
+!
+! *** Fission : Fourth outgoing channel type
+ CALL Zfissi (Gf(1,Kumjjv,Kumurr), &
+ Fnu (1,Kumjjv), Ethr(1,Kumjjv,Kumurr), &
+ Wthr (1,Kumjjv,Kumurr), Jnl, Jxl, &
+ Iflgff(1,Kumjjv,Kumurr), Energy, Tedd, &
+ Kparit, Kumjjv, Jdf, Jdfx, &
+ Dof_Fis, Trc_Fis)
+!
+! *** Calculate effective DOF (Moldauer 1980)
+ CALL Eff_Dof (Aelast, Ainela, Dof_Fis, &
+ Trc_Fis, Bbb_Fis, Tg, Jelast, Inelas)
+!
+ CALL Wav (Ktype, Aelast, Ainela, Melast, &
+ Minela, Dof_Fis, Bbb_Fis, Der_Fis, &
+ Wff, Qsum, Jdfx, Jelast, Inelas)
+! *** Wav calculates Qsum and derivs
IF (Iwff.EQ.1) THEN
WRITE (21,10200) Ienerg, Energy, J2,Pm,Wff
-10200 FORMAT (' Ie=', I6, ' E=', 1PG14.6,
- * ' J=', I2, '/2', A1, ' Wff=', G14.6)
+10200 FORMAT (' Ie=', I6, ' E=', 1PG14.6, &
+ ' J=', I2, '/2', A1, ' Wff=', G14.6)
END IF
-C
-C *** PARTIAL CROSS SECTION:
+!
+! *** PARTIAL CROSS SECTION:
Sclj = Ce*Gg(Kparit,Kumurr)*Edgd*Gj(Kumjjv)
Scljq = Sclj*Qsum
Theory(Ienerg) = Theory(Ienerg) + Scljq
DO Kelast=1,Jelast
L = Melast(2,Kelast)
- Theorl(L,Ienerg) = Theorl(L,Ienerg) +
- * Sclj*Aelast(7,Kelast)
+ Theorl(L,Ienerg) = Theorl(L,Ienerg) + &
+ Sclj*Aelast(7,Kelast)
END DO
-C
+!
IF (Ktype.EQ.2 .AND. Inelas.GT.0) THEN
DO 70 Knelas=1,Inelas
Kumexc = Minela(2,Knelas)
@@ -166,121 +168,117 @@ C
IF (Kumexc.EQ.Lvl) GO TO 70
END DO
END IF
- Siz(Ienerg,Kumexc) = Siz(Ienerg,Kumexc)
- * + Sclj*Ainela(7,Kumexc)
+ Siz(Ienerg,Kumexc) = Siz(Ienerg,Kumexc) &
+ + Sclj*Ainela(7,Kumexc)
70 CONTINUE
END IF
-C
-C *** Derivatives Calculation
+!
+! *** Derivatives Calculation
IF (Ksolve.NE.2) THEN
- CALL Deriva (Gf(1,Kumjjv,Kumurr),
- * Iflstr(1,Kumurr), Ifldst(1,Kumurr),
- * Iflggg(1,Kumurr),
- * Iflgff(1,Kumjjv,Kumurr), Jnl, Jxl,
- * Dth, Aelast, Ainela, Melast, Minela,
- * Der_Fis, Sclj, Qsum, Kparit, Kumjjv,
- * Jelast, Inelas, Jdf)
+ CALL Deriva (Gf(1,Kumjjv,Kumurr), &
+ Iflstr(1,Kumurr), Ifldst(1,Kumurr), &
+ Iflggg(1,Kumurr), &
+ Iflgff(1,Kumjjv,Kumurr), Jnl, Jxl, &
+ Dth, Aelast, Ainela, Melast, Minela, &
+ Der_Fis, Sclj, Qsum, Kparit, Kumjjv, &
+ Jelast, Inelas, Jdf)
END IF
-C *** DERIVATIVES COMPLETE.
-C
-C
-C # END IF (Jelast.NE.0)
+! *** DERIVATIVES COMPLETE.
+!
+!
+! # END IF (Jelast.NE.0)
END IF
-C # END IF (Kparit.LE.Numelv)
+! # END IF (Kparit.LE.Numelv)
END IF
-C # END DO Kparit=1,2
+! # END DO Kparit=1,2
END DO
-C *** RESONANCE PARITIY LOOP COMPLETE.
-C
-C # END IF (Kumjjv.LE.Numjjv)
+! *** RESONANCE PARITIY LOOP COMPLETE.
+!
+! # END IF (Kumjjv.LE.Numjjv)
END IF
-C
-C # END DO J2=J2mn,J2mx,2
+!
+! # END DO J2=J2mn,J2mx,2
END DO
-C *** RESONANCE SPIN LOOP COMPLETE
-C
-C
-C *** Add direct inelastic component if needed
+! *** RESONANCE SPIN LOOP COMPLETE
+!
+!
+! *** Add direct inelastic component if needed
IF (Ktype.EQ.2 .AND. Ndirin.GT.1) THEN
DO Nd=1,Ndirin
IF (Energy.LT.Edirin(Nd)) THEN
IF (Nd.EQ.1) THEN
A = Energy/Edirin(1) * Sdirin(1)
ELSE
- A = (Edirin(Nd)-Energy) /
- * (Edirin(Nd)-Edirin(Nd-1))
- B = (Energy-Edirin(Nd-1)) /
- * (Edirin(Nd)-Edirin(Nd-1))
+ A = (Edirin(Nd)-Energy) / (Edirin(Nd)-Edirin(Nd-1))
+ B = (Energy-Edirin(Nd-1)) / (Edirin(Nd)-Edirin(Nd-1))
A = A*Sdirin(Nd-1) + B*Sdirin(Nd)
END IF
GO TO 10
-C # END IF (Energy.LT.Edirin(Nd))
+! # END IF (Energy.LT.Edirin(Nd))
END IF
-C # END DO Nd=1,Ndirin
+! # END DO Nd=1,Ndirin
END DO
A = Sdirin(Ndirin)
10 CONTINUE
Theory(Ienerg) = Theory(Ienerg) + A
-C # END IF (Type.EQ.Inel .AND. Ndirin.GT.1)
+! # END IF (Type.EQ.Inel .AND. Ndirin.GT.1)
END IF
-C
-C *** Add direct capture component if needed
+!
+! *** Add direct capture component if needed
IF (Ktype.EQ.4 .AND. Ndircp.GT.1) THEN
DO Nd=1,Ndircp
IF (Energy.LT.Edircp(Nd)) THEN
IF (Nd.EQ.1) THEN
A = Energy/Edircp(1) * Sdircp(1)
ELSE
- A = (Edircp(Nd)-Energy) /
- * (Edircp(Nd)-Edircp(Nd-1))
- B = (Energy-Edircp(Nd-1)) /
- * (Edircp(Nd)-Edircp(Nd-1))
+ A = (Edircp(Nd)-Energy) / (Edircp(Nd)-Edircp(Nd-1))
+ B = (Energy-Edircp(Nd-1)) / (Edircp(Nd)-Edircp(Nd-1))
A = A*Sdircp(Nd-1) + B*Sdircp(Nd)
END IF
GO TO 20
-C # END IF (Energy.LT.Edircp(Nd))
+! # END IF (Energy.LT.Edircp(Nd))
END IF
-C # END DO Nd=1,Ndircp
+! # END DO Nd=1,Ndircp
END DO
A = Sdircp(Ndircp)
20 CONTINUE
Theory(Ienerg) = Theory(Ienerg) + A
-C # END IF (Type.EQ.Capt .AND. Ndircp.GT.1)
+! # END IF (Type.EQ.Capt .AND. Ndircp.GT.1)
END IF
-C
+!
IF (Ksolve.NE.2) THEN
DO Ipar=1,Nvpall
Dtheor(Ipar,Ienerg) = Dth(Ipar) + Dtheor(Ipar,Ienerg)
END DO
END IF
-C
-C # END IF (Type.NE.Inel .OR. Energy.GT.Ex(2)) THEN
+!
+! # END IF (Type.NE.Inel .OR. Energy.GT.Ex(2)) THEN
END IF
-C
-C # END DO Ienerg=1,Khmax
+!
+! # END DO Ienerg=1,Khmax
END DO
-C *** ENERGY LOOP COMPLETE
-C
+! *** ENERGY LOOP COMPLETE
+!
RETURN
END
-C
-C
-C ______________________________________________________________________
-C
- DOUBLE PRECISION FUNCTION Fjrat (Fj1a, Fj1b, Fj2a, Fj2b,
- * Energy, J2, Bindee, Pairee, Alevel, Kumurr)
-C *** Energy- and J-dependence of level density parameter
+!
+!
+! ______________________________________________________________________
+!
+ DOUBLE PRECISION FUNCTION Fjrat (Fj1a, Fj1b, Fj2a, Fj2b, &
+ Energy, J2, Bindee, Pairee, Alevel, Kumurr)
+! *** Energy- and J-dependence of level density parameter
use fixedr_m
use z00001_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Bindee(*), Pairee(*), Alevel(*)
DATA Zero /0.0d0/, Half /0.5d0/, One /1.0d0/
-C *** Note that, if already have Fjxb it's from earlier calculation with
-C *** (J2-1) at same energy
-C
+! *** Note that, if already have Fjxb it's from earlier calculation with
+! *** (J2-1) at same energy
+!
Bp = Bindee(Kumurr) - Pairee(Kumurr)
Qj = Half*dFLOAT(J2)
-C
+!
Varj2 = Const(1)*dSQRT(Bp*Alevel(Kumurr))
IF (Fj1b.EQ.Zero) THEN
Fj1a = dEXP(-Qj**2/Varj2)
@@ -288,7 +286,7 @@ C
Fj1a = Fj1b
END IF
Fj1b = dEXP(-(Qj+One)**2/Varj2)
-C
+!
Varj2 = Const(1)*dSQRT((Bp+Energy)*Alevel(Kumurr))
IF (Fj2b.EQ.Zero) THEN
Fj2a = dEXP(-Qj**2/Varj2)
@@ -296,87 +294,86 @@ C
Fj2a = Fj2b
END IF
Fj2b = dEXP(-(Qj+One)**2/Varj2)
-C
+!
Fjrat = (Fj1a-Fj1b)/(Fj2a-Fj2b)
-C
-C *** NOTE that Fjrat is the ratio of {e-e at E=0} to {e-e at E=Energy},
-C *** i.e., of Eq. (VJ1.8) with {E=0}/{E=Energy}
-C *** with Varj2 from Eq. (VJ1.9)
+!
+! *** NOTE that Fjrat is the ratio of {e-e at E=0} to {e-e at E=Energy},
+! *** i.e., of Eq. (VJ1.8) with {E=0}/{E=Energy}
+! *** with Varj2 from Eq. (VJ1.9)
RETURN
END
-C
-C
-C ______________________________________________________________________
-C
- SUBROUTINE Wav (Ktype, Aelast, Ainela, Melast, Minela,
- * Dof_Fis, Bbb_Fis, Der_Fis, Wff, Qsum, Jdfx, Jelast, Inelas)
-C
-C Wav COMPUTES THE WIDTH FLUCTUATION AVERAGE AND ITS DERIVATIVES
-C
+!
+!
+! ______________________________________________________________________
+!
+ SUBROUTINE Wav (Ktype, Aelast, Ainela, Melast, Minela, &
+ Dof_Fis, Bbb_Fis, Der_Fis, Wff, Qsum, Jdfx, Jelast, Inelas)
+!
+! Wav COMPUTES THE WIDTH FLUCTUATION AVERAGE AND ITS DERIVATIVES
+!
use ifwrit_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
CHARACTER*4 Type(5)
DIMENSION Aelast(7,*), Ainela(7,*)
DIMENSION Melast(2,*), Minela(2,*)
-C *** 1 ==> Dof = degree of freedom
-C *** 2 ==> Bbb = Trc*Dof/(2 Tg)
-C *** 3 ==> Trc = transmission coefficient (per dof)
-C *** 4 ==> Tsn
-C *** 5 ==> Tdn
-C *** 6 ==> Der = Derivative wrt Bbb_Typ
-C *** 7 ==> Qn
+! *** 1 ==> Dof = degree of freedom
+! *** 2 ==> Bbb = Trc*Dof/(2 Tg)
+! *** 3 ==> Trc = transmission coefficient (per dof)
+! *** 4 ==> Tsn
+! *** 5 ==> Tdn
+! *** 6 ==> Der = Derivative wrt Bbb_Typ
+! *** 7 ==> Qn
DATA Type /'TOTA', 'INEL', 'FISS', 'CAPT', 'ELAS'/
DATA Zero /0.0d0/, Two /2.0d0/
-C
+!
Qsum = Zero
Der_Fis = Zero
IF (Ktype.EQ.2 .AND. Inelas .EQ.0 ) RETURN
IF (Ktype.EQ.3 .AND. Bbb_Fis.EQ.Zero) RETURN
-C
-C *** BEGIN CALCULATION OF WIDTH RATIO AVERAGE Qsum
+!
+! *** BEGIN CALCULATION OF WIDTH RATIO AVERAGE Qsum
AnfO = Dof_Fis
IF (Ktype.EQ.3) Dof_Fis = Dof_Fis + Two
-C
+!
DO N=1,Jelast
Annn = Aelast(1,N)
Aelast(1,N) = Aelast(1,N) + Two
Knelas = 1
IF (Ktype.EQ.2) Knelas = Inelas
-C
+!
DO I=1,Knelas
Anii = Ainela(1,I)
IF (Ktype.EQ.2) Ainela(1,I) = Ainela(1,I) + Two
- CALL Dres (Aelast, Ainela, Dof_Fis, Bbb_Fis, Jelast, Inelas,
- * Dint)
+ CALL Dres (Aelast, Ainela, Dof_Fis, Bbb_Fis, Jelast, Inelas, Dint)
IF (I.EQ.1) Wff = Dint
IF (Dint.LT.Zero) GO TO 999
Term = Dint*Aelast(2,N)*Annn/Two
IF (Ktype.EQ.2) Term = Term*Ainela(2,I)*Anii/Two
IF (Ktype.EQ.3) Term = Term*Bbb_Fis *AnfO/Two
-C
-C *** WIDTH AVERAGE (Q) AND ITS COMPONENTS WITH RESPECT TO PARTIAL
-C *** WAVES (Qelast(7,N)) AND TO RESIDUAL-NUCLEUS LEVELS (Ainela(7,IZ))
+!
+! *** WIDTH AVERAGE (Q) AND ITS COMPONENTS WITH RESPECT TO PARTIAL
+! *** WAVES (Qelast(7,N)) AND TO RESIDUAL-NUCLEUS LEVELS (Ainela(7,IZ))
Qsum = Qsum + Term
Aelast(7,N) = Aelast(7,N) + Term
IF (Ktype.EQ.2) THEN
Iz = Minela(2,I)
Ainela(7,Iz) = Ainela(7,Iz) + Term
END IF
-C
+!
IF (Ksolve.NE.2) THEN
-C *** elastic -- DERIVATIVES WITH RESPECT TO Bn(M) = Aelast(2,M)
+! *** elastic -- DERIVATIVES WITH RESPECT TO Bn(M) = Aelast(2,M)
IF (Jelast.GT.0) THEN
DO M=1,Jelast
IF (Melast(1,M).NE.0) THEN
Aelast(1,M) = Aelast(1,M) + Two
- CALL Dres (Aelast, Ainela, Dof_Fis, Bbb_Fis,
- * Jelast, Inelas, Dintm)
+ CALL Dres (Aelast, Ainela, Dof_Fis, Bbb_Fis, &
+ Jelast, Inelas, Dintm)
Aelast(1,M) = Aelast(1,M) - Two
Ddint = (Dintm-Dint)*Aelast(1,M)/Aelast(2,M)/Two
-C *** NOTE: Ddint is partial(Dint) wrt (Aelast(2,M))
+! *** NOTE: Ddint is partial(Dint) wrt (Aelast(2,M))
IF (N.EQ.M) Ddint = Ddint + Dint/Aelast(2,M)
-C *** NOTE: extra part here (Dint/Aelast(2,M)) is from
-C *** partial(Term)wrt(Aelast(2,N)), except for Dint part
+! *** NOTE: extra part here (Dint/Aelast(2,M)) is from
+! *** partial(Term)wrt(Aelast(2,N)), except for Dint part
Term = Ddint*Aelast(2,N)*Annn/Two
IF (Ktype.EQ.2) Term = Term*Ainela(2,I)*Anii/Two
IF (Ktype.EQ.3) Term = Term*Bbb_Fis *AnfO/Two
@@ -384,18 +381,18 @@ C *** partial(Term)wrt(Aelast(2,N)), except for Dint part
END IF
END DO
END IF
-C
-C *** inelastic -- DERIVATIVES WITH RESPECT TO Bi(J) = Ainela(2,J)
+!
+! *** inelastic -- DERIVATIVES WITH RESPECT TO Bi(J) = Ainela(2,J)
IF (Inelas.GT.0) THEN
DO J=1,Inelas
IF (Minela(1,J).NE.0) THEN
Ainela(1,J) = Ainela(1,J) + Two
- CALL Dres (Aelast, Ainela, Dof_Fis, Bbb_Fis,
- * Jelast, Inelas, Dintj)
+ CALL Dres (Aelast, Ainela, Dof_Fis, Bbb_Fis, &
+ Jelast, Inelas, Dintj)
Ainela(1,J) = Ainela(1,J) - Two
Ddint = (DintJ-Dint)*Ainela(1,J)/Ainela(2,J)/Two
- IF (I.EQ.J .AND. Ktype.EQ.2) Ddint = Ddint +
- * Dint/Ainela(2,J)
+ IF (I.EQ.J .AND. Ktype.EQ.2) Ddint = Ddint + &
+ Dint/Ainela(2,J)
Term = Ddint*Aelast(2,N)*Annn/Two
IF (Ktype.EQ.2) Term = Term*Ainela(2,I)*Anii/Two
IF (Ktype.EQ.3) Term = Term*Bbb_Fis *AnfO/Two
@@ -403,15 +400,15 @@ C *** inelastic -- DERIVATIVES WITH RESPECT TO Bi(J) = Ainela(2,J)
END IF
END DO
END IF
-C
+!
Term = Zero
-C *** Fission -- DERIVATIVE WITH RESPECT TO Bf... note that this
-C *** is needed for things other than deriv wrt Gf directly,
-C *** so do not use (Jdf.EQ.0) in following statement
+! *** Fission -- DERIVATIVE WITH RESPECT TO Bf... note that this
+! *** is needed for things other than deriv wrt Gf directly,
+! *** so do not use (Jdf.EQ.0) in following statement
IF (Jdfx.NE.0 .AND. Bbb_Fis.NE.Zero) THEN
Dof_Fis = Dof_Fis + Two
- CALL Dres (Aelast, Ainela, Dof_Fis, Bbb_Fis,
- * Jelast, Inelas, Dintf)
+ CALL Dres (Aelast, Ainela, Dof_Fis, Bbb_Fis, &
+ Jelast, Inelas, Dintf)
Dof_Fis = Dof_Fis - Two
Ddint = (Dintf-Dint)*Dof_Fis/Bbb_Fis/Two
IF (Ktype.EQ.3) Ddint = Ddint + Dint/Bbb_Fis
@@ -421,13 +418,13 @@ C *** so do not use (Jdf.EQ.0) in following statement
Der_Fis = Der_Fis + Term
END IF
END IF
-C
+!
Ainela(1,I) = Anii
END DO
Aelast(1,N) = Annn
END DO
Dof_Fis = AnfO
-C
+!
IF (Ksolve.NE.2) THEN
Der_Fis = Der_Fis*Bbb_Fis
DO N=1,Jelast
@@ -440,11 +437,11 @@ C
END IF
END IF
RETURN
-C
+!
999 CONTINUE
WRITE (6,10100) Dint, Type(Ktype), Jdfx, Jelast, Inelas
-10100 FORMAT (/, ' Dint=', 1PG14.6, ' Type=<<<', A4,
- * '>>> Jdfx, Jelast, Inelas=', 3I5)
+10100 FORMAT (/, ' Dint=', 1PG14.6, ' Type=<<<', A4, &
+ '>>> Jdfx, Jelast, Inelas=', 3I5)
WRITE (6,10200) (Aelast(1,K),K=1,Jelast)
WRITE (6,10300) (Aelast(2,K),K=1,Jelast)
WRITE (6,10400) (Ainela(1,K),K=1,Inelas)
@@ -459,3 +456,4 @@ C
10700 FORMAT ('Bf=', 1P5G14.6)
STOP '[STOP in Dint in acs/macs3.f]'
END
+end module acs3_m
diff --git a/sammy/src/dat/mdat1.f90 b/sammy/src/dat/mdat1.f90
index 0804f4468..770bea685 100644
--- a/sammy/src/dat/mdat1.f90
+++ b/sammy/src/dat/mdat1.f90
@@ -28,6 +28,8 @@ contains
use lbro_common_m
use constn_common_m
use Wdsint_m
+ use rpi2_m
+ use rpi3_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
DIMENSION Bcf(*), Cf2(*), Dopwid(*), &
diff --git a/sammy/src/fnc/fexq.f90 b/sammy/src/fnc/fexq.f90
new file mode 100644
index 000000000..dacfc2368
--- /dev/null
+++ b/sammy/src/fnc/fexq.f90
@@ -0,0 +1,32 @@
+!
+module fexq_m
+ contains
+! --------------------------------------------------------------
+!
+DOUBLE PRECISION FUNCTION Fexq (Xx, Yy, Zzz)
+! *** [ ERFC(XX-YY) - ERFC(XX) ] exp(ZZZ**2) sqrt(pi)/(2 YY)
+use aaaerf_m
+use abcerf_m
+IMPLICIT none
+EXTERNAL Qqexp ! in src/fnc/,src/orr/morr5.f
+
+real(8)::xx,yy,zzz,Aa,Aaaa,Bb,Bbb,Cc,Qqexp,Yymin
+integer(4)::N
+
+!Fexq = (erfc(xx-yy) - erfc(xx)) * exp(zzz**2) * sqrtPi/(2.0_8*yy)
+DATA Yymin/0.01d0/
+IF (Yy.LE.Yymin) THEN
+ Aaaa = Abcerf (Xx, Yy, Aa, Bb, Cc, N)
+ Fexq = Aa
+ IF (Zzz.NE.Xx) THEN
+ Fexq = Fexq * Qqexp(-(Xx+Zzz)*(Xx-Zzz))
+ END IF
+ELSE
+ Bbb = Zzz*Zzz
+ Aaaa = Aaaerf (Xx, Yy, Bbb, Aa, N)
+ Fexq = Aa
+END IF
+RETURN
+end function Fexq
+
+end module fexq_m
\ No newline at end of file
diff --git a/sammy/src/fnc/xerfcx.f90 b/sammy/src/fnc/xerfcx.f90
new file mode 100644
index 000000000..510f40311
--- /dev/null
+++ b/sammy/src/fnc/xerfcx.f90
@@ -0,0 +1,24 @@
+
+module xerfcx_m
+ contains
+
+DOUBLE PRECISION FUNCTION Xerfcx (XX)
+!
+! *** PURPOSE -- GENERATE EXP(XX**2) * ERFC(XX) * SQRT(PI) for all xx>0
+use exerfc_m
+IMPLICIT none
+
+real(8) :: xx,Xxmax
+
+Xxmax = 5.01d0
+
+IF (Xx.GT.Xxmax) THEN
+ Xerfcx = Asympt (xx)
+ELSE
+! IF (Xx.LE.Xxmax)
+ Xerfcx = Exerfc (xx)
+END IF
+RETURN
+END FUNCTION Xerfcx
+
+end module xerfcx_m
\ No newline at end of file
diff --git a/sammy/src/inp/minp01.f b/sammy/src/inp/minp01.f
index ccd4cf7d4..a0ca0b367 100644
--- a/sammy/src/inp/minp01.f
+++ b/sammy/src/inp/minp01.f
@@ -277,6 +277,7 @@ C
use broad_common_m
use EndfData_common_m
use Qiso_m
+ use par1_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Nvp(15), Nfp(15)
diff --git a/sammy/src/inp/minp02.f b/sammy/src/inp/minp02.f
index 7739bb9a7..093f68e75 100644
--- a/sammy/src/inp/minp02.f
+++ b/sammy/src/inp/minp02.f
@@ -249,6 +249,7 @@ C
use misccc_common_m
use ntyp_common_m
use partyp_common_m
+ use par10_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
DIMENSION Parbrd(Numbrd), Iflbrd(Numbrd), Delbrd(Numbrd)
diff --git a/sammy/src/inp/minp03.f b/sammy/src/inp/minp03.f
index 52849e297..6e55207a5 100644
--- a/sammy/src/inp/minp03.f
+++ b/sammy/src/inp/minp03.f
@@ -36,6 +36,13 @@ C
use EndfData_common_m
use SammyParticlePairInfo_M
use RMatResonanceParam_M
+ use par3_m
+ use par4_m
+ use par5_m
+ use par6_m
+ use par7_m
+ use par8_m
+ use par13_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
C DIMENSION Parbrd(Numbrd), Iflbrd(Numbrd),
@@ -69,6 +76,8 @@ C
type(SammyParticlePairInfo)::pairInfo
type(RMatParticlePair)::pair
integer,allocatable,dimension(:)::Ipp_Final
+
+ real(8), allocatable, dimension(:):: Siabnd
C
DATA Zero /0.0d0/
C
diff --git a/sammy/src/ort/mort.f b/sammy/src/ort/mort.f
index 17e9a5a9f..769843ce1 100644
--- a/sammy/src/ort/mort.f
+++ b/sammy/src/ort/mort.f
@@ -41,6 +41,7 @@ C
use namfil_common_m
use brdd_common_m
use EndfData_common_m
+ use par5_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
real(kind=8),allocatable,dimension(:)::A_Iprorr,A_Idlorr,A_Iecrnc,
* A_Iedets, A_Iseses, A_Iesese, A_Isgdts
diff --git a/sammy/src/par/mpar0.f b/sammy/src/par/mpar0.f90
similarity index 55%
rename from sammy/src/par/mpar0.f
rename to sammy/src/par/mpar0.f90
index 00fa5c109..267ab0048 100644
--- a/sammy/src/par/mpar0.f
+++ b/sammy/src/par/mpar0.f90
@@ -1,61 +1,92 @@
-C
-C
+!
+! Reading of the PAR file
+!
+! Notes:
+! - Affects regression tests (almost all):
+! (tr114|tr182|tr161|tr126|tr071|tr039|tr051|tr174|tr156|tr119|tr183|
+! tr054|tr085|tr131|tr066|tr171|tr166|tr135|tr160|tr082|tr186|tr069|
+! tr137|tr094|tr060|tr019|tr086|tr096|tr070|tr157|tr130|tr083|tr042|
+! tr017|tr104|tr118|tr152|tr057|tr155|tr087|tr149|tr140|tr091|tr064|
+! tr100|tr112|tr124|tr089|tr098|tr115|tr167|tr090|tr154|tr062|tr136|
+! tr125|tr052|tr175|tr146|tr078|tr076|tr026|tr049|tr040|tr095|tr113|
+! tr010|tr153|tr144|tr188|tr005|tr177|tr084|tr077|tr165|tr105|tr185|
+! tr079|tr107|tr170|tr116|tr080|tr037|tr001|tr074|tr033|tr025|tr147|
+! tr102|tr029|tr132|tr046|tr172|tr038|tr056|tr004|tr011|tr099|tr129|
+! tr048|tr044|tr016|tr103|tr123|tr068|tr169|tr117|tr173|tr108|tr159|
+! tr041|tr058|tr020|tr163|tr021|tr181|tr032|tr009|tr031|tr002|tr034|
+! tr047|tr036|tr014|tr179|tr007|tr003|tr035|tr018|tr180|tr138|tr059|
+! tr111|tr189|tr148|tr093|tr024|tr043|tr097|tr168|tr008|tr151|tr055|
+! tr006|tr022|tr122|tr121|tr013|tr081|tr045|tr028|tr101|tr012|tr015|
+! tr176|tr109|tr030|tr050|tr150|tr184|tr075|tr061|tr164|tr178|tr162|
+! tr106|tr110|tr027|tr023|tr063|tr139|tr067|tr158)
+module par_m
+ contains
+!
SUBROUTINE Sampar_0
-C
-C
+!
+!
use oops_common_m
use fixedi_m
use ifwrit_m
use exploc_common_m
use oopsch_common_m
use MultScatPars_common_m
+ use par1_m
+ use par2_m
+ use par7_m
+ use par11_m
+ use par14_m
+ use par15_m
+ use par16_m
+ use par17_m
+ use par19_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
integer,allocatable,dimension(:)::I_tmp
- real(kind=8),allocatable,dimension(:)::A_Ixtptw, A_Ixtplw,
- * A_Ixtptv, A_Ixtplv, A_Ifthet, A_Iazzz, A_Iwzzz,
- * A_Ihhh, A_Iarrr, A_Iwrrr, A_Iaphi, A_Iwphi,
- * A_Ifff5r, A_Ibb, A_If5phi, A_Isqfb,
- * A_Ixtpvl, A_Iuwzx, A_Ixtpwl, A_Idsqfb
+ real(kind=8),allocatable,dimension(:)::A_Ixtptw, A_Ixtplw, &
+ A_Ixtptv, A_Ixtplv, A_Ifthet, A_Iazzz, A_Iwzzz, &
+ A_Ihhh, A_Iarrr, A_Iwrrr, A_Iaphi, A_Iwphi, &
+ A_Ifff5r, A_Ibb, A_If5phi, A_Isqfb, &
+ A_Ixtpvl, A_Iuwzx, A_Ixtpwl, A_Idsqfb
-C
-C
+!
+!
WRITE (6,99999)
99999 FORMAT (' *** SAMMY-PAR 11 Aug 08 ***')
Segmen(1) = 'P'
Segmen(2) = 'A'
Segmen(3) = 'R'
Nowwww = 0
-C
+!
CALL Initil
-C
- Kount_Par = Nres + Numext + Numrad + Numiso + Numdet + Numbrd
- * + Nummsc + Numpmc + Numorr + Numrpi + Numudr + Numnbk
- * + Numbgf + Numdtp
+!
+ Kount_Par = Nres + Numext + Numrad + Numiso + Numdet + Numbrd &
+ + Nummsc + Numpmc + Numorr + Numrpi + Numudr + Numnbk &
+ + Numbgf + Numdtp
IF (Noffv.LT.0) Kount_Par = Kount_Par + Numusd
IF (Kount_Par.EQ.0) THEN
WRITE (6,10000)
WRITE (21,10000)
-10000 FORMAT (/,
- * ' ##########################################################',
- * /, ' No parameters are given. Check whether PAR file is empty?',
- * /, ' ##########################################################')
+10000 FORMAT (/, &
+ ' ##########################################################', &
+ /, ' No parameters are given. Check whether PAR file is empty?', &
+ /, ' ##########################################################')
STOP
END IF
-C
+!
CALL Estpar
-C *** Routine Estpar guestimates size of array needed for PAR module
-C
-C
+! *** Routine Estpar guestimates size of array needed for PAR module
+!
+!
CALL Set3a (Lmax)
-C *** Routine Set3a sets dimensions for resonance parameters
-C
+! *** Routine Set3a sets dimensions for resonance parameters
+!
Kumpup = Numpup
Numpup = 0
Nnrext = Nrext
IF (Nnrext.EQ.0) Nnrext = 1
-C
-C Lrad and (Kprior, Lprior) can overlap
-C
+!
+! Lrad and (Kprior, Lprior) can overlap
+!
jlrad_size = Lmax*Nppair*Numrad
ikprio_size = Ntotc2*Ngroup + 1
ilprio_size = Lmax + 1
@@ -63,80 +94,80 @@ C
itotsize = max(jlrad_size, ikprio_size + ilprio_size)
allocate(I_tmp(itotsize))
I_tmp(:) = 0
- CALL Parfil ( A_Iprbrd , I_Iflbrd , A_Isiabn ,
- * A_Ipreff , I_Ifleff , A_Ideeff ,
- * A_Iprtru , I_Ifltru , A_Idetru , I_Iigrra ,
- * I_Ifliso , A_Ideiso ,
- * A_Ispiso , I_Ixciso ,
- * A_Iprdet , I_Ifldet , A_Idedet , I_Iigrde ,
- * A_Iprext , I_Iflext ,
- * A_Iprmsc , I_Iflmsc , A_Idemsc , I_Irdmsc , I_Ijkmsc ,
- * A_Iznonu , A_Irnonu , A_Ianonu , A_Ibnonu , A_Ietaee ,
- * A_Iprpmc , I_Iflpmc , A_Idepmc , I_Isopmc ,
- * A_Iprorr , I_Iflorr , A_Ideorr , A_Icrnch , A_Iedets ,
- * A_Iseses , A_Iesese , A_Isgdts ,
- * A_Iprrpi , I_Iflrpi , A_Iderpi ,
- * A_Iprudr , I_Ifludr , A_Ideudr , I_Inud_T , I_Inud_E ,
- * A_Iprnbk , I_Iflnbk , A_Idenbk ,
- * A_Iprbgf , I_Iflbgf , A_Idebgf , I_Indbgf , A_Ibgfmi ,
- * A_Ibgfma , A_Itexbg , A_Iteabg ,
- * A_Iprdtp , I_Ifldtp , A_Idedtp , A_Iptild ,
- * A_Iprusd , A_Iprbag , I_Iflbag ,
- * I_Inn , I_Imm , I_Ikk , I_Ill , A_Ivv ,
- * A_Iuncs , I_Ijuncs ,
- * A_Ipriox , I_Iiprio , I_Ijprio ,
- * I_tmp, I_tmp(1:ikprio_size),
- * I_tmp(ikprio_size+1:itotsize),
- * Noffv, Nuncer, Nprior, Nnrext, Lmax)
-C *** Routine PARameter-FILe reads parameters (resonance, external,
-C *** broadening, unused, etc) from PARameter file
-C
+ CALL Parfil ( A_Iprbrd , I_Iflbrd , A_Isiabn , &
+ A_Ipreff , I_Ifleff , A_Ideeff , &
+ A_Iprtru , I_Ifltru , A_Idetru , I_Iigrra , &
+ I_Ifliso , A_Ideiso , &
+ A_Ispiso , I_Ixciso , &
+ A_Iprdet , I_Ifldet , A_Idedet , I_Iigrde , &
+ A_Iprext , I_Iflext , &
+ A_Iprmsc , I_Iflmsc , A_Idemsc , I_Irdmsc , I_Ijkmsc , &
+ A_Iznonu , A_Irnonu , A_Ianonu , A_Ibnonu , A_Ietaee , &
+ A_Iprpmc , I_Iflpmc , A_Idepmc , I_Isopmc , &
+ A_Iprorr , I_Iflorr , A_Ideorr , A_Icrnch , A_Iedets , &
+ A_Iseses , A_Iesese , A_Isgdts , &
+ A_Iprrpi , I_Iflrpi , A_Iderpi , &
+ A_Iprudr , I_Ifludr , A_Ideudr , I_Inud_T , I_Inud_E , &
+ A_Iprnbk , I_Iflnbk , A_Idenbk , &
+ A_Iprbgf , I_Iflbgf , A_Idebgf , I_Indbgf , A_Ibgfmi , &
+ A_Ibgfma , A_Itexbg , A_Iteabg , &
+ A_Iprdtp , I_Ifldtp , A_Idedtp , A_Iptild , &
+ A_Iprusd , A_Iprbag , I_Iflbag , &
+ I_Inn , I_Imm , I_Ikk , I_Ill , A_Ivv , &
+ A_Iuncs , I_Ijuncs , &
+ A_Ipriox , I_Iiprio , I_Ijprio , &
+ I_tmp, I_tmp(1:ikprio_size), &
+ I_tmp(ikprio_size+1:itotsize), &
+ Noffv, Nuncer, Nprior, Nnrext, Lmax)
+! *** Routine PARameter-FILe reads parameters (resonance, external,
+! *** broadening, unused, etc) from PARameter file
+!
deallocate(I_tmp)
IF (Kadddc.GT.0 .AND. Kdrcap.LE.0) CALL Note_Dir_Cap
-C *** Routine Note_Dir_Cap writes error message re direct capture
-C
+! *** Routine Note_Dir_Cap writes error message re direct capture
+!
IF (Ntgrlq.EQ.1) CALL Fixabn (Ngroup)
-C *** Routine Fixabn sets Abundances to 1 for all spin groups, if
-C *** integral quantities are being calculated
-C
+! *** Routine Fixabn sets Abundances to 1 for all spin groups, if
+! *** integral quantities are being calculated
+!
IF (Numrad.NE.0) CALL Radfix (A_Ibound , I_Iigrra , A_Iprtru)
-C *** Routine Radfix fixes "Bound" for the case where radii are
-C *** different for different spin groups and/or channels
-C *** Note cannot use zkte & zke here, because these are not yet set
-C
-C
+! *** Routine Radfix fixes "Bound" for the case where radii are
+! *** different for different spin groups and/or channels
+! *** Note cannot use zkte & zke here, because these are not yet set
+!
+!
Numpup = Kumpup
Nunit = 21
IF (Kdecpl.NE.0) CALL Outddc (Nunit)
CALL Order (A_Iprmsc , I_Irdmsc , A_Iddcov)
-C *** Sub routine Order reorders resonances according to J-Pi groups
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
-C
+! *** Sub routine Order reorders resonances according to J-Pi groups
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
+!
IF (Kpolar.EQ.1.AND. Nres.NE.0) CALL Fixpol (I_Iflpol )
- CALL Fix (I_Iflbrd , I_Ifleff , I_Ifltru , I_Ifliso ,
- * I_Ifldet , I_Iflext , I_Iflmsc ,
- * I_Irdmsc , I_Iflpmc , I_Iflorr , I_Iflrpi , I_Iflnbk ,
- * I_Iflbgf , I_Ifldtp , I_Iflusd , Nnrext)
-C *** Routine Fix sets Flag = (Parameter Number)
-C
+ CALL Fix (I_Iflbrd , I_Ifleff , I_Ifltru , I_Ifliso , &
+ I_Ifldet , I_Iflext , I_Iflmsc , &
+ I_Irdmsc , I_Iflpmc , I_Iflorr , I_Iflrpi , I_Iflnbk , &
+ I_Iflbgf , I_Ifldtp , I_Iflusd , Nnrext)
+! *** Routine Fix sets Flag = (Parameter Number)
+!
IF (Kpolar.EQ.1.AND. Nres.NE.0) CALL Flgpol (I_Iflpol )
-C
+!
IF (Kdecpl.NE.0.AND. Nres.NE.0) CALL Dddcov (A_Iddcov, A_Idcov )
-C *** Routine Dddcov puts background covariance in terms of Nvpres instead
-C *** of Nres
-C
+! *** Routine Dddcov puts background covariance in terms of Nvpres instead
+! *** of Nres
+!
IF (Nudwhi.NE.0) THEN
CALL Read_User (I_Inud_E , I_Inud_T , A_Iude , A_Iudr ,A_Iudt )
-C *** Routine Read_User reads the User-Defined Resolution Function
+! *** Routine Read_User reads the User-Defined Resolution Function
END IF
-C
+!
IF (Montec.EQ.1) THEN
CALL Monte_Carlo_Preparation ()
END IF
-C
-cxxxxxxxxxxxxxxxxxxxxxxx
-C
-C IF (Kssmsc.EQ.1) need to generate QQQ for single-scattering correction
+!
+!xxxxxxxxxxxxxxxxxxxxxxx
+!
+! IF (Kssmsc.EQ.1) need to generate QQQ for single-scattering correction
IF (Kssmsc.EQ.1 .AND. Krefit.NE.1) THEN
allocate(A_Ixtptw(multScat%getNumInterpSigmaPrime()))
A_Ixtptw = 0.0d0
@@ -159,8 +190,8 @@ C IF (Kssmsc.EQ.1) need to generate QQQ for single-scattering correction
if(Kvers7.EQ.0) then
if( Nonu.eq.0) then
allocate(A_Iazzz(Nzzzz*multScat%getNumTheta()))
- allocate(A_Ihhh(multScat%getNumInterpSigmaPrime()*Nzzzz*
- * multScat%getNumTheta()))
+ allocate(A_Ihhh(multScat%getNumInterpSigmaPrime()*Nzzzz* &
+ multScat%getNumTheta()))
else
allocate(A_Iazzz(Nzzzz))
allocate(A_Ihhh(1))
@@ -188,45 +219,45 @@ C IF (Kssmsc.EQ.1) need to generate QQQ for single-scattering correction
A_Ibb = 0.0d0
allocate(A_If5phi(multScat%getNumInterpSigmaPrime()))
A_If5phi = 0.0d0
- nsize = max(Nsqfb*multScat%getNumInterpSigmaPrime()
- * *multScat%getNumInterpSigma() *multScat%getNumTheta(),
- * 2*multScat%getNumInterpSigma() *
- * multScat%getNumInterpSigmaPrime()*multScat%getNumTheta())
+ nsize = max(Nsqfb*multScat%getNumInterpSigmaPrime() &
+ *multScat%getNumInterpSigma() *multScat%getNumTheta(), &
+ 2*multScat%getNumInterpSigma() * &
+ multScat%getNumInterpSigmaPrime()*multScat%getNumTheta())
allocate(A_Isqfb(nsize))
A_Isqfb = 0.0d0
IF (Kvers7.EQ.0) THEN
- CALL Begin_Qqq (A_Ixtptw , A_Ixtplw , A_Ixtptv, A_Ixtplv,
- * A_Ifthet)
+ CALL Begin_Qqq (A_Ixtptw , A_Ixtplw , A_Ixtptv, A_Ixtplv, &
+ A_Ifthet)
IF (Nonu.EQ.0) THEN
- CALL Hhhset (A_Ixtptw , A_Ixtplw, A_Ifthet, A_Iazzz,
- * A_Iwzzz , A_Ihhh , A_Iarrr, A_Iwrrr ,
- * A_Iaphi , A_Iwphi , A_Ifff5r, A_Ibb ,A_If5phi)
- CALL Qqqset (A_Ixtptv , A_Ifthet, A_Iazzz ,A_Ihhh,
- * A_Isqfb)
+ CALL Hhhset (A_Ixtptw , A_Ixtplw, A_Ifthet, A_Iazzz, &
+ A_Iwzzz , A_Ihhh , A_Iarrr, A_Iwrrr , &
+ A_Iaphi , A_Iwphi , A_Ifff5r, A_Ibb ,A_If5phi)
+ CALL Qqqset (A_Ixtptv , A_Ifthet, A_Iazzz ,A_Ihhh, &
+ A_Isqfb)
ELSE
- CALL Q_Cyl_Set ( A_Ixtptv , A_Ixtptw , A_Ifthet ,
- * A_Isqfb, A_Iarrr , A_Iwrrr , A_Iazzz , A_Iwzzz ,
- * A_Iaphi, A_Iwphi , A_If5phi , A_Iznonu , A_Irnonu ,
- * A_Ianonu , A_Ibnonu )
+ CALL Q_Cyl_Set ( A_Ixtptv , A_Ixtptw , A_Ifthet , &
+ A_Isqfb, A_Iarrr , A_Iwrrr , A_Iazzz , A_Iwzzz , &
+ A_Iaphi, A_Iwphi , A_If5phi , A_Iznonu , A_Irnonu , &
+ A_Ianonu , A_Ibnonu )
END IF
CALL Finish_Qqq (A_Ixtplw, A_Ixtplv, A_Ifthet, A_Isqfb)
ELSE IF (Kvers7.EQ.1) THEN
allocate(A_Ixtpvl(multScat%getNumInterpSigma() ))
A_Ixtpvl(:) = 0.0d0
- allocate(A_Iuwzx(multScat%getNumInterpSigma() *Nzzz*
- * multScat%getNumTheta()))
+ allocate(A_Iuwzx(multScat%getNumInterpSigma() *Nzzz* &
+ multScat%getNumTheta()))
A_Iuwzx(:) = 0.0d0
allocate(A_Ixtpwl(multScat%getNumInterpSigmaPrime()))
A_Ixtpwl(:) = 0.0d0
- allocate(A_Idsqfb(2*multScat%getNumInterpSigma() *
- * multScat%getNumInterpSigmaPrime()*multScat%getNumTheta()))
+ allocate(A_Idsqfb(2*multScat%getNumInterpSigma() * &
+ multScat%getNumInterpSigmaPrime()*multScat%getNumTheta()))
A_Idsqfb(:) = 0.0d0
- CALL Hhhset_7 (A_Ixtptv , A_Ixtpvl, A_Ifthet, A_Iazzz,
- * A_Iwzzz , A_Iuwzx , A_Iarrr , A_Iwrrr, A_Iaphi,
- * A_Iwphi , A_Ifff5r, A_Ibb, A_If5phi)
- CALL Qqqwrt_7 (A_Ixtpvl, A_Ixtptw, A_Ixtpwl,
- * A_Ifthet, A_Iazzz, A_Iuwzx, A_Isqfb, A_Idsqfb)
+ CALL Hhhset_7 (A_Ixtptv , A_Ixtpvl, A_Ifthet, A_Iazzz, &
+ A_Iwzzz , A_Iuwzx , A_Iarrr , A_Iwrrr, A_Iaphi, &
+ A_Iwphi , A_Ifff5r, A_Ibb, A_If5phi)
+ CALL Qqqwrt_7 (A_Ixtpvl, A_Ixtptw, A_Ixtpwl, &
+ A_Ifthet, A_Iazzz, A_Iuwzx, A_Isqfb, A_Idsqfb)
deallocate(A_Ixtpvl)
deallocate(A_Iuwzx)
deallocate(A_Ixtpwl)
@@ -248,10 +279,10 @@ C IF (Kssmsc.EQ.1) need to generate QQQ for single-scattering correction
deallocate(A_Ibb)
deallocate(A_Isqfb)
END IF
-C IF (Kssmsc.GT.10) QQQ file already exists so didn't need to generate
+! IF (Kssmsc.GT.10) QQQ file already exists so didn't need to generate
IF (Kssmsc.GT.10) Kssmsc = Kssmsc - 10
-C
-cxxxxxxxxxxxxxxxxxxxxxxx
+!
+!xxxxxxxxxxxxxxxxxxxxxxx
Kenbbb = 0
IF (Kkkdop.NE.2 .AND. Kkkdop.NE.3 .AND. Ksitmp.GT.0) Kkkdop = 2
CALL Write_Commons_Few
@@ -264,83 +295,83 @@ cxxxxxxxxxxxxxxxxxxxxxxx
END IF
RETURN
END
-C
-C
-C ______________________________________________________________
-C
+!
+!
+! ______________________________________________________________
+!
SUBROUTINE Estpar
-C
-C *** Purpose -- guesstimate the array sizes for SAMPAR
-C
+!
+! *** Purpose -- guesstimate the array sizes for SAMPAR
+!
use fixedi_m
use ifwrit_m
use exploc_common_m
use fixedr_m
use broad_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
Mres = Nres
IF (Nres.EQ.0) Mres = 1
-C
-C *** six
+!
+! *** six
M = Numnbk
IF (M.EQ.0) M = 1
N = (M+1)/2
K = M*2 + N
-C
-C *** seven
+!
+! *** seven
M = Numbgf
IF (M.EQ.0) M = 1
N = (M+1)/2
K = K + M*5 + N
-C
-C *** eight
+!
+! *** eight
M = Numdtp
IF (M.EQ.0) M = 1
N = (M+1)/2
K = K + M*4 + N
-C
-C *** nine
+!
+! *** nine
M = Numusd
IF (M.EQ.0) M = 1
N = (M+1)/2
K = K + M*2 + N
-C
-C *** ten
+!
+! *** ten
M = Numbag
IF (M.EQ.0) M = 1
N = (M+1)/2
K = K + M + N
-C
-C *** not used in PAR
+!
+! *** not used in PAR
N8 = Ntotc*Ngroup
N = (Ngroup+1)/2
K = K + 4*N8 + N
N = (N8+1)/2
K = K + 2*N
-C
-C *** eleven
+!
+! *** eleven
M = Nres
IF (Kdecpl.EQ.0 .AND. Kenunc.EQ.0) M = 1
K = K + M
-C
-C *** twelve
+!
+! *** twelve
M = Nvpres
IF (Kdecpl.EQ.0) M = 1
K = K + M
-C
-C *** thirteen .... for U(IPAR)
+!
+! *** thirteen .... for U(IPAR)
M = Nvpall
IF (M.EQ.0) M = 1
K = K + M
-C
-C *** fourteen
+!
+! *** fourteen
M = Noffv
IF (M.LE.0) M = 1
N = (M+1)/2
K = K + M + 4*N
-C
-C *** fifteen
+!
+! *** fifteen
M = Nuncer*(Ntotc2+1)
IF (M.EQ.0) M = 1
K = K + M
@@ -348,8 +379,8 @@ C *** fifteen
IF (M.EQ.0) M = 1
M = (M+1)/2
K = K + M
-C
-C *** sixteen
+!
+! *** sixteen
IF (Nprior.GT.0) THEN
N = Nprior
K = K + N
@@ -360,8 +391,8 @@ C *** sixteen
K = K + Nover2
ELSE
END IF
-C
-C *** seventeen
+!
+! *** seventeen
IF (Nres.EQ.0) THEN
K = K + 1
ELSE
@@ -372,17 +403,17 @@ C *** seventeen
N = (M+1)/2
K = K + M + 2*N
END IF
-C
-C
+!
+!
K = Idimen (K, 1, 'estimate PAR K, 1')
K = Idimen (K,-1, 'backup PAR K, -1')
K = Idimen (0, 0, 'write for PAR 0, 0')
RETURN
END
-C
-C
-C ______________________________________________________________
-C
+!
+!
+! ______________________________________________________________
+!
SUBROUTINE Fixabn (Ngroup)
use EndfData_common_m
use SammySpinGroupInfo_M
@@ -394,31 +425,31 @@ C
END DO
RETURN
END
-C
-C
-C ----------------------------------------------------------------
-C
+!
+!
+! ----------------------------------------------------------------
+!
SUBROUTINE Note_Dir_Cap
IMPLICIT DOUBLE PRECISION (a-h,o-z)
WRITE (6,10100)
WRITE (21,10100)
-10100 FORMAT ('#######################################################',
- * /, 'INPut file specifies "ADD DIRECT CAPTURE COMPONENT" but',
- * /, 'PARameter file does not contain MSCellaneous parameter',
- * /, '"DRCAP" (coefficient of direct capture component, see',
- * /, 'Card Set 11 Line 11 Table VIB.1 of the SAMMY manual.)',
- * /, '#######################################################')
+10100 FORMAT ('#######################################################', &
+ /, 'INPut file specifies "ADD DIRECT CAPTURE COMPONENT" but', &
+ /, 'PARameter file does not contain MSCellaneous parameter', &
+ /, '"DRCAP" (coefficient of direct capture component, see', &
+ /, 'Card Set 11 Line 11 Table VIB.1 of the SAMMY manual.)', &
+ /, '#######################################################')
CLOSE (UNIT=21)
STOP
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Monte_Carlo_Preparation ()
-C
-C *** PURPOSE -- Prepare input file for SAMMCR Monte-Carlo simulation
-C
+!
+! *** PURPOSE -- Prepare input file for SAMMCR Monte-Carlo simulation
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -436,8 +467,8 @@ C
WRITE (12,10100)
10100 FORMAT ('This file contains input information for SAMMCR')
WRITE (12,*) Emin, Emax, Zero
- WRITE (12,*) sampleDim%getThickness(), sampleDim%getRadius(),
- * sampleDim%getHeight(), sampleDim%getBeamRadius(), Ybeam
+ WRITE (12,*) sampleDim%getThickness(), sampleDim%getRadius(), &
+ sampleDim%getHeight(), sampleDim%getBeamRadius(), Ybeam
WRITE (12,*) Thick, Aaawww
WRITE (12,10500)
10500 FORMAT ('1000 Number of histories')
@@ -459,11 +490,11 @@ C
END IF
IF (Numiso.GT.0) THEN
WRITE (12,11200) (resParData%getMassForIsotope(I),I=1,Numiso)
- WRITE (12,11300)
- * (resParData%getAbundanceByIsotope(I),I=1,Numiso)
+ WRITE (12,11300) (resParData%getAbundanceByIsotope(I),I=1,Numiso)
11200 FORMAT (8F10.6)
11300 FORMAT (8F10.7)
END IF
CLOSE (UNIT=12)
RETURN
END
+end module par_m
diff --git a/sammy/src/par/mpar01.f b/sammy/src/par/mpar01.f90
similarity index 69%
rename from sammy/src/par/mpar01.f
rename to sammy/src/par/mpar01.f90
index 8b86222eb..3210b195f 100644
--- a/sammy/src/par/mpar01.f
+++ b/sammy/src/par/mpar01.f90
@@ -1,7 +1,9 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module par1_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Tell_Intg (Iarray, Chara6, Num)
CHARACTER*6 Chara6
DIMENSION Iarray(Num)
@@ -15,12 +17,12 @@ C
END IF
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Set3a (Lmax)
-C
+!
use fixedi_m
use ifwrit_m
use exploc_common_m
@@ -32,7 +34,7 @@ C
type(SammySpinGroupInfo)::spinInfo
type(RMatChannelParams)::channel
type(SammyChannelInfo)::channelInfo
-C
+!
Lmax = 0
DO Ig=1,resParData%getNumSpinGroups()
call resParData%getSpinGroupInfo(spinInfo, Ig)
@@ -45,52 +47,52 @@ C
END DO
END DO
Lmax = Lmax + 1
-C
-C *** note: zero through eight used to be here too, but then needed them
-C *** in INP for option to read card sets in INPut file
-C
-C *** nine
+!
+! *** note: zero through eight used to be here too, but then needed them
+! *** in INP for option to read card sets in INPut file
+!
+! *** nine
N = Numusd
IF (Numusd.EQ.0) N = 1
call make_A_Iprusd(N)
I = Jdimen (N)
call make_I_Iflusd(N)
-C
-C *** ten
+!
+! *** ten
N = Numbag
IF (Numbag.EQ.0) N = 1
call make_A_Iprbag(N)
call make_I_Iflbag(N)
-C
-C *** not used in PAR but are used in OLD or NEW
+!
+! *** not used in PAR but are used in OLD or NEW
N8 = Ntotc*Ngroup
call make_A_Izke(N8)
call make_A_Izkte(N8)
call make_A_Izkfe(N8)
call make_A_Izeta(N8)
call make_I_Ifzke(Ngroup)
-C Note that Ifzke refers to abundances,
-C and is for a given Group, not Channel
-C The others (Ifzkte, Ifzkfe) refer to
-C channel radius, hence have both G & C
+! Note that Ifzke refers to abundances,
+! and is for a given Group, not Channel
+! The others (Ifzkte, Ifzkfe) refer to
+! channel radius, hence have both G & C
call make_I_Ifzkte(N8)
call make_I_Ifzkfe(N8)
-C
-C *** eleven
+!
+! *** eleven
N = Nres
IF (Kdecpl.EQ.0 .AND. Kenunc.EQ.0) N = 1
IF (Nres.EQ.0) N = 1
call make_A_Iddcov(N)
-C
-C *** twelve
+!
+! *** twelve
N = Nvpres
IF (Kdecpl.EQ.0) N = 1
call make_A_Idcov(N)
-C
-C *** thirteen
+!
+! *** thirteen
K = Nfpall
-C
-C *** thirteen.one
+!
+! *** thirteen.one
IF (Nudwhi.NE.0) THEN
call make_A_Iude(Nudeng*Nudwhi)
call make_A_Iudr(Nudtim*Nudeng*Nudwhi)
@@ -99,10 +101,10 @@ C *** thirteen.one
Nudtim = 1
Nudeng = 1
END IF
-C
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
-C FROM END OF A-SAMOLD OR A-SAMNEW
-C *** fourteen
+!
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
+! FROM END OF A-SAMOLD OR A-SAMNEW
+! *** fourteen
N = Noffv
IF (Noffv.LE.0) N = 1
call make_I_Inn(N)
@@ -110,8 +112,8 @@ C *** fourteen
call make_I_Ikk(N)
call make_I_Ill(N)
call make_A_Ivv(N)
-C
-C *** fifteen
+!
+! *** fifteen
N = Nuncer*(Ntotc2+1)
IF (N.LE.0) N = 1
call make_A_Iuncs(N)
@@ -119,8 +121,8 @@ C *** fifteen
IF (N.LE.0) N = 1
call make_I_Ijuncs(N)
-C
-C *** sixteen
+!
+! *** sixteen
IF (Nprior.GT.0) THEN
N = Nprior
call make_A_Ipriox(N)
@@ -128,60 +130,61 @@ C *** sixteen
N = Nres*Ntotc2
call make_I_Ijprio(N)
END IF
-C
+!
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
FUNCTION Kdimen (Many)
-C
-C PURPOSE -- Be sure there is enough room in /chadtp/
-C
+!
+! PURPOSE -- Be sure there is enough room in /chadtp/
+!
use over_common_m
-C
+!
Kdimen = 1
Kkount = Many
IF (Many.GT.Knsize) WRITE (6,99999) Knsize, Many
IF (Many.GT.Knsize) WRITE (21,99999) Knsize, Many
-99999 FORMAT (' Available size for data parameter names =', I5,
- * ' but you need', I6, '. Error!')
+99999 FORMAT (' Available size for data parameter names =', I5, &
+ ' but you need', I6, '. Error!')
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
FUNCTION Jdimen (Many)
-C
-C PURPOSE -- Be sure there is enough room in /chausd/
-C
+!
+! PURPOSE -- Be sure there is enough room in /chausd/
+!
use over_common_m
-C
+!
Jdimen = 1
Jkount = Many
IF (Many.GT.Jnsize) WRITE (6,99999) Jnsize, Many
IF (Many.GT.Jnsize) WRITE (21,99999) Jnsize, Many
-99999 FORMAT (' Available size for unused parameter names =', I5,
- * ' but you need', I6, '. Error!')
+99999 FORMAT (' Available size for unused parameter names =', I5, &
+ ' but you need', I6, '. Error!')
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
FUNCTION Ldimen (Many)
-C
-C PURPOSE -- Be sure there is enough room in /chamsc/
-C
+!
+! PURPOSE -- Be sure there is enough room in /chamsc/
+!
use over_common_m
-C
+!
Ldimen = 1
Lkount = Many
IF (Many.GT.Lnsize) WRITE (6,99999) Lnsize, Many
IF (Many.GT.Lnsize) WRITE (21,99999) Lnsize, Many
-99999 FORMAT (' Available size for miscellaneous parameter names =',
- * I5, ' but you need', I6, '... ERROR')
+99999 FORMAT (' Available size for miscellaneous parameter names =', &
+ I5, ' but you need', I6, '... ERROR')
RETURN
END
+end module par1_m
\ No newline at end of file
diff --git a/sammy/src/par/mpar02.f b/sammy/src/par/mpar02.f
deleted file mode 100644
index 9ab6dd829..000000000
--- a/sammy/src/par/mpar02.f
+++ /dev/null
@@ -1,339 +0,0 @@
-C
-C
-C *** THIS FILE CONTAINS ROUTINES FOR READING "PARAMETER" FILE
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Parfil (Parbrd, Iflbrd, Siabnd,
- * Pareff, Ifleff, Deleff, Partru, Ifltru, Deltru, Igrrad,
- * Ifliso, Deliso, Spniso, Ixciso,
- * Pardet, Ifldet, Deldet, Igrdet,
- * Parext, Iflext, Parmsc, Iflmsc, Delmsc, Iradms, Ijkmsc,
- * Znonu , Rnonu , Anonu , Bnonu ,
- * Etaeee, Parpmc, Iflpmc, Delpmc, Isopmc,
- * Parorr, Iflorr, Delorr, Ecrnch, Endets, Sesese, Eseses, Sigdts,
- * Parrpi, Iflrpi, Delrpi, Parudr, Ifludr, Deludr, Nud_T, Nud_E,
- * Parnbk, Iflnbk, Delnbk,
- * Parbgf, Iflbgf, Delbgf, Kndbgf, Bgfmin, Bgfmax, Texbgf, Teabgf,
- * Pardtp, Ifldtp, Deldtp, Ptilde,
- * Parusd, Parbag, Iflbag, Nn, Mm, Kk, Ll, Vv, Runcs, Juncs,
- * Prior , Iprior, Jprior,
- * Lrad , Kprior, Lprior,
- * Noffv , Nuncer, Nprior, Nnrext, Lmax)
-C
-C *** Purpose -- Determine input parameters Iflbrd,
-C *** etc., and parameters for generating variance
-C
- use fixedi_m
- use ifwrit_m
- use samxxx_common_m
- use fixedr_m
- use broad_common_m
- use namfil_common_m
- use misccc_common_m
- use partyp_common_m
- use par_parameter_names_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Parbrd(*), Iflbrd(*), Siabnd(*),
- * Pareff(*), Ifleff(*), Deleff(*), Partru(*), Ifltru(*),
- * Deltru(*), Igrrad(Ntotc,*),
- * Ifliso(*), Deliso(*),
- * Spniso(*), Ixciso(*),
- * Pardet(*), Ifldet(*), Deldet(*), Igrdet(*),
- * Parext(Nnrext,Ntotc,*), Iflext(Nnrext,Ntotc,*),
- * Parmsc(*), Iflmsc(*), Delmsc(*), Iradms(*), Ijkmsc(*),
- * Znonu (*), Rnonu (*), Anonu (*), Bnonu (*), Etaeee(*),
- * Parpmc(4,*), Iflpmc(4,*), Delpmc(4,*), Isopmc(*),
- * Parorr(*), Iflorr(*), Delorr(*), Ecrnch(*), Endets(*),
- * Sesese(*), Eseses(*), Sigdts(*),
- * Parrpi(*), Iflrpi(*), Delrpi(*),
- * Parudr(*), Ifludr(*), Deludr(*), Nud_T(*), Nud_E(*),
- * Parnbk(*), Iflnbk(*), Delnbk(*),
- * Parbgf(*), Iflbgf(*), Delbgf(*), Kndbgf(*), Bgfmin(*),
- * Bgfmax(*), Texbgf(*), Teabgf(*),
- * Pardtp(*), Ifldtp(*), Deldtp(*), Ptilde(*),
- * Parusd(*), Parbag(*), Iflbag(*),
- * Nn(*), Mm(*), Kk(*), Ll(*), Vv(*),
- * Runcs(6,*), Juncs(5,*),
- * Prior(*), Iprior(*), Jprior(Ntotc2,*),
- * Lrad(*),
- * Kprior(Ntotc2,*), Lprior(*)
-C
-C DIMENSION Parbrd(Numbrd), Iflbrd(Numbrd),
-C * Siabnd(Ngroup), Pareff(Numrad), Ifleff(Numrad),
-C * Partru(Numrad), Ifltru(Numrad), Igrrad(Ntotc,Ngroup),
-C * Ifliso(Numiso), Deliso(Numiso),
-C * Spniso(Numiso), Ixciso(Numiso),
-C * Pardet(Numdet), Ifldet(Numdet),
-C * Deldet(Numdet), Igrdet(Ngroup),
-C * Parext(Nrext,Ntotc,Ngroup) , Iflext(Nrext,Ntotc,Ngroup),
-C * Parmsc(Nummsc), Iflmsc(Nummsc), Delmsc(Nummsc),
-C * Iradms(Ngroup), Ijkmsc(Nummsc),
-C * Anonu (Nonu ), Rnonu (Nonu ), Etaeee(Mjetan),
-C *Parpmc(4,Numpmc), Iflpmc(4,Numpmc), Delpmc(4,Numpmc), Isopmc(Numpmc),
-C *Parorr(Numorr), Iflorr(Numorr), Delorr(Numorr), Ecrnch(Numorr-11),
-C * Endets(Nmdets), Sesese(Nmdets), Eseses(Nmdets), Sigdts(Nmdets),
-C * Parrpi(Numrpi), Iflrpi(Numrpi), Delrpi(Numrpi), Ecrnch(Numrpi-?),
-C * Parnbk(Numnbk), Iflnbk(Numnbk), Delnbk(Numnbk),
-C * Parbgf(Numbgf), Iflbgf(Numbgf), Delbgf(Numbgf), Kndbgf(Numbgf),
-C * Bgfmin(Numbgf), Bgfmax(Numbgf),
-C * Pardtp(Numdtp), Ifldtp(Numdtp), Deldtp(Numdtp), Ptilde(Numdtp),
-C * Parusd(Numusd), Parbag(Numbag), Iflbag(Numbag),
-C * Nn(Noffv), Mm(Noffv), Kk(Noffv), Ll(Noffv), Vv(Noffv),
-C * Runcs(6,Nuncer), Juncs(5,Nuncer),
-C * Prior(Nprior), Iprior(Nprior), Jprior(Ntotc2,Nres),
-C * Lrad(Lmax,Nppair,Numrad),
-C * Kprior(Ntotc2,Ngroup), Lprior(Lmax)
-C
- DATA Zero /0.0d0/
-C
- Ifbp = 0
-C *** card set 1
-C *** READ RESONANCE PARAMETERS
- IF (Nres.GT.0) then
- CALL Zero_Integer (Iradms, Ngroup)
- CALL Readrs
- end if
-C
-C *** card set 2
-C *** READ VALUE OF "Fudge" (Ratio of delta-gamma to gamma)
-cx READ (Iu32,99999,END=30,ERR=40) Fudge
- READ (Iu32,99999,END=30,ERR=30) Fudge
-99999 FORMAT (F10.1)
- IF (Fudge.EQ.Zero) Fudge = 0.1d0
-C
-C
-C *** DETERMINE WHICH OTHER INFORMATION IS INCLUDED
-C
-C
- 10 CONTINUE
- Iunit = Iu32
- CALL Pread (Iu32)
-C *** PREAD READS AND INTERPRETS MESSAGE LINE
-C
- IF (Alfnm1.EQ.Blank5) THEN
- GO TO 10
- ELSE IF (Alfnm1.EQ.Endddd) THEN
- GO TO 30
-C
- ELSE IF (Alfnm1.EQ.Rexter) THEN
-C *** alternative to card set 3
- CALL Readrx (Parext, Iflext, Nnrext)
-C
- ELSE IF (Alfnm1.EQ.Extern) THEN
-C *** card set 3
- CALL Readex (Parext, Iflext, Nnrext)
-C
- ELSE IF (Alfnm1.EQ.Radius .OR. Alfnm1.EQ.Radiii .OR.
- * Alfnm1.EQ.Channe) THEN
-C *** card set 7 "Radii" or "Channel Radii"
- CALL Readrd (Parbrd, Pareff, Ifleff,
- * Deleff, Partru, Ifltru, Deltru, Igrrad, Lrad, Lmax)
-C
- ELSE IF (Alfnm1.EQ.Xisoto .OR. Alfnm1.EQ.Xnucli) THEN
-C *** card set 10 "Nuclide" or "Isotopic Abundance"
- CALL Readis (Ifliso, Deliso, Spniso, Ixciso, Iu32)
-C
- ELSE IF (Alfnm1.EQ.Broade) THEN
-C *** card set 4 "Broadening parameters"
- CALL Brdfix (Iflbrd, Ifbp, Iu32)
-C
- ELSE IF (Alfnm1.EQ.Amiscl) THEN
-C *** card set 11 "Miscellaneous parameters"
- CALL Readms (Siabnd, Parmsc, Iflmsc, Delmsc, Iradms,
- * Ijkmsc, Znonu, Rnonu, Anonu, Bnonu, Etaeee, Iu32)
-C
- ELSE IF (Alfnm1.EQ.Parama) THEN
-C *** card set 12 "Paramagnetic cross section"
- CALL Readpm (Parpmc, Iflpmc, Delpmc, Isopmc, Iu32)
-C
- ELSE IF (Alfnm1.EQ.Orreso) THEN
-C *** card set 9 "Oak Ridge Resolution function"
- IF (Nobrd.EQ.0) THEN
- CALL Reador (Parorr, Iflorr, Delorr, Ecrnch, Endets, Sesese,
- * Eseses, Sigdts, Iu32)
- ELSE IF (Nobrd.EQ.1) THEN
- CALL Readox (Iu32)
- END IF
-C
- ELSE IF (Alfnm1.EQ.Rpires) THEN
-C *** card set 14 "RPI Resolution function"
- Iwhrpi = 1
- IF (Nobrd.EQ.0) THEN
- CALL Readrp (Parrpi, Iflrpi, Delrpi, Ecrnch, Iu32)
- ELSE IF (Nobrd.EQ.1) THEN
- CALL Readxp (Iu32)
- END IF
-C
- ELSE IF (Alfnm1.EQ.Rpitra) THEN
-C *** card set 14 alt 1 "RPI Resolution function, transmission"
- Iwhrpi = 1
- IF (Nobrd.EQ.0) THEN
- CALL Readr1 (Parrpi, Iflrpi, Delrpi, Ecrnch, Iu32, 1)
- ELSE IF (Nobrd.EQ.1) THEN
- CALL Readxp (Iu32)
- END IF
-C
- ELSE IF (Alfnm1.EQ.Rpicap) THEN
-C *** card set 14 alt 2 "RPI Resolution function, capture"
- Iwhrpi = 1
- IF (Nobrd.EQ.0) THEN
- CALL Readr1 (Parrpi, Iflrpi, Delrpi, Ecrnch, Iu32, 2)
- ELSE IF (Nobrd.EQ.1) THEN
- CALL Readxp (Iu32)
- END IF
-C
- ELSE IF (Alfnm1.EQ.Geelxx .OR. Alfnm1.EQ.Gelina) THEN
-C *** card set 14 alt 3 "Geel resolution function"
- Iwhrpi = 3
- IF (Nobrd.EQ.0) THEN
- IF (Alfnm2.EQ.Defaul) THEN
- CALL Readr3 (Parrpi, Iflrpi, Delrpi, Ecrnch, Iu32, 3)
- ELSE
- CALL Readrp (Parrpi, IFLrpi, Delrpi, Ecrnch, Iu32)
- END IF
- ELSE IF (Nobrd.EQ.1) THEN
- CALL Readxp (Iu32)
- END IF
-C
- ELSE IF (Alfnm1.EQ.Ntofxx) THEN
-C *** card set 14 alt 2 "nTOF resolution function"
- Iwhrpi = 4
- IF (Nobrd.EQ.0) THEN
- IF (Alfnm2.EQ.Defaul) THEN
- CALL Readr3 (Parrpi, Iflrpi, Delrpi, Ecrnch, Iu32, 4)
- ELSE
- CALL Readrp (Parrpi, IFLrpi, Delrpi, Ecrnch, Iu32)
- END IF
- ELSE IF (Nobrd.EQ.1) THEN
- CALL Readxp (Iu32)
- END IF
-C
- ELSE IF (Alfnm1.EQ.Userde) THEN
-C *** card set 16 "User Defined Resolution function"
- IF (Nobrd.EQ.0) THEN
- CALL Readud (Parudr, Ifludr, Deludr, Ecrnch, Nud_T,
- * Nud_E, Iu32)
- ELSE IF (Nobrd.EQ.1) THEN
- CALL Readux (Iu32)
- END IF
-C
- ELSE IF (Alfnm1.EQ.Detect) THEN
-C *** card set 15 "detector efficiency (el-dependent)"
- CALL Readde (Pardet, Ifldet, Deldet, Igrdet, Iu32)
-C
- ELSE IF (Alfnm1.EQ.Anorma) THEN
-C *** card set 6 "normalization and background)
- CALL Readnb (Parnbk, Iflnbk, Delnbk, Iu32)
-C
- ELSE IF (Alfnm1.EQ.Backgr) THEN
-C *** card set 13 "background parameters"
- CALL Readbg (Parbgf, Iflbgf, Delbgf, Kndbgf, Bgfmin, Bgfmax,
- * Texbgf, Teabgf, Iu32)
-C
- ELSE IF (Alfnm1.EQ.Datapr) THEN
-C *** card set 8 "data-reduction parameters"
- CALL Readda (Pardtp, Ifldtp, Deldtp, Ptilde, Iu32)
-C
- ELSE IF (Alfnm1.EQ.Unused) THEN
-C *** card set 5
- CALL Readun (Parusd)
-C
- ELSE IF (Alfnm1.EQ.Baggag) THEN
-C *** card set which? undefined yet
- CALL Readba (Parbag, Iflbag)
-C
- ELSE IF (Alfnm1.EQ.Prioru) THEN
-C *** last card set, "prior" alternative (Key-Word format)
-C *** (called "Last D" in Table VIB.1 in manual)
- CALL Readpr (Prior,
- * Iprior, Jprior, Kprior, Lprior, Alfn80, Lmax, Nprior)
-C
- ELSE IF (Alfnm1.EQ.Relunc .AND. Nuncer.GT.0) THEN
-C *** last card set, "relative" alternative
-C *** (called "Last C" in Table VIB.1 in manual)
- CALL Readre (Runcs, Juncs, Nuncer)
-C
- ELSE IF (Alfnm1.EQ.Explic) THEN
-C *** last card set, "explicit" alternative
-C *** (called "Last B" in Table VIB.1 in manual)
- CALL Readab (Nn, Mm, Kk, Ll, Vv, Noffv)
- IF (Nres.NE.0) CALL Revise (Nn, Mm, Kk, Ll, Vv, Noffv)
-C
- ELSE IF (Alfnm1.EQ.Covari) THEN
-C *** last card set, covariance matrix is in COV file
-C *** (called "Last A" in Table VIB.1 in manual)
- GO TO 30
-C
- ELSE IF (Alfnm1.EQ.Absent) THEN
- GO TO 30
-C
- END IF
- GO TO 10
-C
- 30 CONTINUE
- IF (Ifbp.EQ.0 .AND. Kipbrd.EQ.-1) CALL Brdinp (Parbrd, Iflbrd)
-C
- IF (Numiso.GT.0 .AND. Numrad.GT.0) THEN
- CALL Check_Iso_Rad (Igrrad, Ntotc, Ngroup, Numrad)
- END IF
-C
- CLOSE (UNIT=Iu32)
- RETURN
-C
-C
-cx 40 CONTINUE
-cx WRITE (21,99998)
-cx WRITE (6,99998)
-cx99998 FORMAT (' Error in reading Fudge in PARameter file', /,
-cx *' Value of Fudge is set to 0.1 and rest of PAR file is ignored.')
-cx Fudge = 0.1d0
-cx GO TO 30
- END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Check_Iso_Rad (Igrrad, Ntotc, Ngroup, Numrad)
- use EndfData_common_m
- use SammySpinGroupInfo_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Igrrad(Ntotc,Ngroup)
- type(SammySpinGroupInfo)::spinInfo
- Istop = 0
- DO Irad=1,Numrad
- Iso = 0
- DO Ig=1,Ngroup
- call resParData%getSpinGroupInfo(spinInfo, Ig)
- DO Ich=1,Ntotc
- IF (Igrrad(Ich,Ig).EQ.Irad) THEN
- IF (Iso.EQ.0) THEN
- Iso = spinInfo%getIsotopeIndex()
- Iig = Ig
- Iich = Ich
- ELSE
- isoIg = spinInfo%getIsotopeIndex()
- IF (IsoIg.NE.Iso) THEN
- WRITE ( 6,10000) Irad, Iig, Ig, Iich, Ich, Iso,
- * IsoIg
- WRITE (21,10000) Irad, Iig, Ig, Iich, Ich, Iso,
- * IsoIg
-10000 FORMAT (10I5)
- Istop = 1
- END IF
- END IF
- END IF
- END DO
- END DO
- END DO
- IF (Istop.EQ.1) THEN
- WRITE ( 6,10100)
-10100 FORMAT (' Incompatible input -- radii for different nuclides are
- *e intermixed', /,
- * ' (Numbers = radius #, two spin groups, two channels, two nuclide
- *lide numbers)')
- STOP '[STOP in Check_Iso_Rad in par/mpar02.f]'
- END IF
- RETURN
- END
diff --git a/sammy/src/par/mpar02.f90 b/sammy/src/par/mpar02.f90
new file mode 100644
index 000000000..2b0691fa3
--- /dev/null
+++ b/sammy/src/par/mpar02.f90
@@ -0,0 +1,346 @@
+!
+module par2_m
+ contains
+!
+! *** THIS FILE CONTAINS ROUTINES FOR READING "PARAMETER" FILE
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Parfil (Parbrd, Iflbrd, Siabnd, &
+ Pareff, Ifleff, Deleff, Partru, Ifltru, Deltru, Igrrad, &
+ Ifliso, Deliso, Spniso, Ixciso, &
+ Pardet, Ifldet, Deldet, Igrdet, &
+ Parext, Iflext, Parmsc, Iflmsc, Delmsc, Iradms, Ijkmsc, &
+ Znonu , Rnonu , Anonu , Bnonu , &
+ Etaeee, Parpmc, Iflpmc, Delpmc, Isopmc, &
+ Parorr, Iflorr, Delorr, Ecrnch, Endets, Sesese, Eseses, Sigdts, &
+ Parrpi, Iflrpi, Delrpi, Parudr, Ifludr, Deludr, Nud_T, Nud_E, &
+ Parnbk, Iflnbk, Delnbk, &
+ Parbgf, Iflbgf, Delbgf, Kndbgf, Bgfmin, Bgfmax, Texbgf, Teabgf, &
+ Pardtp, Ifldtp, Deldtp, Ptilde, &
+ Parusd, Parbag, Iflbag, Nn, Mm, Kk, Ll, Vv, Runcs, Juncs, &
+ Prior , Iprior, Jprior, &
+ Lrad , Kprior, Lprior, &
+ Noffv , Nuncer, Nprior, Nnrext, Lmax)
+!
+! *** Purpose -- Determine input parameters Iflbrd,
+! *** etc., and parameters for generating variance
+!
+ use fixedi_m
+ use ifwrit_m
+ use samxxx_common_m
+ use fixedr_m
+ use broad_common_m
+ use namfil_common_m
+ use misccc_common_m
+ use partyp_common_m
+ use par_parameter_names_common_m
+ use par3_m
+ use par4_m
+ use par5_m
+ use par6_m
+ use par7_m
+ use par8_m
+ use par9_m
+ use par10_m
+ use par13_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+!
+ DIMENSION Parbrd(*), Iflbrd(*), Siabnd(*), &
+ Pareff(*), Ifleff(*), Deleff(*), Partru(*), Ifltru(*), &
+ Deltru(*), Igrrad(Ntotc,*), &
+ Ifliso(*), Deliso(*), &
+ Spniso(*), Ixciso(*), &
+ Pardet(*), Ifldet(*), Deldet(*), Igrdet(*), &
+ Parext(Nnrext,Ntotc,*), Iflext(Nnrext,Ntotc,*), &
+ Parmsc(*), Iflmsc(*), Delmsc(*), Iradms(*), Ijkmsc(*), &
+ Znonu (*), Rnonu (*), Anonu (*), Bnonu (*), Etaeee(*), &
+ Parpmc(4,*), Iflpmc(4,*), Delpmc(4,*), Isopmc(*), &
+ Parorr(*), Iflorr(*), Delorr(*), Ecrnch(*), Endets(*), &
+ Sesese(*), Eseses(*), Sigdts(*), &
+ Parrpi(*), Iflrpi(*), Delrpi(*), &
+ Parudr(*), Ifludr(*), Deludr(*), Nud_T(*), Nud_E(*), &
+ Parnbk(*), Iflnbk(*), Delnbk(*), &
+ Parbgf(*), Iflbgf(*), Delbgf(*), Kndbgf(*), Bgfmin(*), &
+ Bgfmax(*), Texbgf(*), Teabgf(*), &
+ Pardtp(*), Ifldtp(*), Deldtp(*), Ptilde(*), &
+ Parusd(*), Parbag(*), Iflbag(*), &
+ Nn(*), Mm(*), Kk(*), Ll(*), Vv(*), &
+ Runcs(6,*), Juncs(5,*), &
+ Prior(*), Iprior(*), Jprior(Ntotc2,*), &
+ Lrad(*), &
+ Kprior(Ntotc2,*), Lprior(*)
+!
+! DIMENSION Parbrd(Numbrd), Iflbrd(Numbrd),
+! * Siabnd(Ngroup), Pareff(Numrad), Ifleff(Numrad),
+! * Partru(Numrad), Ifltru(Numrad), Igrrad(Ntotc,Ngroup),
+! * Ifliso(Numiso), Deliso(Numiso),
+! * Spniso(Numiso), Ixciso(Numiso),
+! * Pardet(Numdet), Ifldet(Numdet),
+! * Deldet(Numdet), Igrdet(Ngroup),
+! * Parext(Nrext,Ntotc,Ngroup) , Iflext(Nrext,Ntotc,Ngroup),
+! * Parmsc(Nummsc), Iflmsc(Nummsc), Delmsc(Nummsc),
+! * Iradms(Ngroup), Ijkmsc(Nummsc),
+! * Anonu (Nonu ), Rnonu (Nonu ), Etaeee(Mjetan),
+! *Parpmc(4,Numpmc), Iflpmc(4,Numpmc), Delpmc(4,Numpmc), Isopmc(Numpmc),
+! *Parorr(Numorr), Iflorr(Numorr), Delorr(Numorr), Ecrnch(Numorr-11),
+! * Endets(Nmdets), Sesese(Nmdets), Eseses(Nmdets), Sigdts(Nmdets),
+! * Parrpi(Numrpi), Iflrpi(Numrpi), Delrpi(Numrpi), Ecrnch(Numrpi-?),
+! * Parnbk(Numnbk), Iflnbk(Numnbk), Delnbk(Numnbk),
+! * Parbgf(Numbgf), Iflbgf(Numbgf), Delbgf(Numbgf), Kndbgf(Numbgf),
+! * Bgfmin(Numbgf), Bgfmax(Numbgf),
+! * Pardtp(Numdtp), Ifldtp(Numdtp), Deldtp(Numdtp), Ptilde(Numdtp),
+! * Parusd(Numusd), Parbag(Numbag), Iflbag(Numbag),
+! * Nn(Noffv), Mm(Noffv), Kk(Noffv), Ll(Noffv), Vv(Noffv),
+! * Runcs(6,Nuncer), Juncs(5,Nuncer),
+! * Prior(Nprior), Iprior(Nprior), Jprior(Ntotc2,Nres),
+! * Lrad(Lmax,Nppair,Numrad),
+! * Kprior(Ntotc2,Ngroup), Lprior(Lmax)
+!
+ DATA Zero /0.0d0/
+!
+ Ifbp = 0
+! *** card set 1
+! *** READ RESONANCE PARAMETERS
+ IF (Nres.GT.0) then
+ CALL Zero_Integer (Iradms, Ngroup)
+ CALL Readrs
+ end if
+!
+! *** card set 2
+! *** READ VALUE OF "Fudge" (Ratio of delta-gamma to gamma)
+!x READ (Iu32,99999,END=30,ERR=40) Fudge
+ READ (Iu32,99999,END=30,ERR=30) Fudge
+99999 FORMAT (F10.1)
+ IF (Fudge.EQ.Zero) Fudge = 0.1d0
+!
+!
+! *** DETERMINE WHICH OTHER INFORMATION IS INCLUDED
+!
+!
+ 10 CONTINUE
+ Iunit = Iu32
+ CALL Pread (Iu32)
+! *** PREAD READS AND INTERPRETS MESSAGE LINE
+!
+ IF (Alfnm1.EQ.Blank5) THEN
+ GO TO 10
+ ELSE IF (Alfnm1.EQ.Endddd) THEN
+ GO TO 30
+!
+ ELSE IF (Alfnm1.EQ.Rexter) THEN
+! *** alternative to card set 3
+ CALL Readrx (Parext, Iflext, Nnrext)
+!
+ ELSE IF (Alfnm1.EQ.Extern) THEN
+! *** card set 3
+ CALL Readex (Parext, Iflext, Nnrext)
+!
+ ELSE IF (Alfnm1.EQ.Radius .OR. Alfnm1.EQ.Radiii .OR. &
+ Alfnm1.EQ.Channe) THEN
+! *** card set 7 "Radii" or "Channel Radii"
+ CALL Readrd (Parbrd, Pareff, Ifleff, &
+ Deleff, Partru, Ifltru, Deltru, Igrrad, Lrad, Lmax)
+!
+ ELSE IF (Alfnm1.EQ.Xisoto .OR. Alfnm1.EQ.Xnucli) THEN
+! *** card set 10 "Nuclide" or "Isotopic Abundance"
+ CALL Readis (Ifliso, Deliso, Spniso, Ixciso, Iu32)
+!
+ ELSE IF (Alfnm1.EQ.Broade) THEN
+! *** card set 4 "Broadening parameters"
+ CALL Brdfix (Iflbrd, Ifbp, Iu32)
+!
+ ELSE IF (Alfnm1.EQ.Amiscl) THEN
+! *** card set 11 "Miscellaneous parameters"
+ CALL Readms (Siabnd, Parmsc, Iflmsc, Delmsc, Iradms, &
+ Ijkmsc, Znonu, Rnonu, Anonu, Bnonu, Etaeee, Iu32)
+!
+ ELSE IF (Alfnm1.EQ.Parama) THEN
+! *** card set 12 "Paramagnetic cross section"
+ CALL Readpm (Parpmc, Iflpmc, Delpmc, Isopmc, Iu32)
+!
+ ELSE IF (Alfnm1.EQ.Orreso) THEN
+! *** card set 9 "Oak Ridge Resolution function"
+ IF (Nobrd.EQ.0) THEN
+ CALL Reador (Parorr, Iflorr, Delorr, Ecrnch, Endets, Sesese, &
+ Eseses, Sigdts, Iu32)
+ ELSE IF (Nobrd.EQ.1) THEN
+ CALL Readox (Iu32)
+ END IF
+!
+ ELSE IF (Alfnm1.EQ.Rpires) THEN
+! *** card set 14 "RPI Resolution function"
+ Iwhrpi = 1
+ IF (Nobrd.EQ.0) THEN
+ CALL Readrp (Parrpi, Iflrpi, Delrpi, Ecrnch, Iu32)
+ ELSE IF (Nobrd.EQ.1) THEN
+ CALL Readxp (Iu32)
+ END IF
+!
+ ELSE IF (Alfnm1.EQ.Rpitra) THEN
+! *** card set 14 alt 1 "RPI Resolution function, transmission"
+ Iwhrpi = 1
+ IF (Nobrd.EQ.0) THEN
+ CALL Readr1 (Parrpi, Iflrpi, Delrpi, Ecrnch, Iu32, 1)
+ ELSE IF (Nobrd.EQ.1) THEN
+ CALL Readxp (Iu32)
+ END IF
+!
+ ELSE IF (Alfnm1.EQ.Rpicap) THEN
+! *** card set 14 alt 2 "RPI Resolution function, capture"
+ Iwhrpi = 1
+ IF (Nobrd.EQ.0) THEN
+ CALL Readr1 (Parrpi, Iflrpi, Delrpi, Ecrnch, Iu32, 2)
+ ELSE IF (Nobrd.EQ.1) THEN
+ CALL Readxp (Iu32)
+ END IF
+!
+ ELSE IF (Alfnm1.EQ.Geelxx .OR. Alfnm1.EQ.Gelina) THEN
+! *** card set 14 alt 3 "Geel resolution function"
+ Iwhrpi = 3
+ IF (Nobrd.EQ.0) THEN
+ IF (Alfnm2.EQ.Defaul) THEN
+ CALL Readr3 (Parrpi, Iflrpi, Delrpi, Ecrnch, Iu32, 3)
+ ELSE
+ CALL Readrp (Parrpi, IFLrpi, Delrpi, Ecrnch, Iu32)
+ END IF
+ ELSE IF (Nobrd.EQ.1) THEN
+ CALL Readxp (Iu32)
+ END IF
+!
+ ELSE IF (Alfnm1.EQ.Ntofxx) THEN
+! *** card set 14 alt 2 "nTOF resolution function"
+ Iwhrpi = 4
+ IF (Nobrd.EQ.0) THEN
+ IF (Alfnm2.EQ.Defaul) THEN
+ CALL Readr3 (Parrpi, Iflrpi, Delrpi, Ecrnch, Iu32, 4)
+ ELSE
+ CALL Readrp (Parrpi, IFLrpi, Delrpi, Ecrnch, Iu32)
+ END IF
+ ELSE IF (Nobrd.EQ.1) THEN
+ CALL Readxp (Iu32)
+ END IF
+!
+ ELSE IF (Alfnm1.EQ.Userde) THEN
+! *** card set 16 "User Defined Resolution function"
+ IF (Nobrd.EQ.0) THEN
+ CALL Readud (Parudr, Ifludr, Deludr, Ecrnch, Nud_T, Nud_E, Iu32)
+ ELSE IF (Nobrd.EQ.1) THEN
+ CALL Readux (Iu32)
+ END IF
+!
+ ELSE IF (Alfnm1.EQ.Detect) THEN
+! *** card set 15 "detector efficiency (el-dependent)"
+ CALL Readde (Pardet, Ifldet, Deldet, Igrdet, Iu32)
+!
+ ELSE IF (Alfnm1.EQ.Anorma) THEN
+! *** card set 6 "normalization and background)
+ CALL Readnb (Parnbk, Iflnbk, Delnbk, Iu32)
+!
+ ELSE IF (Alfnm1.EQ.Backgr) THEN
+! *** card set 13 "background parameters"
+ CALL Readbg (Parbgf, Iflbgf, Delbgf, Kndbgf, Bgfmin, Bgfmax, &
+ Texbgf, Teabgf, Iu32)
+!
+ ELSE IF (Alfnm1.EQ.Datapr) THEN
+! *** card set 8 "data-reduction parameters"
+ CALL Readda (Pardtp, Ifldtp, Deldtp, Ptilde, Iu32)
+!
+ ELSE IF (Alfnm1.EQ.Unused) THEN
+! *** card set 5
+ CALL Readun (Parusd)
+!
+ ELSE IF (Alfnm1.EQ.Baggag) THEN
+! *** card set which? undefined yet
+ CALL Readba (Parbag, Iflbag)
+!
+ ELSE IF (Alfnm1.EQ.Prioru) THEN
+! *** last card set, "prior" alternative (Key-Word format)
+! *** (called "Last D" in Table VIB.1 in manual)
+ CALL Readpr (Prior, Iprior, Jprior, Kprior, Lprior, Alfn80, Lmax, &
+ Nprior)
+!
+ ELSE IF (Alfnm1.EQ.Relunc .AND. Nuncer.GT.0) THEN
+! *** last card set, "relative" alternative
+! *** (called "Last C" in Table VIB.1 in manual)
+ CALL Readre (Runcs, Juncs, Nuncer)
+!
+ ELSE IF (Alfnm1.EQ.Explic) THEN
+! *** last card set, "explicit" alternative
+! *** (called "Last B" in Table VIB.1 in manual)
+ CALL Readab (Nn, Mm, Kk, Ll, Vv, Noffv)
+ IF (Nres.NE.0) CALL Revise (Nn, Mm, Kk, Ll, Vv, Noffv)
+!
+ ELSE IF (Alfnm1.EQ.Covari) THEN
+! *** last card set, covariance matrix is in COV file
+! *** (called "Last A" in Table VIB.1 in manual)
+ GO TO 30
+!
+ ELSE IF (Alfnm1.EQ.Absent) THEN
+ GO TO 30
+!
+ END IF
+ GO TO 10
+!
+ 30 CONTINUE
+ IF (Ifbp.EQ.0 .AND. Kipbrd.EQ.-1) CALL Brdinp (Parbrd, Iflbrd)
+!
+ IF (Numiso.GT.0 .AND. Numrad.GT.0) THEN
+ CALL Check_Iso_Rad (Igrrad, Ntotc, Ngroup, Numrad)
+ END IF
+!
+ CLOSE (UNIT=Iu32)
+ RETURN
+!
+!
+!x 40 CONTINUE
+!x WRITE (21,99998)
+!x WRITE (6,99998)
+!x99998 FORMAT (' Error in reading Fudge in PARameter file', /,
+!x *' Value of Fudge is set to 0.1 and rest of PAR file is ignored.')
+!x Fudge = 0.1d0
+!x GO TO 30
+ END
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Check_Iso_Rad (Igrrad, Ntotc, Ngroup, Numrad)
+ use EndfData_common_m
+ use SammySpinGroupInfo_M
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ DIMENSION Igrrad(Ntotc,Ngroup)
+ type(SammySpinGroupInfo)::spinInfo
+ Istop = 0
+ DO Irad=1,Numrad
+ Iso = 0
+ DO Ig=1,Ngroup
+ call resParData%getSpinGroupInfo(spinInfo, Ig)
+ DO Ich=1,Ntotc
+ IF (Igrrad(Ich,Ig).EQ.Irad) THEN
+ IF (Iso.EQ.0) THEN
+ Iso = spinInfo%getIsotopeIndex()
+ Iig = Ig
+ Iich = Ich
+ ELSE
+ isoIg = spinInfo%getIsotopeIndex()
+ IF (IsoIg.NE.Iso) THEN
+ WRITE ( 6,10000) Irad, Iig, Ig, Iich, Ich, Iso, IsoIg
+ WRITE (21,10000) Irad, Iig, Ig, Iich, Ich, Iso, IsoIg
+10000 FORMAT (10I5)
+ Istop = 1
+ END IF
+ END IF
+ END IF
+ END DO
+ END DO
+ END DO
+ IF (Istop.EQ.1) THEN
+ WRITE ( 6,10100)
+10100 FORMAT (' Incompatible input -- radii for different nuclides are intermixed', &
+ /,'(Numbers = radius #, two spin groups, two channels, two nuclide numbers)')
+ STOP '[STOP in Check_Iso_Rad in par/mpar02.f]'
+ END IF
+ RETURN
+ END
+end module par2_m
diff --git a/sammy/src/par/mpar03.f b/sammy/src/par/mpar03.f90
similarity index 71%
rename from sammy/src/par/mpar03.f
rename to sammy/src/par/mpar03.f90
index 6f67723bf..96ae46fd4 100644
--- a/sammy/src/par/mpar03.f
+++ b/sammy/src/par/mpar03.f90
@@ -1,12 +1,14 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module par3_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readrs ()
-C
-C *** Card Set 1
-C *** PURPOSE -- read resonance data
-C
+!
+! *** Card Set 1
+! *** PURPOSE -- read resonance data
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -28,18 +30,18 @@ C
call reader%initialize()
-C Q( 60) = 'USE I4 FORMAT TO READ SPIN GROUP NUMBER ' from input
-C
+! Q( 60) = 'USE I4 FORMAT TO READ SPIN GROUP NUMBER ' from input
+!
if(Kkkgrp.eq.50) then
largeSpin = .false.
else
largeSpin = .true.
end if
call reader%setManySpinGroups(largeSpin)
-C
-C Kgenpd: Q(332) = 'GENERATE PARTIAL DERIVATIVES ONLY from input
-C Kflags: Q( 63) = 'FLAG ALL RESONANCE PARAMETERS from input
-c
+!
+! Kgenpd: Q(332) = 'GENERATE PARTIAL DERIVATIVES ONLY from input
+! Kflags: Q( 63) = 'FLAG ALL RESONANCE PARAMETERS from input
+!
IF (Kgenpd.NE.1 .AND. Kflags.EQ.0) THEN
flagAll = .false.
else
@@ -71,33 +73,33 @@ c
call reader%destroy()
-C
+!
-C
-C
-C *** READ BLANK LINE SIGNIFYING END OF RESONANCE PARAMETERS
-C
+!
+!
+! *** READ BLANK LINE SIGNIFYING END OF RESONANCE PARAMETERS
+!
Fudge = 0.1d0
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readrx (Parext, Iflext, Nnrext)
-C
-C *** alternative to card set 3
-C *** PURPOSE -- READ R-EXTERNAL PARAMETERS
-C
+!
+! *** alternative to card set 3
+! *** PURPOSE -- READ R-EXTERNAL PARAMETERS
+!
use fixedi_m
use ifwrit_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Parext(Nrext,Ntotc,Ngroup), Iflext(Nrext,Ntotc,Ngroup)
+!
+! DIMENSION Parext(Nrext,Ntotc,Ngroup), Iflext(Nrext,Ntotc,Ngroup)
DIMENSION Parext(Nnrext,Ntotc,*), Iflext(Nnrext,Ntotc,*)
DIMENSION P(7), Js(7)
DATA Zero /0.0d0/
-C
+!
K1 = 0
K3 = 0
DO N=1,Ngroup
@@ -111,7 +113,7 @@ C
END DO
N = 0
Numext = 0
-C
+!
40 CONTINUE
N = N + 1
READ (Iu32,99999,END=90,ERR=90) Nnn, Nchnn, Js, P
@@ -126,7 +128,7 @@ C
Js(1) = -1
60 CONTINUE
IF (Js(1).LT.0) THEN
-C All flags are zero (or -1) if parameters are zero
+! All flags are zero (or -1) if parameters are zero
ELSE
DO Kqqq=1,7
Parext(Kqqq,Nchnn,Nnn) = P(Kqqq)
@@ -140,33 +142,33 @@ C All flags are zero (or -1) if parameters are zero
IF (Iflext(Kqqq,Nchnn,Nnn).EQ.3) K3 = K3 + 1
END DO
GO TO 40
-C
+!
90 CONTINUE
IF (K1.NE.Nvpext) STOP '[STOP in Readrx in mpar03.f # 3]'
IF (K1+K3.NE.Nfpext) STOP '[STOP in Readrx in mpar03.f # 4]'
Numext = Nnrext*Ntotc*Ngroup
-C *** Nvpext = NUMBER OF ADDITIONAL VARIED PARAMETERS
-C *** Numext = TOTAL NUMBER OF R-EXTERNAL PARAMETERS
+! *** Nvpext = NUMBER OF ADDITIONAL VARIED PARAMETERS
+! *** Numext = TOTAL NUMBER OF R-EXTERNAL PARAMETERS
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readex (Parext, Iflext, Nnrext)
-C
-C *** card set 3
-C *** PURPOSE -- READ EXTERNAL R-MATRIX PARAMETERS
-C
+!
+! *** card set 3
+! *** PURPOSE -- READ EXTERNAL R-MATRIX PARAMETERS
+!
use fixedi_m
use ifwrit_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Parext(Nrext,Ntotc,Ngroup), Iflext(Nrext,Ntotc,Ngroup)
+!
+! DIMENSION Parext(Nrext,Ntotc,Ngroup), Iflext(Nrext,Ntotc,Ngroup)
DIMENSION Parext(Nnrext,Ntotc,*), Iflext(Nnrext,Ntotc,*)
DIMENSION P(5), JS(5)
DATA Zero /0.0d0/
-C
+!
K1 = 0
K3 = 0
DO N=1,Ngroup
@@ -179,7 +181,7 @@ C
END DO
END DO
N = 0
-C
+!
40 CONTINUE
N = N + 1
READ (Iu32,99999,END=70,ERR=70) Nnn, Nchnn, P, Js
@@ -188,10 +190,10 @@ C
IF (Nnn.EQ.0) GO TO 70
Numext = Numext + 5
IF (Nchnn.EQ.0) Nchnn = 1
- IF (P(1).EQ.Zero .AND. P(2).EQ.Zero .AND. P(3).EQ.Zero .AND.
- * P(4).EQ.Zero .AND. P(5).EQ.Zero) Js(1) = -1
+ IF (P(1).EQ.Zero .AND. P(2).EQ.Zero .AND. P(3).EQ.Zero .AND. &
+ P(4).EQ.Zero .AND. P(5).EQ.Zero) Js(1) = -1
IF (Js(1).LT.0) THEN
-C All flags are zero (or -1) if parameters are zero
+! All flags are zero (or -1) if parameters are zero
ELSE
DO Kqqq=1,5
Parext(Kqqq,Nchnn,Nnn) = P(Kqqq)
@@ -205,25 +207,25 @@ C All flags are zero (or -1) if parameters are zero
IF (Iflext(Kqqq,Nchnn,Nnn).EQ.3) K3 = K3 + 1
END DO
GO TO 40
-C
+!
70 CONTINUE
IF (K1.NE.Nvpext) STOP '[STOP in Readex in mpar03.f # 2]'
IF (K1+K3.NE.Nfpext) STOP '[STOP in Readex in mpar03.f # 3]'
Numext = Nnrext*Ntotc*Ngroup
-C *** Nvpext = NUMBER OF ADDITIONAL VARIED PARAMETERS
-C *** Numext = TOTAL NUMBER OF R-EXTERNAL PARAMETERS
+! *** Nvpext = NUMBER OF ADDITIONAL VARIED PARAMETERS
+! *** Numext = TOTAL NUMBER OF R-EXTERNAL PARAMETERS
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Readrd (Parbrd, Pareff, Ifleff,
- * Deleff, Partru, Ifltru, Deltru, Igrrad, Lrad, Lmax)
-C
-C *** Card Set 7
-C *** PURPOSE -- READ RADIUS PARAMETERS and maybe uncertainties
-C
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Readrd (Parbrd, Pareff, Ifleff, &
+ Deleff, Partru, Ifltru, Deltru, Igrrad, Lrad, Lmax)
+!
+! *** Card Set 7
+! *** PURPOSE -- READ RADIUS PARAMETERS and maybe uncertainties
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -233,15 +235,15 @@ C
use EndfData_common_m
use SammyResonanceInfo_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(SammySpinGroupInfo)::spinInfo
- DIMENSION Parbrd(*),
- * Pareff(*), Ifleff(*), Deleff(*),
- * Partru(*), Ifltru(*), Deltru(*), Igrrad(Ntotc,*), Lrad(*)
+ DIMENSION Parbrd(*), &
+ Pareff(*), Ifleff(*), Deleff(*), &
+ Partru(*), Ifltru(*), Deltru(*), Igrrad(Ntotc,*), Lrad(*)
DIMENSION Iss(28), Jss(1003)
EQUIVALENCE (Iss(1),Jss(1))
DATA Zero /0.0d0/
-C
+!
CALL Zero_Array (Pareff, Numrad)
CALL Zero_Integer (Ifleff, Numrad)
CALL Zero_Array (Deleff, Numrad)
@@ -249,20 +251,20 @@ C
CALL Zero_Integer (Ifltru, Numrad)
CALL Zero_Array (Deltru, Numrad)
CALL Zero_Integer (Igrrad, Ngroup*Ntotc)
-C
+!
K1 = 0
K3 = 0
IF (Alfnm1.NE.Channe) THEN
CALL Find_Key_Word
-C *** Note that Find_Key_Word may change Alfnm1, so "END IF" and new "IF"
+! *** Note that Find_Key_Word may change Alfnm1, so "END IF" and new "IF"
END IF
IF (Alfnm1.EQ.Channe) THEN
- CALL Rd_Rad_Key_Word (Pareff, Ifleff,
- * Deleff, Partru, Ifltru, Deltru, Igrrad, Dumnam,
- * Lrad, Alfnum, I_Rad, Ntotc, Nnniso, Nppair, Lmax, Numrad,
- * Ngroup, Iu32)
- IF (I_Rad.NE.Numrad)
- * STOP '[STOP I_Rad.NE.Numrad in Readrd in mpar03.f]'
+ CALL Rd_Rad_Key_Word (Pareff, Ifleff, &
+ Deleff, Partru, Ifltru, Deltru, Igrrad, Dumnam, &
+ Lrad, Alfnum, I_Rad, Ntotc, Nnniso, Nppair, Lmax, Numrad, &
+ Ngroup, Iu32)
+ IF (I_Rad.NE.Numrad) &
+ STOP '[STOP I_Rad.NE.Numrad in Readrd in mpar03.f]'
IF (Kgenpd.EQ.1) THEN
DO I=1,Numrad
IF (Ifleff(I).GT.0) Ifleff(I) = 0
@@ -285,33 +287,33 @@ C *** Note that Find_Key_Word may change Alfnm1, so "END IF" and new "IF"
END IF
RETURN
END IF
-C
-C
-C *** Arrive here only if not key-word format
+!
+!
+! *** Arrive here only if not key-word format
Krad = 28
IF (Ngroup.GT.99) Krad = 10
- IF (Ngroup+Ntotc.GT.1003)
- * STOP '[STOP in Readrd in par/mpar03.f # 4]'
+ IF (Ngroup+Ntotc.GT.1003) &
+ STOP '[STOP in Readrd in par/mpar03.f # 4]'
CALL Zero_Integer (Jss, 1003)
-C
+!
Kq = 0
Iwrong = 0
DO 140 I=1,Numrad
IF (Ngroup.LE.99) THEN
- READ (Iu32,99999,END=170,ERR=170) Pareff(I),
- * Aaaa, Ix, Ifleff(I), Ifltru(I), Iss
+ READ (Iu32,99999,END=170,ERR=170) Pareff(I), &
+ Aaaa, Ix, Ifleff(I), Ifltru(I), Iss
99999 FORMAT (2F10.0, I1, I1, 29I2)
ELSE
- READ (Iu32,99998,END=170,ERR=170) Pareff(I),
- * Aaaa, Ix, Ifleff(I), Ifltru(I), (Jss(K),K=1,Krad)
+ READ (Iu32,99998,END=170,ERR=170) Pareff(I), &
+ Aaaa, Ix, Ifleff(I), Ifltru(I), (Jss(K),K=1,Krad)
99998 FORMAT (2F10.0, I2, I3, 11I5)
END IF
Jssmin = Krad
Nnn = Ngroup + 1
IF (Ix.NE.0) Nnn = Nnn + Ntotc
-C
+!
40 CONTINUE
-C *** Read remainder of spin groups & channel numbers, if needed
+! *** Read remainder of spin groups & channel numbers, if needed
IF (Jss(Jssmin).LT.0) THEN
Jssmax = Jssmin + 15
IF (Nnn.GT.Jssmin .AND. Jss(Jssmin).LT.0) THEN
@@ -321,7 +323,7 @@ C *** Read remainder of spin groups & channel numbers, if needed
Jssmin = Jssmax
GO TO 40
END IF
-C
+!
IF (Kgenpd.EQ.1) THEN
IF (Ifleff(I).GT.0) Ifleff(I) = 0
IF (Ifltru(I).GT.0) Ifltru(I) = 0
@@ -334,12 +336,12 @@ C
Partru(I) = Pareff(I)
ELSE
IF (Aaaa.GT.Zero) Partru(I) = Aaaa
- IF (Aaaa.LT.Zero) Partru(I) = 1.23d0*
- * (-Aaaa)**0.333333333d0 + 0.80d0
-C THIS IS ENDF'S ORIGINAL VERSION, IN OUR UNITS
+ IF (Aaaa.LT.Zero) Partru(I) = 1.23d0* &
+ (-Aaaa)**0.333333333d0 + 0.80d0
+! THIS IS ENDF'S ORIGINAL VERSION, IN OUR UNITS
IF (Aaaa.EQ.Zero) Partru(I) = Crfn
END IF
-C
+!
Ichmin = 1
Ichmax = Ntotc
IF (Ix.NE.0) THEN
@@ -358,11 +360,11 @@ C
IF (Jss(k).GT.Ngroup) THEN
WRITE ( 6,55555) Iss(K)
WRITE (21,55555) Iss(K)
-55555 FORMAT (' #######################################',
- * /, ' Radii in Par file require spin group',
- * /, ' #', I3, ', which is not in INPut file.', /,
- * ' Correct your input and try again.',
- * /, ' #######################################')
+55555 FORMAT (' #######################################', &
+ /, ' Radii in Par file require spin group', &
+ /, ' #', I3, ', which is not in INPut file.', /, &
+ ' Correct your input and try again.', &
+ /, ' #######################################')
Iwrong = Iwrong + 1
END IF
IF (Jss(K).EQ.0) GO TO 140
@@ -378,10 +380,10 @@ C
END IF
END DO
END DO
-C
+!
140 CONTINUE
IF (Iwrong.GT.0) STOP '[STOP in Readrd in par/mpar03.f # 5]'
-C
+!
DO N=1,Ngroup
call resparData%getSpinGroupInfo(spinInfo,N)
Ntot_N = spinInfo%getNumChannels()
@@ -399,39 +401,38 @@ C
END IF
END DO
END DO
-99996 FORMAT (' Channel #', I2, ' for spin group #', I3,
- * ' is not in "RADIUS" so is assigned #', I3)
-C
-C
+99996 FORMAT (' Channel #', I2, ' for spin group #', I3, &
+ ' is not in "RADIUS" so is assigned #', I3)
+!
+!
170 CONTINUE
Crfn = Partru(1)
Parbrd(1) = Partru(1)
IF (K1.NE.Nvprad) STOP '[STOP in Readrd in mpar03.f # 7]'
IF (K1+K3.NE.Nfprad) STOP '[STOP in Readrd in mpar03.f # 8]'
-C *** Nvprad = NUMBER OF ADDITIONAL VARIED PARAMETERS
-C *** Numrad = TOTAL NUMBER OF RADIUS-TYPE PARAMETERS
-C
+! *** Nvprad = NUMBER OF ADDITIONAL VARIED PARAMETERS
+! *** Numrad = TOTAL NUMBER OF RADIUS-TYPE PARAMETERS
+!
RETURN
-C
-C
-C
+!
+!
+!
180 CONTINUE
WRITE (6,99995) N
-99995 FORMAT (' Spin Group Number', I2,' is included in "RADIUS" too man
- *y times')
+99995 FORMAT (' Spin Group Number',I2,' is included in "RADIUS" too many times')
STOP '[STOP in Readrd in par/mpar03.f # 9]'
-C
+!
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readis (Ifliso, Deliso, Spniso, Ixciso, Kfile)
-C
-C *** Card Set 10
-C *** PURPOSE -- Read isotopic (nuclide) parameters -- mass and
-C *** abundance of isotopes (nuclides)
-C
+!
+! *** Card Set 10
+! *** PURPOSE -- Read isotopic (nuclide) parameters -- mass and
+! *** abundance of isotopes (nuclides)
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -444,12 +445,11 @@ C
use SammyIsoInfo_M
use RMatResonanceParam_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION
-C * Ifliso(Numiso), Deliso(Numiso),
-C * Spniso(Numiso), Ixciso(Numiso)
- DIMENSION Ifliso(*),
- * Deliso(*), Spniso(*), Ixciso(*)
+!
+! DIMENSION
+! * Ifliso(Numiso), Deliso(Numiso),
+! * Spniso(Numiso), Ixciso(Numiso)
+ DIMENSION Ifliso(*), Deliso(*), Spniso(*), Ixciso(*)
DIMENSION Iss(24), Jss(1003)
EQUIVALENCE (Iss(1),Jss(1))
@@ -462,9 +462,9 @@ C * Spniso(Numiso), Ixciso(Numiso)
call reader%initialize()
-C
-C Kgenpd: Q(332) = 'GENERATE PARTIAL DERIVATIVES ONLY from input
-c
+!
+! Kgenpd: Q(332) = 'GENERATE PARTIAL DERIVATIVES ONLY from input
+!
IF (Kgenpd.NE.1) THEN
flagAll = .false.
else
@@ -512,8 +512,8 @@ c
DO 120 N=1,Numiso
parisoVal = resParData%getAbundanceByIsotope(N)
IF (Ifliso(N).LE.-2) THEN
-C
-C *** here when want to use what was in INPut file
+!
+! *** here when want to use what was in INPut file
DO I=1,Ngroup
call resParData%getSpinGroupInfo(spinInfo, I)
Iso = spinInfo%getIsotopeIndex()
@@ -524,11 +524,11 @@ C *** here when want to use what was in INPut file
END IF
END IF
END DO
-C
+!
ELSE
-C
-C *** Here when want to use what's in Par file which may be different
-C *** from what's in COV file and from what's in INP file
+!
+! *** Here when want to use what's in Par file which may be different
+! *** from what's in COV file and from what's in INP file
DO I=1,Ngroup
call resParData%getSpinGroupInfo(spinInfo, I)
Iso = spinInfo%getIsotopeIndex()
@@ -539,9 +539,9 @@ C *** from what's in COV file and from what's in INP file
END IF
END IF
END DO
-C
+!
END IF
-C
+!
Spniso(N) = Zero
Ix = 0
DO I=1,Ngroup
@@ -551,18 +551,18 @@ C
IF (Ix.EQ.0) THEN
Spniso(N) = spinInfo%getTargetSpin()
Ix = 1
- ELSE IF (Ix.NE.0 .AND.
- * spinInfo%getTargetSpin().NE.Spniso(N)) THEN
+ ELSE IF (Ix.NE.0 .AND. &
+ spinInfo%getTargetSpin().NE.Spniso(N)) THEN
WRITE (6,99995)
-99995 FORMAT (' #### All spin groups belonging to the same',
- * 1X, 'isotope must have same Spinx ####')
+99995 FORMAT (' #### All spin groups belonging to the same', &
+ 1X, 'isotope must have same Spinx ####')
STOP '[STOP in Readis in par/mpar03.f # 3]'
END IF
END IF
END DO
-C
+!
120 CONTINUE
-C
+!
DO Iso=1,Numiso
Ixciso(Iso) = 1
END DO
@@ -571,16 +571,16 @@ C
Iso = spinInfo%getIsotopeIndex()
IF (spinInfo%getIncludeInCalc()) Ixciso(Iso) = 0
END DO
-C *** Note that Ixciso(Iso)=1 means exclude this isotope completely
-C
-C *** Test whether Aaawww (as read from the INPut file) is almost equal to
-C *** one of the masses from the PAR file; set it equal to the nearest one
+! *** Note that Ixciso(Iso)=1 means exclude this isotope completely
+!
+! *** Test whether Aaawww (as read from the INPut file) is almost equal to
+! *** one of the masses from the PAR file; set it equal to the nearest one
Nuc = 1
Awx = Aaawww
IF (Aaawww.EQ.Zero) THEN
Aaawww = resParData%getMassForIsotope(1)
ELSE
-C *** Choose the nuclide whose mass is closest to Aaawww
+! *** Choose the nuclide whose mass is closest to Aaawww
L = 0
Ax = 100.0d0
DO Iso=1,Numiso
@@ -593,8 +593,8 @@ C *** Choose the nuclide whose mass is closest to Aaawww
Aaawww = resParData%getMassForIsotope(L)
Nuc = L
END IF
-C
-C
+!
+!
Aw = resParData%getMassForIsotope(1)
DO Iso=1,Numiso
IF (Ixciso(Iso).NE.1) THEN
@@ -603,40 +603,34 @@ C
end if
END IF
END DO
-C *** Now Aw = mass of smallest nuclide
-C *** Note that we SHOULD be using the smallest-mass nuclide for
-C calculating Doppler widths and for determining lower limit for
-C multiple-scattering corrections. However, that can increase
-C computation time enormously. So use whatever's in Aaawww, and
-C issue a warning.
+! *** Now Aw = mass of smallest nuclide
+! *** Note that we SHOULD be using the smallest-mass nuclide for
+! calculating Doppler widths and for determining lower limit for
+! multiple-scattering corrections. However, that can increase
+! computation time enormously. So use whatever's in Aaawww, and
+! issue a warning.
IF (Aw.LT.Aaawww) THEN
WRITE (6,10000) Nuc, Aaawww, Awx, Aw
WRITE (21,10000) Nuc, Aaawww,Awx, Aw
-10000 FORMAT (' *****************************************************
- ***********************',
- * /, ' * Warning -- Mass used to determine limits for auxili
- *ary grid (for Dopplr *',
- * /, ' * and multiple-scattering corrections) may be too big
- *. SAMMY is using the *', /, ' * mass from nuclide number', I2,
- * ' (' , F10.6, '), because that is closest to the *',
- * /, ' * mass from Line 2 of the INPut file (', F10.6,
- * '). For more accurate *',
- * /, ' * results, use the mass of the smallest nuclide (',
- * F10.6, '). (Expect *',
- * /, ' * longer runtime if you change to the smaller mass.)'
- * , 22x, '*',
- * /, ' *****************************************************
- ***********************')
+10000 FORMAT (' ***************************************************************************', &
+ /, ' * Warning -- Mass used to determine limits for auxiliary grid (for Dopplr *', &
+ /, ' * and multiple-scattering corrections) may be too big. SAMMY is using the *', &
+ /, ' * mass from nuclide number', I2,' (' ,F10.6,'), because that is closest to the *', &
+ /, ' * mass from Line 2 of the INPut file (', F10.6,'). For more accurate *', &
+ /, ' * results, use the mass of the smallest nuclide (',F10.6, '). (Expect *', &
+ /, ' * longer runtime if you change to the smaller mass.)', 22x, '*', &
+ /, ' ***************************************************************************')
END IF
IF (K1.NE.Nvpiso) STOP '[STOP in Readis in mpar03.f # 4]'
IF (K1+K3.NE.Nfpiso) STOP '[STOP in Readis in mpar03.f # 5]'
RETURN
-C
-C
+!
+!
130 CONTINUE
WRITE (6,99994) N
-99994 FORMAT (' Spin group Number', I2,
- * 'is included in "NUCLIde masses and abundances" twice.')
+99994 FORMAT (' Spin group Number', I2, &
+ 'is included in "NUCLIde masses and abundances" twice.')
STOP '[STOP in Readis in mpar03.f # 6]'
-C
+!
END
+end module par3_m
diff --git a/sammy/src/par/mpar04.f b/sammy/src/par/mpar04.f90
similarity index 76%
rename from sammy/src/par/mpar04.f
rename to sammy/src/par/mpar04.f90
index 831eff003..91fa53e38 100644
--- a/sammy/src/par/mpar04.f
+++ b/sammy/src/par/mpar04.f90
@@ -1,41 +1,43 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module par4_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Brdfix (Iflbrd, Ifbp, Kfile)
-C
-C *** Card Set 4
-C
+!
+! *** Card Set 4
+!
use fixedi_m
use ifwrit_m
use broad_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Iflbrd(Numbrd)
+!
+! DIMENSION Iflbrd(Numbrd)
DIMENSION Iflbrd(*)
DATA Zero /0.0d0/
-C
+!
Iw = 1
Ifbp = 1
10100 FORMAT (60X, 6I2)
READ (Kfile,10100) (Iflbrd(I),I=1,6)
-C IF Numbrd.GT.6, the other are read elsewhere
-C
+! IF Numbrd.GT.6, the other are read elsewhere
+!
IF (Kgenpd.NE.0) THEN
CALL Zero_Integer (Iflbrd, 6)
END IF
-C
+!
READ (Kfile,10200,END=10,ERR=10) A, B, C, D, E, F
10200 FORMAT (6F10.1)
- IF (A.NE.Zero .OR. B.NE.Zero .OR. C.NE.Zero .OR. D.NE.Zero .OR.
- * E.NE.Zero .OR. F.NE.Zero) THEN
+ IF (A.NE.Zero .OR. B.NE.Zero .OR. C.NE.Zero .OR. D.NE.Zero .OR. &
+ E.NE.Zero .OR. F.NE.Zero) THEN
READ (Kfile,10100,END=10,ERR=10) Iiiii
END IF
10 CONTINUE
IF (Iesopr.EQ.1 .AND. Iflbrd(6).GT.0) Iflbrd(6) = 0
IF (Iesopr.EQ.2 .AND. Iflbrd(4).GT.0) Iflbrd(4) = 0
IF (Iesopr.EQ.2 .AND. Iflbrd(5).GT.0) Iflbrd(5) = 0
-C
+!
IF (Iflbrd(1).GT.0) Kvcrfn = Iflbrd(1)
IF (Iflbrd(2).NE.0) Kvtemp = Iflbrd(2)
IF (Iflbrd(3).NE.0) Kvthck = Iflbrd(3)
@@ -52,7 +54,7 @@ C
ELSE
Kvdlt2 = 0
END IF
-C
+!
K1 = 0
K3 = 0
IF (Kfile.EQ.Iu22) THEN
@@ -62,7 +64,7 @@ C
K3 = K3 + 1
END IF
DO I=2,Numbrd
-C IF (Iflbrd(I).EQ.1) ignore "vary" flag in INPut file
+! IF (Iflbrd(I).EQ.1) ignore "vary" flag in INPut file
IF (Iflbrd(I).EQ.3) K3 = K3 + 1
END DO
ELSE
@@ -79,30 +81,29 @@ C IF (Iflbrd(I).EQ.1) ignore "vary" flag in INPut file
IF (Iflbrd(I).EQ.3) K3 = K3 + 1
END DO
END IF
-C
+!
IF (K1.NE.Nvpbrd) STOP '[STOP in Brdfix in mpar04.f]'
IF (K1+K3.NE.Nfpbrd) THEN
STOP '[STOP in Brdfix in mpar04.f # 2]'
END IF
-C *** Nvpbrd IS NUMBER OF BROADENING WIDTHS (ETC) TO BE VARIED
+! *** Nvpbrd IS NUMBER OF BROADENING WIDTHS (ETC) TO BE VARIED
RETURN
-C
+!
20 CONTINUE
WRITE (6,10300)
-10300 FORMAT ('### Cannot vary or PUP radius in "BROADening Parameters"
- *Card Set',
- * '### when have RADIUs Card Set')
+10300 FORMAT ('### Cannot vary or PUP radius in "BROADening Parameters Card Set',&
+ '### when have RADIUs Card Set')
STOP '[STOP in Brdfix in mpar04.f # 3]'
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Readms (Siabnd, Parmsc, Iflmsc, Delmsc, Iradms,
- * Ijkmsc, Znonu, Rnonu, Anonu, Bnonu, Etaeee, Kfile)
-C
-C *** Card Set 11
-C
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Readms (Siabnd, Parmsc, Iflmsc, Delmsc, Iradms, &
+ Ijkmsc, Znonu, Rnonu, Anonu, Bnonu, Etaeee, Kfile)
+!
+! *** Card Set 11
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -112,33 +113,33 @@ C
use EndfData_common_m
use SammySpinGroupInfo_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Siabnd(Ngroup), Parmsc(Nummsc),
-C * Iflmsc(Nummsc), Delmsc(Nummsc), Iradms(Ngroup), Ijkmsc(Nummsc)
- DIMENSION Siabnd(*), Parmsc(*), Iflmsc(*), Delmsc(*),
- * Iradms(*), Ijkmsc(*), Znonu(*), Rnonu(*), Anonu(*), Bnonu(*),
- * Etaeee(*)
-C
+!
+! DIMENSION Siabnd(Ngroup), Parmsc(Nummsc),
+! * Iflmsc(Nummsc), Delmsc(Nummsc), Iradms(Ngroup), Ijkmsc(Nummsc)
+ DIMENSION Siabnd(*), Parmsc(*), Iflmsc(*), Delmsc(*), &
+ Iradms(*), Ijkmsc(*), Znonu(*), Rnonu(*), Anonu(*), Bnonu(*), &
+ Etaeee(*)
+!
Character*5 Blank
- CHARACTER*5 Xx , Aaaaaa, Bbbbbb, Cccccc, Eeeeee,
- * Siabnc, Selfin, Concrz, Effici, Ffffff, Direct, Nsensi,
- * Polari, Nonuni, Nonunf
- CHARACTER*5 Aaaaay, Cccccy, Eeeeey, Fffffy, Fffffz, Concry,
- * Fiseff, Gammax
-C
+ CHARACTER*5 Xx , Aaaaaa, Bbbbbb, Cccccc, Eeeeee, &
+ Siabnc, Selfin, Concrz, Effici, Ffffff, Direct, Nsensi, &
+ Polari, Nonuni, Nonunf
+ CHARACTER*5 Aaaaay, Cccccy, Eeeeey, Fffffy, Fffffz, Concry, &
+ Fiseff, Gammax
+!
type(SammySpinGroupInfo)::spinInfo
- DATA Aaaaaa /'DELTA'/, Bbbbbb /'ETA '/, Cccccc /'FINIT'/,
- * Eeeeee /'TZERO'/, Ffffff /'DELTE'/,
- * Siabnc /'SIABN'/, Selfin /'SELFI'/, Concrz /'CONCR'/,
- * Effici /'EFFIC'/, Direct /'DRCAP'/, Nsensi /'NSENS'/,
- * Polari /'NPOLA'/, Nonuni /'NONUN'/, Nonunf /'NON U'/
- DATA Aaaaay /'DELT2'/, Cccccy /'FINI2'/, Eeeeey /'LZERO'/,
- * Fffffy /'DELE0'/, Fffffz /'DELE2'/, Concry /'CONTR'/,
- * Fiseff /'FISEF'/, Gammax /'GAMMA'/
+ DATA Aaaaaa /'DELTA'/, Bbbbbb /'ETA '/, Cccccc /'FINIT'/, &
+ Eeeeee /'TZERO'/, Ffffff /'DELTE'/, &
+ Siabnc /'SIABN'/, Selfin /'SELFI'/, Concrz /'CONCR'/, &
+ Effici /'EFFIC'/, Direct /'DRCAP'/, Nsensi /'NSENS'/, &
+ Polari /'NPOLA'/, Nonuni /'NONUN'/, Nonunf /'NON U'/
+ DATA Aaaaay /'DELT2'/, Cccccy /'FINI2'/, Eeeeey /'LZERO'/, &
+ Fffffy /'DELE0'/, Fffffz /'DELE2'/, Concry /'CONTR'/, &
+ Fiseff /'FISEF'/, Gammax /'GAMMA'/
DATA Blank /' '/
DATA Zero /0.0d0/
-C
-C
+!
+!
CALL Zero_Integer (Ijkmsc, Nummsc)
Kdrcap = 0
Jradms = 0
@@ -150,13 +151,13 @@ C
99999 FORMAT (A5, 2I2, I1, 7F10.2)
CALL Convert_To_Caps (Xx, 5, Kpound)
IF (Kpound.EQ.1) GO TO 10
-C *** Note: G is dummy here, but included for generality
+! *** Note: G is dummy here, but included for generality
15 CONTINUE
IF (Xx.EQ.Blank) THEN
GO TO 200
-C
+!
ELSE IF (Xx.EQ.Aaaaaa) THEN
-C *** Line # 2 *** DELTA, DELT2 delta-L = deLL11*e + dell00
+! *** Line # 2 *** DELTA, DELT2 delta-L = deLL11*e + dell00
Parmsc(N+1) = A
Parmsc(N+2) = C
Delmsc(N+1) = B
@@ -178,9 +179,9 @@ C *** Line # 2 *** DELTA, DELT2 delta-L = deLL11*e + dell00
END IF
IF (Kjdell.NE.N+1) STOP '[ in Readms in par/mpar04.f # 3]'
N = N + 2
-C
+!
ELSE IF (Xx.EQ.Bbbbbb) THEN
-C *** Line # 3 *** ETA
+! *** Line # 3 *** ETA
Nammsc(N+1) = Bbbbbb
Parmsc(N+1) = A
Delmsc(N+1) = B
@@ -191,23 +192,23 @@ C *** Line # 3 *** ETA
IF (Nammsc(N).NE.Bbbbbb) THEN
WRITE (6,20010) Nammsc(N)
WRITE (21,20010) Nammsc(N)
-20010 FORMAT (' #############################################',
- * /, ' # Error in reading MISCellaneous parameters. ',
- * /, ' # All "ETA" must be together in the list.',
- * /, ' # Instead, you have intermixed with ', A5, /,
- * /, ' #############################################')
+20010 FORMAT (' #############################################', &
+ /, ' # Error in reading MISCellaneous parameters. ', &
+ /, ' # All "ETA" must be together in the list.', &
+ /, ' # Instead, you have intermixed with ', A5, /, &
+ /, ' #############################################')
STOP '[STOP in Readms in par/mpar04.f # 4]'
END IF
Jetan = N + 2 - Kjetan
- IF (Jetan.GT.Mjetan)
- * STOP '[STOP in Readms in par/mpar04.f # 5]'
+ IF (Jetan.GT.Mjetan) &
+ STOP '[STOP in Readms in par/mpar04.f # 5]'
Etaeee(Jetan) = C
END IF
N = N + 1
-C
+!
ELSE IF (Xx.EQ.Cccccc) THEN
-C *** Line # 4 *** FINIT *** here are attenuations...
-C *** Finite-size corrections for angular Distributions
+! *** Line # 4 *** FINIT *** here are attenuations...
+! *** Finite-size corrections for angular Distributions
IF (A.NE.Atteni) THEN
WRITE (6,30001) A, Atteni
30001 FORMAT (' A, Atteni=', 1P6G16.8)
@@ -220,13 +221,13 @@ C *** Finite-size corrections for angular Distributions
STOP '[STOP in Readms in par/mpar04.f # 7]'
END IF
IF (Kjatti.NE.N+1) STOP '[ in Readms in par/mpar04.f # 8]'
- IF (Kjatto.NE.N+Nangle+1) STOP'[ in Readms in par/mpar04.f# 9]'
+ IF (Kjatto.NE.N+Nangle+1) STOP '[ in Readms in par/mpar04.f# 9]'
IF (Atteni.EQ.Zero) Atteni = Thick * 0.5d0
IF (Atteno.EQ.Zero) Atteno = Atteni * 0.9d0
-C defaults are ATTENI=Thick, ATTENO=0.9*ATTENI
+! defaults are ATTENI=Thick, ATTENO=0.9*ATTENI
A = Atteni
C = Atteno
-C *** set attenuations for all angles to be the same
+! *** set attenuations for all angles to be the same
Ka = N
DO K=1,Nangle
Parmsc(Ka+K) = A
@@ -243,9 +244,9 @@ C *** set attenuations for all angles to be the same
36 CONTINUE
Ka = Ka + 1
Kb = Ka + Nangle
-C *** Read attenuations for other angles, if they are in Par file
- READ (Kfile,99999,END=300,ERR=300) Xx, I, J, K, A, B, C,
- * D, E, F, G
+! *** Read attenuations for other angles, if they are in Par file
+ READ (Kfile,99999,END=300,ERR=300) Xx, I, J, K, A, B, C, &
+ D, E, F, G
IF (Xx.EQ.Cccccc) THEN
IF (I.NE.-1) THEN
IF (A.NE.Zero) Parmsc(Ka) = A
@@ -261,11 +262,11 @@ C *** Read attenuations for other angles, if they are in Par file
ELSE
GO TO 15
END IF
-C
+!
ELSE IF (Xx.EQ.Gammax) THEN
-C *** Line # 5 *** GAMMA
+! *** Line # 5 *** GAMMA
Jradms = Jradms + 1
-cx IF (Jradms.NE.I) STOP '[ in Readms in par/mpar04.f # 10]'
+!x IF (Jradms.NE.I) STOP '[ in Readms in par/mpar04.f # 10]'
Parmsc(N+1) = A
Delmsc(N+1) = B
Iflmsc(N+1) = J
@@ -273,13 +274,13 @@ cx IF (Jradms.NE.I) STOP '[ in Readms in par/mpar04.f # 10]'
Iradms(I) = N + 1
call resParData%getSpinGroupInfo(spinInfo, I)
call spinInfo%setGammWidthParIndex(N+1)
-C (reduced) radiation width for spin group # I is misc par # N+1
+! (reduced) radiation width for spin group # I is misc par # N+1
N = N + 1
-C ### NOTE ### all spin groups must be represented here. Otherwise,
-C ### logic in minp18.f for counting flags will be incorrect.
-C
+! ### NOTE ### all spin groups must be represented here. Otherwise,
+! ### logic in minp18.f for counting flags will be incorrect.
+!
ELSE IF (Xx.EQ.Eeeeee) THEN
-C *** Line # 6 *** tzero
+! *** Line # 6 *** tzero
Parmsc(N+1) = A
Parmsc(N+2) = C
Delmsc(N+1) = B
@@ -298,16 +299,16 @@ C *** Line # 6 *** tzero
Parmsc(N+2) = 1.0d0
END IF
Tttzzz = Sm2*Dist*Elzero
-C = sqrt(m/2)*Dist
+! = sqrt(m/2)*Dist
Tzeroo = Tzero
Elzeoo = Elzero
Tttzoo = Tttzzz
-C *** These are ORIGINAL Tzero, Elzero, & Tttzzz respectively
+! *** These are ORIGINAL Tzero, Elzero, & Tttzzz respectively
N = N + 2
-C
+!
ELSE IF (Xx.EQ.Siabnc) THEN
-C *** Line # 7 *** Here are abundances for transmission portion of
-C *** Self-Indication experiment
+! *** Line # 7 *** Here are abundances for transmission portion of
+! *** Self-Indication experiment
IF (Numiso.EQ.0) STOP '[STOP in Readms in par/mpar04.f # 15]'
Ksindi = N + 1
DO Ii=1,Numiso
@@ -328,8 +329,8 @@ C *** Self-Indication experiment
Iflmsc(N+Ii+2) = K
END IF
IF (Ii+2.LT.Numiso) THEN
- READ (Kfile,99999,END=300,ERR=300) Xx, I, J, K, A, B, C,
- * D, E, F, G
+ READ (Kfile,99999,END=300,ERR=300) Xx, I, J, K, A, B, C, &
+ D, E, F, G
END IF
END DO
N = N + Numiso
@@ -338,10 +339,10 @@ C *** Self-Indication experiment
isoIg = spinInfo%getIsotopeIndex()
Siabnd(Ig) = Parmsc(Ksindi+IsoIg-1)
END DO
-C
+!
ELSE IF (Xx.EQ.Selfin) THEN
-C *** Line # 8 Here are temperature and thickness for transmission
-C *** portion of self-indication expt
+! *** Line # 8 Here are temperature and thickness for transmission
+! *** portion of self-indication expt
Parmsc(N+1) = A
Parmsc(N+2) = C
Delmsc(N+1) = B
@@ -357,9 +358,9 @@ C *** portion of self-indication expt
Dopple = dSQRT(Boltzm* Temp*Aneutr/Aaawww)
Dosind = dSQRT(Boltzm*Sitemp*Aneutr/Aaawww)
N = N + 2
-C
+!
ELSE IF (Xx.EQ.Effici) THEN
-C *** Line # 9 *** Efficiency for capture and fission detectors for eta
+! *** Line # 9 *** Efficiency for capture and fission detectors for eta
Parmsc(N+1) = A
Parmsc(N+2) = C
Delmsc(N+1) = B
@@ -373,10 +374,10 @@ C *** Line # 9 *** Efficiency for capture and fission detectors for eta
Effcap = A
Efffis = C
N = N + 2
-C
+!
ELSE IF (Xx.EQ.Ffffff) THEN
-C *** Line # 10 *** Delte, Dele0, Dele2 (Delte===dele1)
-C *** delta-E = dele11*e + dele00 + dele22*dlog(e)
+! *** Line # 10 *** Delte, Dele0, Dele2 (Delte===dele1)
+! *** delta-E = dele11*e + dele00 + dele22*dlog(e)
Parmsc(N+1) = A
Parmsc(N+2) = C
Parmsc(N+3) = E
@@ -394,9 +395,9 @@ C *** delta-E = dele11*e + dele00 + dele22*dlog(e)
IF (E.NE.Dele22) STOP '[STOP in Readms in par/mpar04.f # 18]'
IF (Kjdele.NE.N+1)STOP '[STOP in Readms in par/mpar04.f #19]'
N = N + 3
-C
+!
ELSE IF (Xx.EQ.Direct) THEN
-C *** Line # 11 *** coefficient of direct capture component
+! *** Line # 11 *** coefficient of direct capture component
Parmsc(N+1) = A
Delmsc(N+1) = B
Iflmsc(N+1) = I
@@ -404,13 +405,13 @@ C *** Line # 11 *** coefficient of direct capture component
Nammsc(N+1) = Direct
N = N + 1
IF (Kdrcap.EQ.0) Kdrcap = N
-C
+!
ELSE IF (Xx.EQ.Nsensi) THEN
-C *** Line # 12 *** neutron detector efficiencies (relative to
-C *** capture efficiency) for additional term in
-C *** multiple-scattering correction; value given
-C *** here should be the binding energy of the
-C *** target nucleus
+! *** Line # 12 *** neutron detector efficiencies (relative to
+! *** capture efficiency) for additional term in
+! *** multiple-scattering correction; value given
+! *** here should be the binding energy of the
+! *** target nucleus
Parmsc(N+1) = A
Delmsc(N+1) = B
Iflmsc(N+1) = I
@@ -419,9 +420,9 @@ C *** target nucleus
Sensin = A
IF (A.LT.Zero) Sensin = - A
N = N + 1
-C
+!
ELSE IF (Xx.EQ.Polari) THEN
-C *** Line # 13 *** neutron polarizability
+! *** Line # 13 *** neutron polarizability
Parmsc(N+1) = A
Delmsc(N+1) = B
Iflmsc(N+1) = I
@@ -432,9 +433,9 @@ C *** Line # 13 *** neutron polarizability
IF (J.GT.0) Nasy = J*10 + K
IF (D.GT.0) Nasy = D
N = N + 1
-C
+!
ELSE IF (Xx.EQ.Nonuni .OR. Xx.EQ.Nonunf) THEN
-C *** Line # 14 *** nonuniform thickness of sample
+! *** Line # 14 *** nonuniform thickness of sample
IF (Knonu.EQ.0) THEN
Knonu = N + 1
ELSE
@@ -452,10 +453,10 @@ C *** Line # 14 *** nonuniform thickness of sample
Nammsc(N+2) = Nonuni
Nonux = Nonux + 1
N = N + 2
-C
+!
ELSE IF (Xx.EQ.Concrz) THEN
-C *** Line # xx *** Constant cross section added to what's calculated
-C *** NOTE THAT THIS OPTION IS NOT COMPLETED, NOT USED ANYWHERE!
+! *** Line # xx *** Constant cross section added to what's calculated
+! *** NOTE THAT THIS OPTION IS NOT COMPLETED, NOT USED ANYWHERE!
Parmsc(N+1) = A
Parmsc(N+2) = C
Delmsc(N+1) = B
@@ -469,19 +470,18 @@ C *** NOTE THAT THIS OPTION IS NOT COMPLETED, NOT USED ANYWHERE!
Concro = A
Contot = C
N = N + 2
-C
+!
END IF
GO TO 10
-C
+!
200 CONTINUE
300 CONTINUE
-C
+!
IF (Nonu.NE.0) THEN
IF (Nonu.NE.Nonux) THEN
STOP '[Nonu.NE.Nonux in mpar04.f]'
END IF
- CALL Fix_Non_Uniform (Znonu, Rnonu, Anonu, Bnonu,
- * Parmsc(Knonu), Nonu)
+ CALL Fix_Non_Uniform (Znonu, Rnonu, Anonu, Bnonu, Parmsc(Knonu), Nonu)
END IF
K1 = 0
K3 = 0
@@ -494,11 +494,9 @@ C
END DO
Msitmp = -1
Msithc = -1
- IF (Ksitmp.GT.0 .AND. Iflmsc(Ksitmp).GT.0) Msitmp =
- * Iflmsc(Ksitmp)
- IF (Ksithc.GT.0 .AND. Iflmsc(Ksithc).GT.0) Msithc =
- * Iflmsc(Ksithc)
-C
+ IF (Ksitmp.GT.0 .AND. Iflmsc(Ksitmp).GT.0) Msitmp = Iflmsc(Ksitmp)
+ IF (Ksithc.GT.0 .AND. Iflmsc(Ksithc).GT.0) Msithc = Iflmsc(Ksithc)
+!
IF (Jradms.NE.0) THEN
DO I=1,Ngroup
IF (Iradms(I).EQ.0) GO TO 330
@@ -511,22 +509,21 @@ C
STOP '[STOP in Readms in mpar04.f # 21]'
END IF
RETURN
-C
+!
330 WRITE (6,10000) (Iradms(I),I=1,Ngroup)
-10000 FORMAT (' All spin groups must have GAMMA in MISCEllaneous list',
- * /, ' Iradms=', 15I3)
+10000 FORMAT (' All spin groups must have GAMMA in MISCEllaneous list', &
+ /, ' Iradms=', 15I3)
STOP '[STOP in Readms in par/mpar04.f # 22]'
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Fix_Non_Uniform (Znonu, Rnonu, Anonu, Bnonu, Parmsc,
- * Nonu)
-C
-C *** Purpose -- Reorganize non-uniform thickness such that
-C *** Z(R) = Anonu*R + Bnonu
-C
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Fix_Non_Uniform (Znonu, Rnonu, Anonu, Bnonu, Parmsc, Nonu)
+!
+! *** Purpose -- Reorganize non-uniform thickness such that
+! *** Z(R) = Anonu*R + Bnonu
+!
use ssssss_common_m
use xsect_x_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
@@ -539,12 +536,12 @@ C
Znonu(I) = Parmsc(J)
J = J + 1
END DO
-C
-C *** Test whether Znonu is .GE. Zero
+!
+! *** Test whether Znonu is .GE. Zero
DO I=1,Nonu
IF (Znonu(I).LT.Zero) STOP '[Fix_Non_Uniform 1]'
END DO
-C *** Test whether Rnonu is monotonically increasing
+! *** Test whether Rnonu is monotonically increasing
IF (Rnonu(1).NE.Zero) STOP '[Fix_Non_Uniform 2]'
IF (Nonu.GT.2) THEN
DO I=2,Nonu-1
@@ -553,21 +550,21 @@ C *** Test whether Rnonu is monotonically increasing
END DO
END IF
IF (Rnonu(Nonu).LE.Rnonu(Nonu-1)) STOP '[Fix_Non_Uniform 5]'
-C
-C *** Normalize Rnonu so that range is 0 to 1
+!
+! *** Normalize Rnonu so that range is 0 to 1
R = Rnonu(Nonu)
DO I=1,Nonu
Rnonu(I) = Rnonu(I)/R
END DO
-C
-C *** Normalize Znonu so that average value of Z is 1 -- i.e.,
-C *** {pi Rs^2}^{-1}
-C *** int (0 to 2 pi) dPhi
-C *** int (0 to Rs=1) Z(R) R dR = 1
+!
+! *** Normalize Znonu so that average value of Z is 1 -- i.e.,
+! *** {pi Rs^2}^{-1}
+! *** int (0 to 2 pi) dPhi
+! *** int (0 to Rs=1) Z(R) R dR = 1
R2 = Rnonu(1)
-C = Zero
+! = Zero
R3 = Rnonu(2)
-C Qq = R3**2 + R3*R2 - 2.0d0*R2**2
+! Qq = R3**2 + R3*R2 - 2.0d0*R2**2
Qq = R3**2
Sum = Znonu(1)*Qq
IF (Nonu.GT.2) THEN
@@ -585,8 +582,8 @@ C Qq = R3**2 + R3*R2 - 2.0d0*R2**2
DO I=1,Nonu
Znonu(I) = Znonu(I)*Sum
END DO
-C
-C *** Generate Anonu and Bnonu such that Z = Anonu*R + Bnonu
+!
+! *** Generate Anonu and Bnonu such that Z = Anonu*R + Bnonu
DO I=2,Nonu
D = Rnonu(I) - Rnonu(I-1)
B = Znonu(I) - Znonu(I-1)
@@ -595,30 +592,30 @@ C *** Generate Anonu and Bnonu such that Z = Anonu*R + Bnonu
Bnonu(I) = B/D
END DO
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readpm (Parpmc, Iflpmc, Delpmc, Isopmc, Kfile)
-C
-C *** Card Set 12
-C
+!
+! *** Card Set 12
+!
use fixedi_m
use ifwrit_m
use fixedr_m
use broad_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
DIMENSION Parpmc(4,*), Iflpmc(4,*), Delpmc(4,*), Isopmc(*)
-C DIMENSION Parpmc(4,Nummsc), Iflpmc(4,Nummsc), Delpmc(4,Nummsc),
-C Isopmc(Nummsc)
+! DIMENSION Parpmc(4,Nummsc), Iflpmc(4,Nummsc), Delpmc(4,Nummsc),
+! Isopmc(Nummsc)
CHARACTER*5 Xx, Xxx, Aaaaaa, Bbbbbb, Cccccc, Blank
-C
+!
DATA Aaaaaa /'TM '/, Bbbbbb /'ER '/, Cccccc /'HO '/
DATA Blank /' '/
DATA Zero /0.0d0/
-C
-C
+!
+!
N = 0
10 CONTINUE
READ (Kfile,99999,END=20,ERR=20) Xx, I, J, K, A, B, C, D, E, F
@@ -627,10 +624,10 @@ C
IF (Xx.EQ.BLANK .AND. I.EQ.0 .AND. A.EQ.Zero) GO TO 20
READ (Kfile,99999,END=20,ERR=20) Xxx, Iso, L, Kx, G, H
IF (Iso.EQ.0) Iso = 1
-C
- IF (Xx.NE.Blank .AND. Xx.NE.Aaaaaa .AND.
- * Xx.NE.Bbbbbb .AND. Xx.NE.Cccccc ) GO TO 20
-C
+!
+ IF (Xx.NE.Blank .AND. Xx.NE.Aaaaaa .AND. &
+ Xx.NE.Bbbbbb .AND. Xx.NE.Cccccc ) GO TO 20
+!
N = N + 1
Isopmc( N) = Iso
Parpmc(1,N) = A
@@ -651,8 +648,8 @@ C
IF (Iflpmc(3,N).EQ.1) Iflpmc(3,N) = 0
IF (Iflpmc(4,N).EQ.1) Iflpmc(4,N) = 0
END IF
-C *** Note that cannot vary both #1 & #4. It's really only
-C *** the product ((#4) * (#1)**2) that matters
+! *** Note that cannot vary both #1 & #4. It's really only
+! *** the product ((#4) * (#1)**2) that matters
IF (Xx.NE.Blank) THEN
IF (Xx.EQ.Aaaaaa) THEN
IF (A.EQ.Zero) Parpmc(1,N) = 6.1691d0
@@ -678,7 +675,7 @@ C *** the product ((#4) * (#1)**2) that matters
END IF
N = N + 1
GO TO 10
-C
+!
20 CONTINUE
IF (Numpmc.NE.N-1) THEN
WRITE (6,10000) Numpmc, N
@@ -693,8 +690,9 @@ C
IF (Iflpmc(J,I).EQ.3) K3 = K3 + 1
END DO
END DO
-C
+!
IF (K1 .NE.Nvppmc) STOP '[STOP in Readpm in mpar04.f # 1]'
IF (K1+K3.NE.Nfppmc) STOP '[STOP in Readpm in mpar04.f # 2]'
RETURN
END
+end module par4_m
diff --git a/sammy/src/par/mpar05.f b/sammy/src/par/mpar05.f90
similarity index 78%
rename from sammy/src/par/mpar05.f
rename to sammy/src/par/mpar05.f90
index 74b71128c..1404717c9 100644
--- a/sammy/src/par/mpar05.f
+++ b/sammy/src/par/mpar05.f90
@@ -1,88 +1,90 @@
-C
-C *** February 9, 1993 This routine is separate from the rest
-C *** of the "READxx" routines in order to
-C *** use it in testing ORR parameters (program
-C *** SAMORT = SAMMY_ORR_TEST)
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Reador (Parorr, Iflorr, Delorr, Ecrnch, Endets, Sesese,
- * Eseses, Sigdts, Kfile)
-C
-C *** card set 9 of Parameter file
-C *** purpose -- READ ORResolution function parameters
-C
+!
+module par5_m
+ contains
+! *** February 9, 1993 This routine is separate from the rest
+! *** of the "READxx" routines in order to
+! *** use it in testing ORR parameters (program
+! *** SAMORT = SAMMY_ORR_TEST)
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Reador (Parorr, Iflorr, Delorr, Ecrnch, Endets, Sesese, &
+ Eseses, Sigdts, Kfile)
+!
+! *** card set 9 of Parameter file
+! *** purpose -- READ ORResolution function parameters
+!
use fixedi_m
use ifwrit_m
use fixedr_m
use Gachmi_common_m
use Orreso_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Parorr(Numorr), Iflorr(Numorr), Delorr(Numorr),
-C * Ecrnch(Numorr-11), Endets(Nmdets), Sesese(Nmdets), Eseses(Nmdets),
-C * Sigdts(Nmdets), Delorr(Numorr)
-C
- DIMENSION Parorr(*), Iflorr(*), Delorr(*), Ecrnch(*), Endets(*),
- * Sesese(*), Eseses(*), Sigdts(*)
-C
-C
- CHARACTER*5 What, Burst, Tanta, Water, NE110, Lithi, Chann,
- * Orres, Bbbbb
+!
+! DIMENSION Parorr(Numorr), Iflorr(Numorr), Delorr(Numorr),
+! * Ecrnch(Numorr-11), Endets(Nmdets), Sesese(Nmdets), Eseses(Nmdets),
+! * Sigdts(Nmdets), Delorr(Numorr)
+!
+ DIMENSION Parorr(*), Iflorr(*), Delorr(*), Ecrnch(*), Endets(*), &
+ Sesese(*), Eseses(*), Sigdts(*)
+!
+!
+ CHARACTER*5 What, Burst, Tanta, Water, NE110, Lithi, Chann, &
+ Orres, Bbbbb
DIMENSION Ene110(17), Sne110(17)
-C
- DATA Burst /'BURST'/, Tanta /'TANTA'/, Water /'WATER'/,
- * Ne110 /'NE110'/, Lithi /'LITHI'/, Chann /'CHANN'/,
- * Orres /'ORRES'/, Bbbbb /' '/
-C
+!
+ DATA Burst /'BURST'/, Tanta /'TANTA'/, Water /'WATER'/, &
+ Ne110 /'NE110'/, Lithi /'LITHI'/, Chann /'CHANN'/, &
+ Orres /'ORRES'/, Bbbbb /' '/
+!
DATA Mne110 /17/, Dne110 /0.0047d0/
- DATA Sne110 /27.200d0, 27.17d0, 27.02d0, 26.60 d0, 25.91d0,
- * 24.69d0, 21.77 d0, 18.51d0, 14.80d0, 11.999d0, 11.24d0,
- * 8.72d0, 7.28 d0, 4.89d0, 3.02d0, 2.22 d0, 2.03d0/
- DATA Ene110 / 10.00d0, 1000.d0, 2000.d0, 5000.d0,
- * 10000.d0, 20000.d0, 50000.d0, 100000.d0, 200000.d0,
- * 300000.d0, 400000.d0, 700000.d0, 1000000.d0, 2000000.d0,
- * 5000000.d0, 10000000.d0, 20000000.d0/
+ DATA Sne110 /27.200d0, 27.17d0, 27.02d0, 26.60d0, 25.91d0, &
+ 24.69d0, 21.77d0, 18.51d0, 14.80d0, 11.999d0, 11.24d0, &
+ 8.72d0, 7.28d0, 4.89d0, 3.02d0, 2.22d0, 2.03d0/
+ DATA Ene110 / 10.00d0, 1000.d0, 2000.d0, 5000.d0, &
+ 10000.d0, 20000.d0, 50000.d0, 100000.d0, 200000.d0, &
+ 300000.d0, 400000.d0, 700000.d0, 1000000.d0, 2000000.d0, &
+ 5000000.d0, 10000000.d0, 20000000.d0/
DATA Zero /0.0d0/
-C
-C
+!
+!
Nortx = Numorr
IF (Nortx.LT.0) Numorr = 11
Iold = 0
Lithne = 0
Kwatta = 0
-C
-C ***
+!
+! ***
10 CONTINUE
READ (Kfile,10100,ERR=60,END=60) What, I1, I2, I3, I4, A, B, C
10100 FORMAT (A5, 1X, 4I1, 4F10.1)
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 10
20 CONTINUE
-C
-C ***
+!
+! ***
IF (What.EQ.Orres) THEN
-C *** Header card only
+! *** Header card only
GO TO 10
-C
-C
-C ***
+!
+!
+! ***
ELSE IF (What.EQ.Bbbbb) THEN
-C *** Blank, end of the list
+! *** Blank, end of the list
GO TO 60
-C
-C ***
+!
+! ***
ELSE IF (What.EQ.Burst) THEN
-C *** burst width
+! *** burst width
Parorr(1) = a
Delorr(1) = b
Iflorr(1) = I1
-C
-C
-C ***
+!
+!
+! ***
ELSE IF (What.EQ.Water) THEN
-C *** water moderator
+! *** water moderator
Parorr(2) = A
Iflorr(2) = I1
Kwatta = 2
@@ -101,14 +103,14 @@ C *** water moderator
Mmmorr = I4
IF (Mmmorr.GT.10 .OR. Mmmorr.LT.1) Mmmorr = 4
Parorr(5) = dfloat(Mmmorr)
-C *** Read uncertainties for water moderator, or, for "old" input,
-C *** Read lithium-glass or ne110 detector information
+! *** Read uncertainties for water moderator, or, for "old" input,
+! *** Read lithium-glass or ne110 detector information
21 CONTINUE
READ (Kfile,10100) What, I1, I2, I3, I4, D, F, G
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 21
-C
-C ### following lines are for "old" input
+!
+! ### following lines are for "old" input
IF (What.EQ.Lithi) Iold = 1
IF (What.EQ.Ne110) Iold = 1
IF (Iold.EQ.1) THEN
@@ -119,29 +121,29 @@ C ### following lines are for "old" input
Delorr(2) = B
A = D
B = F
- C = G
+ ! = G
GO TO 20
END IF
-C ### preceeding lines are for "old" input
-C
+! ### preceeding lines are for "old" input
+!
Delorr(2) = D
Delorr(3) = F
Delorr(4) = G
-C
-C
-C ***
+!
+!
+! ***
ELSE IF (What.EQ.Tanta) THEN
-C *** Tantalum target
+! *** Tantalum target
Parorr(2) = A
Iflorr(2) = I1
Kwatta = 1
Delorr(2) = B
22 CONTINUE
- READ (Kfile,10100) What, I1, I2, I3, I4, Parorr(4), Parorr(5),
- * Parorr(6), Parorr(7)
+ READ (Kfile,10100) What, I1, I2, I3, I4, Parorr(4), Parorr(5), &
+ Parorr(6), Parorr(7)
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 22
-C *** 4=x1, 5=x2, 6=x3, 7=x0
+! *** 4=x1, 5=x2, 6=x3, 7=x0
IF (Parorr(5).LE.Parorr(4)) Parorr(5) = Parorr(4)
IF (Parorr(6).LE.Parorr(5)) Parorr(6) = Parorr(5)
Iflorr(4) = I1
@@ -149,16 +151,16 @@ C *** 4=x1, 5=x2, 6=x3, 7=x0
Iflorr(6) = I3
Iflorr(7) = I4
23 CONTINUE
- READ (Kfile,10100) What, I1, I2, I3, I4, Delorr(4), Delorr(5),
- * Delorr(6), Delorr(7)
+ READ (Kfile,10100) What, I1, I2, I3, I4, Delorr(4), Delorr(5), &
+ Delorr(6), Delorr(7)
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 23
-C
+!
24 CONTINUE
READ (Kfile,10100) What, I1, I2, I3, I4, Parorr(3), Parorr(8)
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 24
-C *** 3=www, 8=alpha
+! *** 3=www, 8=alpha
Iflorr(3) = I1
Iflorr(8) = I2
25 CONTINUE
@@ -166,11 +168,11 @@ C *** 3=www, 8=alpha
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 25
Mmmorr = 0
-C
-C
-C ***
+!
+!
+! ***
ELSE IF (What.EQ.Ne110) THEN
-C *** Here detector is Ne110
+! *** Here detector is Ne110
Lithne = 1
Parorr(9) = A
Iflorr(9) = I1
@@ -181,8 +183,7 @@ C *** Here detector is Ne110
Nmdets = I2*100 + I3*10 + I4
DO I=1,Nmdets
26 CONTINUE
- READ (Kfile,10100) What, I1, I2, I3, I4, Endets(I),
- * Sigdts(I)
+ READ (Kfile,10100) What, I1, I2, I3, I4, Endets(I), Sigdts(I)
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 26
END DO
@@ -194,8 +195,8 @@ C *** Here detector is Ne110
Sigdts(I) = Sne110(I)
END DO
END IF
-C *** Find the coefficients for linear interpolation from one energy
-C *** to the next
+! *** Find the coefficients for linear interpolation from one energy
+! *** to the next
DO I=1,Nmdets-1
Dele = Endets(I+1) - Endets(I)
X = Densty/Dele
@@ -208,10 +209,10 @@ C *** to the next
Parorr(11) = Zero
Delorr(11) = Zero
Iflorr(11) = 0
-C
-C ***
+!
+! ***
ELSE IF (What.EQ.Lithi) THEN
-C *** Here detector is lithium-glass
+! *** Here detector is lithium-glass
IF (B.EQ.Zero) WRITE (6,10200)
10200 FORMAT (' For lithium-glass detector, value of F cannot be Zero.')
IF (B.EQ.Zero) STOP '[STOP in Reador in par/mpar05.f]'
@@ -229,7 +230,7 @@ C *** Here detector is lithium-glass
Delorr( 9) = A
Delorr(10) = B
Delorr(11) = C
-C ### following lines are for old-fashioned input
+! ### following lines are for old-fashioned input
IF (Iold.EQ.1) THEN
Parorr( 9) = Parorr( 9)*1000.d0
Delorr( 9) = Delorr( 9)*1000.d0
@@ -264,11 +265,11 @@ C ### following lines are for old-fashioned input
STOP '[STOP in Reador in par/mpar05.f: missing f-values]'
END IF
END IF
-C
-C
-C ***
+!
+!
+! ***
ELSE IF (What.EQ.Chann) THEN
-C *** READ channel widths and uncertainties for energy-ranges specified
+! *** READ channel widths and uncertainties for energy-ranges specified
J = 1
IFlorr(J+11) = I1
Ecrnch(J ) = A
@@ -284,13 +285,11 @@ C *** READ channel widths and uncertainties for energy-ranges specified
DO J=2,Nnnnnn
Jj = J - 1
28 CONTINUE
- READ (Kfile,10100,END=30,ERR=30) What, I1, I2, I3, I4,
- * A, B, C
+ READ (Kfile,10100,END=30,ERR=30) What, I1, I2, I3, I4, A, B, C
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 28
IF (Nortx.LT.0) THEN
- IF (What.EQ.' ' .AND. I1.EQ.0 .AND. A.EQ.Zero) GO
- * TO 30
+ IF (What.EQ.' ' .AND. I1.EQ.0 .AND. A.EQ.Zero) GO TO 30
END IF
IFlorr(J+11) = I1
Ecrnch(J ) = A
@@ -337,30 +336,30 @@ C *** READ channel widths and uncertainties for energy-ranges specified
END DO
50 CONTINUE
END IF
-C
-C
-C ***
+!
+!
+! ***
END IF
-C ***
+! ***
GO TO 10
-C
-C
-C ***
+!
+!
+! ***
60 CONTINUE
IF (Parorr(2).GT.60.0d0) THEN
WRITE (21,10400)
WRITE ( 6,10400)
-10400 FORMAT (/, ' ###############################################',
- * /, ' SAMMY may not have read ORResolution function', /,
- * ' correctly. Please compare your intended input to', /,
- * ' these values:')
+10400 FORMAT (/, ' ###############################################', &
+ /, ' SAMMY may not have read ORResolution function', /, &
+ ' correctly. Please compare your intended input to', /, &
+ ' these values:')
WRITE (21,10500) (I, Parorr(I),I=1,Numorr)
WRITE ( 6,10500) (I, Parorr(I),I=1,Numorr)
10500 FORMAT (' Parorr(', I2, ') =', 1PG20.13)
END IF
-C
-C ***
-C *** done reading input; now generate other info
+!
+! ***
+! *** done reading input; now generate other info
K1 = 0
K3 = 0
DO I=1,Numorr
@@ -370,22 +369,23 @@ C *** done reading input; now generate other info
IF (Iflorr(I).EQ.3) K3 = K3 + 1
END DO
IF (Kiporr.EQ.1) WRITE (21,10600) Numorr, K1
-10600 FORMAT (' Number of ORELA-Resolution parameters is', I5, /,
- * ' and the number varied is', I5)
+10600 FORMAT (' Number of ORELA-Resolution parameters is', I5, /, &
+ ' and the number varied is', I5)
IF (Kiporr.EQ.0) WRITE (21,10700) Numorr
10700 FORMAT (' Number of ORELA-Resolution parameters is', I5)
IF (K3.GT.0) WRITE (21,10800) K3
10800 FORMAT (' Number of PUPped ORR parameters is', I5)
-C
+!
IF (K1 .NE.Nvporr) THEN
STOP '[STOP in Reador in mpar05.f # 1]'
END IF
IF (K1+K3.NE.Nfporr) STOP '[STOP in Reador in mpar05.f # 2]'
-C
+!
IF (Lithne.NE.0) RETURN
IF (Parorr(1).NE.Zero) RETURN
IF (Numorr.GT.11 .AND. Parorr(Numorr).NE.Zero) RETURN
-C *** here only the tantalum target or water moderator contributes to resolution
+! *** here only the tantalum target or water moderator contributes to resolution
Kwatta = - Kwatta
RETURN
END
+end module par5_m
\ No newline at end of file
diff --git a/sammy/src/par/mpar06.f b/sammy/src/par/mpar06.f90
similarity index 72%
rename from sammy/src/par/mpar06.f
rename to sammy/src/par/mpar06.f90
index 1d2c3301e..68e8e8310 100644
--- a/sammy/src/par/mpar06.f
+++ b/sammy/src/par/mpar06.f90
@@ -1,15 +1,17 @@
-C
-C *** This routine is separate from the rest of the "Readxx" routines in
-C *** order to use it in testing RPI parameters (program SAMRPT =
-C *** SAMmy_RPi_Test)
-C
-C --------------------------------------------------------------
-C
+!
+module par6_m
+ contains
+! *** This routine is separate from the rest of the "Readxx" routines in
+! *** order to use it in testing RPI parameters (program SAMRPT =
+! *** SAMmy_RPi_Test)
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readrp (Parrpi, Iflrpi, Delrpi, Ecrnch, Kfile)
-C
-C *** Card Set 14
-C *** Purpose -- Read RPI resolution function parameters
-C
+!
+! *** Card Set 14
+! *** Purpose -- Read RPI resolution function parameters
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -18,43 +20,43 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Parrpi(Numrpi), Iflrpi(Numrpi), Delrpi(Numrpi),
-C * Ecrnch(Numrpi-Nnnrpi)
-C
+!
+! DIMENSION Parrpi(Numrpi), Iflrpi(Numrpi), Delrpi(Numrpi),
+! * Ecrnch(Numrpi-Nnnrpi)
+!
DIMENSION Parrpi(*), Iflrpi(*), Delrpi(*), Ecrnch(*)
-C
- CHARACTER*5 What, Elsex, Burst, Tauxxx, Lambda, Aaaone, Expone,
- * A3xxxx, A5xxxx, Xxpone, Chann, Bbbbb, Rpires, A3sqee, A5sqee,
- * Binpdc
-C
- DATA Burst /'BURST'/, Tauxxx /'TAU '/, Lambda /'LAMBD'/,
- * Aaaone /'A1 '/, Expone /'EXPON'/, A3xxxx /'A3 '/,
- * A5xxxx /'A5 '/, Xxpone /'XXPON'/, Chann /'CHANN'/,
- * A3sqee /'A3SQE'/, A5sqee /'A5SQE'/, Binpdc /'BINS '/
-C
+!
+ CHARACTER*5 What, Elsex, Burst, Tauxxx, Lambda, Aaaone, Expone, &
+ A3xxxx, A5xxxx, Xxpone, Chann, Bbbbb, Rpires, A3sqee, A5sqee, &
+ Binpdc
+!
+ DATA Burst /'BURST'/, Tauxxx /'TAU '/, Lambda /'LAMBD'/, &
+ Aaaone /'A1 '/, Expone /'EXPON'/, A3xxxx /'A3 '/, &
+ A5xxxx /'A5 '/, Xxpone /'XXPON'/, Chann /'CHANN'/, &
+ A3sqee /'A3SQE'/, A5sqee /'A5SQE'/, Binpdc /'BINS '/
+!
DATA Bbbbb /' '/, Rpires /'RPI R'/
DATA Zero /0.0d0/
-C
+!
Ichbin = 0
Ifnumo = 0
-C
-C
+!
+!
IF (Dist.LE.Zero) THEN
WRITE (6,10100)
-10100 FORMAT ('Must have positive value for DIST when using RPI',
- * 1X, 'resolution function.')
+10100 FORMAT ('Must have positive value for DIST when using RPI', &
+ 1X, 'resolution function.')
STOP '[Stop in Readrp in par/mpar06.f]'
END IF
-C
+!
CALL Test_Midrpi (Midrpi)
-C
+!
Iseta1 = 0
CALL Zero_Array (Parrpi, Numrpi)
CALL Zero_Array (Delrpi, Numrpi)
IF (Numrpi.GT.Nnnrpi) CALL Zero_Array (Ecrnch, Numrpi-Nnnrpi)
CALL Zero_Integer (Iflrpi, Numrpi)
-C
+!
If_Rpi_Chi = 0
If_Rpi_Exp = 0
Jtrip = 0
@@ -62,49 +64,48 @@ C
Mmmrpi = 0
Medrpi = 0
Itdchi = 1
-C
+!
Kount_Card = 0
10 CONTINUE
IF (Kount_Card.LT.Kntchn) THEN
-CX READ (Kfile,99999,ERR=30,END=20) What, I1, I2, I3, I4, I5, A,
- READ (Kfile,99999,ERR=20,END=20) What, I1, I2, I3, I4, I5, A,
- * B, C, D, E, F, G
+!X READ (Kfile,99999,ERR=30,END=20) What, I1, I2, I3, I4, I5, A,
+ READ (Kfile,99999,ERR=20,END=20) What, I1, I2, I3, I4, I5, A, &
+ B, C, D, E, F, G
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 10
ELSE
-CX READ (Kfile,99999,ERR=30,END=20) What, I1, I2, I3, I4, I5, A,
- READ (Kfile,99999,ERR=20,END=20) What, I1, I2, I3, I4, I5, A,
- * B, C
+!X READ (Kfile,99999,ERR=30,END=20) What, I1, I2, I3, I4, I5, A,
+ READ (Kfile,99999,ERR=20,END=20) What, I1, I2, I3, I4, I5, A, B, C
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 10
END IF
Kount_Card = Kount_Card + 1
Jtrip = Jtrip + 1
IF (Jtrip.GT.1000) STOP '[Stop in Readrp in par/mpar06.f # 2]'
-C
-C ***
+!
+! ***
IF (What.EQ.Rpires) THEN
-C *** Just re-read if this is the header "card" (line)
-C
-C ***
+! *** Just re-read if this is the header "card" (line)
+!
+! ***
ELSE IF (What.EQ.Bbbbb) THEN
-C *** Blank line so we're done
+! *** Blank line so we're done
GO TO 20
-C
-C ***
+!
+! ***
ELSE IF (What.EQ.Burst) THEN
-C *** Line 2 of Card Set 14 -- Burst Width
+! *** Line 2 of Card Set 14 -- Burst Width
IF (Kumrpi.LE.1) Kumrpi = 1
Parrpi(1) = A
Delrpi(1) = B
Iflrpi(1) = I1
-C
-C ***
+!
+! ***
ELSE IF (What.EQ.Tauxxx) THEN
If_Rpi_Chi = 1
-C *** Line 3 of Card Set 14
-C *** chi squared function; tau-parameters
-C *** tau = a exp(-bE) + b exp(-cE) + e + f E^g
+! *** Line 3 of Card Set 14
+! *** chi squared function; tau-parameters
+! *** tau = a exp(-bE) + b exp(-cE) + e + f E^g
Itdchi = 1
IF (Kumrpi.LE.6) Kumrpi = 8
Parrpi(2) = A
@@ -122,10 +123,10 @@ C *** tau = a exp(-bE) + b exp(-cE) + e + f E^g
Iflrpi(4) = I3
Iflrpi(5) = I4
Iflrpi(6) = I5
-CX READ (Kfile,99999,END=20) What, I1, I2, I3, I4, i5, A,
- READ (Kfile,99999,END=20,ERR=20) What, I1, I2, I3, I4, I5, A,
- * B, C, D, E, F, G
-C *** Line 4 of Card Set 14
+!X READ (Kfile,99999,END=20) What, I1, I2, I3, I4, i5, A,
+ READ (Kfile,99999,END=20,ERR=20) What, I1, I2, I3, I4, I5, A, &
+ B, C, D, E, F, G
+! *** Line 4 of Card Set 14
Kount_Card = Kount_Card + 1
Iflrpi(7) = I1
Iflrpi(8) = I2
@@ -136,12 +137,12 @@ C *** Line 4 of Card Set 14
Delrpi(6) = E
Delrpi(7) = F
Delrpi(8) = G
-C
-C ***
+!
+! ***
ELSE IF (What.EQ.Lambda) THEN
If_Rpi_Chi = 1
-C *** Line 5 of Card Set 14
-C *** lambda parameters for chi squared function
+! *** Line 5 of Card Set 14
+! *** lambda parameters for chi squared function
IF (Kumrpi.LE.13) Kumrpi = 13
Parrpi( 9) = A
Parrpi(10) = B
@@ -158,22 +159,22 @@ C *** lambda parameters for chi squared function
Iflrpi(11) = I3
Iflrpi(12) = I4
Iflrpi(13) = I5
-CX READ (Kfile,99999,END=20) What, I1, I2, I3, I4, I5, A, B, C,
- READ (Kfile,99999,END=20,ERR=20) What, I1, I2, I3, I4, I5, A,
- * B, C, D, E, F, G
-C *** Line 6 of Card Set 14
+!X READ (Kfile,99999,END=20) What, I1, I2, I3, I4, I5, A, B, C,
+ READ (Kfile,99999,END=20,ERR=20) What, I1, I2, I3, I4, I5, A, &
+ B, C, D, E, F, G
+! *** Line 6 of Card Set 14
Kount_Card = Kount_Card + 1
Delrpi( 9) = A
Delrpi(10) = B
Delrpi(11) = C
Delrpi(12) = D
Delrpi(13) = E
-C
-C ***
+!
+! ***
ELSE IF (What.EQ.Aaaone) THEN
If_Rpi_Exp = 1
-C *** Line 7 of Card Set 14
-C *** A1 = a exp(-bE) + c exp(-dE) + e + fE^g
+! *** Line 7 of Card Set 14
+! *** A1 = a exp(-bE) + c exp(-dE) + e + fE^g
IF (Kumrpi.LE.20) Kumrpi = 20
Iseta1 = 1
Parrpi(14) = A
@@ -188,10 +189,10 @@ C *** A1 = a exp(-bE) + c exp(-dE) + e + fE^g
Iflrpi(16) = I3
Iflrpi(17) = I4
Iflrpi(18) = I5
-CX READ (Kfile,99999,end=20) What, I1, I2, I3, I4, I5, A, B, C,
- READ (Kfile,99999,END=20,ERR=20) What, I1, I2, I3, I4, I5, A,
- * B, C, D, E, F, G
-C *** Line 8 of Card Set 14
+!X READ (Kfile,99999,end=20) What, I1, I2, I3, I4, I5, A, B, C,
+ READ (Kfile,99999,END=20,ERR=20) What, I1, I2, I3, I4, I5, A, &
+ B, C, D, E, F, G
+! *** Line 8 of Card Set 14
Kount_Card = Kount_Card + 1
Iflrpi(19) = I1
Iflrpi(20) = I2
@@ -202,16 +203,16 @@ C *** Line 8 of Card Set 14
Delrpi(18) = E
Delrpi(19) = F
Delrpi(20) = G
-C
-C ***
+!
+! ***
ELSE IF (What.EQ.Expone) THEN
If_Rpi_Exp = 1
-C *** Line 9 of Card Set 14
-C *** parameters for exponential functions, including tzero=Shift
+! *** Line 9 of Card Set 14
+! *** parameters for exponential functions, including tzero=Shift
IF (Kumrpi.LE.25) Kumrpi = 25
-C
+!
IF (Iseta1.EQ.0) THEN
-C ??? here parameters for A1 have not been read. Ergo, define as 1.
+! ??? here parameters for A1 have not been read. Ergo, define as 1.
Parrpi(18) = 1.0d-3
END IF
Parrpi(21) = A
@@ -224,23 +225,23 @@ C ??? here parameters for A1 have not been read. Ergo, define as 1.
Iflrpi(23) = I3
Iflrpi(24) = I4
Iflrpi(25) = I5
-CX READ (Kfile,99999,end=20) What, I1, I2, I3, I4, I5, A, B, C,
- READ (Kfile,99999,END=20,ERR=20) What, I1, I2, I3, I4, I5, A,
- * B, C, D, E, F, G
-C *** Line 10 of Card Set 14
+!X READ (Kfile,99999,end=20) What, I1, I2, I3, I4, I5, A, B, C,
+ READ (Kfile,99999,END=20,ERR=20) What, I1, I2, I3, I4, I5, A, &
+ B, C, D, E, F, G
+! *** Line 10 of Card Set 14
Kount_Card = Kount_Card + 1
Delrpi(21) = A
Delrpi(22) = B
Delrpi(23) = C
Delrpi(24) = D
Delrpi(25) = E
-C
-C ***
+!
+! ***
ELSE IF (What.EQ.A3xxxx .OR. What.EQ.A3sqee) THEN
If_Rpi_Exp = 1
-C *** Line 11 of Card Set 14
-C *** Parameters for energy-dependent exponential function, to
-C *** be used instead of Parrpi(23)=A3,
+! *** Line 11 of Card Set 14
+! *** Parameters for energy-dependent exponential function, to
+! *** be used instead of Parrpi(23)=A3,
IF (Kumrpi.GT.25) STOP '[STOP in Readrp in par/mpar06.f #3]'
IF (Kumrpi.LE.25) Kumrpi = 25
Parrpi(Kumrpi+1) = A
@@ -255,9 +256,9 @@ C *** be used instead of Parrpi(23)=A3,
Iflrpi(Kumrpi+3) = I3
Iflrpi(Kumrpi+4) = I4
Iflrpi(Kumrpi+5) = I5
- READ (Kfile,99999,END=20,ERR=20) Elsex, I1, I2, I3, I4, I5, A,
- * B, C, D, E, F, G
-C *** Line 12, Uncertainties on A3 components; flag whether sqrt(E)
+ READ (Kfile,99999,END=20,ERR=20) Elsex, I1, I2, I3, I4, I5, A, &
+ B, C, D, E, F, G
+! *** Line 12, Uncertainties on A3 components; flag whether sqrt(E)
Kount_Card = Kount_Card + 1
Iflrpi(Kumrpi+6) = I1
Iflrpi(Kumrpi+7) = I2
@@ -276,13 +277,13 @@ C *** Line 12, Uncertainties on A3 components; flag whether sqrt(E)
Delrpi(Kumrpi+7) = G
Kumrpi = Kumrpi + 7
Medrpi = Medrpi + 7
-C
-C ***
+!
+! ***
ELSE IF (What.EQ.A5xxxx .OR. What.EQ.A5sqee) THEN
If_Rpi_Exp = 1
-C *** Line 13 of Card Set 14
-C *** Parameters for energy-dependent exponential function, to
-C *** be used instead of Parrpi(25)=A5,
+! *** Line 13 of Card Set 14
+! *** Parameters for energy-dependent exponential function, to
+! *** be used instead of Parrpi(25)=A5,
Parrpi(Kumrpi+1) = A
Parrpi(Kumrpi+2) = B
Parrpi(Kumrpi+3) = C
@@ -295,9 +296,9 @@ C *** be used instead of Parrpi(25)=A5,
Iflrpi(Kumrpi+3) = I3
Iflrpi(Kumrpi+4) = I4
Iflrpi(Kumrpi+5) = I5
- READ (Kfile,99999,END=20,ERR=20) Elsex, I1, I2, I3, I4, I5, A,
- * B,C, D, E, F, G
-C *** Line 14, Uncertainties on Exponential; plus flags
+ READ (Kfile,99999,END=20,ERR=20) Elsex, I1, I2, I3, I4, I5, A, &
+ B,C, D, E, F, G
+! *** Line 14, Uncertainties on Exponential; plus flags
Kount_Card = Kount_Card + 1
Iflrpi(Kumrpi+6) = I1
Iflrpi(Kumrpi+7) = I2
@@ -316,20 +317,20 @@ C *** Line 14, Uncertainties on Exponential; plus flags
Delrpi(Kumrpi+7) = G
Kumrpi = Kumrpi + 7
Medrpi = Medrpi + 7
-C
-C ***
+!
+! ***
ELSE IF (What.EQ.Xxpone) THEN
-C *** Line 15 of Card Set 14
-C *** parameters for extra exponential functions; first, constant
+! *** Line 15 of Card Set 14
+! *** parameters for extra exponential functions; first, constant
Parrpi(Kumrpi+1) = A
Delrpi(Kumrpi+1) = B
Iflrpi(Kumrpi+1) = I1
Kumrpi = Kumrpi + 1
Mmmrpi = Mmmrpi + 1
IF (C.EQ.Zero .AND. D.EQ.Zero .AND. I2.EQ.0) THEN
- READ (Kfile,99999,END=20,ERR=20) What, I1, I2, I3, I4, I5,
- * A, B, C, D, E, F, G
-C *** Line 16, exponential
+ READ (Kfile,99999,END=20,ERR=20) What, I1, I2, I3, I4, I5, &
+ A, B, C, D, E, F, G
+! *** Line 16, exponential
Kount_Card = Kount_Card + 1
Parrpi(Kumrpi+1) = A
Parrpi(Kumrpi+2) = B
@@ -343,9 +344,9 @@ C *** Line 16, exponential
Iflrpi(Kumrpi+3) = I3
Iflrpi(Kumrpi+4) = I4
Iflrpi(Kumrpi+5) = I5
- READ (Kfile,99999,END=20,ERR=20) What, I1, I2, I3, I4, I5,
- * A, B, C, D, E, F, G
-C *** Line 17, Uncertainties on Exponential
+ READ (Kfile,99999,END=20,ERR=20) What, I1, I2, I3, I4, I5, &
+ A, B, C, D, E, F, G
+! *** Line 17, Uncertainties on Exponential
Kount_Card = Kount_Card + 1
Iflrpi(Kumrpi+6) = I1
Iflrpi(Kumrpi+7) = I2
@@ -365,22 +366,21 @@ C *** Line 17, Uncertainties on Exponential
Kumrpi = Kumrpi + 7
Mmmrpi = Mmmrpi + 7
END IF
-C
-C ***
+!
+! ***
ELSE IF (What.EQ.Binpdc) THEN
IF (Ichbin.EQ.2) THEN
Write (6,10200)
Write (21,10200)
-10200 FORMAT (' Cannot use continuously-varying channel widths (Lin
- *ne 19) and', /,
- * ' discrete channel widths (Line 20) together.')
+10200 FORMAT (' Cannot use continuously-varying channel widths ', &
+ /,' (Line 19) and discrete channel widths (Line 20) together.')
STOP
END IF
Ichbin = 1
Nbinpd = I5 + 10*(I4+10*(I3+10*(I2+10*I1)))
GO TO 20
-C
-C ***
+!
+! ***
ELSE IF (What.EQ.Chann) THEN
IF (Ichbin.EQ.1) THEN
Write (6,10200)
@@ -388,41 +388,40 @@ C ***
STOP
END IF
Ichbin = 2
-C *** Line 20 of Card Set 14
-C *** channel widths and uncertainties for energy-ranges specified
- CALL Readrp_Ch (Parrpi, Iflrpi, Delrpi, Ecrnch, Kfile,
- * Kumrpi, I2, A, B, C, Kount_Card, Ifnumo)
+! *** Line 20 of Card Set 14
+! *** channel widths and uncertainties for energy-ranges specified
+ CALL Readrp_Ch (Parrpi, Iflrpi, Delrpi, Ecrnch, Kfile, &
+ Kumrpi, I2, A, B, C, Kount_Card, Ifnumo)
GO TO 20
-C
-C
+!
+!
END IF
GO TO 10
-C
-C
+!
+!
20 CONTINUE
-C *** done reading input; now generate other info
- CALL Readrp_Finish (Parrpi, Iflrpi, Delrpi, Ecrnch, Kumrpi,
- * Ifnumo)
+! *** done reading input; now generate other info
+ CALL Readrp_Finish (Parrpi, Iflrpi, Delrpi, Ecrnch, Kumrpi, Ifnumo)
Lother = Mmmrpi/8
RETURN
-C
-C
-CX 30 CONTINUE
-CX WRITE (6,10600)
-CX10600 FORMAT(' Error in reading file "Kfile" first time in to Readrp')
-CX GO TO 10
-C
+!
+!
+!X 30 CONTINUE
+!X WRITE (6,10600)
+!X10600 FORMAT(' Error in reading file "Kfile" first time in to Readrp')
+!X GO TO 10
+!
99999 FORMAT (A5, 5I1, 7F10.1)
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readr1 (Parrpi, Iflrpi, Delrpi, Ecrnch, Kfile, Ialt)
-C
-C *** Card Set 14, alt 1 or 2
-C *** Purpose -- generate RPI transmission resolution function parameters
-C
+!
+! *** Card Set 14, alt 1 or 2
+! *** Purpose -- generate RPI transmission resolution function parameters
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -431,36 +430,35 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Parrpi(Numrpi), Iflrpi(Numrpi), Delrpi(Numrpi),
-C * Ecrnch(Numrpi-Nnnrpi)
-C
+!
+! DIMENSION Parrpi(Numrpi), Iflrpi(Numrpi), Delrpi(Numrpi),
+! * Ecrnch(Numrpi-Nnnrpi)
+!
DIMENSION Parrpi(*), Iflrpi(*), Delrpi(*), Ecrnch(*)
-C
-C
+!
+!
CHARACTER*5 What, Burst, Chann, Bbbbb, Rpitra, Rpicap, Binpdc
-C
+!
DATA Burst /'BURST'/, Chann /'CHANN'/, Binpdc /'BINS '/
DATA Bbbbb /' '/, Rpitra /'RPI T'/, Rpicap /'RPI C'/
-C
-C
+!
+!
If_Rpi_Chi = 1
If_Rpi_Exp = 1
CALL Test_Midrpi (Midrpi)
-C
+!
CALL Zero_Array (Parrpi, Numrpi)
CALL Zero_Array (Delrpi, Numrpi)
IF (Numrpi.GT.Nnnrpi) CALL Zero_Array (Ecrnch, Numrpi-Nnnrpi)
CALL Zero_Integer (Iflrpi, Numrpi)
-C
-C ***
-C *** chi squared function; tau-parameters
-C *** tau = a exp(-bE) + b exp(-cE) + e
+!
+! ***
+! *** chi squared function; tau-parameters
+! *** tau = a exp(-bE) + b exp(-cE) + e
IF (Ialt.EQ.1) THEN
IF (Krpitc.EQ.2) THEN
WRITE (6,10000)
-10000 FORMAT (' Cannot use RPI Transmission defaults if data type is
- *is capture.')
+10000 FORMAT (' Cannot use RPI Transmission defaults if data type is capture.')
STOP '[Stop in Readr1 in par/mpar06.f]'
END IF
Parrpi(2) = 326.0000d0
@@ -472,8 +470,7 @@ C *** tau = a exp(-bE) + b exp(-cE) + e
IF (Krpitc.NE.2) THEN
WRITE (6,10100)
WRITE (21,10100)
-10100 FORMAT (' Cannot use RPI Capture defaults unless data type is
- *s capture.')
+10100 FORMAT (' Cannot use RPI Capture defaults unless data type is capture.')
STOP '[Cannot use RPI Capture defaults if not capture data]'
END IF
Parrpi(2) = 381.0000d0
@@ -482,15 +479,15 @@ C *** tau = a exp(-bE) + b exp(-cE) + e
Parrpi(5) = 0.0940d0
Parrpi(6) = 105.0000d0
END IF
-C
-C ***
-C *** lambda parameters for chi squared function
+!
+! ***
+! *** lambda parameters for chi squared function
Parrpi( 9) = 686.50d0
Parrpi(10) = -224.90d0
Parrpi(11) = 21.04d0
-C
-C ***
-C *** A1 = a exp(-bE) + c exp(-dE) + e
+!
+! ***
+! *** A1 = a exp(-bE) + c exp(-dE) + e
IF (Ialt.EQ.1) THEN
Parrpi(14) = -0.000985d0
Parrpi(15) = 0.024100d0
@@ -504,22 +501,22 @@ C *** A1 = a exp(-bE) + c exp(-dE) + e
Parrpi(17) = 65.083000d0
Parrpi(18) = 0.001264d0
END IF
-C
-C ***
-C *** Parameters for exponential functions, including tzero=Shift
+!
+! ***
+! *** Parameters for exponential functions, including tzero=Shift
Parrpi(21) = 940.00000d0
Parrpi(22) = -65.63800d0
Parrpi(23) = 0.00500d0
Parrpi(24) = 0.39383d0
Parrpi(25) = 0.00080d0
-C
+!
DO I=2,Nnnrpi
Iflrpi(I) = 0
Delrpi(I) = dABS(Parrpi(I))*0.10d0
END DO
-C
-C
-C *** Finished setting default values. Now read burst & channel values.
+!
+!
+! *** Finished setting default values. Now read burst & channel values.
Kount_Card = 0
Jtrip = 0
@@ -530,83 +527,81 @@ C *** Finished setting default values. Now read burst & channel values.
Nnnrpi = 25
Itdchi = 0
Ichbin = 0
-C
+!
10 CONTINUE
-CX READ (Kfile,99999,ERR=50,END=20) What, I1, I2, I3, I4, I5, A, B,
- READ (Kfile,99999,ERR=20,END=20) What, I1, I2, I3, I4, I5, A, B,
- * C, D, E, F, G
+!X READ (Kfile,99999,ERR=50,END=20) What, I1, I2, I3, I4, I5, A, B,
+ READ (Kfile,99999,ERR=20,END=20) What, I1, I2, I3, I4, I5, A, B, &
+ C, D, E, F, G
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 10
IF (Ialt.EQ.1 .AND. What.EQ.Rpitra) GO TO 10
IF (Ialt.EQ.2 .AND. What.EQ.Rpicap) GO TO 10
Jtrip = Jtrip + 1
-C
+!
IF (What.EQ.Bbbbb) THEN
GO TO 20
-C
+!
ELSE IF (What.EQ.Burst) THEN
-C *** Line 2 of Card Set 14a -- Burst Width
+! *** Line 2 of Card Set 14a -- Burst Width
Parrpi(1) = A
Delrpi(1) = B
Iflrpi(1) = I1
-C
+!
ELSE IF (What.EQ.Binpdc) THEN
-C *** Line 19 of Card Set 14a -- Continuously-varying channel width
+! *** Line 19 of Card Set 14a -- Continuously-varying channel width
IF (Ichbin.EQ.2) THEN
Write (6,10200)
Write (21,10200)
-10200 FORMAT (' Cannot use continuously-varying channel widths (Lin
- *ne 19) and', /,
- * ' discrete channel widths (Line 20) together.')
+10200 FORMAT (' Cannot use continuously-varying channel widths (Line 19)',&
+ /,' and discrete channel widths (Line 20) together.')
STOP
END IF
Ichbin = 1
Nbinpd = I5 + 10*(I4+10*(I3+10*(I2+10*I1)))
GO TO 20
-C
+!
ELSE IF (What.EQ.Chann) THEN
-C *** Line 20 of Card Set 14a
-C *** channel widths and uncertainties for energy-ranges specified
+! *** Line 20 of Card Set 14a
+! *** channel widths and uncertainties for energy-ranges specified
IF (Ichbin.EQ.1) THEN
Write (6,10200)
Write (21,10200)
STOP
END IF
Ichbin = 2
- CALL Readrp_Ch (Parrpi, Iflrpi, Delrpi, Ecrnch, Kfile,
- * Kumrpi, I2, A, B, C, Kount_Card, Ifnumo)
+ CALL Readrp_Ch (Parrpi, Iflrpi, Delrpi, Ecrnch, Kfile, &
+ Kumrpi, I2, A, B, C, Kount_Card, Ifnumo)
GO TO 20
-C ***
+! ***
END IF
GO TO 10
-C
+!
20 CONTINUE
-C *** done reading input; now generate other info
- CALL Readrp_Finish (Parrpi, Iflrpi, Delrpi, Ecrnch, Kumrpi,
- * Ifnumo)
+! *** done reading input; now generate other info
+ CALL Readrp_Finish (Parrpi, Iflrpi, Delrpi, Ecrnch, Kumrpi, Ifnumo)
RETURN
-C
+!
50 CONTINUE
WRITE (6,10300)
10300 FORMAT(' Error in reading file "Kfile" first time in to Readr1')
GO TO 10
-C
+!
99999 FORMAT (A5, 5I1, 7F10.1)
END
-C
-C
-C ---------------------------------------------------------------------
-C
+!
+!
+! ---------------------------------------------------------------------
+!
SUBROUTINE Test_Midrpi (Midrpi)
IF (Midrpi.EQ.-1) THEN
WRITE (6,50100)
WRITE (21,50100)
-50100 FORMAT (' INPut file did not specify whether to Shift the RPI',
- * 1x, 'resolution', /,
- * ' function. The INPut file must contain one or the other',
- * 1x, 'of --', /,
- * ' >> SHIFT RPI RESOLUTION function to center <<; or', /,
- * ' >> DO NOT SHIFT RPI RESOlution function to center <<', /)
+50100 FORMAT (' INPut file did not specify whether to Shift the RPI', &
+ 1x, 'resolution', /, &
+ ' function. The INPut file must contain one or the other', &
+ 1x, 'of --', /, &
+ ' >> SHIFT RPI RESOLUTION function to center <<; or', /, &
+ ' >> DO NOT SHIFT RPI RESOlution function to center <<', /)
STOP '[Stop in Test_Midrpi in par/mpar06.f]'
ELSE
IF (Midrpi.EQ.1) WRITE (21,50200)
@@ -616,27 +611,26 @@ C
END IF
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Readrp_Finish (Parrpi, Iflrpi, Delrpi, Ecrnch, Kumrpi,
- * Ifnumo)
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Readrp_Finish (Parrpi, Iflrpi, Delrpi, Ecrnch, Kumrpi, Ifnumo)
use fixedi_m
use ifwrit_m
use fixedr_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Parrpi(*), Iflrpi(*), Delrpi(*), Ecrnch(*)
DATA Zero /0.0d0/
-C
+!
IF (Kumrpi.GT.Numrpi) THEN
WRITE (6,10100) Kumrpi, Numrpi
-10100 FORMAT (' Counting more RPI parameters in Par than in INP',
- * 2I5, /, ' This may be a bug in the code.')
+10100 FORMAT (' Counting more RPI parameters in Par than in INP', &
+ 2I5, /, ' This may be a bug in the code.')
ELSE
Numrpi = Kumrpi
END IF
-C
+!
K3 = 0
K1 = 0
DO I=1,Numrpi
@@ -646,13 +640,13 @@ C
IF (Iflrpi(I).EQ.3) K3 = K3 + 1
END DO
IF (Ifnumo.EQ.0 .AND. Kiprpi.EQ.1) WRITE (21,10300) Numrpi, K1
-10300 FORMAT (' Number of RPI Resolution parameters is', I5, /,
- * ' and the number varied is', I5)
+10300 FORMAT (' Number of RPI Resolution parameters is', I5, /, &
+ ' and the number varied is', I5)
IF (Ifnumo.EQ.0 .AND. Kiprpi.EQ.0) WRITE (21,10400) Numrpi
10400 FORMAT (' Number of RPI Resolution parameters is', I5)
IF (K3.GT.0) WRITE (21,10500) K3
10500 FORMAT (' Number of PUPped RPI parameters is', I5)
-C
+!
IF (K1.NE.Nvprpi) THEN
WRITE (6,10600) K1, K3, Nvprpi, Nfprpi
10600 FORMAT ('K1, K3, Nvprpi, Nfprpi=', 5I10)
@@ -663,28 +657,28 @@ C
WRITE (6,10600) K1, K3, Nvprpi, Nfprpi
STOP '[STOP in Readrp_Finish in mpar06.f # 2]'
END IF
-C
+!
DO I=1,Numrpi
IF (Delrpi(I).EQ.Zero) Delrpi(I) = dABS(Parrpi(i))*Fudge
IF (Delrpi(I).EQ.Zero) Delrpi(I) = 1.0d-5
END DO
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Readrp_Ch (Parrpi, Iflrpi, Delrpi, Ecrnch, Kfile,
- * Kumrpi, I2, A, B, C, Kount_Card, Ifnumo)
-C
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Readrp_Ch (Parrpi, Iflrpi, Delrpi, Ecrnch, Kfile, &
+ Kumrpi, I2, A, B, C, Kount_Card, Ifnumo)
+!
use fixedi_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Parrpi(*), Iflrpi(*), Delrpi(*), Ecrnch(*)
-C
+!
CHARACTER*5 Bbbbb, What
DATA Bbbbb /' '/
DATA Zero /0.0d0/
-C
+!
Iflrpi(1+Nnnrpi) = I2
Ecrnch(1) = A
Parrpi(1+Nnnrpi) = B
@@ -693,11 +687,10 @@ C
Nnnnnn = Numrpi - Nnnrpi
IF (Nnnnnn.GT.1) THEN
DO J=2,Nnnnnn
-CX READ (Kfile,99999,END=100) What, I1, I2, I3, I4, I5, A, B, C
- READ (Kfile,99999,END=100,ERR=100) What, I1, I2, I3, I4, I5,
- * A, B, C
+!X READ (Kfile,99999,END=100) What, I1, I2, I3, I4, I5, A, B, C
+ READ (Kfile,99999,END=100,ERR=100) What, I1, I2, I3, I4, I5, A, B, C
99999 FORMAT (A5, 5I1, 7F10.1)
-C *** Card 11 of Card Set 14
+! *** Card 11 of Card Set 14
Kount_Card = Kount_Card + 1
IF (What.EQ.Bbbbb) GO TO 110
Iflrpi(J+Nnnrpi) = I2
@@ -709,22 +702,22 @@ C *** Card 11 of Card Set 14
END IF
Ifnumo = 0
GO TO 120
-C
+!
100 CONTINUE
- IF (What.EQ.Bbbbb .AND. Iflrpi(J+Nnnrpi).EQ.0 .AND.
- * Ecrnch(J).EQ.Zero) J = J - 1
+ IF (What.EQ.Bbbbb .AND. Iflrpi(J+Nnnrpi).EQ.0 .AND. &
+ Ecrnch(J).EQ.Zero) J = J - 1
110 Nnnnnn = J - 1
Ifnumo = 1
IF (Numrpi.NE.Nnnnnn+Nnnrpi) Numrpi = Nnnnnn+Nnnrpi
Kumrpi = Numrpi
-C
-C *** now reorder if Ecrnch are not energy-ordered
+!
+! *** now reorder if Ecrnch are not energy-ordered
120 CONTINUE
IF (Nnnnnn.GT.1) THEN
DO J=2,Nnnnnn
IF (Ecrnch(J-1).GT.Ecrnch(J)) GO TO 140
- IF (Ecrnch(J-1).EQ.Ecrnch(J))
- * STOP '[Stop in Readrp_Ch in par/mpar06.f # 1]'
+ IF (Ecrnch(J-1).EQ.Ecrnch(J)) &
+ STOP '[Stop in Readrp_Ch in par/mpar06.f # 1]'
END DO
GO TO 200
140 CONTINUE
@@ -753,15 +746,15 @@ C *** now reorder if Ecrnch are not energy-ordered
END IF
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readr3 (Parrpi, Iflrpi, Delrpi, Ecrnch, Kfile, Ialt)
-C
-C *** Card Set 14, alt 3 or 4
-C *** Purpose -- Generate GELINA or NTOF resolution function parameters
-C
+!
+! *** Card Set 14, alt 3 or 4
+! *** Purpose -- Generate GELINA or NTOF resolution function parameters
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -770,47 +763,46 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Parrpi(Numrpi), Iflrpi(Numrpi), Delrpi(Numrpi),
-C * Ecrnch(Numrpi-Nnnrpi)
-C
+!
+! DIMENSION Parrpi(Numrpi), Iflrpi(Numrpi), Delrpi(Numrpi),
+! * Ecrnch(Numrpi-Nnnrpi)
+!
DIMENSION Parrpi(*), Iflrpi(*), Delrpi(*), Ecrnch(*)
-C
-C
- CHARACTER*5 What, Burst, Chann, Bbbbb, Geelxx, Ntofxx, Gelina,
- * Binpdc
-C
- DATA Burst /'BURST'/, Chann /'CHANN'/, Gelina /'GELIN'/,
- * Bbbbb /' '/, Geelxx /'GEEL '/, Ntofxx /'NTOF '/,
- * Binpdc /'BINS '/
-C
-C
+!
+!
+ CHARACTER*5 What, Burst, Chann, Bbbbb, Geelxx, Ntofxx, Gelina, Binpdc
+!
+ DATA Burst /'BURST'/, Chann /'CHANN'/, Gelina /'GELIN'/, &
+ Bbbbb /' '/, Geelxx /'GEEL '/, Ntofxx /'NTOF '/, &
+ Binpdc /'BINS '/
+!
+!
CALL Test_Midrpi (Midrpi)
-C
+!
CALL Zero_Array (Parrpi, Numrpi)
CALL Zero_Array (Delrpi, Numrpi)
IF (Numrpi.GT.Nnnrpi) CALL Zero_Array (Ecrnch, Numrpi-Nnnrpi)
CALL Zero_Integer (Iflrpi, Numrpi)
If_Rpi_Chi = 1
If_Rpi_Exp = 1
-C
-C ***
-C *** Chi squared function; tau-parameters
-C *** tau = a exp(-bE) + b exp(-cE) + e
+!
+! ***
+! *** Chi squared function; tau-parameters
+! *** tau = a exp(-bE) + b exp(-cE) + e
IF (Ialt.EQ.3) THEN
-C THEN use GELINA parameter values
+! THEN use GELINA parameter values
Parrpi(6) = -0.7722d0
Parrpi(7) = 1363.8500d0
Parrpi(8) = -0.5322d0
ELSE
-C ELSE IF (Ialt.EQ.4) THEN use NTOF parameter values
+! ELSE IF (Ialt.EQ.4) THEN use NTOF parameter values
Parrpi(6) = -3.7004d0
Parrpi(7) = -684.3900d0
Parrpi(8) = -0.5189d0
END IF
-C
-C ***
-C *** lambda parameters for chi squared function
+!
+! ***
+! *** lambda parameters for chi squared function
IF (Ialt.EQ.3) THEN
Parrpi( 9) = 1.4460d0
Parrpi(12) = 454.9720d0
@@ -820,9 +812,9 @@ C *** lambda parameters for chi squared function
Parrpi(12) = 502.9930d0
Parrpi(13) = -0.4155d0
END IF
-C
-C ***
-C *** A1 = a exp(-bE) + c exp(-dE) + e
+!
+! ***
+! *** A1 = a exp(-bE) + c exp(-dE) + e
IF (Ialt.EQ.3) THEN
Parrpi(16) = 0.04152d0
Parrpi(17) = -5.84700d-6
@@ -836,15 +828,15 @@ C *** A1 = a exp(-bE) + c exp(-dE) + e
Parrpi(17) = 0.0001019d0
Parrpi(18) = 0.0500900d0
END IF
-C
-C ***
-C *** Parameters for exponential functions, including tzero=Shift
+!
+! ***
+! *** Parameters for exponential functions, including tzero=Shift
Parrpi(22) = 1.0d0
Parrpi(24) = -1.0d0
-C
-C ***
-C *** Parameters for energy-dependent exponential function, to
-C *** be used instead of Parrpi(23)=A3,
+!
+! ***
+! *** Parameters for energy-dependent exponential function, to
+! *** be used instead of Parrpi(23)=A3,
Kumrpi = 25
Parrpi(23) = -2.0d0
IF (Ialt.EQ.3) THEN
@@ -858,10 +850,10 @@ C *** be used instead of Parrpi(23)=A3,
END IF
Kumrpi = Kumrpi + 7
Medrpi = Medrpi + 7
-C
-C ***
-C *** Parameters for energy-dependent exponential function, to
-C *** be used instead of Parrpi(25)=A5
+!
+! ***
+! *** Parameters for energy-dependent exponential function, to
+! *** be used instead of Parrpi(25)=A5
Parrpi(25) = -2.0d0
IF (Ialt.EQ.3) THEN
Parrpi(Kumrpi+5) = 0.0073310d0
@@ -870,15 +862,15 @@ C *** be used instead of Parrpi(25)=A5
END IF
Kumrpi = Kumrpi + 7
Medrpi = Medrpi + 7
-C
+!
DO I=2,Nnnrpi
Iflrpi(I) = 0
Delrpi(I) = dABS(Parrpi(I))*0.10d0
END DO
-C
-C
-C *** Finished setting default values. Now read burst & channel values.
-C
+!
+!
+! *** Finished setting default values. Now read burst & channel values.
+!
Kount_Card = 0
Jtrip = 0
Mmmrpi = 0
@@ -886,43 +878,42 @@ C
Itdchi = 0
Ichbin = 0
Kumrpi = Nnnrpi
-C ***
+! ***
10 CONTINUE
-CX READ (Kfile,99999,ERR=50,END=20) What, I1, I2, I3, I4, I5, A, B,
- READ (Kfile,99999,ERR=20,END=20) What, I1, I2, I3, I4, I5, A, B,
- * C, D, E, F, G
+!X READ (Kfile,99999,ERR=50,END=20) What, I1, I2, I3, I4, I5, A, B,
+ READ (Kfile,99999,ERR=20,END=20) What, I1, I2, I3, I4, I5, A, B, &
+ C, D, E, F, G
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 10
IF (Ialt.EQ.3 .AND. (What.EQ.Geelxx .OR. What.EQ.Gelina)) GO TO 10
IF (Ialt.EQ.4 .AND. What.EQ.Ntofxx) GO TO 10
Jtrip = Jtrip + 1
IF (Jtrip.GT.1000) STOP '[Stop in Readr3 in par/mpar06.f # 2]'
-C
-C
+!
+!
IF (What.EQ.Bbbbb) THEN
GO TO 20
-C
+!
ELSE IF (What.EQ.Burst) THEN
-C *** Line 2 of Card Set 14a -- Burst Width
+! *** Line 2 of Card Set 14a -- Burst Width
Parrpi(1) = A
Delrpi(1) = B
Iflrpi(1) = I1
-C
+!
ELSE IF (What.EQ.Binpdc) THEN
-C *** Line 19 of Card Set 14a -- Continuously-varying channel width
+! *** Line 19 of Card Set 14a -- Continuously-varying channel width
IF (Ichbin.EQ.2) THEN
Write (6,10200)
Write (21,10200)
-10200 FORMAT (' Cannot use continuously-varying channel widths (Lin
- *ne 19) and', /,
- * ' discrete channel widths (Line 20) together.')
+10200 FORMAT (' Cannot use continuously-varying channel widths (Line 19) and',&
+ /,' discrete channel widths (Line 20) together.')
STOP '[Stop in Readr3 in par/mpar06.f # 3]'
END IF
Ichbin = 1
Nbinpd = I5 + 10*(I4+10*(I3+10*(I2+10*I1)))
GO TO 20
-C
-C ***
+!
+! ***
ELSE IF (What.EQ.Chann) THEN
IF (Ichbin.EQ.1) THEN
Write (6,10200)
@@ -930,24 +921,24 @@ C ***
STOP
END IF
Ichbin = 2
-C *** Line 20 of Card Set 14a
-C *** channel widths and uncertainties for energy-ranges specified
- CALL Readrp_Ch (Parrpi, Iflrpi, Delrpi, Ecrnch, Kfile,
- * Kumrpi, I2, A, B, C, Kount_Card, Ifnumo)
+! *** Line 20 of Card Set 14a
+! *** channel widths and uncertainties for energy-ranges specified
+ CALL Readrp_Ch (Parrpi, Iflrpi, Delrpi, Ecrnch, Kfile, &
+ Kumrpi, I2, A, B, C, Kount_Card, Ifnumo)
GO TO 20
END IF
GO TO 10
-C
+!
20 CONTINUE
-C *** done reading input; now generate other info
- CALL Readrp_Finish (Parrpi, Iflrpi, Delrpi, Ecrnch, Kumrpi,
- * Ifnumo)
+! *** done reading input; now generate other info
+ CALL Readrp_Finish (Parrpi, Iflrpi, Delrpi, Ecrnch, Kumrpi, Ifnumo)
RETURN
-C
+!
50 CONTINUE
WRITE (6,10300)
10300 FORMAT(' Error in reading file "Kfile" first time in to Readr3')
GO TO 10
-C
+!
99999 FORMAT (A5, 5I1, 7F10.1)
END
+end module par6_m
diff --git a/sammy/src/par/mpar07.f b/sammy/src/par/mpar07.f90
similarity index 73%
rename from sammy/src/par/mpar07.f
rename to sammy/src/par/mpar07.f90
index f9a56512f..ee59b3708 100644
--- a/sammy/src/par/mpar07.f
+++ b/sammy/src/par/mpar07.f90
@@ -1,17 +1,18 @@
-C
-C *** This routine is separate from the rest of the "Readxx" routines in
-C *** order to use it in testing udr parameters (program samudt =
-C *** SAM_UDr_Test)
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Readud (Parudr, Ifludr, Deludr, Ecrnch, Nud_T,
- * Nud_E, Kfile)
-C
-C *** card set 15
-C *** purpose -- Read user-defined resolution function parameters; count
-C *** how many time-steps for each type of udr function
-C
+!
+module par7_m
+ contains
+! *** This routine is separate from the rest of the "Readxx" routines in
+! *** order to use it in testing udr parameters (program samudt =
+! *** SAM_UDr_Test)
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Readud (Parudr, Ifludr, Deludr, Ecrnch, Nud_T, Nud_E, Kfile)
+!
+! *** card set 15
+! *** purpose -- Read user-defined resolution function parameters; count
+! *** how many time-steps for each type of udr function
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -19,46 +20,45 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
CHARACTER*5 What, Burst, Chann, Bbbbb, Udrres
CHARACTER*70 File_Name
-C
-C
- DIMENSION Parudr(*), Ifludr(*), Deludr(*), Ecrnch(*), Nud_T(*),
- * Nud_E(*)
-C
+!
+!
+ DIMENSION Parudr(*), Ifludr(*), Deludr(*), Ecrnch(*), Nud_T(*), Nud_E(*)
+!
DATA Burst /'BURST'/, Chann /'CHANN'/
DATA Bbbbb /' '/, Udrres /'USER '/
DATA Zero /0.0d0/
-C
+!
Iseta1 = 0
IF (Numudr.GT.0) CALL Zero_Array (Parudr, Numudr)
IF (Numudr.GT.0) CALL Zero_Array (Deludr, Numudr)
IF (Numudr.GT.0) CALL Zero_Integer (Ifludr, Numudr)
CALL Zero_Integer (Nud_T, Nudwhi)
CALL Zero_Integer (Nud_E, Nudwhi)
-C
+!
Jtrip = 0
Kumudr = 0
Mmmudr = 0
Itdchi = 1
-C
-C *****************************************************************
+!
+! *****************************************************************
Ifnumo = 1
-C *** What in the world does Ifnumo mean?
-C *****************************************************************
-C
+! *** What in the world does Ifnumo mean?
+! *****************************************************************
+!
Kount_Card = 0
10 CONTINUE
IF (Kount_Card.LT.Kntchn) THEN
-CX READ (Kfile,11100,ERR=200,END=210) What, I1, I2, I3, I4, I5,
- READ (Kfile,11100,ERR=210,END=210) What, I1, I2, I3, I4, I5,
- * A, B, C, D, E, F, G
+!X READ (Kfile,11100,ERR=200,END=210) What, I1, I2, I3, I4, I5,
+ READ (Kfile,11100,ERR=210,END=210) What, I1, I2, I3, I4, I5, &
+ A, B, C, D, E, F, G
CALL Convert_To_Caps (What, 5, Kpound)
Kount_Card = Kount_Card + 1
-C ***
+! ***
IF (What.EQ.Udrres) THEN
-C *** Just re-read if this is the header card
-C ***
+! *** Just re-read if this is the header card
+! ***
ELSE IF (What.EQ.Burst) THEN
-C *** Line 2 of Card Set 15 -- Burst Width
+! *** Line 2 of Card Set 15 -- Burst Width
IF (Kumudr.LE.1) Kumudr = 1
Parudr(1) = A
Deludr(1) = B
@@ -66,17 +66,16 @@ C *** Line 2 of Card Set 15 -- Burst Width
ELSE
STOP '[STOP in Readud in par/mpar07.f # 1]'
END IF
-C
+!
ELSE IF (Kount_Card.LT.Numudr) THEN
-CX READ (Kfile,11100,ERR=200,END=210) What, I1, I2, I3, I4, I5,
- READ (Kfile,11100,ERR=210,END=210) What, I1, I2, I3, I4, I5,
- * A, B, C
+!X READ (Kfile,11100,ERR=200,END=210) What, I1, I2, I3, I4, I5,
+ READ (Kfile,11100,ERR=210,END=210) What, I1, I2, I3, I4, I5, A, B, C
Kount_Card = Kount_Card + 1
CALL Convert_To_Caps (What, 5, Kpound)
-C ***
+! ***
IF (What.EQ.Chann) THEN
-C *** Line 3 of Card Set 15
-C *** channel widths and uncertainties for energy-ranges specified
+! *** Line 3 of Card Set 15
+! *** channel widths and uncertainties for energy-ranges specified
Ifludr(1+Nnnudr) = I2
Ecrnch(1) = A
Parudr(1+Nnnudr) = B
@@ -86,7 +85,7 @@ C *** channel widths and uncertainties for energy-ranges specified
IF (Nnnnnn.GT.1) THEN
DO J=2,Nnnnnn
READ (Kfile,11100) What, I1, I2, I3, I4, I5, A, B, C
-C *** Line 3 of Card Set 15
+! *** Line 3 of Card Set 15
Kount_Card = Kount_Card + 1
IFludr(J+Nnnudr) = I2
Ecrnch(J ) = A
@@ -95,11 +94,12 @@ C *** Line 3 of Card Set 15
Kumudr = J + Nnnudr
END DO
Ifnumo = 0
-C *** Now reorder if Ecrnch are not energy-ordered
+! *** Now reorder if Ecrnch are not energy-ordered
DO J=2,Nnnnnn
IF (Ecrnch(J-1).GT.Ecrnch(J)) GO TO 20
- IF (Ecrnch(J-1).EQ.Ecrnch(J))
- * STOP '[STOP in Readud in par/mpar07.f # 2]'
+ IF (Ecrnch(J-1).EQ.Ecrnch(J)) then
+ STOP '[STOP in Readud in par/mpar07.f # 2]'
+ end if
END DO
GO TO 30
20 CONTINUE
@@ -129,27 +129,26 @@ C *** Now reorder if Ecrnch are not energy-ordered
ELSE
STOP '[STOP in Readud in par/mpar07.f # 3]'
END IF
-C
+!
ELSE
-C ***
+! ***
Nudeng = 0
Nudtim = 0
WRITE ( 6,10100)
WRITE (21,10100)
-10100 FORMAT (/,
- * ' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@',
- * /, ' @@@ File names for User-Defined Resolution Function @@@')
+10100 FORMAT (/, &
+ ' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@', &
+ /, ' @@@ File names for User-Defined Resolution Function @@@')
DO I=1,Nudwhi
-CX READ (Kfile,10200,ERR=200,END=210) What, File_Name
+!X READ (Kfile,10200,ERR=200,END=210) What, File_Name
READ (Kfile,10200,ERR=210,END=210) What, File_Name
CALL Convert_To_Caps (What, 5, Kpound)
10200 FORMAT (A5, A70)
WRITE ( 6,10300) File_Name
WRITE (21,10300) File_Name
10300 FORMAT (' @@@ ', A47, ' @@@')
-C *** Line 4 of Card Set 15 -- Filename for user-defined res fnct
- OPEN (UNIT=78, FILE=File_Name, STATUS='OLD',
- * FORM='FORMATTED')
+! *** Line 4 of Card Set 15 -- Filename for user-defined res fnct
+ OPEN (UNIT=78, FILE=File_Name, STATUS='OLD', FORM='FORMATTED')
N = 0
Mn = 0
40 CONTINUE
@@ -157,7 +156,7 @@ C *** Line 4 of Card Set 15 -- Filename for user-defined res fnct
IF (What.NE.'-----') GO TO 40
50 CONTINUE
READ (78,*,END=80,ERR=80) Aa
-C *** Aa = Energy
+! *** Aa = Energy
IF (Aa.EQ.Zero) Go to 80
N = N + 1
M = 0
@@ -171,8 +170,8 @@ C *** Aa = Energy
IF (Mn.GT.0) THEN
IF (M.NE.Mn) THEN
WRITE (6,10400) M, Mn
-10400 FORMAT (' Have', I3, ' and', I3,' but need same',
- * 1X, 'number of time-steps for each energy')
+10400 FORMAT (' Have', I3, ' and', I3,' but need same', &
+ 1X, 'number of time-steps for each energy')
STOP '[STOP in Readud in par/mpar07.f # 4]'
END IF
ELSE
@@ -188,16 +187,15 @@ C *** Aa = Energy
END DO
WRITE ( 6,10500)
WRITE (21,10500)
-10500 FORMAT (
- * ' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@')
+10500 FORMAT (' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@')
GO TO 210
END IF
-C
+!
GO TO 10
-C
-C ***
-C *** done reading input; now generate other info
-C
+!
+! ***
+! *** done reading input; now generate other info
+!
210 CONTINUE
IF (Kumudr.GT.Numudr) THEN
WRITE (6,10600) Kumudr, Numudr
@@ -205,7 +203,7 @@ C
ELSE
Numudr = Kumudr
END IF
-C
+!
K1 = 0
K3 = 0
IF (Numudr.GT.0) THEN
@@ -216,51 +214,51 @@ C
IF (Ifludr(I).EQ.3) K3 = K3 + 1
END DO
END IF
-C
+!
IF (Ifnumo.EQ.0 .AND. Kipudr.EQ.1) WRITE (21,10700) Numudr, K1
-10700 FORMAT (' Number of UDR Resolution parameters is', I5, /,
- * ' and the number varied is', I5)
+10700 FORMAT (' Number of UDR Resolution parameters is', I5, /, &
+ ' and the number varied is', I5)
IF (Ifnumo.EQ.0 .AND. Kiprpi.EQ.0) WRITE (21,10800) Numudr
10800 FORMAT (' Number of UDR Resolution parameters is', I5)
IF (K3.GT.0) WRITE (21,10900) K3
10900 FORMAT (' Number of PUPped UDR parameters is', I5)
-C
+!
IF (K1 .NE.Nvpudr) STOP '[STOP in Readud in mpar07.f # 1]'
IF (K1+K3.NE.Nfpudr) STOP '[STOP in Readud in mpar07.f # 2]'
-C
+!
IF (Numudr.GT.0) THEN
DO I=1,Numudr
IF (Deludr(I).EQ.Zero) Deludr(I) = dABS(Parudr(I))*fudge
IF (Deludr(I).EQ.Zero) Deludr(I) = 1.0d-5
END DO
END IF
-C
-C
+!
+!
RETURN
-C
-C
-CX 200 CONTINUE
-CX WRITE (6,11000)
-CX11000 FORMAT(' Error in reading file "Kfile" first time in to Readud')
-CX GO TO 10
-C
+!
+!
+!X 200 CONTINUE
+!X WRITE (6,11000)
+!X11000 FORMAT(' Error in reading file "Kfile" first time in to Readud')
+!X GO TO 10
+!
600 CONTINUE
WRITE (6,11050)
11050 FORMAT ('error in reading udr files')
STOP '[STOP in Readud in par/mpar07.f # 5]'
-C
+!
11100 FORMAT (A5, 5I1, 7F10.1)
END
-C
-C --------------------------------------------------------------
-C
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readux (Kfile)
-C
-C
-C *** Card set 15
-C *** Purpose -- Read user-defined resolution function parameters
-C but do not use them for anything
-C
+!
+!
+! *** Card set 15
+! *** Purpose -- Read user-defined resolution function parameters
+! but do not use them for anything
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -268,109 +266,108 @@ C
IMPLICIT DOUBLE PRECISION (a-h,o-z)
CHARACTER*5 What, Burst, Chann, Udrres
CHARACTER*70 File_Name
-C
-C
+!
+!
DATA Burst /'BURST'/, Chann /'CHANN'/, Udrres /'USER '/
-C
+!
Iseta1 = 0
-C
+!
Jtrip = 0
Kumudr = 0
Mmmudr = 0
Itdchi = 1
-C
+!
Kount_Card = 0
10 CONTINUE
IF (Kount_Card.LT.Kntchn) THEN
-CX READ (Kfile,11100,ERR=200,END=210) What, I1, I2, I3, I4, I5,
- READ (Kfile,11100,ERR=210,END=210) What, I1, I2, I3, I4, I5,
- * A, B, C, D, E, F, G
+!X READ (Kfile,11100,ERR=200,END=210) What, I1, I2, I3, I4, I5,
+ READ (Kfile,11100,ERR=210,END=210) What, I1, I2, I3, I4, I5, &
+ A, B, C, D, E, F, G
Kount_Card = Kount_Card + 1
CALL Convert_To_Caps (What, 5, Kpound)
-C ***
+! ***
IF (What.EQ.Udrres) THEN
-C *** Just re-read if this is the header card
-C ***
+! *** Just re-read if this is the header card
+! ***
ELSE IF (What.EQ.Burst) THEN
-C *** Line 2 of Card Set 15 -- Burst Width
+! *** Line 2 of Card Set 15 -- Burst Width
IF (Kumudr.LE.1) Kumudr = 1
ELSE
STOP '[STOP in Readux in par/mpar07.f # 1]'
END IF
-C
+!
ELSE IF (Kount_Card.LT.Numudr) THEN
-CX READ (Kfile,11100,ERR=200,END=210) What, I1, I2, I3, I4, I5,
- READ (Kfile,11100,ERR=210,END=210) What, I1, I2, I3, I4, I5,
- * A, B, C
+!X READ (Kfile,11100,ERR=200,END=210) What, I1, I2, I3, I4, I5,
+ READ (Kfile,11100,ERR=210,END=210) What, I1, I2, I3, I4, I5, A, B, C
CALL Convert_To_Caps (What, 5, Kpound)
Kount_Card = Kount_Card + 1
-C ***
+! ***
IF (What.EQ.Chann) THEN
-C *** Line 3 of Card Set 15
-C *** channel widths and uncertainties for energy-ranges specified
+! *** Line 3 of Card Set 15
+! *** channel widths and uncertainties for energy-ranges specified
Kumudr = 1 + Nnnudr
Nnnnnn = Numudr - Nnnudr
IF (Nnnnnn.GT.1) THEN
DO J=2,Nnnnnn
READ (Kfile,11100) What, I1, I2, I3, I4, I5, A, B, C
-C *** Line 3 of Card Set 15
+! *** Line 3 of Card Set 15
Kumudr = J + Nnnudr
END DO
END IF
ELSE
STOP '[STOP in Readux in par/mpar07.f # 2]'
END IF
-C
+!
ELSE
-C ***
+! ***
Nudeng = 0
Nudtim = 0
DO I=1,Nudwhi
-CX READ (Kfile,10200,ERR=200,END=210) What, File_Name
+!X READ (Kfile,10200,ERR=200,END=210) What, File_Name
READ (Kfile,10200,ERR=210,END=210) What, File_Name
10200 FORMAT (A5, A70)
-C *** Line 4 of Card Set 15 -- Filename for user-defined res fnct
+! *** Line 4 of Card Set 15 -- Filename for user-defined res fnct
CALL Convert_To_Caps (What, 5, Kpound)
END DO
GO TO 210
END IF
-C
+!
GO TO 10
-C
-C ***
-C *** done reading input
+!
+! ***
+! *** done reading input
210 CONTINUE
RETURN
-C
-C
+!
+!
200 CONTINUE
WRITE (6,10100)
10100 FORMAT(' Error in reading file "Kfile" first time in to Readux')
GO TO 10
-C
+!
11100 FORMAT (A5, 5I1, 7F10.1)
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Read_User (Nud_E, Nud_T, UdE, UdR, UdT)
-C
-C *** Purpose -- Read files of user-defined resolution
-C
+!
+! *** Purpose -- Read files of user-defined resolution
+!
use fixedi_m
use samxxx_common_m
use namfil_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
CHARACTER*5 What, What2, Udrres, Udrret, Udrrex, Filex
CHARACTER*70 File_Name
-C
-C
- DIMENSION Nud_E(Nudwhi), Nud_t(Nudwhi), UdE(Nudeng,Nudwhi),
- * UdR(Nudtim,Nudeng,Nudwhi), UdT(Nudtim,Nudeng,Nudwhi)
- DATA Filex /'FILE='/, Udrres /'USER-'/, Udrret /'USER '/,
- * Udrrex /'SUPPL'/
-C
+!
+!
+ DIMENSION Nud_E(Nudwhi), Nud_t(Nudwhi), UdE(Nudeng,Nudwhi), &
+ UdR(Nudtim,Nudeng,Nudwhi), UdT(Nudtim,Nudeng,Nudwhi)
+ DATA Filex /'FILE='/, Udrres /'USER-'/, Udrret /'USER '/, &
+ Udrrex /'SUPPL'/
+!
IF (Kipudr.EQ.0) THEN
IF (Iu22.EQ.11) CALL Filopn (79, Finput, 0)
IF (Iu22.EQ.22) CALL Filopn (79, Finput, 0)
@@ -382,7 +379,7 @@ C
ELSE
STOP '[STOP in Read_User in par/mpar07.f # 1]'
END IF
-C
+!
10 CONTINUE
READ (79,10000) What, What2
10000 FORMAT (2A5)
@@ -390,27 +387,26 @@ C
IF (What.NE.Udrres .AND. What.NE.Udrret) GO TO 10
CALL Convert_To_Caps (What2, 5, Kpound)
IF (What2.EQ.Udrrex) GO TO 10
-C
-C *** Here we've found the User-Defined Resolution Function location
+!
+! *** Here we've found the User-Defined Resolution Function location
IF (Numudr.GE.1) THEN
DO I=1,Numudr
READ (79,10000) What
END DO
END IF
-C
-C *** Here are the file names
+!
+! *** Here are the file names
DO Nud=1,Nudwhi
READ (79,10100) What, File_Name
10100 FORMAT (A5, A70)
CALL Convert_To_Caps (What, 5, Kpound)
- IF (What.NE.Filex)
- * STOP '[STOP in Read_User in par/mpar07.f # 2]'
+ IF (What.NE.Filex) STOP '[STOP in Read_User in par/mpar07.f # 2]'
OPEN (UNIT=78, FILE=File_Name, STATUS='OLD', FORM='FORMATTED')
360 CONTINUE
READ (78,10000) What
IF (What.NE.'-----') GO TO 360
DO N=1,Nud_E(Nud)
-C *** note that blanks are ignored here because free-form input
+! *** note that blanks are ignored here because free-form input
READ (78,*,END=400,ERR=400) Ee
UdE(N,Nud) = Ee
DO M=1,Nud_T(Nud)
@@ -425,3 +421,4 @@ C *** note that blanks are ignored here because free-form input
CLOSE (UNIT=79)
RETURN
END
+end module par7_m
diff --git a/sammy/src/par/mpar08.f b/sammy/src/par/mpar08.f90
similarity index 75%
rename from sammy/src/par/mpar08.f
rename to sammy/src/par/mpar08.f90
index a174948ea..d2ff0e88f 100644
--- a/sammy/src/par/mpar08.f
+++ b/sammy/src/par/mpar08.f90
@@ -1,130 +1,128 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module par8_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readox (Kfile)
-C
-C *** Card Set 9
-C *** Purpose -- Read ORResolution function parameters, but don't
-C *** store or use them because "broadening is not wanted"
-C *** was specified in the INPut file
-C
+!
+! *** Card Set 9
+! *** Purpose -- Read ORResolution function parameters, but don't
+! *** store or use them because "broadening is not wanted"
+! *** was specified in the INPut file
+!
use fixedi_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- CHARACTER*5 What, Burst, Tanta, Water, Ne110, Lithi, Chann,
- * Orres, Bbbbb
-C
- DATA Burst /'BURST'/, Tanta /'TANTA'/, Water /'WATER'/,
- * Ne110 /'NE110'/, Lithi /'LITHI'/, Chann /'CHANN'/,
- * Orres /'ORRES'/, Bbbbb /' '/
-C
-C
-C ***
-C *** burst width
+!
+ CHARACTER*5 What, Burst, Tanta, Water, Ne110, Lithi, Chann, Orres, Bbbbb
+!
+ DATA Burst /'BURST'/, Tanta /'TANTA'/, Water /'WATER'/, &
+ Ne110 /'NE110'/, Lithi /'LITHI'/, Chann /'CHANN'/, &
+ Orres /'ORRES'/, Bbbbb /' '/
+!
+!
+! ***
+! *** burst width
10 CONTINUE
-cx READ (Kfile,99999,ERR=10,END=300) What, I1, I2, I3, I4, A, B, C
+!x READ (Kfile,99999,ERR=10,END=300) What, I1, I2, I3, I4, A, B, C
READ (Kfile,99999,ERR=300,END=300) What, I1, I2, I3, I4, A, B, C
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 10
IF (What.EQ.Orres) GO TO 10
IF (What.NE.Burst) GO TO 30
-C
-C ***
+!
+! ***
20 CONTINUE
-C *** water moderator or tantalum target ?
-cx READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B, C
+! *** water moderator or tantalum target ?
+!x READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B, C
READ (Kfile,99999,END=300,ERR=300) What, I1, I2, I3, I4, A, B, C
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 20
30 CONTINUE
-C
+!
IF (What.EQ.WATER) THEN
-C *** water moderator
+! *** water moderator
Mmmorr = I4
IF (Mmmorr.GT.10 .OR. Mmmorr.LT.1) Mmmorr = 4
40 CONTINUE
-cx READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B, C
- READ (Kfile,99999,END=300,ERR=300) What, I1, I2, I3, I4, A, B,C
+!x READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B, C
+ READ (Kfile,99999,END=300,ERR=300) What, I1, I2, I3, I4, A, B, C
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 40
-C ### following lines are for "old" input
+! ### following lines are for "old" input
Iold = 0
IF (What.EQ.LITHI) Iold = 1
IF (What.EQ.Ne110) Iold = 1
IF (Iold.EQ.1) GO TO 50
-C ### preceeding lines are for "old" input
-C
+! ### preceeding lines are for "old" input
+!
ELSE IF (What.EQ.Tanta) THEN
-C *** tantalum target so need to read other information
+! *** tantalum target so need to read other information
41 CONTINUE
-CX READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B, C, D
- READ (Kfile,99999,END=300,ERR=300) What, I1, I2, I3, I4, A,
- * B, C, D
+!X READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B, C, D
+ READ (Kfile,99999,END=300,ERR=300) What, I1, I2, I3, I4, A, B, C, D
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 41
42 CONTINUE
-CX READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B, C, D
- READ (Kfile,99999,END=300,ERR=300) What, I1, I2, I3, I4, A,
- * B, C, D
+!X READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B, C, D
+ READ (Kfile,99999,END=300,ERR=300) What, I1, I2, I3, I4, A, B, C, D
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 42
43 CONTINUE
-CX READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B
+!X READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B
READ (Kfile,99999,END=300,ERR=300) What, I1, I2, I3, I4, A,B
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 43
44 CONTINUE
-CX READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B
+!X READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B
READ (Kfile,99999,END=300,ERR=300) What, I1, I2, I3, I4, A,B
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 44
Mmmorr = 0
-C
+!
ELSE
GO TO 50
END IF
-C
-C ***
-C *** detector type
+!
+! ***
+! *** detector type
45 CONTINUE
-CX READ (Kfile,99999,END=300) What, I1, I2, I3, I4, D, F, G
+!X READ (Kfile,99999,END=300) What, I1, I2, I3, I4, D, F, G
READ (Kfile,99999,END=300,ERR=300) What, I1, I2, I3, I4, D, F, G
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 45
50 CONTINUE
-C
-C
+!
+!
IF (What.EQ.Ne110) THEN
-C *** Here detector is Ne110
+! *** Here detector is Ne110
IF (I2.NE.0 .OR. I3.NE.0 .OR. I4.NE.0) THEN
Nmdets = I2*100 + I3*10 + I4
DO I=1,Nmdets
51 CONTINUE
-CX READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B
- READ (Kfile,99999,END=300,ERR=300) What, I1, I2, I3, I4,
- * A, B
+!X READ (Kfile,99999,END=300) What, I1, I2, I3, I4, A, B
+ READ (Kfile,99999,END=300,ERR=300) What, I1, I2, I3, I4, A, B
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 51
END DO
END IF
-C
+!
ELSE IF (What.EQ.Lithi) THEN
-C *** Here detector is lithium-glass
+! *** Here detector is lithium-glass
52 CONTINUE
-CX READ (Kfile,99999,END=300) What, I1, I2, I3, I4, D, F, G
+!X READ (Kfile,99999,END=300) What, I1, I2, I3, I4, D, F, G
READ (Kfile,99999,END=300,ERR=300) What, I1, I2, I3, I4, D, F,G
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 52
-C
+!
ELSE
GO TO 140
END IF
-C
-C ***
-C *** Read channel widths and uncertainties for energy-ranges specified
+!
+! ***
+! *** Read channel widths and uncertainties for energy-ranges specified
120 CONTINUE
-CX READ (Kfile,99999,END=140) What, I1, I2, I3, I4, A, B, C
+!X READ (Kfile,99999,END=140) What, I1, I2, I3, I4, A, B, C
READ (Kfile,99999,END=140,ERR=140) What, I1, I2, I3, I4, A, B, C
CALL Convert_To_Caps (What, 5, Kpound)
IF (Kpound.EQ.1) GO TO 120
@@ -134,33 +132,33 @@ CX READ (Kfile,99999,END=140) What, I1, I2, I3, I4, A, B, C
140 CONTINUE
300 CONTINUE
Numorr = 0
-C *** because here we are not using or storing these parameters
+! *** because here we are not using or storing these parameters
RETURN
-C
-C
+!
+!
99999 FORMAT (A5, 1X, 4I1, 4F10.1)
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readxp (Kfile)
-C
-C *** Card Set 14
-C *** Purpose -- Read RPI resolution function parameters, but don't
-C *** store or use them because "broadening is not wanted"
-C *** was specified in the INPut file
-C
+!
+! *** Card Set 14
+! *** Purpose -- Read RPI resolution function parameters, but don't
+! *** store or use them because "broadening is not wanted"
+! *** was specified in the INPut file
+!
use fixedi_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
CHARACTER*5 What, Whats(9), Bbbbb
- DATA Whats /'BURST', 'TAU ', 'LAMBD', 'A1 ', 'EXPON', 'EDEXP',
- * 'XXPON', 'CHANN', 'RPI R'/
+ DATA Whats /'BURST', 'TAU ', 'LAMBD', 'A1 ', 'EXPON', 'EDEXP', &
+ 'XXPON', 'CHANN', 'RPI R'/
DATA Bbbbb /' '/
-C
-C ***
-C
+!
+! ***
+!
10 CONTINUE
READ (Kfile,99999,ERR=10) What, I1, I2, I3, I4, A, B, C
99999 FORMAT (A5, 1X, 4I1, 4F10.1)
@@ -175,46 +173,46 @@ C
WRITE (6,10000)
10000 FORMAT (' Oops, error reading RPI resolution function')
STOP '[STOP in Readxp in par/mpar08.f]'
-C
+!
ELSE
-C
+!
Numrpi = 0
-C *** because here we are not using or storing these parameters
+! *** because here we are not using or storing these parameters
RETURN
-C
+!
END IF
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readnb (Parnbk, Iflnbk, Delnbk, Kfile)
-C
-C *** Card Set 6; normalization and background parameters
-C
+!
+! *** Card Set 6; normalization and background parameters
+!
use fixedi_m
use ifwrit_m
use fixedr_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Parnbk(6,Nangle), Iflnbk(6,Nangle), Delnbk(6,Nangle)
+!
+! DIMENSION Parnbk(6,Nangle), Iflnbk(6,Nangle), Delnbk(6,Nangle)
DIMENSION Parnbk(6,*), Iflnbk(6,*), Delnbk(6,*)
DIMENSION AA(6), Ii(6)
DATA Zero /0.0d0/
-C
+!
N = Nangle*6
IF (Nangle.GT.0 .AND. N.NE.Numnbk) THEN
Nn = Numnbk/6
WRITE (6,10100) Nn, Nangle
WRITE (21,10100) Nn, Nangle
-10100 FORMAT (/,
- * ' ***********************************************************',
- * /,' * Two lines for normalization and background (one with *',
- * /,' * values, the other with uncertainties) must appear for *',
- * /,' * each angle. The lines appear', I2,
- * ' times but should appear *',
- * /,' *', I2, ' times.', 48x, '*', /,
- * ' ***********************************************************')
+10100 FORMAT (/, &
+ ' ***********************************************************', &
+ /,' * Two lines for normalization and background (one with *', &
+ /,' * values, the other with uncertainties) must appear for *', &
+ /,' * each angle. The lines appear', I2, &
+ ' times but should appear *', &
+ /,' *', I2, ' times.', 48x, '*', /, &
+ ' ***********************************************************')
STOP
END IF
IF (N.EQ.0) N = 6
@@ -255,9 +253,9 @@ C
END DO
GO TO 80
END IF
-C
+!
ELSE
-C
+!
DO Iang=1,Nangle
READ (Kfile,10200,END=10,ERR=10) Aa, Ii
IF (Aa(1).EQ.Zero .AND. Aa(2).EQ.Zero) GO TO 10
@@ -276,7 +274,7 @@ C
END DO
READ (Kfile,10200,END=80,ERR=80) Aa
END IF
-C
+!
80 CONTINUE
IF (K1.NE.Nvpnbk .OR. K1+K3.NE.Nfpnbk) THEN
WRITE (6,10300) K1, K3, Nvpnbk, Nfpnbk
@@ -284,56 +282,56 @@ C
STOP '[STOP in Readnb in mpar08.f]'
END IF
RETURN
-C
+!
10 CONTINUE
-C *** Here if reached end of angles too soon
+! *** Here if reached end of angles too soon
Write ( 6,10400) Nangle, Iang-1
Write (21,10400) Nangle, Iang-1
-10400 FORMAT (' Expect to see', I3,
- * ' normalization lines, but have only', I3,' of them.')
+10400 FORMAT (' Expect to see', I3, &
+ ' normalization lines, but have only', I3,' of them.')
STOP '[STOP in Readnb in par/mpar08.f]'
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Readbg (Parbgf, Iflbgf, Delbgf, Kndbgf, Bgfmin, Bgfmax,
- * Texbgf, Teabgf, Kfile)
-C
-C *** Purpose -- Read Card Set 13 (background functions)
-C
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Readbg (Parbgf, Iflbgf, Delbgf, Kndbgf, Bgfmin, Bgfmax, &
+ Texbgf, Teabgf, Kfile)
+!
+! *** Purpose -- Read Card Set 13 (background functions)
+!
use fixedi_m
use ifwrit_m
use fixedr_m
use constn_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
CHARACTER*70 Filbgf
- CHARACTER*5 Xx, Aaaaaa, Bbbbbb, Cccccc, Dddddd, T_Pnt, E_Pnt,
- * Blank, Tfile, Efile, Aetob
+ CHARACTER*5 Xx, Aaaaaa, Bbbbbb, Cccccc, Dddddd, T_Pnt, E_Pnt, &
+ Blank, Tfile, Efile, Aetob
COMMON /Bgffil/ Filbgf(30)
-C
- DIMENSION Parbgf(*), Iflbgf(*), Delbgf(*), Kndbgf(*), Bgfmin(*),
- * Bgfmax(*), Texbgf(Ntepnt,*), Teabgf(Ntepnt,*)
- DATA Aaaaaa /'CONST'/, Bbbbbb /'EXPON'/, Cccccc /'POWER'/,
- * Dddddd /'EXPLN'/, T_Pnt /'T PNT'/, E_Pnt /'E PNT'/,
- * Tfile /'TFILE'/, Efile /'EFILE'/, Aetob /'AETOB'/,
- * Blank /' '/
+!
+ DIMENSION Parbgf(*), Iflbgf(*), Delbgf(*), Kndbgf(*), Bgfmin(*), &
+ Bgfmax(*), Texbgf(Ntepnt,*), Teabgf(Ntepnt,*)
+ DATA Aaaaaa /'CONST'/, Bbbbbb /'EXPON'/, Cccccc /'POWER'/, &
+ Dddddd /'EXPLN'/, T_Pnt /'T PNT'/, E_Pnt /'E PNT'/, &
+ Tfile /'TFILE'/, Efile /'EFILE'/, Aetob /'AETOB'/, &
+ Blank /' '/
DATA Zero /0.0d0/
-C
+!
Kdist = 0
Itefil = 0
Itepnt = 1
N = 1
10 CONTINUE
-C
+!
READ (Kfile,99999,END=100,ERR=100) Xx, I, J, K, A, B, C, D, E, F,G
99999 FORMAT (A5, 2I2, I1, 7F10.1)
99998 FORMAT (' Error in Par file:', A5, 2I2, I1, 6F10.1)
CALL Convert_To_Caps (Xx, 5, Kpound)
IF (Kpound.EQ.1) GO TO 10
-C
+!
IF (Xx.EQ.Aaaaaa) THEN
-C *** CONST
+! *** CONST
Parbgf(N ) = A
Delbgf(N ) = B
Iflbgf(N ) = I
@@ -345,9 +343,9 @@ C *** CONST
Ttoe = Sm2*Dist
END IF
N = N + 1
-C
+!
ELSE IF (Xx.EQ.Bbbbbb) THEN
-C *** EXPON
+! *** EXPON
Parbgf(N ) = A
Parbgf(N+1) = C
Delbgf(N ) = B
@@ -364,9 +362,9 @@ C *** EXPON
Ttoe = Sm2*Dist
END IF
N = N + 2
-C
+!
ELSE IF (Xx.EQ.Cccccc) THEN
-C *** POWER
+! *** POWER
Parbgf(N ) = A
Parbgf(N+1) = C
Delbgf(N ) = B
@@ -383,9 +381,9 @@ C *** POWER
Ttoe = Sm2*Dist
END IF
N = N + 2
-C
+!
ELSE IF (Xx.EQ.Dddddd) THEN
-C *** EXPLN
+! *** EXPLN
Parbgf(N ) = A
Parbgf(N+1) = C
Parbgf(N+2) = E
@@ -398,8 +396,7 @@ C *** EXPLN
Kndbgf(N ) = 4
Kndbgf(N+1) = -4
Kndbgf(N+2) = -5
- READ (Kfile,99999,END=100,ERR=100) Xx, I, J, K, A, B, C, D,
- * E, F, G
+ READ (Kfile,99999,END=100,ERR=100) Xx, I, J, K, A, B, C, D, E, F, G
Bgfmin(N ) = A
Bgfmax(N ) = B
Kdist = 1
@@ -408,9 +405,9 @@ C *** EXPLN
Ttoe = Sm2*Dist
END IF
N = N + 3
-C
+!
ELSE IF (Xx.EQ.T_Pnt) THEN
-C *** point-wise in time
+! *** point-wise in time
Parbgf(N ) = A
Delbgf(N ) = B
Iflbgf(N ) = I
@@ -422,18 +419,18 @@ C *** point-wise in time
Ttoe = Sm2*Dist
END IF
N = N + 1
-C
+!
ELSE IF (Xx.EQ.E_Pnt) THEN
-C *** point-wise in energy
+! *** point-wise in energy
Parbgf(N ) = A
Delbgf(N ) = B
Iflbgf(N ) = I
Kndbgf(N ) = 6
Bgfmin(N ) = C
N = N + 1
-C
+!
ELSE IF (Xx.EQ.Tfile) THEN
-C *** point-wise in time, with flagged multiplier
+! *** point-wise in time, with flagged multiplier
Itefil = Itefil + 1
IF (Itefil.GT.30) STOP '[STOP Too many background files]'
Parbgf(N ) = A
@@ -452,7 +449,7 @@ C *** point-wise in time, with flagged multiplier
20100 FORMAT (A5)
Ij = 0
30 CONTINUE
-CX READ (20,*,END=40) A,B
+!X READ (20,*,END=40) A,B
READ (20,*,END=40,ERR=40) A,B
IF (IJ.GT.0 .AND. A.EQ.Zero .AND. B.EQ.Zero) GO TO 40
Ij = Ij + 1
@@ -464,9 +461,9 @@ CX READ (20,*,END=40) A,B
CALL Te_Sort (Texbgf(1,Itefil), Teabgf(1,Itefil), Ij)
IF (Itepnt.LT.Ij) Itepnt = Ij
N = N + 1
-C
+!
ELSE IF (Xx.EQ.Efile) THEN
-C *** point-wise in energy, with flagged multiplier
+! *** point-wise in energy, with flagged multiplier
Itefil = Itefil + 1
IF (Itefil.GT.30) STOP '[STOP Too many background files]'
Parbgf(N ) = A
@@ -483,7 +480,7 @@ C *** point-wise in energy, with flagged multiplier
READ (20,20100) Xx
Ij = 0
50 CONTINUE
-CX READ (20,*,END=60) A,B
+!X READ (20,*,END=60) A,B
READ (20,*,END=60,ERR=60) A,B
IF (Ij.GT.0 .AND. A.EQ.Zero .AND. B.EQ.Zero) GO TO 60
Ij = Ij + 1
@@ -495,9 +492,9 @@ CX READ (20,*,END=60) A,B
CALL Te_Sort (Texbgf(1,Itefil), Teabgf(1,Itefil), Ij)
IF (Itepnt.LT.Ij) Itepnt = Ij
N = N + 1
-C
+!
ELSE IF (Xx.EQ.AETOB) THEN
-C *** Power of E
+! *** Power of E
Parbgf(N ) = A
Parbgf(N+1) = C
Delbgf(N ) = B
@@ -509,28 +506,28 @@ C *** Power of E
Iflbgf(N ) = I
Iflbgf(N+1) = J
N = N + 2
-C
+!
ELSE IF (Xx.EQ.Blank) THEN
GO TO 100
ELSE
WRITE (6,99998) Xx, I, J, K, A, B, C, D, E, F
STOP '[STOP in Readbg in par/mpar08.f]'
-C should never get here
+! should never get here
END IF
GO TO 10
-C
+!
100 CONTINUE
-C *** Done !
+! *** Done !
IF (Kdist.EQ.1 .AND. Dist.EQ.Zero) THEN
WRITE (6,10100)
WRITE (21,10100)
-10100 FORMAT (' ####################################################'
- * , /, ' Need to know the flight-path-length in order for the'
- * , /, ' background functions to work. Fix your input.', /,
- * ' ####################################################')
+10100 FORMAT (' ####################################################' &
+ , /, ' Need to know the flight-path-length in order for the' &
+ , /, ' background functions to work. Fix your input.', /, &
+ ' ####################################################')
STOP '[STOP in Readbg in par/mpar08.f # 2]'
END IF
-C
+!
IF (N.NE.Numbgf+1) THEN
WRITE ( 6,10200) N, Numbgf
WRITE (21,10200) N, Numbgf
@@ -555,37 +552,37 @@ C
10300 FORMAT (' ERROR: K1, K3, Nvpbgf, Nfpbgf =', 4I10)
STOP '[STOP in Readbg in par/mpar08.f # 4]'
END IF
-C
+!
IF (Ntefil.NE.Itefil) STOP '[STOP Ntefil.NE.Itefil]'
IF (Ntepnt.NE.Itepnt) STOP '[STOP Ntepnt.NE.Itepnt]'
-C
+!
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readda (Pardtp, Ifldtp, Ptilde, Deldtp, Kfile)
-C
-C *** Card Set 8 (Data parameters, virtually never used)
-C
+!
+! *** Card Set 8 (Data parameters, virtually never used)
+!
use fixedi_m
use ifwrit_m
use par_parameter_names_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
CHARACTER*5 Nam
-C DIMENSION Pardtp(Numdtp), Namdtp(Numdtp), Ifldtp(Numdtp),
-C * Deldtp(Numdtp), Ptilde(numdtp)
+! DIMENSION Pardtp(Numdtp), Namdtp(Numdtp), Ifldtp(Numdtp),
+! * Deldtp(Numdtp), Ptilde(numdtp)
DIMENSION Pardtp(*), Ifldtp(*), Deldtp(*), Ptilde(*)
-C
+!
K1 = 0
K3 = 0
DO I=1,Numdtp
- READ (Kfile,99999) Namdtp(I), Ifldtp(I), Pardtp(I),
- * Deldtp(I), Ptilde(I)
- IF (Ifldtp(I).LT.0 .OR. Ifldtp(I).GT.3)
- * STOP '[STOP in Readda in par/mpar08.f]'
+ READ (Kfile,99999) Namdtp(I), Ifldtp(I), Pardtp(I), Deldtp(I), Ptilde(I)
+ IF (Ifldtp(I).LT.0 .OR. Ifldtp(I).GT.3) then
+ STOP '[STOP in Readda in par/mpar08.f]'
+ end if
IF (Kgenpd.EQ.1) Ifldtp(I) = 0
IF (Kipdtp.EQ.0 .AND. Ifldtp(I).EQ.1) Ifldtp(I) = 0
IF (Ifldtp(I).EQ.1) K1 = K1 + 1
@@ -597,22 +594,22 @@ C
RETURN
99999 FORMAT (A5, 1X, I1, 3X, 3F10.1)
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readun (Parusd)
-C
-C *** Card Set 5, unused parameters
-C
+!
+! *** Card Set 5, unused parameters
+!
use fixedi_m
use par_parameter_names_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
CHARACTER*5 Nam
-C DIMENSION Parusd(Numusd), Namusd(Numusd)
+! DIMENSION Parusd(Numusd), Namusd(Numusd)
DIMENSION Parusd(*)
-C
+!
N = (Numusd-1)/8 + 1
Kmin = 1
Kmax = 8
@@ -626,24 +623,24 @@ C
IF (Kmax.GT.Numusd) Kmax = Numusd
END DO
20 READ (Iu32,99999) Nam
-C BLANK CARD
+! BLANK CARD
RETURN
99999 FORMAT (8(A5, 5X))
99998 FORMAT (8F10.1)
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readba (Parbag, Iflbag)
-C
-C *** card set number what ? baggage parameters?
-C
+!
+! *** card set number what ? baggage parameters?
+!
use fixedi_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
DIMENSION Parbag(*), Iflbag(*)
-C
+!
READ (Iu32,99999) (Iflbag(I),I=1,Numbag)
READ (Iu32,99998) (Parbag(I),I=1,Numbag)
READ (Iu32,99998) A
@@ -651,21 +648,21 @@ C
99999 FORMAT (16I5)
99998 FORMAT (8F10.1)
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Brdinp (Parbrd, Iflbrd)
-C
+!
use fixedi_m
use ifwrit_m
use fixedr_m
use broad_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Parbrd(Numbrd), Iflbrd(Numbrd)
+!
+! DIMENSION Parbrd(Numbrd), Iflbrd(Numbrd)
DIMENSION Parbrd(*), Iflbrd(*)
-C
+!
Parbrd(1) = Crfn
Parbrd(2) = Temp
Parbrd(3) = Thick
@@ -675,7 +672,7 @@ C
Parbrd(7) = 0.0d0
CALL Zero_Integer (Iflbrd, 7)
Nvpbrd = 0
-C
+!
Kvcrfn = 0
Kvtemp = -1
Kvthck = -1
@@ -685,12 +682,12 @@ C
Kvdltc = 0
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Te_Sort (A, B, K)
-C *** Purpose -- Sort A & B in increasing order on A
+! *** Purpose -- Sort A & B in increasing order on A
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION A(*), B(*)
DO J=1,K
@@ -710,3 +707,4 @@ C *** Purpose -- Sort A & B in increasing order on A
END DO
RETURN
END
+end module par8_m
\ No newline at end of file
diff --git a/sammy/src/par/mpar09.f b/sammy/src/par/mpar09.f90
similarity index 70%
rename from sammy/src/par/mpar09.f
rename to sammy/src/par/mpar09.f90
index 566d36705..713d9a249 100755
--- a/sammy/src/par/mpar09.f
+++ b/sammy/src/par/mpar09.f90
@@ -1,20 +1,22 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module par9_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readre (Runcs, Juncs, Nuncer)
-C
-C *** last card set, second alternative
-C *** PURPOSE -- READ RELATIVE UNCERTAINTIES
-C
+!
+! *** last card set, second alternative
+! *** PURPOSE -- READ RELATIVE UNCERTAINTIES
+!
use fixedi_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Runcs(_,Nuncer), Juncs(_,Nuncer)
+!
+! DIMENSION Runcs(_,Nuncer), Juncs(_,Nuncer)
DIMENSION Runcs(Ntotc2+1,*), Juncs(Ntotc2,*)
DIMENSION Rr(5), Jj(5)
DATA Zero /0.0d0/
-C
+!
WRITE (21,99999)
99999 FORMAT (' RELATIVE UNCERTAINTIES INCLUDED IN PARAMETER FILE')
DO I=1,Nuncer
@@ -25,8 +27,7 @@ C
Runcs(Ntotc2+1,I) = Zero
Nm = 0
10 CONTINUE
- READ (Iu32,99998,END=30,ERR=30) A, (Rr(N),N=1,5),
- * (Jj(K),K=1,5), Z
+ READ (Iu32,99998,END=30,ERR=30) A, (Rr(N),N=1,5), (Jj(K),K=1,5), Z
99998 FORMAT (6E11.4, 5I2, F10.1)
IF (Nm.EQ.0) Runcs(1,I) = A
DO N=1,5
@@ -45,54 +46,49 @@ C
END DO
END DO
RETURN
-C
+!
30 WRITE (21,99997)
99997 FORMAT (' WARNING ** A NUMBER OF UNCERTAINTIES ARE INCORRECT')
RETURN
-C
+!
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readab (Nn, Mm, Kk, Ll, Vv, Noffv)
-C
-C *** Last card set, first alternative
-C *** PURPOSE -- READ EXPLICIT UNCERTAINTIES (ABSOLUTE)
-C
+!
+! *** Last card set, first alternative
+! *** PURPOSE -- READ EXPLICIT UNCERTAINTIES (ABSOLUTE)
+!
use fixedi_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Nn(Noffv), Mm(Noffv), Kk(Noffv), Ll(Noffv), Vv(Noffv)
+!
+! DIMENSION Nn(Noffv), Mm(Noffv), Kk(Noffv), Ll(Noffv), Vv(Noffv)
DIMENSION Nn(*), Mm(*), Kk(*), Ll(*), Vv(*)
-C
-C
+!
+!
DO No=1,Noffv
99999 FORMAT (4I5, F20.10)
- READ (Iu32,99999,END=40,ERR=40) Nn(No), Mm(No), Kk(No),
- * Ll(No), Vv(No)
+ READ (Iu32,99999,END=40,ERR=40) Nn(No), Mm(No), Kk(No), Ll(No), Vv(No)
END DO
-C
+!
IF (Noffv.EQ.1) RETURN
-C
-C *** CHECK IF THE SAME MATRIX ELEMENT IS INPUT MORE THAN ONCE
+!
+! *** CHECK IF THE SAME MATRIX ELEMENT IS INPUT MORE THAN ONCE
ISTOP = 0
DO 30 No=2,Noffv
Nom = No - 1
DO Noo=1,Nom
- IF (Nn(No).EQ.Nn(Noo) .AND. Mm(No).EQ.Mm(Noo) .AND.
- * Kk(No).EQ.Kk(Noo) .AND. Ll(No).EQ.Ll(Noo) ) THEN
+ IF (Nn(No).EQ.Nn(Noo) .AND. Mm(No).EQ.Mm(Noo) .AND. &
+ Kk(No).EQ.Kk(Noo) .AND. Ll(No).EQ.Ll(Noo) ) THEN
ISTOP = 1
WRITE (21,99998)
- WRITE (21,99997) No , Nn(No ), Mm(No ), Kk(No ), Ll(No ),
- * Vv(No)
- WRITE (21,99997) Noo, Nn(Noo), Mm(Noo), Kk(Noo), Ll(Noo),
- * Vv(Noo)
+ WRITE (21,99997) No , Nn(No ), Mm(No ), Kk(No ), Ll(No ), Vv(No)
+ WRITE (21,99997) Noo, Nn(Noo), Mm(Noo), Kk(Noo), Ll(Noo), Vv(Noo)
WRITE ( 6,99998)
- WRITE ( 6,99997) No , Nn(No ), Mm(No ), Kk(No ), Ll(No ),
- * Vv(No)
- WRITE ( 6,99997) Noo, Nn(Noo), Mm(Noo), Kk(Noo), Ll(Noo),
- * Vv(Noo)
+ WRITE ( 6,99997) No , Nn(No ), Mm(No ), Kk(No ), Ll(No ), Vv(No)
+ WRITE ( 6,99997) Noo, Nn(Noo), Mm(Noo), Kk(Noo), Ll(Noo), Vv(Noo)
GO TO 30
END IF
END DO
@@ -100,46 +96,46 @@ C *** CHECK IF THE SAME MATRIX ELEMENT IS INPUT MORE THAN ONCE
IF (ISTOP.EQ.1) STOP '[STOP in Readab in par/mpar7.f]'
40 CONTINUE
RETURN
-C
+!
99998 FORMAT(' ERROR ON EXPLICIT INPUT OF UNCERTAINTIES & CORRELATIONS')
99997 FORMAT (' CARD #', I3, '***', 4I5, 1PG14.6)
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Revise (NN, MM, KK, LL, VV, Noffv)
-C
-C *** PURPOSE -- CHECK WHETHER ANY OF THE EXPLICIT UNCERTAINTIES ARE WAY
-C *** OUT OF LINE -- IN WHICH CASE, CHANGE VALUE OF Gamma!!
-C
+!
+! *** PURPOSE -- CHECK WHETHER ANY OF THE EXPLICIT UNCERTAINTIES ARE WAY
+! *** OUT OF LINE -- IN WHICH CASE, CHANGE VALUE OF Gamma!!
+!
use fixedi_m
use SammyRMatrixParameters_M
use SammyResonanceInfo_M
use RMatResonanceParam_M
use EndfData_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Nn(Noffv), Mm(Noffv),
-C * Kk(Noffv), Ll(Noffv), Vv(Noffv)
+!
+! DIMENSION Nn(Noffv), Mm(Noffv),
+! * Kk(Noffv), Ll(Noffv), Vv(Noffv)
DIMENSION Nn(*), Mm(*), Kk(*), Ll(*), Vv(*)
type(SammyResonanceInfo)::resInfo
type(RMatResonance)::resonance
DATA Zero /0.0d0/
-C
-C
+!
+!
DO No=1,Noffv
IF (Nn(No).LE.1000) THEN
-C IF (THIS IS RESONANCE)
-C
+! IF (THIS IS RESONANCE)
+!
IF (Mm(No).NE.1) THEN
-C IF (THIS IS NOT ENERGY)
-C
+! IF (THIS IS NOT ENERGY)
+!
IF (Kk(No).EQ.0 .OR. Kk(No).EQ.Nn(No)) THEN
IF (Ll(No).EQ.0 .OR. Ll(No).EQ.Mm(No)) THEN
-C IF (THIS IS DIAGONAL)
-C
-C CHECK IF (Gamma)/(DelTA Gamma) .GT. 1.0/50.0
+! IF (THIS IS DIAGONAL)
+!
+! CHECK IF (Gamma)/(DelTA Gamma) .GT. 1.0/50.0
call resParData%getResonanceInfo(resInfo, Nn(No))
call resParData%getResonance(resonance, resInfo)
value = resonance%getWidth( Mm(No) - 1) ! Mm(No) can't be 1, because of above if statement
@@ -158,9 +154,10 @@ C CHECK IF (Gamma)/(DelTA Gamma) .GT. 1.0/50.0
END IF
END DO
RETURN
-C
-99999 FORMAT (/, ' For Resonance number', I3, ', Parameter number',
- * I2, ', the uncertainty Delta Gamma is', 1pE14.6, /,
- * ' This is more than 50 times the value of Gamma,',
- * E14.6, ', which is therefore changed to', E14.6, /)
+!
+99999 FORMAT (/, ' For Resonance number', I3, ', Parameter number', &
+ I2, ', the uncertainty Delta Gamma is', 1pE14.6, /, &
+ ' This is more than 50 times the value of Gamma,', &
+ E14.6, ', which is therefore changed to', E14.6, /)
END
+end module par9_m
\ No newline at end of file
diff --git a/sammy/src/par/mpar10.f b/sammy/src/par/mpar10.f90
similarity index 68%
rename from sammy/src/par/mpar10.f
rename to sammy/src/par/mpar10.f90
index 24609481e..994a32d77 100755
--- a/sammy/src/par/mpar10.f
+++ b/sammy/src/par/mpar10.f90
@@ -1,9 +1,11 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module par10_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Qpriu (Ix, Nprior, Alfn80)
-C *** Scan through "Prior uncertainties in key-word format", learn Nprior
+! *** Scan through "Prior uncertainties in key-word format", learn Nprior
use fixedi_m
use partyp_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
@@ -12,12 +14,12 @@ C *** Scan through "Prior uncertainties in key-word format", learn Nprior
CHARACTER*8 Name
EQUIVALENCE (File, Alfn80_Orig)
DIMENSION Junk(1)
-C
+!
Iprio = 0
Ippxx = 0
Ix = 1
10 CONTINUE
-CX READ (Iu32,10000,END=50) Alfn80
+!X READ (Iu32,10000,END=50) Alfn80
READ (Iu32,10000,END=50,ERR=50) Alfn80
10000 FORMAT (80A1)
IF (Alfn80(1).EQ.'#') GO TO 10
@@ -30,7 +32,7 @@ CX READ (Iu32,10000,END=50) Alfn80
GO TO 40
END IF
CALL Convert_To_Caps (Alfn80, Istop, Kpound)
-C
+!
Istart = 1
20 CONTINUE
IF (Istart.GT.Istop) GO TO 10
@@ -41,80 +43,80 @@ C
END IF
END DO
30 CONTINUE
-C
+!
IF (Istart.GT.Istop) GO TO 10
Ii = Istart
DO I=Ii,Istop
Istart = I
-C
- IF (Alfn80(I ).EQ.'P' .AND. Alfn80(I+1).EQ.'R' .AND.
- * Alfn80(I+2).EQ.'I' .AND. Alfn80(I+3).EQ.'O' .AND.
- * Ig.EQ.0) THEN
-C *** Here we have title line, so ignore
+!
+ IF (Alfn80(I ).EQ.'P' .AND. Alfn80(I+1).EQ.'R' .AND. &
+ Alfn80(I+2).EQ.'I' .AND. Alfn80(I+3).EQ.'O' .AND. &
+ Ig.EQ.0) THEN
+! *** Here we have title line, so ignore
GO TO 10
-C
- ELSE IF (Alfn80(I).EQ.'R' .AND. Alfn80(I+1).EQ.'E' .AND.
- * Alfn80(I+2).EQ.'L' .AND. Alfn80(I+3).EQ.'A') THEN
-C *** Here the key-word is "relative uncertainty"
+!
+ ELSE IF (Alfn80(I).EQ.'R' .AND. Alfn80(I+1).EQ.'E' .AND. &
+ Alfn80(I+2).EQ.'L' .AND. Alfn80(I+3).EQ.'A') THEN
+! *** Here the key-word is "relative uncertainty"
Istart = Istart + 4
CALL Get_Value (Value, Alfn80, Istart, Istop, Ierr)
Iprio = Iprio + 1
Ippxx = 0
IF (Istart.GE.Istop) GO TO 10
-C
- ELSE IF ((Alfn80(I).EQ.'A' .AND. Alfn80(I+1).EQ.'B' .AND.
- * Alfn80(I+2).EQ.'S' .AND. Alfn80(I+3).EQ.'O') .OR.
- * (Alfn80(I).EQ.'U' .AND. Alfn80(I+1).EQ.'N' .AND.
- * Alfn80(I+2).EQ.'C' .AND. Alfn80(I+3).EQ.'E'))THEN
-C *** Here the key-word is "absolute unc" or "uncertainty"
+!
+ ELSE IF ((Alfn80(I).EQ.'A' .AND. Alfn80(I+1).EQ.'B' .AND. &
+ Alfn80(I+2).EQ.'S' .AND. Alfn80(I+3).EQ.'O') .OR. &
+ (Alfn80(I).EQ.'U' .AND. Alfn80(I+1).EQ.'N' .AND. &
+ Alfn80(I+2).EQ.'C' .AND. Alfn80(I+3).EQ.'E'))THEN
+! *** Here the key-word is "absolute unc" or "uncertainty"
Istart = Istart + 2
CALL Get_Value (Value, Alfn80, Istart, Istop, Ierr)
Iprio = Iprio + 1
Ippxx = 0
IF (Istart.GE.Istop) GO TO 10
-C
- ELSE IF (Alfn80(I).EQ.'E' .AND. Alfn80(I+1).EQ.'M' .AND.
- * Alfn80(I+2).EQ.'I' .AND. Alfn80(I+3).EQ.'N') THEN
-C *** Here the key-word is "EMIN"
+!
+ ELSE IF (Alfn80(I).EQ.'E' .AND. Alfn80(I+1).EQ.'M' .AND. &
+ Alfn80(I+2).EQ.'I' .AND. Alfn80(I+3).EQ.'N') THEN
+! *** Here the key-word is "EMIN"
Istart = Istart + 4
CALL Get_Value (Value, Alfn80, Istart, Istop, Ierr)
IF (Istart.GE.Istop) GO TO 10
-C
- ELSE IF (Alfn80(I).EQ.'E' .AND. Alfn80(I+1).EQ.'M' .AND.
- * Alfn80(I+2).EQ.'A' .AND. Alfn80(I+3).EQ.'X') THEN
-C *** Here the key-word is "EMAX"
+!
+ ELSE IF (Alfn80(I).EQ.'E' .AND. Alfn80(I+1).EQ.'M' .AND. &
+ Alfn80(I+2).EQ.'A' .AND. Alfn80(I+3).EQ.'X') THEN
+! *** Here the key-word is "EMAX"
Istart = Istart + 4
CALL Get_Value (Value, Alfn80, Istart, Istop, Ierr)
IF (Istart.GE.Istop) GO TO 10
-C
- ELSE IF ((Alfn80(I).EQ.'P' .AND. Alfn80(I+1).EQ.'A' .AND.
- * Alfn80(I+2).EQ.'R' .AND. Alfn80(I+3).EQ.'T') .OR.
- * (Alfn80(I).EQ.'P' .AND. Alfn80(I+1).EQ.'P'))THEN
-C *** Here the key-word is "Particle-Pair" or "PP"
+!
+ ELSE IF ((Alfn80(I).EQ.'P' .AND. Alfn80(I+1).EQ.'A' .AND. &
+ Alfn80(I+2).EQ.'R' .AND. Alfn80(I+3).EQ.'T') .OR. &
+ (Alfn80(I).EQ.'P' .AND. Alfn80(I+1).EQ.'P'))THEN
+! *** Here the key-word is "Particle-Pair" or "PP"
Istart = Istart + 2
CALL Set_Nam (Name, Alfn80_Orig, Istart, Istop, Ierr)
Ippxx = Ippxx + 1
-C
- ELSE IF ((Alfn80(I).EQ.'L' .AND. Alfn80(I+1).EQ.'=') .OR.
- * (Alfn80(I).EQ.'L' .AND. Alfn80(I+1).EQ.' ') .OR.
- * (Alfn80(I).EQ.'O' .AND. Alfn80(I+1).EQ.'R'))THEN
-C *** Here the key-word is "L" or "Orbital angular momentum"
- IF (Ippxx.EQ.0)
- * STOP '[Ippx.EQ.0 in Qpriu in par/mpar10.f]'
- IF (Iprio.EQ.0)
- * STOP '[Iprio.EQ.0 in Qpriu in par/mpar10.f]'
+!
+ ELSE IF ((Alfn80(I).EQ.'L' .AND. Alfn80(I+1).EQ.'=') .OR. &
+ (Alfn80(I).EQ.'L' .AND. Alfn80(I+1).EQ.' ') .OR. &
+ (Alfn80(I).EQ.'O' .AND. Alfn80(I+1).EQ.'R'))THEN
+! *** Here the key-word is "L" or "Orbital angular momentum"
+ IF (Ippxx.EQ.0) &
+ STOP '[Ippx.EQ.0 in Qpriu in par/mpar10.f]'
+ IF (Iprio.EQ.0) &
+ STOP '[Iprio.EQ.0 in Qpriu in par/mpar10.f]'
CALL Get_L (Junk, Alfn80, Istart, Istop, Ierr, -99)
-C
+!
ELSE IF (Alfn80(I).EQ.'G' .AND. Alfn80(I+1).EQ.'R') THEN
-C *** Here the key-word is "GRoup"
- CALL Get_Group (Ig, Alfn80, Istart, Istop, Ierr,
- * Ngroup)
+! *** Here the key-word is "GRoup"
+ CALL Get_Group (Ig, Alfn80, Istart, Istop, Ierr, &
+ Ngroup)
Istart = Istop + 1
-C
+!
ELSE IF (Alfn80(I).EQ.'C' .AND. Alfn80(I+1).EQ.'H') THEN
-C *** Here the key-word is "CHannel" [with Ig > 0]
+! *** Here the key-word is "CHannel" [with Ig > 0]
Istart = Istop + 1
-C
+!
ELSE
WRITE (6,30100) (Alfn80( K),K=1,20)
WRITE (6,30100) (Alfn80(I-1+K),K=1,20)
@@ -131,23 +133,23 @@ C
END IF
END DO
GO TO 10
-C
+!
40 CONTINUE
-C
-C ---
+!
+! ---
CALL Pread (Iu32)
-C
+!
IF (Alfnm1.NE.Endddd .AND. Alfnm1.NE.Blank5) THEN
IF (Alfnm1.NE.Explic .AND. Alfnm1.NE.Relunc) THEN
WRITE (6,10100)
-10100 FORMAT (/, ' ###############################################
- *##################', /)
+10100 FORMAT (/, ' ########################################', &
+ '########################', /)
WRITE (6,10200) Alfnm1
-10200 FORMAT (' ERROR -- Covariance information must be the',
- * 1X, 'final Card Set in', /,
- * ' the PARameter file. Please move the',
- * 1X, 'following Card Set', /,
- * ' <<< ', A5, ' >>> to an earlier site.')
+10200 FORMAT (' ERROR -- Covariance information must be the', &
+ 1X, 'final Card Set in', /, &
+ ' the PARameter file. Please move the', &
+ 1X, 'following Card Set', /, &
+ ' <<< ', A5, ' >>> to an earlier site.')
WRITE (6,10100)
STOP '[STOP in Qrelu in par/mpar10.f]'
END IF
@@ -155,12 +157,12 @@ C
ELSE
Ix = 1
END IF
-C ---
-C
+! ---
+!
50 CONTINUE
Nprior = Iprio
RETURN
-C
+!
200 CONTINUE
IF (Ierr.EQ.1) THEN
WRITE (6,10300)
@@ -170,15 +172,15 @@ C
10400 FORMAT ('No equal sign after key word')
END IF
STOP '[STOP in Qpriu in par/mpar10.f # 2]'
-C
+!
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Readpr (Prior,
- * Iprior, Jprior, Kprior, Lprior, Alfn80, Lmax, Nprior)
-C *** Read resonance parameter uncertainties in key-word format
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Readpr (Prior, Iprior, Jprior, Kprior, Lprior, Alfn80, Lmax, &
+ Nprior)
+! *** Read resonance parameter uncertainties in key-word format
use fixedi_m
use ifwrit_m
use par_parameter_names_common_m
@@ -191,36 +193,34 @@ C *** Read resonance parameter uncertainties in key-word format
CHARACTER*80 File
CHARACTER*1 Alfn80(80), Alfn80_Orig(80)
CHARACTER*8 Name, Prinam
- DIMENSION
- * Prior(*), Iprior(*), Jprior(Ntotc2,*),
- * Kprior(Ntotc2,*), Lprior(*)
-C * Kprior(Ntotc2,Ngroup), Lprior(Lmax)
+ DIMENSION Prior(*),Iprior(*),Jprior(Ntotc2,*), Kprior(Ntotc2,*), Lprior(*)
+! * Kprior(Ntotc2,Ngroup), Lprior(Lmax)
EQUIVALENCE (File, Alfn80_Orig)
DATA Zero /0.0d0/
-C
-C
-C *** Prior (Ipr) = value of uncertainty Number "Ipr"
-C *** Iprior(Ipr) = 1 if relative, 0 if absolute
-C *** Jprior(I,Irs) = Ipr = uncertainty number for that channel & resonance
-C *** where I=Ntot(Igroup)+1 means energy
-C *** and I=Ntot(Igroup)+2 means gamma width
+!
+!
+! *** Prior (Ipr) = value of uncertainty Number "Ipr"
+! *** Iprior(Ipr) = 1 if relative, 0 if absolute
+! *** Jprior(I,Irs) = Ipr = uncertainty number for that channel & resonance
+! *** where I=Ntot(Igroup)+1 means energy
+! *** and I=Ntot(Igroup)+2 means gamma width
CALL Zero_Array (Prior , Nprior)
CALL Zero_Integer (Iprior, Nprior)
CALL Zero_Integer (Jprior, Ntotc2*Nres)
Pmin = Zero
Pmax = Zero
-C
-C *** Temporary arrays used here only --
-C *** Kprior(I,Igr) = Ipr = uncertainty number for that channel & group
-C *** Lprior(L ) = 1 if this (L-1) uses this uncertainty
+!
+! *** Temporary arrays used here only --
+! *** Kprior(I,Igr) = Ipr = uncertainty number for that channel & group
+! *** Lprior(L ) = 1 if this (L-1) uses this uncertainty
CALL Zero_Integer (Kprior, Ntotc2*Ngroup)
CALL Zero_Integer (Lprior, Lmax)
-C
+!
Iprio = 0
Ippxx = 0
Ig = 0
10 CONTINUE
-CX READ (Iu32,10200,END=40) Alfn80
+!X READ (Iu32,10200,END=40) Alfn80
READ (Iu32,10200,END=40,ERR=40) Alfn80
10200 FORMAT (80A1)
IF (Alfn80(1).EQ.'#') GO TO 10
@@ -233,7 +233,7 @@ CX READ (Iu32,10200,END=40) Alfn80
GO TO 40
END IF
CALL Convert_To_Caps (Alfn80, Istop, Kpound)
-C
+!
Istart = 1
20 CONTINUE
IF (Istart.GT.Istop) GO TO 10
@@ -244,24 +244,24 @@ C
END IF
END DO
30 CONTINUE
-C
+!
IF (Istart.GT.Istop) GO TO 10
Ii = Istart
DO I=Ii,Istop
Istart = I
-C
- IF (Alfn80(I ).EQ.'P' .AND. Alfn80(I+1).EQ.'R' .AND.
- * Alfn80(I+2).EQ.'I' .AND. Alfn80(I+3).EQ.'O' .AND.
- * Ig.EQ.0) THEN
-C *** Here we have title line, so ignore
+!
+ IF (Alfn80(I ).EQ.'P' .AND. Alfn80(I+1).EQ.'R' .AND. &
+ Alfn80(I+2).EQ.'I' .AND. Alfn80(I+3).EQ.'O' .AND. &
+ Ig.EQ.0) THEN
+! *** Here we have title line, so ignore
GO TO 10
-C
- ELSE IF (Alfn80(I).EQ.'R' .AND. Alfn80(I+1).EQ.'E' .AND.
- * Alfn80(I+2).EQ.'L' .AND. Alfn80(I+3).EQ.'A') THEN
-C *** Here the key-word is "relative uncertainty"
- IF (Iprio.GT.0) CALL Group_To_Resonance (
- * Jprior, Kprior, Lprior, Pmin, Pmax, Iprio,
- * Lmax)
+!
+ ELSE IF (Alfn80(I).EQ.'R' .AND. Alfn80(I+1).EQ.'E' .AND. &
+ Alfn80(I+2).EQ.'L' .AND. Alfn80(I+3).EQ.'A') THEN
+! *** Here the key-word is "relative uncertainty"
+ IF (Iprio.GT.0) CALL Group_To_Resonance ( &
+ Jprior, Kprior, Lprior, Pmin, Pmax, Iprio, &
+ Lmax)
Istart = Istart + 4
CALL Get_Value (Value, Alfn80, Istart, Istop, Ierr)
Iprio = Iprio + 1
@@ -269,15 +269,15 @@ C *** Here the key-word is "relative uncertainty"
Iprior(Iprio) = 1
Ippxx = 0
IF (Istart.GE.Istop) GO TO 10
-C
- ELSE IF ((Alfn80(I).EQ.'A' .AND. Alfn80(I+1).EQ.'B' .AND.
- * Alfn80(I+2).EQ.'S' .AND. Alfn80(I+3).EQ.'O') .OR.
- * (Alfn80(I).EQ.'U' .AND. Alfn80(I+1).EQ.'N' .AND.
- * Alfn80(I+2).EQ.'C' .AND. Alfn80(I+3).EQ.'E'))THEN
-C *** Here the key-word is "absolute unc" or "uncertainty"
- IF (Iprio.GT.0) CALL Group_To_Resonance (
- * Jprior, Kprior, Lprior, Pmin, Pmax, Iprio,
- * Lmax)
+!
+ ELSE IF ((Alfn80(I).EQ.'A' .AND. Alfn80(I+1).EQ.'B' .AND. &
+ Alfn80(I+2).EQ.'S' .AND. Alfn80(I+3).EQ.'O') .OR. &
+ (Alfn80(I).EQ.'U' .AND. Alfn80(I+1).EQ.'N' .AND. &
+ Alfn80(I+2).EQ.'C' .AND. Alfn80(I+3).EQ.'E'))THEN
+! *** Here the key-word is "absolute unc" or "uncertainty"
+ IF (Iprio.GT.0) CALL Group_To_Resonance ( &
+ Jprior, Kprior, Lprior, Pmin, Pmax, Iprio, &
+ Lmax)
Istart = Istart + 2
CALL Get_Value (Value, Alfn80, Istart, Istop, Ierr)
Iprio = Iprio + 1
@@ -285,27 +285,27 @@ C *** Here the key-word is "absolute unc" or "uncertainty"
Iprior(Iprio) = 0
Ippxx = 0
IF (Istart.GE.Istop) GO TO 10
-C
- ELSE IF (Alfn80(I).EQ.'E' .AND. Alfn80(I+1).EQ.'M' .AND.
- * Alfn80(I+2).EQ.'I' .AND. Alfn80(I+3).EQ.'N') THEN
-C *** Here the key-word is "EMIN"
+!
+ ELSE IF (Alfn80(I).EQ.'E' .AND. Alfn80(I+1).EQ.'M' .AND. &
+ Alfn80(I+2).EQ.'I' .AND. Alfn80(I+3).EQ.'N') THEN
+! *** Here the key-word is "EMIN"
Istart = Istart + 4
CALL Get_Value (Value, Alfn80, Istart, Istop, Ierr)
Pmin = Value
IF (Istart.GE.Istop) GO TO 10
-C
- ELSE IF (Alfn80(I).EQ.'E' .AND. Alfn80(I+1).EQ.'M' .AND.
- * Alfn80(I+2).EQ.'A' .AND. Alfn80(I+3).EQ.'X') THEN
-C *** Here the key-word is "EMAX"
+!
+ ELSE IF (Alfn80(I).EQ.'E' .AND. Alfn80(I+1).EQ.'M' .AND. &
+ Alfn80(I+2).EQ.'A' .AND. Alfn80(I+3).EQ.'X') THEN
+! *** Here the key-word is "EMAX"
Istart = Istart + 4
CALL Get_Value (Value, Alfn80, Istart, Istop, Ierr)
Pmax = Value
IF (Istart.GE.Istop) GO TO 10
-C
- ELSE IF ((Alfn80(I).EQ.'P' .AND. Alfn80(I+1).EQ.'A' .AND.
- * Alfn80(I+2).EQ.'R' .AND. Alfn80(I+3).EQ.'T') .OR.
- * (Alfn80(I).EQ.'P' .AND. Alfn80(I+1).EQ.'P'))THEN
-C *** Here the key-word is "Particle-Pair" or "PP"
+!
+ ELSE IF ((Alfn80(I).EQ.'P' .AND. Alfn80(I+1).EQ.'A' .AND. &
+ Alfn80(I+2).EQ.'R' .AND. Alfn80(I+3).EQ.'T') .OR. &
+ (Alfn80(I).EQ.'P' .AND. Alfn80(I+1).EQ.'P'))THEN
+! *** Here the key-word is "Particle-Pair" or "PP"
Istart = Istart + 2
Ia = Istart
Ib = Istop
@@ -317,32 +317,29 @@ C *** Here the key-word is "Particle-Pair" or "PP"
Prinam = Name
CALL Move_To_Ke (Kprior, Prinam, Iprio)
END IF
-C
- ELSE IF ((Alfn80(I).EQ.'L' .AND. Alfn80(I+1).EQ.'=') .OR.
- * (Alfn80(I).EQ.'L' .AND. Alfn80(I+1).EQ.' ') .OR.
- * (Alfn80(I).EQ.'O' .AND. Alfn80(I+1).EQ.'R'))THEN
-C *** Here the key-word is "L" or "Orbital angular momentum"
-C *** (Must know Ippxx before read these)
-C *** (These must be the last values on the line)
- IF (Ippxx.EQ.0)
- * STOP '[Ippxx.EQ.0 in Readpr in par/mpar10.f]'
- IF (Iprio.EQ.0)
- * STOP '[Iprio.EQ.0 in Readpr in par/mpar10.f]'
+!
+ ELSE IF ((Alfn80(I).EQ.'L' .AND. Alfn80(I+1).EQ.'=') .OR. &
+ (Alfn80(I).EQ.'L' .AND. Alfn80(I+1).EQ.' ') .OR. &
+ (Alfn80(I).EQ.'O' .AND. Alfn80(I+1).EQ.'R'))THEN
+! *** Here the key-word is "L" or "Orbital angular momentum"
+! *** (Must know Ippxx before read these)
+! *** (These must be the last values on the line)
+ IF (Ippxx.EQ.0) STOP '[Ippxx.EQ.0 in Readpr in par/mpar10.f]'
+ IF (Iprio.EQ.0) STOP '[Iprio.EQ.0 in Readpr in par/mpar10.f]'
CALL Get_L (Lprior, Alfn80, Istart, Istop, Ierr, Lmax)
CALL Move_To_K (Kprior, Prinam, Lprior, Lmax, Iprio)
-C
+!
ELSE IF (Alfn80(I).EQ.'G' .AND. Alfn80(I+1).EQ.'R') THEN
-C *** Here the key-word is "GRoup"
- CALL Get_Group (Ig, Alfn80, Istart, Istop, Ierr,
- * Ngroup)
- CALL Get_Channel (Kprior, Alfn80, Istart,
- * Istop, Ierr, Ntotc2, Ig, Iprio)
-C
+! *** Here the key-word is "GRoup"
+ CALL Get_Group (Ig, Alfn80, Istart, Istop, Ierr, Ngroup)
+ CALL Get_Channel (Kprior, Alfn80, Istart, &
+ Istop, Ierr, Ntotc2, Ig, Iprio)
+!
ELSE IF (Alfn80(I).EQ.'C' .AND. Alfn80(I+1).EQ.'H') THEN
-C *** Here the key-word is "CHannel"
- CALL Get_Channel (Kprior, Alfn80, Istart,
- * Istop, Ierr, Ntotc2, Ig, Iprio)
-C
+! *** Here the key-word is "CHannel"
+ CALL Get_Channel (Kprior, Alfn80, Istart, &
+ Istop, Ierr, Ntotc2, Ig, Iprio)
+!
ELSE
WRITE (6,10400) (Alfn80(I-1+K),K=1,10)
10400 FORMAT ('Alfn80 = <<<', 10A1, '>>>')
@@ -357,15 +354,14 @@ C
END IF
END DO
GO TO 10
-C
+!
40 CONTINUE
- IF (Iprio.NE.Nprior)
- * STOP '[Iprio.NE.Nprior in Readpr in par/mpar10.f]'
- IF (Iprio.GT.0) CALL Group_To_Resonance (
- * Jprior, Kprior, Lprior, Pmin, Pmax, Iprio, Lmax)
-C
-C *** Reorganize to put energy & gamma width ahead of particle-widths
-C *** Note that Lprior is a dummy here
+ IF (Iprio.NE.Nprior) STOP '[Iprio.NE.Nprior in Readpr in par/mpar10.f]'
+ IF (Iprio.GT.0) CALL Group_To_Resonance ( &
+ Jprior, Kprior, Lprior, Pmin, Pmax, Iprio, Lmax)
+!
+! *** Reorganize to put energy & gamma width ahead of particle-widths
+! *** Note that Lprior is a dummy here
DO Ires=1,Nres
call resParData%getResonanceInfo(resInfo, Ires)
Ig = resInfo%getSpinGroupIndex()
@@ -380,9 +376,9 @@ C *** Note that Lprior is a dummy here
Jprior(Ich+2,Ires) = Lprior(Ich)
END DO
END DO
-C
+!
RETURN
-C
+!
200 CONTINUE
IF (Ierr.EQ.1) THEN
WRITE (6,10600)
@@ -392,16 +388,16 @@ C
10700 FORMAT ('No equal sign after key word')
END IF
STOP '[STOP in Readpr in par/mpar10.f # 2]'
-C
+!
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Group_To_Resonance (Jprior,
- * Kprior, Lprior, Pmin, Pmax, Iprio, Lmax)
-C *** Convert from Kprior to Jprior to take care of Emin,Emax
-C *** Zero temporary arrays to restart
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Group_To_Resonance (Jprior, &
+ Kprior, Lprior, Pmin, Pmax, Iprio, Lmax)
+! *** Convert from Kprior to Jprior to take care of Emin,Emax
+! *** Zero temporary arrays to restart
use fixedi_m
use ifwrit_m
use par_parameter_names_common_m
@@ -422,7 +418,7 @@ C *** Zero temporary arrays to restart
integer::ires, kp, nchan2, I, ig
DATA Zero /0.0d0/
-C
+!
DO Ires=1,resParData%getNumResonances()
call resParData%getResonanceInfo(resInfo, Ires)
call resParData%getResonance(resonance, resInfo)
@@ -450,12 +446,12 @@ C
CALL Zero_Integer (Lprior, Lmax)
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Move_To_Ke (Kprior, Prinam, Iprio)
-C *** Convert from Prinam=ENERGY or GAMMA to Kprior
+! *** Convert from Prinam=ENERGY or GAMMA to Kprior
use fixedi_m
use EndfData_common_m
use SammyParticlePairInfo_M
@@ -463,7 +459,7 @@ C *** Convert from Prinam=ENERGY or GAMMA to Kprior
CHARACTER*8 Prinam
type(SammySpinGroupInfo)::spinInfo
DIMENSION Kprior(Ntotc2,*)
-C
+!
DO Ig=1,resParData%getNumSpinGroups()
call resParData%getSpinGroupInfo(spinInfo, Ig)
IF (Prinam.EQ.'ENERGY ') THEN
@@ -480,13 +476,12 @@ C
END DO
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Move_To_K (Kprior, Prinam, Lprior,
- * Lmax, Iprio)
-C *** Convert from Lprior+Prinam to Kprior
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Move_To_K (Kprior, Prinam, Lprior, Lmax, Iprio)
+! *** Convert from Lprior+Prinam to Kprior
use fixedi_m
use par_parameter_names_common_m
use EndfData_common_m
@@ -500,7 +495,7 @@ C *** Convert from Lprior+Prinam to Kprior
type(SammyChannelInfo)::channelInfo
character(len=8)::pname
DIMENSION Kprior(Ntotc2,*), Lprior(Lmax)
-C
+!
DO Ig=1,resParData%getNumSpinGroups()
call resParData%getSpinGroupInfo(spinInfo, Ig)
DO Ich=1,spinInfo%getNumChannels()
@@ -528,3 +523,4 @@ C
END DO
RETURN
END
+end module par10_m
\ No newline at end of file
diff --git a/sammy/src/par/mpar11.f b/sammy/src/par/mpar11.f90
similarity index 73%
rename from sammy/src/par/mpar11.f
rename to sammy/src/par/mpar11.f90
index 50eec0786..5f1728be6 100644
--- a/sammy/src/par/mpar11.f
+++ b/sammy/src/par/mpar11.f90
@@ -1,9 +1,11 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module par11_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Radfix (Bound, Igrrad, Partru)
-C
+!
use sammy_CoulombSelector_I
use fixedi_m
use ifwrit_m
@@ -14,30 +16,30 @@ C
use RMatResonanceParam_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
EXTERNAL Sf
-C
-C DIMENSION Ntot(Ngroup),
-C * Bound(Ntotc,Ngroup), Igrrad(Ntotc,Ngroup),
-C * Partru(Numrad)
+!
+! DIMENSION Ntot(Ngroup),
+! * Bound(Ntotc,Ngroup), Igrrad(Ntotc,Ngroup),
+! * Partru(Numrad)
type(SammySpinGroupInfo)::spinInfo
type(SammyParticlePairInfo)::pairInfo
type(RMatParticlePair)::pair
type(RMatChannelParams)::channel
type(SammyChannelInfo)::channelInfo
DIMENSION Bound(Ntotc,*), Igrrad(Ntotc,*), Partru(*)
-C
+!
Jdopha = 0
Jdoder = 0
-C
+!
DATA Zero /0.0d0/
-C
+!
DO J=1,resParData%getNumSpinGroups()
call resParData%getSpinGroupInfo(spinInfo, J)
Ntotj = spinInfo%getNumChannels()
DO N=1,Ntotj
call spinInfo%getChannelInfo(channelInfo, N)
- call resParData%getParticlePairInfo(
- * pairInfo,
- * channelInfo%getParticlePairIndex())
+ call resParData%getParticlePairInfo( &
+ pairInfo, &
+ channelInfo%getParticlePairIndex())
call resParData%getParticlePair(pair, pairInfo)
call resParData%getChannel(channel, channelInfo)
enbnd = channel%getBnd()
@@ -48,8 +50,8 @@ C
Cycrfn = Cayt*Partru(Igrrad(N,J))
Docoul = dfloat(pair%getZa(1)*pair%getZa(2))
IF (Docoul.EQ.Zero) THEN
- Bound(N,J) = Sf(Cycrfn*dSQRT(Enbnd),
- * channel%getL(), Zero)
+ Bound(N,J) = Sf(Cycrfn*dSQRT(Enbnd), &
+ channel%getL(), Zero)
ELSE
L = channel%getL()
Rho = Cycrfn * dSQRT(Enbnd)
@@ -63,11 +65,11 @@ C
else
Ishift = 0
end if
- CALL f_sammy_columb_Pspcou (kwcoul,
- & Rho, L, Eta, Ishift,
- & Jdopha,
- & Jdoder, Ifail, Pent, Shift, Der, Dshift,
- & Sinphi, Cosphi, Dphi)
+ CALL f_sammy_columb_Pspcou (kwcoul, &
+ Rho, L, Eta, Ishift, &
+ Jdopha, &
+ Jdoder, Ifail, Pent, Shift, Der, Dshift, &
+ Sinphi, Cosphi, Dphi)
IF (Ifail.EQ.0) THEN
Bound(N,J) = Shift
ELSE
@@ -85,21 +87,21 @@ C
END DO
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Outddc (Nunit)
-C
-C *** PURPOSE -- OUTPUT I VS A1(I) IN COLUMNS
-C
+!
+! *** PURPOSE -- OUTPUT I VS A1(I) IN COLUMNS
+!
use parentheses_common_m
use ptitle_common_m
use EndfData_common_m
use SammyRMatrixParameters_M
use SammyResonanceInfo_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
real(kind=8),allocatable,dimension(:):: A1
type(SammyResonanceInfo)::resInfo
@@ -115,7 +117,7 @@ C
M = 6
IF (N.LT.M) M = N
WRITE (Nunit,99998) (T1,I=1,M)
-C
+!
M = N/6
MM = M*6
IF (MM.NE.N) THEN
@@ -127,50 +129,48 @@ C
MM = M
END IF
DO I=1,MM
- IF (N.LE.999) WRITE (Nunit,99997)
- * ((Parenl,L,Parenr,L=I+(K-1)*M,I+(K-1)*M),
- * A1(I+(K-1)*M),K=1,6)
- IF (N.GT.999) WRITE (Nunit,99996)
- * ((Parenl,L,Parenr,L=I+(K-1)*M,I+(K-1)*M),
- * A1(I+(K-1)*M),K=1,6)
+ IF (N.LE.999) WRITE (Nunit,99997) &
+ ((Parenl,L,Parenr,L=I+(K-1)*M,I+(K-1)*M), &
+ A1(I+(K-1)*M),K=1,6)
+ IF (N.GT.999) WRITE (Nunit,99996) &
+ ((Parenl,L,Parenr,L=I+(K-1)*M,I+(K-1)*M), &
+ A1(I+(K-1)*M),K=1,6)
END DO
IF (MM.NE.M) THEN
MM = MM + 1
DO I=MM,M
- IF (N.LE.999) WRITE (Nunit,99997)
- * ((Parenl,L,Parenr,L=I+(K-1)*M,I+(K-1)*M),
- * A1(I+(K-1)*M),K=1,5)
- IF (N.GT.999) WRITE (Nunit,99996)
- * ((Parenl,L,Parenr,L=I+(K-1)*M,I+(K-1)*M),
- * A1(I+(K-1)*M),K=1,5)
+ IF (N.LE.999) WRITE (Nunit,99997) &
+ ((Parenl,L,Parenr,L=I+(K-1)*M,I+(K-1)*M), &
+ A1(I+(K-1)*M),K=1,5)
+ IF (N.GT.999) WRITE (Nunit,99996) &
+ ((Parenl,L,Parenr,L=I+(K-1)*M,I+(K-1)*M), &
+ A1(I+(K-1)*M),K=1,5)
END DO
END IF
deallocate(A1)
RETURN
-C
+!
60 CONTINUE
- IF (N.LE.999) WRITE (Nunit,99997) (Parenl,I,Parenr,
- * A1(I),I=1,N)
- IF (N.GT.999) WRITE (Nunit,99996) (Parenl,I,Parenr,
- * A1(I),I=1,N)
+ IF (N.LE.999) WRITE (Nunit,99997) (Parenl,I,Parenr, A1(I),I=1,N)
+ IF (N.GT.999) WRITE (Nunit,99996) (Parenl,I,Parenr, A1(I),I=1,N)
RETURN
99999 FORMAT (///,' *****', 10A5)
99998 FORMAT (/8X, 5(2A5, 10X), 2A5)
99997 FORMAT ((1X, A1, I3, A1, 1PG12.4, 5(3X, A1, I3, A1, 1PG12.4)))
99996 FORMAT ((1X, A1, I4, A1, 1PG12.4, 5(2X, A1, I4, A1, 1PG12.4)))
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Order (Parmsc, Iradms, Ddcov)
-C
-C *** Purpose -- Reorder resonance parameters by energy (low to high) and
-C *** by J-pi groups
-C *** Also, introduce Gamma-gamma fixed per spin group,
-C *** If needed.
-C ***
-C
+!
+! *** Purpose -- Reorder resonance parameters by energy (low to high) and
+! *** by J-pi groups
+! *** Also, introduce Gamma-gamma fixed per spin group,
+! *** If needed.
+! ***
+!
use fixedi_m
use ifwrit_m
use SammyRMatrixParameters_M
@@ -178,23 +178,21 @@ C
use SammySpinGroupInfo_M
use EndfData_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION
- * Parmsc(*),
- * Iradms(*), Ddcov(*)
-C
+!
+ DIMENSION Parmsc(*), Iradms(*), Ddcov(*)
+!
type(SammyResonanceInfo)::resInfo
type(SammySpinGroupInfo)::spinInfo
type(RMatResonance)::resonance
DATA Zero /0.0d0/
-C
-C
+!
+!
WRITE (21,99999) Nres, Ntotc, Ngroup, Nfpall, Nvpall
-99999 FORMAT (/' Total number of resonances is', I5, /,
- * ' Number of particle channels is', I5, /,
- * ' Number of spin groups is ', I5, /,
- * ' Number of flagged parametrs is', I5, /,
- * ' Number of varied parameters is', I5)
+99999 FORMAT (/' Total number of resonances is', I5, /, &
+ ' Number of particle channels is', I5, /, &
+ ' Number of spin groups is ', I5, /, &
+ ' Number of flagged parametrs is', I5, /, &
+ ' Number of varied parameters is', I5)
IF (Numiso.GT.0) WRITE (21,79998) Numiso
79998 FORMAT ( ' Number of nuclides is ', i5)
IF (LLLmax.GT.0) WRITE (21,79997) LLLmax
@@ -202,8 +200,8 @@ C
IF (Nangle.GT.0) WRITE (21,79996) Nangle
79996 FORMAT ( ' Number of angles d_sig/d_omeg ', I5)
IF (Numpup.GT.0) WRITE (21,79995) Numpup
-79995 FORMAT ( ' Number of pupped parameters is', I5, /,
- * ' ("pup" = "Propagated-Uncertainty Parameter")')
+79995 FORMAT ( ' Number of pupped parameters is', I5, /, &
+ ' ("pup" = "Propagated-Uncertainty Parameter")')
IF (Kdebug.NE.0) THEN
WRITE (6,99999) Nres, Ntotc, Ngroup, Nfpall, Nvpall
IF (Numiso.GT.0) WRITE (6,79998) Numiso
@@ -211,22 +209,22 @@ C
IF (Nangle.GT.0) WRITE (6,79996) Nangle
IF (Numpup.GT.0) WRITE (6,79995) Numpup
END IF
-C
+!
IF (Ksolve.NE.2) THEN
IF (Nvpall.EQ.0) THEN
IF (Kaverg.EQ.0) THEN
WRITE (21,99998)
WRITE (6,99998)
-99998 FORMAT (//' ***** SAMMY expects to find a varied parameter',
- * /, ' when SOLVE BAYES EQUATIONS is specified.'/
- * ' ***** Fix your parameter file and try again, please.')
+99998 FORMAT (//' ***** SAMMY expects to find a varied parameter', &
+ /, ' when SOLVE BAYES EQUATIONS is specified.'/ &
+ ' ***** Fix your parameter file and try again, please.')
STOP '[STOP in Order in mpar11.f; need varied parameter]'
ELSE
WRITE (21,69998)
WRITE (6,69998)
-69998 FORMAT (//' ***** SAMMY expects to find a varied parameter',
- * /, ' when averages are requested. Modify your'/
- * ' parameter file and try again, please.')
+69998 FORMAT (//' ***** SAMMY expects to find a varied parameter', &
+ /, ' when averages are requested. Modify your'/ &
+ ' parameter file and try again, please.')
STOP '[STOP in Order in par/mpar11.f # 2]'
END IF
END IF
@@ -284,28 +282,27 @@ C
end if
end do
-C
+!
RETURN
-C
-99997 FORMAT (/, ' ***** Number of channels in Par file is inconsistent
- *with', /
- * ' number of channels in INP file for group number',
- * I3, ' (i.e.', I2, '.ne.', I2, ')', //,
- * ' ***** Please check your input! *****', /)
+!
+99997 FORMAT (/, ' ***** Number of channels in Par file is inconsistent with', &
+ /, ' number of channels in INP file for group number', &
+ I3, ' (i.e.', I2, '.ne.', I2, ')', //, &
+ ' ***** Please check your input! *****', /)
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Fixpol (Iflpol)
-CC *** Purpose -- Generate flags for polar version of fission widths
-C
+! *** Purpose -- Generate flags for polar version of fission widths
+!
use fixedi_m
use SammyResonanceInfo_M
use RMatResonanceParam_M
use EndfData_common_m
IMPLICIT NONE
-C
+!
INTEGER::Iflpol(2,*)
type(SammyResonanceInfo)::resInfo
@@ -320,12 +317,12 @@ C
Iflpol(1,N) = 0
Iflpol(2,N) = 0
-C if lrf=3, channel 3 and 4 are fission width 1 and 2
-C Sammy here assumes the same is true if setting iflpol
-C resInfo%getChannelFitOption(1) -> gamma
-C resInfo%getChannelFitOption(2) -> capture
-C resInfo%getChannelFitOption(3) -> fission 1
-C resInfo%getChannelFitOption(4) -> fission 2
+! if lrf=3, channel 3 and 4 are fission width 1 and 2
+! Sammy here assumes the same is true if setting iflpol
+! resInfo%getChannelFitOption(1) -> gamma
+! resInfo%getChannelFitOption(2) -> capture
+! resInfo%getChannelFitOption(3) -> fission 1
+! resInfo%getChannelFitOption(4) -> fission 2
if (numChan.ge.3) Iflpol(1,N) = resInfo%getChannelFitOption(3)
if (numChan.ge.4) Iflpol(2,N) = resInfo%getChannelFitOption(4)
@@ -336,19 +333,19 @@ C resInfo%getChannelFitOption(4) -> fission 2
END DO
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Flgpol (Iflpol)
-C
-C *** Purpose -- fix flags for polar version of fission widths
-C
+!
+! *** Purpose -- fix flags for polar version of fission widths
+!
use SammyResonanceInfo_M
use RMatResonanceParam_M
use EndfData_common_m
IMPLICIT none
-C
+!
integer:: Iflpol(2,*)
type(SammyResonanceInfo)::resInfo
@@ -369,19 +366,19 @@ C
END DO
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Dddcov (Ddcov, Dcov)
-C
+!
use fixedi_m
use ifwrit_m
use SammyResonanceInfo_M
use RMatResonanceParam_M
use EndfData_common_m
IMPLICIT none
-C
+!
real(kind=8):: Dcov(*), Ddcov(*)
real(kind=8):: Zero
type(SammyResonanceInfo)::resInfo
@@ -389,9 +386,9 @@ C
integer::N,M,ii,ipar
DATA Zero /0.0d0/
-C
-C
-C *** Adjust Dcov to be with respect to Nfpall not Nres
+!
+!
+! *** Adjust Dcov to be with respect to Nfpall not Nres
IF (Kdecpl.NE.1) THEN
DO N=1,resParData%getNumResonances()
IF (Ddcov(N).EQ.Zero) Ddcov(N) = 1.d-6
@@ -421,3 +418,4 @@ C *** Adjust Dcov to be with respect to Nfpall not Nres
END DO
RETURN
END
+end module par11_m
diff --git a/sammy/src/par/mpar13.f b/sammy/src/par/mpar13.f90
similarity index 75%
rename from sammy/src/par/mpar13.f
rename to sammy/src/par/mpar13.f90
index c85e7a6f7..5aa01ff9d 100644
--- a/sammy/src/par/mpar13.f
+++ b/sammy/src/par/mpar13.f90
@@ -1,44 +1,44 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module par13_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Readde (Pardet, Ifldet, Deldet, Igrdet, Kfile)
-C
-C *** Card set 15
-C *** PURPOSE -- Read detector efficiencies -- el-dependent
-C
+!
+! *** Card set 15
+! *** PURPOSE -- Read detector efficiencies -- el-dependent
+!
use fixedi_m
use ifwrit_m
use fixedr_m
use constn_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C DIMENSION Pardet(Numdet), IFldet(Numdet),
-C * Deldet(Numdet), Igrdet(Ngroup)
+!
+! DIMENSION Pardet(Numdet), IFldet(Numdet),
+! * Deldet(Numdet), Igrdet(Ngroup)
DIMENSION Pardet(*), Ifldet(*), Deldet(*), Igrdet(*)
DIMENSION Iss(24), Jss(114)
EQUIVALENCE (Iss(1),Jss(1))
-C
-C
+!
+!
Maxk = 29
IF (Ngroup.GT.99) Maxk = 11
IF (Ngroup.GT.114) STOP '[STOP in Readde in par/mpar13.f]'
CALL Zero_Integer (Jss, 114)
CALL Zero_Integer (Igrdet, Ngroup)
-C
+!
K1 = 0
K3 = 0
Kq = 0
-C *** Read from parameter file
+! *** Read from parameter file
DO I=1,Numdet
IF (Ngroup.LE.99) THEN
- READ (Kfile,99999,END=130,ERR=130)
- * Pardet(I), Deldet(I), Ifldet(I), Iss
+ READ (Kfile,99999,END=130,ERR=130) Pardet(I),Deldet(I),Ifldet(I),Iss
99999 FORMAT (2F10.0, 30I2)
END IF
IF (Ngroup.GT.99) THEN
- READ (Kfile,99998,END=130,ERR=130)
- * Pardet(I), Deldet(I), Ifldet(I), Iss
+ READ (Kfile,99998,END=130,ERR=130) Pardet(I),Deldet(I),Ifldet(I),Iss
99998 FORMAT (2F10.0, 12I5)
END IF
Jssmin = Maxk
@@ -53,7 +53,7 @@ C *** Read from parameter file
IF (Kgenpd.EQ.1 .AND. Ifldet(I).GT.0) Ifldet(I) = 0
IF (Ifldet(I).EQ.1) K1 = K1 + 1
IF (Ifldet(I).EQ.3) K3 = K3 + 1
-C
+!
DO K=1,Ngroup
IF (Jss(K).EQ.0) GO TO 40
KQ = KQ + 1
@@ -69,27 +69,28 @@ C
END DO
40 CONTINUE
END DO
-C
+!
IF (Kq.NE.Ngroup) THEN
DO N=1,Ngroup
IF (Igrdet(N).EQ.0) WRITE (21,99996) N, Numdet
IF (Igrdet(N).EQ.0) Igrdet(N) = Numdet
END DO
-99996 FORMAT (' Spin group #', I3, ' was not in detector efficiency',
- * 1X, 'list, so is assigned #', I3)
+99996 FORMAT (' Spin group #', I3, ' was not in detector efficiency', &
+ 1X, 'list, so is assigned #', I3)
END IF
-C
+!
IF (K1 .NE.Nvpdet) STOP '[STOP in Readde in par/mpar13.f # 2]'
IF (K1+K3.NE.Nfpdet) STOP '[STOP in Readde in par/mpar13.f # 3]'
-C
+!
RETURN
-C
-C
-C
+!
+!
+!
130 CONTINUE
WRITE (6,99994) N
-99994 FORMAT (' Spin group number', I2,
- * ' is included in "detector efficiencies" twice')
+99994 FORMAT (' Spin group number', I2, &
+ ' is included in "detector efficiencies" twice')
STOP '[STOP in Readde in par/mpar13.f # 4]'
-C
+!
END
+end module par13_m
\ No newline at end of file
diff --git a/sammy/src/par/mpar14.f b/sammy/src/par/mpar14.f90
similarity index 50%
rename from sammy/src/par/mpar14.f
rename to sammy/src/par/mpar14.f90
index f6862109f..f4aa2f970 100644
--- a/sammy/src/par/mpar14.f
+++ b/sammy/src/par/mpar14.f90
@@ -1,11 +1,13 @@
-C
-C
-C -----------------------------------------------------------------
-C
+!
+module par14_m
+ contains
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Begin_Qqq (Xtpt_W, Xtptln_W, Xtpt_V, Xtptln_V, Ftheta)
-C
-C *** Setup initializes arrays
-C
+!
+! *** Setup initializes arrays
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -15,96 +17,96 @@ C
use ExpPars_common_m
use MultScatPars_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
DIMENSION Xtpt_W(*), Xtptln_W(*), Xtpt_V(*), Xtptln_V(*),Ftheta(*)
DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/
-C
-C --------------
+!
+! --------------
WRITE (21,10000)
-10000 FORMAT (//, ' *** Edge-effects for single-scattering correction to
- * capture', /, ' or fission yield calculations ***',/)
+10000 FORMAT (//,' *** Edge-effects for single-scattering correction to capture',&
+ /, ' or fission yield calculations ***',/)
Rs = sampleDim%getRadius()
Rb = sampleDim%getBeamRadius()
Dthick = Thick
Sthick = sampleDim%getThickness()
Dnsty = Dthick/Sthick
-C --------------
-C
-C
-C --------------
-C *** Initialize Xtpt_V and Xtpt_W, the arrays for interpolation of total
-C *** cross sections at the scattered energy and at the
-C *** energy, respectively
-C *** NOTE *** Experience has shown that the functions Sqfb and Qfb tend
-C *** to be relatively smooth when viewed on log-log plots.
-C *** Ergo, let Xtptln_V represent dLOG(Sigma), equally
-C *** spaced from Xtmin to Xtmax
-C *** Xtmin & Xtmax are input quantities, defaults are large
-C *** enough to cover almost everything so is best to give
-C *** specific values for a given situation.
-C
-C *** Interpolation on Totalp (dense mesh is often needed -- larger
-C *** Nxtptw is used for default)
+! --------------
+!
+!
+! --------------
+! *** Initialize Xtpt_V and Xtpt_W, the arrays for interpolation of total
+! *** cross sections at the scattered energy and at the
+! *** energy, respectively
+! *** NOTE *** Experience has shown that the functions Sqfb and Qfb tend
+! *** to be relatively smooth when viewed on log-log plots.
+! *** Ergo, let Xtptln_V represent dLOG(Sigma), equally
+! *** spaced from Xtmin to Xtmax
+! *** Xtmin & Xtmax are input quantities, defaults are large
+! *** enough to cover almost everything so is best to give
+! *** specific values for a given situation.
+!
+! *** Interpolation on Totalp (dense mesh is often needed -- larger
+! *** Nxtptw is used for default)
Dx = multScat%getLogSigmaTotMax() - multScat%getLogSigmaTotMin()
Del= Dx/(Nxtptw-1)
DO I=1,Nxtptw
Xtptln_W(I) = multScat%getLogSigmaTotMin() + Del*dFLOAT(I-1)
Xtpt_W (I) = dEXP(Xtptln_W(I))
END DO
-C
-C *** Interpolation on Total (super-dense mesh is not needed)
+!
+! *** Interpolation on Total (super-dense mesh is not needed)
Del = Dx/(Nxtptv-1)
DO I=1,Nxtptv
Xtptln_V(I) = multScat%getLogSigmaTotMin() + Del*dFLOAT(I-1)
Xtpt_V (I) = dEXP(Xtptln_V(I))
END DO
-C
-C *** Interpolation on Theta
-C --------------
-C Ntheta is total number of Ftheta values
-C Ktheta gives denser grid near Costhe = Zero
-C Jtheta gives denser grid near Costhe = One
-C (Ntheta-Ktheta-Jtheta) points are equally distributed in two central
-C regions, from C to X to (Costh1-D)
-C where (1) Costhe = X is located at Tanthe=Rs/Z
-C (2) C is uniform spacing between C and X
-C (3) D is uniform spacing between X and Costh1
-C (4) M = # of points in [C,X]; M is chosen to make C ~ D
-C (4) B is geometric spacing parameter below C
-C (5) E is geometric spacing parameter above D
-C --------------
-C *** generate ftheta as follows -- with N=33, K=2, J=5, M=12
-C C = X / [M-1] C = X / [11]
-C D = (Costh1-X)/ [2+N-K-J-M] C = (C1-X) / [16]
-C B = C / [1+K(K-1)] B = C / [3]
-C E = C / [1+J(J-1)] E = D / [21]
-C
-C Ftheta( 1 ) = 0 (1) = 0
-C Ftheta( 2 ) = B (2) = C/3
-C Ftheta(1+i ) = [1+i(i-1)]*B (3) = C
-C up to Ftheta(1+K ) = [1+K(K-1)]*B = C
-C
-C Ftheta(K+2 ) = [2]*C (4) = 2C
-C Ftheta(K+i ) = [i]*C (3+i) = iC
-C up to Ftheta(K+M-1) = [M-1]*C = X (14) = 11C = X
-C
-C Ftheta(K+M-1+1) = X + [1]*D (15) = X + D
-C Ftheta(K+M-1+i) = X + [i]*D (14+i) = X + i*D
-C up to Ftheta(K+M-1+(1+N-K-J-M))
-C = Ftheta(N-J ) = X +[1+N-K-J-M]*D (28) = X + 15D = C1-D
-C
-C Ftheta(N-J) = C1-[1+J(J-1)]E (28) = C1- D
-C = C1 -21D/21
-C Ftheta(N-J) = C1-[1+i(i-1)]E (29) = C1 -13D/21
-C (30) = C1 - 7D/21
-C Ftheta(N-2) = C1-3E (31) = C1 - 3D/21
-C Ftheta(N-1) = C1-E (32) = C1 - 1D/21
-C Ftheta(N ) = C1 (33) = C1
-C
+!
+! *** Interpolation on Theta
+! --------------
+! Ntheta is total number of Ftheta values
+! Ktheta gives denser grid near Costhe = Zero
+! Jtheta gives denser grid near Costhe = One
+! (Ntheta-Ktheta-Jtheta) points are equally distributed in two central
+! regions, from C to X to (Costh1-D)
+! where (1) Costhe = X is located at Tanthe=Rs/Z
+! (2) C is uniform spacing between C and X
+! (3) D is uniform spacing between X and Costh1
+! (4) M = # of points in [C,X]; M is chosen to make C ~ D
+! (4) B is geometric spacing parameter below C
+! (5) E is geometric spacing parameter above D
+! --------------
+! *** generate ftheta as follows -- with N=33, K=2, J=5, M=12
+! C = X / [M-1] C = X / [11]
+! D = (Costh1-X)/ [2+N-K-J-M] C = (C1-X) / [16]
+! B = C / [1+K(K-1)] B = C / [3]
+! E = C / [1+J(J-1)] E = D / [21]
+!
+! Ftheta( 1 ) = 0 (1) = 0
+! Ftheta( 2 ) = B (2) = C/3
+! Ftheta(1+i ) = [1+i(i-1)]*B (3) = C
+! up to Ftheta(1+K ) = [1+K(K-1)]*B = C
+!
+! Ftheta(K+2 ) = [2]*C (4) = 2C
+! Ftheta(K+i ) = [i]*C (3+i) = iC
+! up to Ftheta(K+M-1) = [M-1]*C = X (14) = 11C = X
+!
+! Ftheta(K+M-1+1) = X + [1]*D (15) = X + D
+! Ftheta(K+M-1+i) = X + [i]*D (14+i) = X + i*D
+! up to Ftheta(K+M-1+(1+N-K-J-M))
+! = Ftheta(N-J ) = X +[1+N-K-J-M]*D (28) = X + 15D = C1-D
+!
+! Ftheta(N-J) = C1-[1+J(J-1)]E (28) = C1- D
+! = C1 -21D/21
+! Ftheta(N-J) = C1-[1+i(i-1)]E (29) = C1 -13D/21
+! (30) = C1 - 7D/21
+! Ftheta(N-2) = C1-3E (31) = C1 - 3D/21
+! Ftheta(N-1) = C1-E (32) = C1 - 1D/21
+! Ftheta(N ) = C1 (33) = C1
+!
A = (Rs-Rb)/Sthick
Costh1 = One/Dsqrt(A**2+One)
IF (sampleDim%getHeight().GT.Zero) Costh1 = One
-C *** tan(theta1) = (Rs-Rb)/Sthick
+! *** tan(theta1) = (Rs-Rb)/Sthick
X = Rs/Sthick
N = multScat%getNumTheta()
J = multScat%getNumThetaNearOne()
@@ -165,96 +167,96 @@ C *** tan(theta1) = (Rs-Rb)/Sthick
END DO
END IF
Ftheta(multScat%getNumTheta()) = Costh1
-C
+!
IF (Kdebug.NE.0) THEN
WRITE (6,10100) multScat%getNumTheta()
10100 FORMAT (/, ' ### Ftheta(I), I=1,', I5, ' =')
WRITE (6,10200) (Ftheta(I),I=1,multScat%getNumTheta())
10200 FORMAT (1X, 1P5G13.6)
END IF
-C --------------
-C
+! --------------
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Gausqd (A, B, R, W, N, M)
-C *** Purpose -- Generate an m-point Gaussian quadrature scheme from
-C *** a to b, where m = 4, 8, or 16 (default is 16). Store
-C *** points in R and weights in W
-C
+! *** Purpose -- Generate an m-point Gaussian quadrature scheme from
+! *** a to b, where m = 4, 8, or 16 (default is 16). Store
+! *** points in R and weights in W
+!
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION R(*), W(*)
DIMENSION Xx4(4), Ww4(4)
DIMENSION Xx8(8), Ww8(8)
DIMENSION Xx16(16), Ww16(16)
- DATA Xx4 /-0.861136311594053, -0.339981043584856,
- * 0.339981043584856, 0.861136311594053/
- DATA Ww4 / 0.347854845137454, 0.652145154862546,
- * 0.652145154862546, 0.347854845137454/
- DATA Xx8/ -0.960289856497536, -0.796666477413627,
- * -0.525532409916329, -0.183434642495650,
- * 0.183434642495650, 0.525532409916329,
- * 0.796666477413627, 0.960289856497536/
- DATA Ww8/ 0.101228536290376, 0.222381034453374,
- * 0.313706645877887, 0.362683783378362,
- * 0.362683783378362, 0.313706645877887,
- * 0.222381034453374, 0.101228536290376/
- DATA Xx16/-0.989400934991649932596, -0.944575023073232576078,
- * -0.865631202387831743880, -0.755404408355003033895,
- * -0.617876244402643748447, -0.458016777657227386342,
- * -0.281603550779258913230, -0.095012509837637440185,
- * 0.095012509837637440185, 0.281603550779258913230,
- * 0.458016777657227386342, 0.617876244402643748447,
- * 0.755404408355003033895, 0.865631202387831743880,
- * 0.944575023073232576078, 0.989400934991649932596/
- DATA Ww16/ 0.027152459411754094852, 0.062253523938647892863,
- * 0.095158511682492784810, 0.124628971255533872052,
- * 0.149595988816576732081, 0.169156519395002538189,
- * 0.182603415044923588867, 0.189450610455068496285,
- * 0.189450610455068496285, 0.182603415044923588867,
- * 0.169156519395002538189, 0.149595988816576732081,
- * 0.124628971255533872052, 0.095158511682492784810,
- * 0.062253523938647892863, 0.027152459411754094852/
-C
+ DATA Xx4 /-0.861136311594053, -0.339981043584856, &
+ 0.339981043584856, 0.861136311594053/
+ DATA Ww4 / 0.347854845137454, 0.652145154862546, &
+ 0.652145154862546, 0.347854845137454/
+ DATA Xx8/ -0.960289856497536, -0.796666477413627, &
+ -0.525532409916329, -0.183434642495650, &
+ 0.183434642495650, 0.525532409916329, &
+ 0.796666477413627, 0.960289856497536/
+ DATA Ww8/ 0.101228536290376, 0.222381034453374, &
+ 0.313706645877887, 0.362683783378362, &
+ 0.362683783378362, 0.313706645877887, &
+ 0.222381034453374, 0.101228536290376/
+ DATA Xx16/-0.989400934991649932596, -0.944575023073232576078, &
+ -0.865631202387831743880, -0.755404408355003033895, &
+ -0.617876244402643748447, -0.458016777657227386342, &
+ -0.281603550779258913230, -0.095012509837637440185, &
+ 0.095012509837637440185, 0.281603550779258913230, &
+ 0.458016777657227386342, 0.617876244402643748447, &
+ 0.755404408355003033895, 0.865631202387831743880, &
+ 0.944575023073232576078, 0.989400934991649932596/
+ DATA Ww16/ 0.027152459411754094852, 0.062253523938647892863, &
+ 0.095158511682492784810, 0.124628971255533872052, &
+ 0.149595988816576732081, 0.169156519395002538189, &
+ 0.182603415044923588867, 0.189450610455068496285, &
+ 0.189450610455068496285, 0.182603415044923588867, &
+ 0.169156519395002538189, 0.149595988816576732081, &
+ 0.124628971255533872052, 0.095158511682492784810, &
+ 0.062253523938647892863, 0.027152459411754094852/
+!
N = M
IF (N.NE.4 .AND. N.NE.8) N = 16
Aa = (B-A)*0.5D0
Bb = (B+A)*0.5D0
-C
+!
IF (N.EQ.4) THEN
DO I=1,N
R(I) = Aa*Xx4(I) + Bb
W(I) = Aa*Ww4(I)
END DO
-C
+!
ELSE IF (N.EQ.8) THEN
DO I=1,N
R(I) = Aa*Xx8(I) + Bb
W(I) = Aa*Ww8(I)
END DO
-C
+!
ELSE IF (N.EQ.16) THEN
DO I=1,N
R(I) = Aa*Xx16(I) + Bb
W(I) = Aa*Ww16(I)
END DO
-C
+!
ELSE
STOP '[STOP in Gausqd in par/mpar14.f]'
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Finish_Qqq (Xtptln_W, Xtptln_V, Ftheta, Sqfb)
-C
-C *** Finish_Qqq converts to logarithm and writes results onto Fqqqqq
-C
+!
+! *** Finish_Qqq converts to logarithm and writes results onto Fqqqqq
+!
use fixedi_m
use ifwrit_m
use samxxx_common_m
@@ -264,11 +266,11 @@ C
use xsect_x_common_m
use MultScatPars_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Xtptln_W(Nxtptw), Xtptln_V(Nxtptv), Ftheta(Ntheta),
- * Sqfb(Nsqfb,Nxtptv,Nxtptw,Ntheta)
-C
-C *** Normalize Sqfb via (n/(2 pi R0^2)), and convert to logarithm thereof
+!
+ DIMENSION Xtptln_W(Nxtptw), Xtptln_V(Nxtptv), Ftheta(Ntheta), &
+ Sqfb(Nsqfb,Nxtptv,Nxtptw,Ntheta)
+!
+! *** Normalize Sqfb via (n/(2 pi R0^2)), and convert to logarithm thereof
Bb = dLOG(2.0d0*Dnsty/Area)
DO Jth=1,multScat%getNumTheta()
DO Kw=1,Nxtptw
@@ -303,8 +305,8 @@ C *** Normalize Sqfb via (n/(2 pi R0^2)), and convert to logarithm thereof
END DO
END DO
END IF
-C
-C *** Write results onto file 25 to be read later in SAMSSM
+!
+! *** Write results onto file 25 to be read later in SAMSSM
CALL Newopn (25, Fqqqqq, 1)
WRITE (25) multScat%getNumTheta(),Nzzz,Nxtptw,Nxtptv, Nsqfb, Nzzzz
WRITE (25) Rs, Rb, Sthick, Dthick, Dnsty, A1, B1, Costh1, Area
@@ -312,6 +314,7 @@ C *** Write results onto file 25 to be read later in SAMSSM
WRITE (25) Ftheta
WRITE (25) Sqfb
CLOSE (UNIT=25)
-C
+!
RETURN
END
+end module par14_m
diff --git a/sammy/src/par/mpar15.f b/sammy/src/par/mpar15.f90
similarity index 55%
rename from sammy/src/par/mpar15.f
rename to sammy/src/par/mpar15.f90
index 650acad00..4b226fd71 100644
--- a/sammy/src/par/mpar15.f
+++ b/sammy/src/par/mpar15.f90
@@ -1,16 +1,18 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Hhhset (Xtpt_W, Xtptln_W, Ftheta, Azzz, Wzzz, Hhh,
- * Arrr, Wrrr, Aphi, Wphi, Ffff5r, Bbb, Ff5phi)
-C
-C
-C *** Hhhset generates the integrand for integral over mu (which
-C *** is performed in samssm) for single-scattering correction
-C *** to the capture yield, for cylindrical or rectangular
-C *** samples.
-C
+!
+module par15_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Hhhset (Xtpt_W, Xtptln_W, Ftheta, Azzz, Wzzz, Hhh, &
+ Arrr, Wrrr, Aphi, Wphi, Ffff5r, Bbb, Ff5phi)
+!
+!
+! *** Hhhset generates the integrand for integral over mu (which
+! *** is performed in samssm) for single-scattering correction
+! *** to the capture yield, for cylindrical or rectangular
+! *** samples.
+!
use fixedi_m
use ifwrit_m
use samxxx_common_m
@@ -23,82 +25,82 @@ C
use MultScatPars_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Rect_is_Fixed
-C
- DIMENSION Xtpt_W(Nxtptw), Xtptln_W(Nxtptw), Ftheta(*),
- * Azzz(Nzzzz,*), Wzzz(*), Hhh(Nxtptw,Nzzzz,*), Arrr(*), Wrrr(*),
- * Aphi(*), Wphi(*), Ffff5r(*), Bbb(*), Ff5phi(*)
+!
+ DIMENSION Xtpt_W(Nxtptw), Xtptln_W(Nxtptw), Ftheta(*), &
+ Azzz(Nzzzz,*), Wzzz(*), Hhh(Nxtptw,Nzzzz,*), Arrr(*), Wrrr(*), &
+ Aphi(*), Wphi(*), Ffff5r(*), Bbb(*), Ff5phi(*)
DATA Zero /0.0d0/, Rect_is_Fixed /.false./
real(kind=8) Ybeam
Ybeam = 0.0d0 ! always zero, since we don't use right now
-C
-C
-C --------------
-C *** Zero Azzz
+!
+!
+! --------------
+! *** Zero Azzz
CALL Zero_Array (Azzz, multScat%getNumTheta()*Nzzzz)
-C
-C *** Zero the array in which to store intermediate answers...
+!
+! *** Zero the array in which to store intermediate answers...
CALL Zero_Array (Hhh, multScat%getNumTheta()*Nzzzz*Nxtptw)
-C --------------
-C
+! --------------
+!
IF (sampleDim%getHeight().LE.Zero) THEN
-C
-C *** Here for r-phi coordinates (polar) instead of x-y (cartesian)
-C *** (cylinder) (rectangle)
-C
+!
+! *** Here for r-phi coordinates (polar) instead of x-y (cartesian)
+! *** (cylinder) (rectangle)
+!
R0 = Rs
IF (R0.GT.Rb) R0 = Rb
Area = Pi*R0**2
WRITE (21,10100) Rs, Rb, Area
-10100 FORMAT (' CYLINDRICAL SAMPLE', /,
- * ' Radius of sample, radius of beam', 17x, '=', 1p2g14.6, /,
- * ' Area of overlap', 35x, '=', 1pg14.6)
+10100 FORMAT (' CYLINDRICAL SAMPLE', /, &
+ ' Radius of sample, radius of beam', 17x, '=', 1p2g14.6, /, &
+ ' Area of overlap', 35x, '=', 1pg14.6)
WRITE (21,10200) Sthick, Dnsty
-10200 FORMAT (' Thickness of sample (cm), density (atom/barn-cm) =',
- * 1p2g14.6)
- WRITE (21,10250) multScat%getLogSigmaTotMin(),
- * multScat%getLogSigmaTotMax()
-10250 FORMAT (' Interpolation limits for edge effects =',
- * 1P2G14.6)
+10200 FORMAT (' Thickness of sample (cm), density (atom/barn-cm) =', &
+ 1p2g14.6)
+ WRITE (21,10250) multScat%getLogSigmaTotMin(), &
+ multScat%getLogSigmaTotMax()
+10250 FORMAT (' Interpolation limits for edge effects =', &
+ 1P2G14.6)
call multScat%setNumZHatIntegration( Nzzz / 3 )
Ngausz = Nzzz/3 ! remove
- WRITE (21,10300) multScat%getNumZHatIntegration(),
- * multScat%getNumBeamAreaIntegration(), multScat%getNumTheta(),
- * multScat%getNumThetaNearOne(),multScat%getNumThetaNearZero(),
- * multScat%getNumInterpSigma(),
- * multScat%getNumInterpSigmaPrime()
-10300 FORMAT (' Ngausz, Ngaus for r & phi =', 2I10, /,
- * ' Ntheta, Jtheta, Ktheta for Theta =', 3I10, /,
- * ' Nxtptv, Nxtptw for Sigma =', 2I10)
+ WRITE (21,10300) multScat%getNumZHatIntegration(), &
+ multScat%getNumBeamAreaIntegration(), multScat%getNumTheta(), &
+ multScat%getNumThetaNearOne(),multScat%getNumThetaNearZero(), &
+ multScat%getNumInterpSigma(), &
+ multScat%getNumInterpSigmaPrime()
+10300 FORMAT (' Ngausz, Ngaus for r & phi =', 2I10, /, &
+ ' Ntheta, Jtheta, Ktheta for Theta =', 3I10, /, &
+ ' Nxtptv, Nxtptw for Sigma =', 2I10)
- CALL Urfset (Xtpt_W, Ftheta, Azzz, Wzzz, Hhh,
- * Arrr, Wrrr, Aphi, Wphi, Ffff5r, Ff5phi)
-C
-C
+ CALL Urfset (Xtpt_W, Ftheta, Azzz, Wzzz, Hhh, &
+ Arrr, Wrrr, Aphi, Wphi, Ffff5r, Ff5phi)
+!
+!
ELSE IF (.NOT.Rect_is_Fixed) THEN
-C *** Here for rectangle not cylinder -- but rectangular doesn't work
+! *** Here for rectangle not cylinder -- but rectangular doesn't work
WRITE (6,10401)
WRITE (21,10401)
-10401 FORMAT (/,
- * ' *************************************************', /,
- * ' The option to use Rectangular Sample is disabled!', /,
- * ' Please convert to equivalent Cylindrical Sample ', /,
- * ' or to Infinite-Slab before continuing. ', /,
- * ' *************************************************', /)
+10401 FORMAT (/, &
+ ' *************************************************', /, &
+ ' The option to use Rectangular Sample is disabled!', /, &
+ ' Please convert to equivalent Cylindrical Sample ', /, &
+ ' or to Infinite-Slab before continuing. ', /, &
+ ' *************************************************', /)
STOP '[STOP in Hhhset in par/mpar15.f]'
-C
+!
ELSE
-C *** Here for rectangle not cylinder
- WRITE (21,10400) sampleDim%getBeamRadius(), Ybeam,
- * sampleDim%getRadius(), sampleDim%getHeight()
-10400 FORMAT (' RECTANGULAR SAMPLE', /,
- * ' Dimensions of beam (cm) =', 1p2g14.6, /,
- * ' Dimensions of sample(cm) =', 1p2g14.6)
+! *** Here for rectangle not cylinder
+ WRITE (21,10400) sampleDim%getBeamRadius(), Ybeam, &
+ sampleDim%getRadius(), sampleDim%getHeight()
+10400 FORMAT (' RECTANGULAR SAMPLE', /, &
+ ' Dimensions of beam (cm) =', 1p2g14.6, /, &
+ ' Dimensions of sample(cm) =', 1p2g14.6)
Area = sampleDim%getBeamRadius()*Ybeam
- IF (sampleDim%getBeamRadius().GT.sampleDim%getRadius()
- * .AND. Ybeam.GT.sampleDim%getHeight()) then
+ IF (sampleDim%getBeamRadius().GT.sampleDim%getRadius() &
+ .AND. Ybeam.GT.sampleDim%getHeight()) then
Area = sampleDim%getRadius()*sampleDim%getHeight()
end if
WRITE (21,10500) Area
@@ -120,25 +122,25 @@ C *** Here for rectangle not cylinder
10600 FORMAT (' A0, A1, A2 =', 1p3g14.6,/, ' B0, B1, B2 =', 1p3g14.6)
call multScat%setNumZHatIntegration( Nzzzz / 5 )
Ngausz = Nzzzz/5
- WRITE (21,10700) multScat%getNumZHatIntegration(),
- * multScat%getNumTheta(), multScat%getNumBeamAreaIntegration()
+ WRITE (21,10700) multScat%getNumZHatIntegration(), &
+ multScat%getNumTheta(), multScat%getNumBeamAreaIntegration()
10700 FORMAT (' Ngausz, Ntheta, Ngaus for x & y=', 4I10)
-cxxxxx CALL Uxyset (Xtpt_W, Ftheta, Azzz, Wzzz, Hhh, Arrr, Wrrr,
-cxxxxx * Aphi, Wphi, Ffff5r, Bbb, Ff5phi)
-C
+!xxxxx CALL Uxyset (Xtpt_W, Ftheta, Azzz, Wzzz, Hhh, Arrr, Wrrr,
+!xxxxx * Aphi, Wphi, Ffff5r, Bbb, Ff5phi)
+!
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Urfset (Xtpt_W, Ftheta, Azzz, Wzzz, Hhh, Arrr, Wrrr,
- * Aphi, Wphi, Ffff5r, Ff5phi)
-C
-C *** Urfset generates Hhh(E',z,mu') = 1 - H
-C *** This version assumes cylindrical not rectangular sample
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Urfset (Xtpt_W, Ftheta, Azzz, Wzzz, Hhh, Arrr, Wrrr, &
+ Aphi, Wphi, Ffff5r, Ff5phi)
+!
+! *** Urfset generates Hhh(E',z,mu') = 1 - H
+! *** This version assumes cylindrical not rectangular sample
+!
use fixedi_m
use ifwrit_m
use lbro_common_m
@@ -146,21 +148,22 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use par14_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Xtpt_W(Nxtptw), Ftheta(*), Azzz(Nzzzz,*), Wzzz(*),
- * Hhh(Nxtptw,Nzzzz,*), Arrr(*), Wrrr(*), Aphi(*), Wphi(*),
- * Ffff5r(*), Ff5phi(*)
-C
+ DIMENSION Xtpt_W(Nxtptw), Ftheta(*), Azzz(Nzzzz,*), Wzzz(*), &
+ Hhh(Nxtptw,Nzzzz,*), Arrr(*), Wrrr(*), Aphi(*), Wphi(*), &
+ Ffff5r(*), Ff5phi(*)
+!
DATA Zero /0.0d0/, One /1.0d0/
-C
-C
-C *** theta-loop from Zero to +costh1
+!
+!
+! *** theta-loop from Zero to +costh1
DO Ith=1,multScat%getNumTheta()
IF (Ith.EQ.multScat%getNumTheta()) THEN
- Costhe = 0.9d0*Ftheta(multScat%getNumTheta()) +
- * Ftheta(multScat%getNumTheta()-1)*0.1d0
-C *** Since the value is zero for Ntheta, and we cannot take
-C *** a logarithm of zero, calculate at a near-by point
+ Costhe = 0.9d0*Ftheta(multScat%getNumTheta()) + &
+ Ftheta(multScat%getNumTheta()-1)*0.1d0
+! *** Since the value is zero for Ntheta, and we cannot take
+! *** a logarithm of zero, calculate at a near-by point
ELSE
Costhe = Ftheta(Ith)
END IF
@@ -176,18 +179,18 @@ C *** a logarithm of zero, calculate at a near-by point
IF (Z3th.LT.Zero) Z3th = Zero
N = 1
IF (Z1th.GT.Zero) THEN
- CALL Gausqd (Zero, Z1th, Azzz(N,Ith), Wzzz(N), M,
- * multScat%getNumZHatIntegration())
+ CALL Gausqd (Zero, Z1th, Azzz(N,Ith), Wzzz(N), M, &
+ multScat%getNumZHatIntegration())
N = N + M
END IF
IF (Z2th.GT.Z1th) THEN
- CALL Gausqd (Z1th, Z2th, Azzz(N,Ith), Wzzz(N), M,
- * multScat%getNumZHatIntegration())
+ CALL Gausqd (Z1th, Z2th, Azzz(N,Ith), Wzzz(N), M, &
+ multScat%getNumZHatIntegration())
N = N + M
END IF
IF (Z3th.GT.Z2th) THEN
- CALL Gausqd (Z2th, Z3th, Azzz(N,Ith), Wzzz(N), M,
- * multScat%getNumZHatIntegration())
+ CALL Gausqd (Z2th, Z3th, Azzz(N,Ith), Wzzz(N), M, &
+ multScat%getNumZHatIntegration())
N = N + M
END IF
IF (Kvthck.GT.0) THEN
@@ -196,13 +199,13 @@ C *** a logarithm of zero, calculate at a near-by point
N = N + 1
END IF
N = N - 1
-C *** Azzz(Iz,Ith) now stores points for integration over z
-C *** from 0 to z3
-C *** Wzzz(Iz ) weights
-C
-C
+! *** Azzz(Iz,Ith) now stores points for integration over z
+! *** from 0 to z3
+! *** Wzzz(Iz ) weights
+!
+!
IF (N.GT.0) THEN
-C *** Loop over z from 0 to z3, plus extra point maybe for Kvthck
+! *** Loop over z from 0 to z3, plus extra point maybe for Kvthck
DO Iz=1,N
Z = Azzz(Iz,Ith)
Zprime = Sthick - Z
@@ -210,33 +213,33 @@ C *** Loop over z from 0 to z3, plus extra point maybe for Kvthck
Ztan = Zprime/Cotth
ELSE
Ztan = 10000.0D0*(Rs+R0)
-C *** = infinity
+! *** = infinity
END IF
-C
+!
R1 = Rs - Ztan
R2 = R1 + R0
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-czzzzzzzzzzzzzz R2 = R1 - R0
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c Do I believe either of these? What's right here?
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc!
+!zzzzzzzzzzzzzz R2 = R1 - R0
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc!
+! Do I believe either of these? What's right here?
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc!
IF (R1.LE.R0) THEN
IF (R1.LE.Zero) R1 = Zero
-C
- CALL Gausqd (R1, R0, Arrr, Wrrr, Nrrr,
- * multScat%getNumBeamAreaIntegration())
-C *** Gausqd figures grid for r-integration from R1 to R0
-C
-C *** Initialize storage for integral over R
+!
+ CALL Gausqd (R1, R0, Arrr, Wrrr, Nrrr, &
+ multScat%getNumBeamAreaIntegration())
+! *** Gausqd figures grid for r-integration from R1 to R0
+!
+! *** Initialize storage for integral over R
DO Ie=1,Nxtptw
Ffff5r(Ie) = Zero
END DO
Ffff4r = Zero
-C
-C *** Integrate over r from R1 to R0
+!
+! *** Integrate over r from R1 to R0
DO Ir=1,Nrrr
R = Arrr(Ir)
-C
+!
IF (R2.LE.Zero) THEN
Phi1 = Pi
ELSE
@@ -246,14 +249,14 @@ C
IF (D.GT. One) D = One
Phi1 = dACOS(D)
END IF
- CALL Gausqd (Zero, Phi1, Aphi, Wphi, Nphi,
- * multScat%getNumBeamAreaIntegration())
-C *** Gausqd figures grid for phi-integration
-C
+ CALL Gausqd (Zero, Phi1, Aphi, Wphi, Nphi, &
+ multScat%getNumBeamAreaIntegration())
+! *** Gausqd figures grid for phi-integration
+!
DO Ie=1,Nxtptw
Ff5phi(Ie) = Zero
END DO
-C *** Integrate over phi from 0 to phi1
+! *** Integrate over phi from 0 to phi1
DO Iphi=1,Nphi
Phi = Aphi(Iphi)
Cosphi = Dcos(Phi)
@@ -262,70 +265,69 @@ C *** Integrate over phi from 0 to phi1
D = (-R*Cosphi+D)/Sinth * Dnsty
DO Ie=1,Nxtptw
Ccc = Xtpt_W(Ie)*D
-c one - Ddd = Dexp(-Ccc)*Wphi(Iphi)
+! one - Ddd = Dexp(-Ccc)*Wphi(Iphi)
Ddd = (One-Dexp(-Ccc))*Wphi(Iphi)
Ff5phi(Ie) = Ff5phi(Ie) + Ddd
END DO
END DO
-C *** END of loop over Phi from Zero to Phi1
-C
+! *** END of loop over Phi from Zero to Phi1
+!
DO Ie=1,Nxtptw
Ffff5r(Ie) = Ffff5r(Ie)+Ff5phi(Ie)*R*Wrrr(Ir)
END DO
IF (Phi1.LT.Pi) THEN
Ffff4r = Ffff4r + (Pi-Phi1)*R*Wrrr(Ir)
-C *** Ffff4r is integral over Phi from Phi1 to Pi
+! *** Ffff4r is integral over Phi from Phi1 to Pi
END IF
-C
+!
END DO
-C *** END of loop over R from R1 to R0
-C
+! *** END of loop over R from R1 to R0
+!
IF (Costhe.NE.Zero) THEN
A = Dnsty*Zprime/Costhe
DO Ie=1,Nxtptw
-c one - Ddd = Ffff4r*Dexp(-A*Xtpt_W(Ie))
+! one - Ddd = Ffff4r*Dexp(-A*Xtpt_W(Ie))
Ddd = Ffff4r*(One-Dexp(-A*Xtpt_W(Ie)))
- Hhh(Ie,Iz,Ith) = Hhh(Ie,Iz,Ith) +
- * Ffff5r(Ie) + Ddd
-C *** Hhh = F5r + h*F4r
+ Hhh(Ie,Iz,Ith) = Hhh(Ie,Iz,Ith) + Ffff5r(Ie) + Ddd
+! *** Hhh = F5r + h*F4r
END DO
ELSE
DO Ie=1,Nxtptw
- Hhh(Ie,Iz,Ith) = Hhh(Ie,Iz,Ith) +
- * Ffff5r(Ie)
-C *** Hhh = F5r + h*F4r
+ Hhh(Ie,Iz,Ith) = Hhh(Ie,Iz,Ith) + Ffff5r(Ie)
+! *** Hhh = F5r + h*F4r
END DO
END IF
DO Ie=1,Nxtptw
Hhh(Ie,Iz,Ith) = Hhh(Ie,Iz,Ith)*Wzzz(Iz)
END DO
-C *** NOTE that Hhh is now (h F4r + F5r) * Wz (See
-C *** Appendix D of multiple-scattering manual.)
-C
+! *** NOTE that Hhh is now (h F4r + F5r) * Wz (See
+! *** Appendix D of multiple-scattering manual.)
+!
END IF
END DO
-C *** End of loop over z from 0 to z3
-C
- IF (Kdebug.NE.0. AND. (Ith/10)*10.EQ.Ith) WRITE (6,11111)
- * Ith, multScat%getNumTheta()
+! *** End of loop over z from 0 to z3
+!
+ IF (Kdebug.NE.0. .AND. (Ith/10)*10.EQ.Ith) then
+ WRITE (6,11111) Ith, multScat%getNumTheta()
+ end if
11111 FORMAT (' finished with Angle #', I4, '/', I4)
END IF
END IF
130 CONTINUE
END DO
-C *** End of loop over Costhe from 0 to Costh1
-C
-C
+! *** End of loop over Costhe from 0 to Costh1
+!
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Qqqset (Xtpt_V, Ftheta, Azzz, Hhh, Sqfb)
-C
-C *** Qqqset performs integration over dz
-C
+!
+! *** Qqqset performs integration over dz
+!
use fixedi_m
use ifwrit_m
use samxxx_common_m
@@ -335,21 +337,21 @@ C
use xsect_x_common_m
use MultScatPars_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Xtpt_V(Nxtptv), Ftheta(Ntheta), Azzz(Nzzzz,Ntheta),
- * Hhh(Nxtptw,Nzzzz,*), Sqfb(Nsqfb,Nxtptv,Nxtptw,Ntheta)
+!
+ DIMENSION Xtpt_V(Nxtptv), Ftheta(Ntheta), Azzz(Nzzzz,Ntheta), &
+ Hhh(Nxtptw,Nzzzz,*), Sqfb(Nsqfb,Nxtptv,Nxtptw,Ntheta)
DATA Zero /0.0d0/
-C
-C
-C *** First, initialize Sqfb
- CALL Zero_Array (Sqfb, multScat%getNumTheta()*
- * multScat%getNumInterpSigma()*
- * multScat%getNumInterpSigmaPrime()*Nsqfb)
-C
-C *** Calculate Integ (dz) exp(-N Total z ) uuu for ifb=1
-C *** Integ (dz) exp(-N Total (Sthick-z)) uuu for ifb=2
-C *** Note that the weights for z-integration are included in Hhh=U*Wz
-C
+!
+!
+! *** First, initialize Sqfb
+ CALL Zero_Array (Sqfb, multScat%getNumTheta()* &
+ multScat%getNumInterpSigma()* &
+ multScat%getNumInterpSigmaPrime()*Nsqfb)
+!
+! *** Calculate Integ (dz) exp(-N Total z ) uuu for ifb=1
+! *** Integ (dz) exp(-N Total (Sthick-z)) uuu for ifb=2
+! *** Note that the weights for z-integration are included in Hhh=U*Wz
+!
DO Jth=1,multScat%getNumTheta()
DO Iz=1,Nzzz
Izz = Iz
@@ -362,16 +364,16 @@ C
Exp2x = dEXP(-Xtpt_V(Jsig)*Cc)
IF (Exp2.NE.Zero .OR. Exp2x.NE.Zero) THEN
DO Ksig=1,Nxtptw
- Sqfb(1,Jsig,Ksig,Jth) = Sqfb(1,Jsig,Ksig,Jth)
- * + Hhh(Ksig,Iz,Jth)*Exp2
- Sqfb(2,Jsig,Ksig,Jth) = Sqfb(2,Jsig,Ksig,Jth)
- * + Hhh(Ksig,Iz,Jth)*Exp2x
+ Sqfb(1,Jsig,Ksig,Jth) = Sqfb(1,Jsig,Ksig,Jth) &
+ + Hhh(Ksig,Iz,Jth)*Exp2
+ Sqfb(2,Jsig,Ksig,Jth) = Sqfb(2,Jsig,Ksig,Jth) &
+ + Hhh(Ksig,Iz,Jth)*Exp2x
END DO
END IF
END DO
END DO
10 CONTINUE
-C
+!
IF (Kvthck.GT.0) THEN
Iz = Izz
IF (Iz.EQ.Nzzz) Iz = Iz + 1
@@ -385,6 +387,7 @@ C
END DO
END IF
END DO
-C
+!
RETURN
END
+end module par15_m
\ No newline at end of file
diff --git a/sammy/src/par/mpar16.f b/sammy/src/par/mpar16.f90
similarity index 69%
rename from sammy/src/par/mpar16.f
rename to sammy/src/par/mpar16.f90
index 972eecf1e..a4e69de39 100644
--- a/sammy/src/par/mpar16.f
+++ b/sammy/src/par/mpar16.f90
@@ -1,14 +1,16 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Q_Cyl_Set (Xtpt_V, Xtpt_W, Ftheta, Sqfb, Arrr, Wrrr,
- * Azzz, Wzzz, Aphi, Wphi, Ff5phi, Znonu, Rnonu, Anonu, Bnonu)
-C
-C *** Purpose -- Q_Cyl_Set generates QQQ(2,total,totalp,mu)
-C *** Assumptns -- Sample is cylindrical, with non-uniform thickness
-C *** that varies with the radius R
-C
+!
+module par16_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Q_Cyl_Set (Xtpt_V, Xtpt_W, Ftheta, Sqfb, Arrr, Wrrr, &
+ Azzz, Wzzz, Aphi, Wphi, Ff5phi, Znonu, Rnonu, Anonu, Bnonu)
+!
+! *** Purpose -- Q_Cyl_Set generates QQQ(2,total,totalp,mu)
+! *** Assumptns -- Sample is cylindrical, with non-uniform thickness
+! *** that varies with the radius R
+!
use fixedi_m
use ifwrit_m
use lbro_common_m
@@ -16,23 +18,24 @@ C
use xsect_x_common_m
use constn_common_m
use MultScatPars_common_m
+ use par14_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Xtpt_V(Nxtptv), Xtpt_W(Nxtptw), Ftheta(*),
- * Sqfb(Nsqfb,Nxtptv,Nxtptw,*),
- * Arrr(*), Wrrr(*), Azzz(*), Wzzz(*), Aphi(*), Wphi(*),
- * Ff5phi(*), Znonu(*), Rnonu(*), Anonu(*), Bnonu(*)
-C
+ DIMENSION Xtpt_V(Nxtptv), Xtpt_W(Nxtptw), Ftheta(*), &
+ Sqfb(Nsqfb,Nxtptv,Nxtptw,*), &
+ Arrr(*), Wrrr(*), Azzz(*), Wzzz(*), Aphi(*), Wphi(*), &
+ Ff5phi(*), Znonu(*), Rnonu(*), Anonu(*), Bnonu(*)
+!
DATA Zero /0.0d0/, One /1.0d0/
-C
-C
+!
+!
CALL Zero_Array (Sqfb, 2*Nxtptv*Nxtptw*multScat%getNumTheta())
CALL Renorm_Nonu (Znonu, Rnonu, Anonu, Bnonu, Sthick, Rs, Nonu)
-c **************************** Careful! normalization is not necessarily
-c **************************** consistent with transmission
-C
+! **************************** Careful! normalization is not necessarily
+! **************************** consistent with transmission
+!
R0 = Rb
IF (Rs.LT.Rb) R0 = Rs
-C *** Theta-loop from Zero to +costh1
+! *** Theta-loop from Zero to +costh1
DO Ith=1,multScat%getNumTheta()
Costhe = Ftheta(Ith)
Sinth = One - Costhe**2
@@ -42,20 +45,20 @@ C *** Theta-loop from Zero to +costh1
END IF
IF (Costhe.GT.Zero) THEN
Tanth = Sinth/Costhe
-C *** Find value Rf = Rs - Z(Rf) tan Theta
- CALL Find_Rf (Znonu, Rnonu, Anonu, Bnonu, Nonu, Tanth,
- * Rs, Rf, Sthick)
+! *** Find value Rf = Rs - Z(Rf) tan Theta
+ CALL Find_Rf (Znonu, Rnonu, Anonu, Bnonu, Nonu, Tanth, &
+ Rs, Rf, Sthick)
IF (Rf.LT.Zero) Rf = Zero
ELSE
Rf = Zero
END IF
IF (Rf.LT.R0) THEN
-C
- CALL Gausqd (Rf, R0, Arrr, Wrrr, Nrrr,
- * multScat%getNumBeamAreaIntegration())
-C *** Gausqd figures grid for r-integration from Rf to R0
-C
-C *** Integrate over r from Rf to R0
+!
+ CALL Gausqd (Rf, R0, Arrr, Wrrr, Nrrr, &
+ multScat%getNumBeamAreaIntegration())
+! *** Gausqd figures grid for r-integration from Rf to R0
+!
+! *** Integrate over r from Rf to R0
Iii = 0
DO Ir=1,Nrrr
Rr = Arrr(Ir)
@@ -68,18 +71,18 @@ C *** Integrate over r from Rf to R0
Zf = Zr
END IF
R_Wr = Wrrr(Ir)*Arrr(Ir)
-C
- CALL Gausqd (Zero, Zf, Azzz, Wzzz, Nzzz,
- * multScat%getNumBeamAreaIntegration())
-C *** Gausqd figures grid for z-integration from Zero to Zf
-C
-C *** Integrate over z from zero to Zf
+!
+ CALL Gausqd (Zero, Zf, Azzz, Wzzz, Nzzz, &
+ multScat%getNumBeamAreaIntegration())
+! *** Gausqd figures grid for z-integration from Zero to Zf
+!
+! *** Integrate over z from zero to Zf
DO Iz=1,Nzzz
Zz = Azzz(Iz)
Zprime = Zr - Zz
IF (Costhe.NE.Zero)THEN
Ztan = Zprime * Tanth
-C *** Figure value of cos(phi_f)
+! *** Figure value of cos(phi_f)
D = Rs**2 - Rr**2 - Ztan**2
D = D/(2.0D0*Rr*Ztan)
IF (D.LT.-One) THEN
@@ -94,17 +97,17 @@ C *** Figure value of cos(phi_f)
ELSE
Phi1 = Pi
END IF
-C
+!
DO Iep=1,Nxtptw
Ff5phi(Iep) = Zero
END DO
-C
+!
IF (Phi1.NE.Zero) THEN
- CALL Gausqd (Zero, Phi1, Aphi, Wphi, Nphi,
- * multScat%getNumBeamAreaIntegration())
-C *** Gausqd figures grid for phi-integration
-C
-C *** Integrate over phi from 0 to phi1
+ CALL Gausqd (Zero, Phi1, Aphi, Wphi, Nphi, &
+ multScat%getNumBeamAreaIntegration())
+! *** Gausqd figures grid for phi-integration
+!
+! *** Integrate over phi from 0 to phi1
DO Iphi=1,Nphi
Phi = Aphi(Iphi)
Cosphi = Dcos(Phi)
@@ -120,62 +123,60 @@ C *** Integrate over phi from 0 to phi1
END DO
END IF
END DO
-C *** END of loop over Phi from Zero to Phi1
+! *** END of loop over Phi from Zero to Phi1
END IF
-C
+!
IF (Phi1.LT.Pi) THEN
A = Dnsty*Zprime/Costhe
-cx A = Zprime/Costhe
+!x A = Zprime/Costhe
DO Iep=1,Nxtptw
Ddd = Dexp(-A*Xtpt_W(Iep)) * (Pi-Phi1)
Ff5phi(Iep) = Ff5phi(Iep) + Ddd
END DO
END IF
-C
+!
Wzr = Wzzz(Iz)*R_Wr
Dnf = Dnsty*Zz
Dnb = Dnsty*Zprime
-cx Dnf = Zz
-cx Dnb = Zprime
-C
+!x Dnf = Zz
+!x Dnb = Zprime
+!
DO Ie=1,Nxtptv
-C # forward
+! # forward
Gf = dEXP(-Dnf*Xtpt_V(Ie)) * Wzr
-C # backward
+! # backward
Gb = dEXP(-Dnb*Xtpt_V(Ie)) * Wzr
-C
+!
DO Iep=1,Nxtptw
Ddd = Ff5phi(Iep)
Sqfb(1,Ie,Iep,Ith) = Sqfb(1,Ie,Iep,Ith) + Ddd*Gf
Sqfb(2,Ie,Iep,Ith) = Sqfb(2,Ie,Iep,Ith) + Ddd*Gb
END DO
-C
+!
END DO
-cx stop
-C
+!
END DO
-C *** End of loop over z from 0 to Zf
-C
+! *** End of loop over z from 0 to Zf
+!
END DO
-C *** End of loop over R from Rf to R0
+! *** End of loop over R from Rf to R0
END IF
-C
- IF (Kdebug.NE.0. AND. (Ith/10)*10.EQ.Ith) WRITE (6,10000)
- * Ith, multScat%getNumTheta()
+!
+ IF (Kdebug.NE.0. .AND. (Ith/10)*10.EQ.Ith) WRITE (6,10000) &
+ Ith, multScat%getNumTheta()
10000 FORMAT (' finished with Angle #', I4, '/', I4)
END DO
-C *** End of loop over Costhe from 0 to Costh1
-C
-C
+! *** End of loop over Costhe from 0 to Costh1
+!
+!
RETURN
END
-C
-C
-C -------------------------------------------------------------
-C
- SUBROUTINE Find_Rf (Znonu, Rnonu, Anonu, Bnonu, Nonu, Tanth, Rs,
- * Rf, Sthick)
-C *** Purpose -- Find value Rf = Rs - Z(Rf) tan Theta
+!
+!
+! -------------------------------------------------------------
+!
+ SUBROUTINE Find_Rf (Znonu, Rnonu, Anonu, Bnonu, Nonu, Tanth, Rs,Rf,Sthick)
+! *** Purpose -- Find value Rf = Rs - Z(Rf) tan Theta
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Znonu(Nonu), Rnonu(Nonu), Anonu(Nonu), Bnonu(Nonu)
DATA Zero /0.0d0/
@@ -204,23 +205,23 @@ C *** Purpose -- Find value Rf = Rs - Z(Rf) tan Theta
Iii = 0
Z = Z_Find (Znonu, Rnonu, Anonu, Bnonu, Nonu, R, Iii)
Rfx = Rs - Z
- IF (Iii.LE.Nonu .AND. Iii.NE.Iix .AND. Iii.NE.-1)
- * STOP '[STOP in Find_Rf in par/mpar16.f]'
+ IF (Iii.LE.Nonu .AND. Iii.NE.Iix .AND. Iii.NE.-1) then
+ STOP '[STOP in Find_Rf in par/mpar16.f]'
+ end if
END IF
-cx stop
+!x stop
RETURN
END
-C
-C
-C -------------------------------------------------------------
-C
- DOUBLE PRECISION FUNCTION Z_Find (Znonu, Rnonu, Anonu, Bnonu,
- * Nonu, R, Iii)
-C *** Purpose -- Find value Rf = Rs - Z(Rf) tan Theta
+!
+!
+! -------------------------------------------------------------
+!
+ DOUBLE PRECISION FUNCTION Z_Find (Znonu, Rnonu, Anonu, Bnonu, Nonu, R,Iii)
+! *** Purpose -- Find value Rf = Rs - Z(Rf) tan Theta
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Znonu(Nonu), Rnonu(Nonu), Anonu(Nonu), Bnonu(Nonu)
DATA Zero /0.0d0/
-cx In = Iii
+!x In = Iii
IF (R.LT.Rnonu(1)) THEN
Iii = -1
Z_Find = Znonu(1)
@@ -241,12 +242,11 @@ cx In = Iii
Z_Find = Z
RETURN
END
-C
-C
-C -------------------------------------------------------------
-C
- SUBROUTINE Renorm_Nonu (Znonu, Rnonu, Anonu, Bnonu, Sthick, Rs,
- * Nonu)
+!
+!
+! -------------------------------------------------------------
+!
+ SUBROUTINE Renorm_Nonu (Znonu, Rnonu, Anonu, Bnonu, Sthick, Rs, Nonu)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Znonu(Nonu), Rnonu(Nonu), Anonu(Nonu), Bnonu(Nonu)
DO I=1,Nonu
@@ -263,3 +263,4 @@ C
END DO
RETURN
END
+end module par16_m
\ No newline at end of file
diff --git a/sammy/src/par/mpar17.f b/sammy/src/par/mpar17.f90
similarity index 55%
rename from sammy/src/par/mpar17.f
rename to sammy/src/par/mpar17.f90
index 50f35c17a..668086ed1 100644
--- a/sammy/src/par/mpar17.f
+++ b/sammy/src/par/mpar17.f90
@@ -1,16 +1,18 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Hhhset_7 (Xtptv, Xtptvl, Ftheta, Azzz, Wzzz, Hhh,
- * Arrr, Wrrr, Aphi, Wphi, Ffff5r, Bb, Ff5phi)
-C
-C
-C *** Hhhset generates the integrand for integral over mu (which
-C *** is performed in samssm) for single-scattering correction
-C *** to the capture yield, for cylindrical or rectangular
-C *** samples.
-C
+!
+module par17_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Hhhset_7 (Xtptv, Xtptvl, Ftheta, Azzz, Wzzz, Hhh, &
+ Arrr, Wrrr, Aphi, Wphi, Ffff5r, Bb, Ff5phi)
+!
+!
+! *** Hhhset generates the integrand for integral over mu (which
+! *** is performed in samssm) for single-scattering correction
+! *** to the capture yield, for cylindrical or rectangular
+! *** samples.
+!
use fixedi_m
use ifwrit_m
use samxxx_common_m
@@ -19,78 +21,78 @@ C
use constn_common_m
use ExpPars_common_m
use MultScatPars_common_m
+ use par18_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Rect_is_Fixed
-C
- DIMENSION Xtptv(Nxtptv), Xtptvl(Nxtptv), Ftheta(*), Azzz(Nzzz,*),
- * Wzzz(*), Hhh(Nxtptv,Nzzz,*), Arrr(*), Wrrr(*), Aphi(*),Wphi(*),
- * Ffff5r(*), Bb(*), Ff5phi(*)
- COMMON /Ssssss/ Dthick, Sthick, Dnsty, Rs, Rb, Costh1,
- * A0, A1, A2, B0, B1, B2, Area
+!
+ DIMENSION Xtptv(Nxtptv), Xtptvl(Nxtptv), Ftheta(*), Azzz(Nzzz,*), &
+ Wzzz(*), Hhh(Nxtptv,Nzzz,*), Arrr(*), Wrrr(*), Aphi(*),Wphi(*), &
+ Ffff5r(*), Bb(*), Ff5phi(*)
+ COMMON /Ssssss/ Dthick,Sthick,Dnsty,Rs,Rb,Costh1,A0,A1,A2,B0, B1, B2, Area
DATA Zero /0.0d0/, Rect_is_Fixed /.false./
real(kind=8) Ybeam
Ybeam = 0.0d0 ! always zero, since we don't use right now
-C
+!
WRITE (21,10000)
-10000 FORMAT (//, ' *** Edge-effects for single-scattering correction to
- * capture', /, ' or fission yield calculations ***',/)
+10000 FORMAT (//, ' *** Edge-effects for single-scattering correction to capture',&
+ /, ' or fission yield calculations ***',/)
Rs = sampleDim%getRadius()
Rb = sampleDim%getBeamRadius()
Dthick = Thick
Sthick = sampleDim%getThickness()
Dnsty = Dthick/Sthick
CALL Setup_7 (Xtptv, Xtptvl, Azzz, Hhh, Ftheta)
-C
+!
IF (sampleDim%getHeight().LE.Zero) THEN
-C
-C *** here for r-phi coordinates (polar) instead of x-y (cartesian)
-C *** (cylinder) (rectangle)
-C
+!
+! *** here for r-phi coordinates (polar) instead of x-y (cartesian)
+! *** (cylinder) (rectangle)
+!
Area = Pi*Rb**2
WRITE (21,10100) Rs, Rb, Area
-10100 FORMAT (' CYLINDRICAL SAMPLE', /,
- * ' Radius of sample, radius of beam =', 1p2g14.6, /,
- * ' Area of overlap =', 1pg14.6)
+10100 FORMAT (' CYLINDRICAL SAMPLE', /, &
+ ' Radius of sample, radius of beam =', 1p2g14.6, /, &
+ ' Area of overlap =', 1pg14.6)
WRITE (21,10200) Sthick, Dnsty
-10200 FORMAT (' Thickness of sample (cm), density (atom/barn-cm) =',
- * 1p2g14.6)
+10200 FORMAT (' Thickness of sample (cm), density (atom/barn-cm) =', &
+ 1p2g14.6)
call multScat%setNumBeamAreaIntegration( Nzzz / 3 )
Ngaus = Nzzz/3
- WRITE (21,10300) multScat%getNumTheta(),
- * multScat%getNumZHatIntegration(),
- * multScat%getNumBeamAreaIntegration(),
- * multScat%getNumThetaNearZero(), Nxtptv, Nxtptw
-10300 FORMAT (' Ntheta, Ngausz, Ngaus for r & phi =', 3I10, /,
- * ' Ktheta, Nxtptv, Nxtptw for theta & sigma=', 3I10)
- CALL Urfset_7 (Xtptv, Ftheta, Azzz, Wzzz, Hhh,
- * Arrr, Wrrr, Aphi, Wphi, Ffff5r, Ff5phi)
-C
-C
+ WRITE (21,10300) multScat%getNumTheta(), &
+ multScat%getNumZHatIntegration(), &
+ multScat%getNumBeamAreaIntegration(), &
+ multScat%getNumThetaNearZero(), Nxtptv, Nxtptw
+10300 FORMAT (' Ntheta, Ngausz, Ngaus for r & phi =', 3I10, /, &
+ ' Ktheta, Nxtptv, Nxtptw for theta & sigma=', 3I10)
+ CALL Urfset_7 (Xtptv, Ftheta, Azzz, Wzzz, Hhh, &
+ Arrr, Wrrr, Aphi, Wphi, Ffff5r, Ff5phi)
+!
+!
ELSE IF (.NOT.Rect_is_Fixed) THEN
-C *** here for rectangle not cylinder -- but rectangular doesn't work
+! *** here for rectangle not cylinder -- but rectangular doesn't work
WRITE (6,10401)
WRITE (21,10401)
-10401 FORMAT (/,
- * ' *************************************************', /,
- * ' The option to use Rectangular Sample is disabled!', /,
- * ' Please convert to equivalent Cylindrical Sample ', /,
- * ' or to Infinite-Slab before continuing. ', /,
- * ' *************************************************', /)
+10401 FORMAT (/, &
+ ' *************************************************', /, &
+ ' The option to use Rectangular Sample is disabled!', /, &
+ ' Please convert to equivalent Cylindrical Sample ', /, &
+ ' or to Infinite-Slab before continuing. ', /, &
+ ' *************************************************', /)
STOP '[STOP in Hhhset_7 in par/mpar17.f]'
-C
+!
ELSE
-C *** here for rectangle not cylinder
- WRITE (21,10400) sampleDim%getBeamRadius(), Ybeam,
- * sampleDim%getRadius(), sampleDim%getHeight()
-10400 FORMAT (' RECTANGULAR SAMPLE', /,
- * ' Dimensions of beam (cm) =', 1p2g14.6, /,
- * ' Dimensions of sample(cm) =', 1p2g14.6)
+! *** here for rectangle not cylinder
+ WRITE (21,10400) sampleDim%getBeamRadius(), Ybeam, &
+ sampleDim%getRadius(), sampleDim%getHeight()
+10400 FORMAT (' RECTANGULAR SAMPLE', /, &
+ ' Dimensions of beam (cm) =', 1p2g14.6, /, &
+ ' Dimensions of sample(cm) =', 1p2g14.6)
Area = sampleDim%getBeamRadius()*Ybeam
- IF (sampleDim%getBeamRadius().GT.sampleDim%getRadius()
- * .AND. Ybeam.GT.sampleDim%getHeight()) then
+ IF (sampleDim%getBeamRadius().GT.sampleDim%getRadius() &
+ .AND. Ybeam.GT.sampleDim%getHeight()) then
Area = sampleDim%getRadius()*sampleDim%getHeight()
end if
WRITE (21,10500) Area
@@ -114,27 +116,27 @@ C *** here for rectangle not cylinder
call multScat%setNumBeamAreaIntegration( Nzzz / 5 )
Ngaus = Nzzz/5
- WRITE (21,10700) multScat%getNumZHatIntegration(),
- * multScat%getNumTheta(),
- * multScat%getNumBeamAreaIntegration()
+ WRITE (21,10700) multScat%getNumZHatIntegration(), &
+ multScat%getNumTheta(), &
+ multScat%getNumBeamAreaIntegration()
10700 FORMAT (' Ngausz, Ntheta, Ngaus for x & y=', 4I10)
- CALL Uxyset_7 (Xtptv, Ftheta, Azzz, Wzzz, Hhh, Arrr, Wrrr,
- * Aphi, Wphi, Ffff5r, Bb, Ff5phi)
-C
+ CALL Uxyset_7 (Xtptv, Ftheta, Azzz, Wzzz, Hhh, Arrr, Wrrr, &
+ Aphi, Wphi, Ffff5r, Bb, Ff5phi)
+!
END IF
-C
-C *** Write Hhh onto file 36 to be read (as smaller array) in Qqqwrt
-C
+!
+! *** Write Hhh onto file 36 to be read (as smaller array) in Qqqwrt
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
+!
+!
+! -----------------------------------------------------------------
+!
SUBROUTINE Setup_7 (Xtptv, Xtptvl, Azzz, Hhh, Ftheta)
-C
-C *** Setup initializes arrays
-C
+!
+! *** Setup initializes arrays
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -142,50 +144,48 @@ C
use ExpPars_common_m
use MultScatPars_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Xtptv(*), Azzz(Nzzz,*), Hhh(Nxtptv,Nzzz,*), Ftheta(*),
- * Xtptvl(*)
- COMMON /Ssssss/ Dthick, Sthick, Dnsty, Rs, Rb, Costh1,
- * A0, A1, A2, B0, B1, B2, Area
+!
+ DIMENSION Xtptv(*), Azzz(Nzzz,*), Hhh(Nxtptv,Nzzz,*), Ftheta(*), Xtptvl(*)
+ COMMON /Ssssss/ Dthick,Sthick,Dnsty,Rs,Rb,Costh1,A0,A1,A2,B0, B1, B2, Area
DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/
-C
-C
-C --------------
-C *** initialize Xtptv, the array for interpolation of total cross sections
-C *** NOTE *** experience has shown that the functions SQFB and QFB tend to
-C *** be relatively smooth when viewed on log-log plots. Ergo,
-C *** let Xtptvl represent dLOG(SIGMA), equally spaced from
-C *** -7.0 to almost 9 (Xtptv represents sigma ~ 0.0009 to
-C *** almost 8103., where "almost 9" means 9-Del)
-C *** (Nxtptv,1/Del,Ik) = (32,2,15), (64,4,29), (128,8,57)
+!
+!
+! --------------
+! *** initialize Xtptv, the array for interpolation of total cross sections
+! *** NOTE *** experience has shown that the functions SQFB and QFB tend to
+! *** be relatively smooth when viewed on log-log plots. Ergo,
+! *** let Xtptvl represent dLOG(SIGMA), equally spaced from
+! *** -7.0 to almost 9 (Xtptv represents sigma ~ 0.0009 to
+! *** almost 8103., where "almost 9" means 9-Del)
+! *** (Nxtptv,1/Del,Ik) = (32,2,15), (64,4,29), (128,8,57)
Del = 16.0d0/Nxtptv
Ik = 1 + (7.0d0/Del) + 0.01
DO I=1,Nxtptv
Xtptvl(I) = Del*dFLOAT(I-Ik)
Xtptv(I) = dEXP(Xtptvl(I))
END DO
-C
-C --------------
-C *** generate ftheta as follows:
-C C = Costh1 / [2+N-K-M]
-C B = C / [1+K(K-1)]
-C D = C / [1+M(M-1)]
-C Ftheta( 1 ) = 0
-C Ftheta( 2 ) = B
-C Ftheta(1+J ) = [1+J(J-1)]*B
-C up to Ftheta(K+1 ) = [1+K(K-1)]*B = C
-C Ftheta(K+2 ) = [1+1]*C
-C Ftheta(K+1+J) = [1+J]*C
-C up to Ftheta(N+1-M) = Ftheta(K+1+(N-M-K)) = [1+N-M-K]C
-C Ftheta(N+1-M) = 1-[1+M(M-1)]D
-C Ftheta(N+1-J) = 1-[1+J(J-1)]D
-C Ftheta(N+1-1) = 1-D
-C Ftheta(N+1 ) = 1
-C
+!
+! --------------
+! *** generate ftheta as follows:
+! C = Costh1 / [2+N-K-M]
+! B = C / [1+K(K-1)]
+! D = C / [1+M(M-1)]
+! Ftheta( 1 ) = 0
+! Ftheta( 2 ) = B
+! Ftheta(1+J ) = [1+J(J-1)]*B
+! up to Ftheta(K+1 ) = [1+K(K-1)]*B = C
+! Ftheta(K+2 ) = [1+1]*C
+! Ftheta(K+1+J) = [1+J]*C
+! up to Ftheta(N+1-M) = Ftheta(K+1+(N-M-K)) = [1+N-M-K]C
+! Ftheta(N+1-M) = 1-[1+M(M-1)]D
+! Ftheta(N+1-J) = 1-[1+J(J-1)]D
+! Ftheta(N+1-1) = 1-D
+! Ftheta(N+1 ) = 1
+!
A = (Rs-Rb)/Sthick
Costh1 = One/Dsqrt(A**2+One)
IF (sampleDim%getHeight().GT.Zero) Costh1 = One
-C *** tan(theta1) = (Rs-Rb)/Sthick
+! *** tan(theta1) = (Rs-Rb)/Sthick
N = multScat%getNumTheta() - 1
call multScat%setNumThetaNearZero( 2 )
Ktheta = 2 ! remove
@@ -216,44 +216,45 @@ C *** tan(theta1) = (Rs-Rb)/Sthick
WRITE (6,10100) (Ftheta(I),I=1,multScat%getNumTheta())
10100 FORMAT (1X, 1P5G13.6)
END IF
-C
-C --------------
-C *** Zero Azzz
+!
+! --------------
+! *** Zero Azzz
CALL Zero_Array (Azzz, multScat%getNumTheta()*Nzzz)
-C
-C *** Zero the array in which to store intermediate answers...
+!
+! *** Zero the array in which to store intermediate answers...
CALL Zero_Array (Hhh, multScat%getNumTheta()*Nzzz*Nxtptv)
-C --------------
+! --------------
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Urfset_7 (Xtptv, Ftheta, Azzz, Wzzz, Hhh, Arrr, Wrrr,
- * Aphi, Wphi, Ffff5r, Ff5phi)
-C
-C *** Urfset generates Hhh(E',z,MU')
-C *** this version assumes cylindrical not rectangular
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Urfset_7 (Xtptv, Ftheta, Azzz, Wzzz, Hhh, Arrr, Wrrr, &
+ Aphi, Wphi, Ffff5r, Ff5phi)
+!
+! *** Urfset generates Hhh(E',z,MU')
+! *** this version assumes cylindrical not rectangular
+!
use fixedi_m
use ifwrit_m
use lbro_common_m
use constn_common_m
use MultScatPars_common_m
+ use par14_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Xtptv(Nxtptv), Ftheta(*), Azzz(Nzzz,*), Wzzz(*),
- * Hhh(Nxtptv,Nzzz,*), Arrr(*), Wrrr(*), Aphi(*), Wphi(*),
- * Ffff5r(*), Ff5phi(*)
-C
- COMMON /Ssssss/ Dthick, Sthick, Dnsty, Rs, Rb, Costh1,
- * A0, A1, A2, B0, B1, B2, Area
+ DIMENSION Xtptv(Nxtptv), Ftheta(*), Azzz(Nzzz,*), Wzzz(*), &
+ Hhh(Nxtptv,Nzzz,*), Arrr(*), Wrrr(*), Aphi(*), Wphi(*), &
+ Ffff5r(*), Ff5phi(*)
+!
+ COMMON /Ssssss/ Dthick, Sthick, Dnsty, Rs, Rb, Costh1, &
+ A0, A1, A2, B0, B1, B2, Area
DATA Zero /0.0d0/, One /1.0d0/
-C
-C
+!
+!
R0 = Rb
IF (Rs.LT.Rb) R0 = Rs
-C *** theta-loop from Zero to +costh1
+! *** theta-loop from Zero to +costh1
DO Ith=1,multScat%getNumTheta()
Costhe = Ftheta(Ith)
Sinth = One - Costhe**2
@@ -267,26 +268,26 @@ C *** theta-loop from Zero to +costh1
Z3th = Sthick - (Rs-R0)*Cotth
IF (Z3th.LT.Zero) Z3th = Zero
N = 1
- IF (Z1th.GT.Zero) CALL Gausqd (Zero, Z1th,
- * Azzz(N,Ith), Wzzz(N), M,
- * multScat%getNumZHatIntegration())
+ IF (Z1th.GT.Zero) CALL Gausqd (Zero, Z1th, &
+ Azzz(N,Ith), Wzzz(N), M, &
+ multScat%getNumZHatIntegration())
IF (Z1th.GT.Zero) N = N + M
- IF (Z2th.GT.Z1th) CALL Gausqd (Z1th, Z2th,
- * Azzz(N,Ith), Wzzz(N), M,
- * multScat%getNumZHatIntegration())
+ IF (Z2th.GT.Z1th) CALL Gausqd (Z1th, Z2th, &
+ Azzz(N,Ith), Wzzz(N), M, &
+ multScat%getNumZHatIntegration())
IF (Z2th.GT.Z1th) N = N + M
- IF (Z3th.GT.Z2th) CALL Gausqd (Z2th, Z3th,
- * Azzz(N,Ith), Wzzz(N), M,
- * multScat%getNumZHatIntegration())
+ IF (Z3th.GT.Z2th) CALL Gausqd (Z2th, Z3th, &
+ Azzz(N,Ith), Wzzz(N), M, &
+ multScat%getNumZHatIntegration())
IF (Z3th.GT.Z2th) N = N + M
N = N - 1
-C *** Azzz(Iz,ith) now stores points for integration over z
-C *** from 0 to z3
-C *** Wzzz(Iz ) weights
-C
-C
+! *** Azzz(Iz,ith) now stores points for integration over z
+! *** from 0 to z3
+! *** Wzzz(Iz ) weights
+!
+!
IF (N.GT.0) THEN
-C *** loop over z from 0 to z3
+! *** loop over z from 0 to z3
DO Iz=1,N
Z = Azzz(Iz,Ith)
IF (Z.LE.Zero) GO TO 130
@@ -295,28 +296,28 @@ C *** loop over z from 0 to z3
Ztan = Zprime/Cotth
ELSE
Ztan = 10000.0D0*(Rs+R0)
-C *** = infinity
+! *** = infinity
END IF
-C
+!
R1 = Rs - Ztan
R2 = R1 + R0
IF (R1.LE.R0) THEN
IF (R1.LE.Zero) R1 = Zero
-C
- CALL Gausqd (R1, R0, Arrr, Wrrr, Nrrr,
- * multScat%getNumBeamAreaIntegration())
-C *** Gausqd figures grid for r-integration from R1 to R0
-C
-C *** initialize storage for integral over R
+!
+ CALL Gausqd (R1, R0, Arrr, Wrrr, Nrrr, &
+ multScat%getNumBeamAreaIntegration())
+! *** Gausqd figures grid for r-integration from R1 to R0
+!
+! *** initialize storage for integral over R
DO Ie=1,Nxtptv
Ffff5r(Ie) = Zero
END DO
Ffff4R = Zero
-C
-C *** integrate over r from R1 to R0
+!
+! *** integrate over r from R1 to R0
DO IR=1,Nrrr
R = Arrr(IR)
-C
+!
IF (R2.LE.Zero) THEN
Phi1 = PI
ELSE
@@ -326,14 +327,14 @@ C
IF (D.GT. One) D = One
Phi1 = DACOS(D)
END IF
- CALL Gausqd (Zero, Phi1, Aphi, Wphi, Nphi,
- * multScat%getNumBeamAreaIntegration())
-C *** Gausqd figures grid for phi-integration
-C
+ CALL Gausqd (Zero, Phi1, Aphi, Wphi, Nphi, &
+ multScat%getNumBeamAreaIntegration())
+! *** Gausqd figures grid for phi-integration
+!
DO Ie=1,Nxtptv
Ff5phi(Ie) = Zero
END DO
-C *** integrate over phi from 0 to phi1
+! *** integrate over phi from 0 to phi1
DO Iphi=1,Nphi
Phi = Aphi(Iphi)
Cosphi = Dcos(Phi)
@@ -342,53 +343,53 @@ C *** integrate over phi from 0 to phi1
D = (-R*Cosphi+D)/Sinth
DO Ie=1,Nxtptv
Ccc = Dnsty*Xtptv(Ie)*D
- Ff5phi(Ie) = Ff5phi(Ie) +
- * Dexp(-Ccc)*Wphi(Iphi)
+ Ff5phi(Ie) = Ff5phi(Ie) + Dexp(-Ccc)*Wphi(Iphi)
END DO
END DO
-C *** END of loop over phi from Zero to phi1
-C
+! *** END of loop over phi from Zero to phi1
+!
DO Ie=1,Nxtptv
Ffff5r(Ie) = Ffff5r(Ie)+Ff5phi(Ie)*R*Wrrr(IR)
END DO
Ffff4R = Ffff4R + (Pi-Phi1)*R*Wrrr(IR)
-C *** Ffff4R is integral over Phi from Phi1 to Pi
-C
+! *** Ffff4R is integral over Phi from Phi1 to Pi
+!
END DO
-C *** END of loop over R from R1 to R0
-C
+! *** END of loop over R from R1 to R0
+!
IF (Costhe.NE.Zero) THEN
A = Dnsty*Zprime/Costhe
DO Ie=1,Nxtptv
- Hhh(Ie,Iz,Ith) = Hhh(Ie,Iz,Ith) + Ffff5r(Ie)
- * + Ffff4R*Dexp(-A*Xtptv(Ie))
-C *** Hhh = h F4R + F5r
+ Hhh(Ie,Iz,Ith) = Hhh(Ie,Iz,Ith) + Ffff5r(Ie) &
+ + Ffff4R*Dexp(-A*Xtptv(Ie))
+! *** Hhh = h F4R + F5r
END DO
ELSE
DO Ie=1,Nxtptv
Hhh(Ie,Iz,Ith) = Hhh(Ie,Iz,Ith) + Ffff5r(Ie)
-C *** Hhh = h F4R + F5r
+! *** Hhh = h F4R + F5r
END DO
END IF
DO Ie=1,Nxtptv
Hhh(Ie,Iz,Ith) = Hhh(Ie,Iz,Ith)*Wzzz(Iz)
END DO
-C *** NOTE that Hhh is now (h F4R + F5r) * Wz (See
-C *** Appendix C of multiple-scattering manual.)
-C
+! *** NOTE that Hhh is now (h F4R + F5r) * Wz (See
+! *** Appendix C of multiple-scattering manual.)
+!
END IF
END DO
-C *** END of loop over z from 0 to z3
-C
- IF (Kdebug.NE.0. AND. (Ith/10)*10.EQ.Ith) WRITE (6,11111)
- * Ith, multScat%getNumTheta()
+! *** END of loop over z from 0 to z3
+!
+ IF (Kdebug.NE.0. .AND. (Ith/10)*10.EQ.Ith) WRITE (6,11111) &
+ Ith, multScat%getNumTheta()
11111 FORMAT (' finished with Angle #', I4, '/', I4)
END IF
END IF
130 CONTINUE
END DO
-C *** end of loop over Costhe from 0 to costh1
-C
-C
+! *** end of loop over Costhe from 0 to costh1
+!
+!
RETURN
END
+end module par17_m
\ No newline at end of file
diff --git a/sammy/src/par/mpar18.f b/sammy/src/par/mpar18.f90
similarity index 64%
rename from sammy/src/par/mpar18.f
rename to sammy/src/par/mpar18.f90
index b0f70e342..b52d12a96 100644
--- a/sammy/src/par/mpar18.f
+++ b/sammy/src/par/mpar18.f90
@@ -1,31 +1,33 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Uxyset_7 (Xtptv, Ftheta, Azzz, Wzzz, Hhh, Axxx, Wxxx,
- * Aphi, Wphi, Ffff5r, Bb, Ff5phi)
-C
-C *** Uxyset generates Hhh(E',z,MU')
-C *** This version assumes rectangular not cylindrical
-C
+!
+module par18_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Uxyset_7 (Xtptv, Ftheta, Azzz, Wzzz, Hhh, Axxx, Wxxx, &
+ Aphi, Wphi, Ffff5r, Bb, Ff5phi)
+!
+! *** Uxyset generates Hhh(E',z,MU')
+! *** This version assumes rectangular not cylindrical
+!
use fixedi_m
use ifwrit_m
use lbro_common_m
use MultScatPars_common_m
use abcexp_m
+ use par14_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Xtptv(Nxtptv), Ftheta(*), Azzz(Nzzz,*), Wzzz(*),
- * Hhh(Nxtptv,Nzzz,*), Axxx(*), Wxxx(*), Aphi(*), Wphi(*),
- * Ffff5r(*), Bb(*), Ff5phi(*)
-C
+ DIMENSION Xtptv(Nxtptv), Ftheta(*), Azzz(Nzzz,*), Wzzz(*), &
+ Hhh(Nxtptv,Nzzz,*), Axxx(*), Wxxx(*), Aphi(*), Wphi(*), &
+ Ffff5r(*), Bb(*), Ff5phi(*)
+!
DIMENSION abth(5), zth(5)
- COMMON /Ssssss/ Dthick, Sthick, Dnsty, Rs, Rb, Costh1,
- * A0, A1, A2, B0, B1, B2, Area
-C
-C
-C
-C
-C *** Abth are used in determining limits for z-integration
+ COMMON /Ssssss/ Dthick,Sthick,Dnsty,Rs,Rb,Costh1,A0,A1,A2,B0, B1, B2, Area
+!
+!
+!
+!
+! *** Abth are used in determining limits for z-integration
Abth(1) = Dsqrt(A2**2+B2**2)
Abth(2) = Dsqrt(A2**2+B0**2)
Abth(3) = Dsqrt(A0**2+B2**2)
@@ -37,9 +39,9 @@ C *** Abth are used in determining limits for z-integration
Abth(3) = A
END IF
S10 = Sthick/10.0d0
-C
-C
-C *** cos(theta)-loop from Zero to 1
+!
+!
+! *** cos(theta)-loop from Zero to 1
DO Ith=1,multScat%getNumTheta()
Costhe = Ftheta(Ith)
Iimmuu = 0
@@ -47,26 +49,26 @@ C *** cos(theta)-loop from Zero to 1
Sinth = Dsqrt(1.0D0-Costhe**2)
IF (Sinth.EQ.0.0D0) THEN
Cotth = (Sthick/(A0+B0+0.001))*1000000.
-C = infinity
+! = infinity
Iimmuu = 1
ELSE
Cotth = Costhe/Sinth
END IF
-C
-C *** find limits for regions in z
+!
+! *** find limits for regions in z
DO Iz=1,5
ZTH(Iz) = Sthick - Abth(Iz)*Cotth
END DO
-C
-C *** initialize for energy-interpolation points E'
+!
+! *** initialize for energy-interpolation points E'
IF (Costhe.NE.0.0D0) THEN
A = Dnsty/Costhe
DO Ie=1,Nxtptv
Ffff5r(Ie) = A*Xtptv(Ie)
END DO
END IF
-C
-C *** loop over z from 0 to t=Sthick, in five pieces
+!
+! *** loop over z from 0 to t=Sthick, in five pieces
N = 1
Zmax = 0.0D0
DO Izp=1,5
@@ -78,19 +80,19 @@ C *** loop over z from 0 to t=Sthick, in five pieces
IF (Zmax-Zmin.LT.s10) THEN
CALL Gausqd (Zmin, Zmax, Azzz(N,Ith), Wzzz(N), M, 4)
ELSE
- CALL Gausqd (Zmin, Zmax, Azzz(N,Ith), Wzzz(N), M,
- * multScat%getNumZHatIntegration())
+ CALL Gausqd (Zmin, Zmax, Azzz(N,Ith), Wzzz(N), M, &
+ multScat%getNumZHatIntegration())
END IF
-C *** Azzz(Iz,ith) stores points for integration over
-C *** z from 0 to Sthick
-C *** Wzzz(Iz ) weights
-C
-C *** loop over z for this piece
+! *** Azzz(Iz,ith) stores points for integration over
+! *** z from 0 to Sthick
+! *** Wzzz(Iz ) weights
+!
+! *** loop over z for this piece
DO 90 IIz=1,M
Iz = IIz + N - 1
Z = Azzz(Iz,Ith)
Zprime = Sthick - Z
-C
+!
IF (Costhe.GT.0.0D0) THEN
DO Ie=1,Nxtptv
Ccc = Ffff5r(Ie)*Zprime
@@ -111,49 +113,49 @@ C
IF (Ztan.LT.A2*10.0d0) Ztan = A2*10.0d0
IF (Ztan.LT.B2*10.0d0) Ztan = B2*10.0d0
Ztan2 = Ztan**2
-C = infinity
+! = infinity
END IF
-C
+!
IF (Iimmuu.EQ.1) GO TO 90
-C *** August 27, 1996 Funtion -> 0 as mu -> 1. Function is actually
-C *** proportional to tan(theta), which is Zero if Costhe=1.
-C
-C *** here Sinth.NE.0.0d0 so we're OK
+! *** August 27, 1996 Funtion -> 0 as mu -> 1. Function is actually
+! *** proportional to tan(theta), which is Zero if Costhe=1.
+!
+! *** here Sinth.NE.0.0d0 so we're OK
Fudgex = Dnsty/Sinth
-C
+!
IF (Izp.LE.3) THEN
-C *** ixp = 1; "ixp" relates to Number of the equation on page 22 of notes
-C *** izp = 1,2,3; "izp" relates to Numbers ACROSS the top of page 23 of
-C notes. That is, izp relates to region in z-integration
+! *** ixp = 1; "ixp" relates to Number of the equation on page 22 of notes
+! *** izp = 1,2,3; "izp" relates to Numbers ACROSS the top of page 23 of
+! notes. That is, izp relates to region in z-integration
Xmin = A0
Xmax = A0
IF (Ztan.GT.B2) Xmax = Dsqrt(Ztan2-B2**2)
IF (Xmax.GT.A2) Xmax = A2
IF (Iimmuu.EQ.-1) Xmax = A2
Iwhich = 1
- IF (Xmin.LT.Xmax) CALL Xint_7 (Xtptv, Hhh, Axxx,
- * Wxxx, Aphi, Wphi, Bb, Ff5phi, Xmin, Xmax, B0,
- * B1, B2, Fudgex, Ztan, Iz, Ith, Iwhich,Iimmuu)
-C
+ IF (Xmin.LT.Xmax) CALL Xint_7 (Xtptv, Hhh, Axxx, &
+ Wxxx, Aphi, Wphi, Bb, Ff5phi, Xmin, Xmax, B0, &
+ B1, B2, Fudgex, Ztan, Iz, Ith, Iwhich,Iimmuu)
+!
IF (Izp.LE.2) THEN
-C *** ixp = 4; izp = 1,2
+! *** ixp = 4; izp = 1,2
Xmin = B0
Xmax = B0
IF (Ztan.GT.A2) Xmax = Dsqrt(Ztan2-A2**2)
IF (Xmax.GT.B2) Xmax = B2
IF (Iimmuu.EQ.-1) Xmax = B2
Iwhich = 1
- IF (Xmin.LT.Xmax) CALL Xint_7 (Xtptv, Hhh,
- * Axxx, Wxxx, Aphi, Wphi, Bb, Ff5phi, Xmin,
- * Xmax, A0, A1, A2, Fudgex, Ztan, Iz, Ith,
- * Iwhich, Iimmuu)
+ IF (Xmin.LT.Xmax) CALL Xint_7 (Xtptv, Hhh, &
+ Axxx, Wxxx, Aphi, Wphi, Bb, Ff5phi, Xmin, &
+ Xmax, A0, A1, A2, Fudgex, Ztan, Iz, Ith, &
+ Iwhich, Iimmuu)
IF (Costhe.EQ.0.0D0) GO TO 70
END IF
-C
+!
END IF
-C
+!
IF (Izp.GE.2 .AND. Izp.LE.4) THEN
-C *** ixp = 2; izp = 2,3,4
+! *** ixp = 2; izp = 2,3,4
Xmin = A0
Xmax = A0
IF (Ztan.GT.B2) Xmin = Dsqrt(Ztan2-B2**2)
@@ -161,12 +163,12 @@ C *** ixp = 2; izp = 2,3,4
IF (Xmin.LT.A0) Xmin = A0
IF (Xmax.GT.A2) Xmax = A2
Iwhich = 2
- IF (Xmin.LT.Xmax) CALL Xint_7 (Xtptv, Hhh,
- * Axxx, Wxxx, Aphi, Wphi, Bb, Ff5phi, Xmin,
- * Xmax, B0, B1, B2, Fudgex, Ztan, Iz, Ith,
- * Iwhich, Iimmuu)
-C
-C *** ixp = 5; izp = 2,3,4
+ IF (Xmin.LT.Xmax) CALL Xint_7 (Xtptv, Hhh, &
+ Axxx, Wxxx, Aphi, Wphi, Bb, Ff5phi, Xmin, &
+ Xmax, B0, B1, B2, Fudgex, Ztan, Iz, Ith, &
+ Iwhich, Iimmuu)
+!
+! *** ixp = 5; izp = 2,3,4
Xmin = B0
Xmax = B0
IF (Ztan.GT.A2) Xmin = Dsqrt(Ztan2-A2**2)
@@ -174,95 +176,96 @@ C *** ixp = 5; izp = 2,3,4
IF (Xmin.LT.B0) Xmin = B0
IF (Xmax.GT.B2) Xmax = B2
Iwhich = 2
- IF (Xmin.LT.Xmax) CALL Xint_7 (Xtptv, Hhh,
- * Axxx, Wxxx, Aphi, Wphi, Bb, Ff5phi, Xmin,
- * Xmax, A0, A1, A2, Fudgex, Ztan, Iz, Ith,
- * Iwhich, Iimmuu)
-C
+ IF (Xmin.LT.Xmax) CALL Xint_7 (Xtptv, Hhh, &
+ Axxx, Wxxx, Aphi, Wphi, Bb, Ff5phi, Xmin, &
+ Xmax, A0, A1, A2, Fudgex, Ztan, Iz, Ith, &
+ Iwhich, Iimmuu)
+!
END IF
-C
+!
IF (Izp.GE.3) THEN
-C *** ixp = 3; izp = 3,4,5
+! *** ixp = 3; izp = 3,4,5
Xmin = A0
IF (Ztan.GT.B0) Xmin = Dsqrt(Ztan2-B0**2)
IF (Xmin.LT.A0) Xmin = A0
Xmax = A2
IF (Xmax.GT.Ztan) Xmax = Ztan
Iwhich = 3
- IF (Xmin.LT.Xmax) CALL Xint_7 (Xtptv, Hhh,
- * Axxx, Wxxx, Aphi, Wphi, Bb, Ff5phi, Xmin,
- * Xmax, B0, B1, B2, Fudgex, Ztan, Iz, Ith,
- * Iwhich, Iimmuu)
-C
+ IF (Xmin.LT.Xmax) CALL Xint_7 (Xtptv, Hhh, &
+ Axxx, Wxxx, Aphi, Wphi, Bb, Ff5phi, Xmin, &
+ Xmax, B0, B1, B2, Fudgex, Ztan, Iz, Ith, &
+ Iwhich, Iimmuu)
+!
IF (Izp.GE.4) THEN
-C *** ixp = 6; izp = 4,5
+! *** ixp = 6; izp = 4,5
Xmin = B0
IF (Ztan.GT.A0) Xmin = Dsqrt(Ztan2-A0**2)
IF (Xmin.LT.B0) Xmin = B0
Xmax = B2
IF (Xmax.GT.Ztan) Xmax = Ztan
Iwhich = 3
- IF (Xmin.LT.Xmax) CALL Xint_7 (Xtptv, Hhh,
- * Axxx, Wxxx, Aphi, Wphi, Bb, Ff5phi,
- * Xmin, Xmax, A0, A1, A2, Fudgex, Ztan,
- * Iz, Ith, Iwhich, Iimmuu)
+ IF (Xmin.LT.Xmax) CALL Xint_7 (Xtptv, Hhh, &
+ Axxx, Wxxx, Aphi, Wphi, Bb, Ff5phi, &
+ Xmin, Xmax, A0, A1, A2, Fudgex, Ztan, &
+ Iz, Ith, Iwhich, Iimmuu)
END IF
END IF
-C
+!
70 CONTINUE
Wzzz(Iz) = Wzzz(Iz)/4.0d0
DO Ie=1,Nxtptv
Hhh(Ie,Iz,Ith) = Hhh(Ie,Iz,Ith)*Wzzz(Iz)
END DO
-C
+!
90 CONTINUE
-C *** END of loop over z for this piece
+! *** END of loop over z for this piece
N = N + M
-C
+!
END IF
END DO
-C *** END of loop over five pieces of z
+! *** END of loop over five pieces of z
N = N - 1
-C
- IF(Kdebug.NE.0. AND. (Ith/10)*10.EQ.Ith) WRITE (6,11111) Ith,
- * multScat%getNumTheta()
+!
+ IF(Kdebug.NE.0. .AND. (Ith/10)*10.EQ.Ith) WRITE (6,11111) &
+ Ith, multScat%getNumTheta()
11111 FORMAT (' Finished with Angle #', I4, '/', I4)
END DO
-C *** end of loop over Costhe from 0 to 1
-C
+! *** end of loop over Costhe from 0 to 1
+!
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Xint_7 (Xtptv, Hhh, Axxx, Wxxx, Aphi, Wphi, Bb, Ff5phi,
- * Xmin, Xmax, Const0, Const1, Const2, Fudgex, Ztan, Iz, Ith,
- * Iwhich, Iimmuu)
-C
-C *** Xint generates Hhh(E',iz,iMU) for particular iz & imu
-C *** This version assumes rectangular not cylindrical
-C
+!
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Xint_7 (Xtptv, Hhh, Axxx, Wxxx, Aphi, Wphi, Bb, Ff5phi, &
+ Xmin, Xmax, Const0, Const1, Const2, Fudgex, Ztan, Iz, Ith, &
+ Iwhich, Iimmuu)
+!
+! *** Xint generates Hhh(E',iz,iMU) for particular iz & imu
+! *** This version assumes rectangular not cylindrical
+!
use fixedi_m
use MultScatPars_common_m
use abcexp_m
+ use par14_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Xtptv(Nxtptv), Hhh(Nxtptv,Nzzz,*), Axxx(*), Wxxx(*),
- * Aphi(*), Wphi(*), Bb(*), Ff5phi(*)
-C
- CALL Gausqd (Xmin, Xmax, Axxx, Wxxx, NXxX,
- * multScat%getNumBeamAreaIntegration())
-C *** Gausqd figures grid for x-integration from xmin to xmax
-C
-C *** integrate over x from xmin to xmax
+!
+ DIMENSION Xtptv(Nxtptv), Hhh(Nxtptv,Nzzz,*), Axxx(*), Wxxx(*), &
+ Aphi(*), Wphi(*), Bb(*), Ff5phi(*)
+!
+ CALL Gausqd (Xmin, Xmax, Axxx, Wxxx, NXxX, &
+ multScat%getNumBeamAreaIntegration())
+! *** Gausqd figures grid for x-integration from xmin to xmax
+!
+! *** integrate over x from xmin to xmax
DO Ix=1,NXxX
-C
-C *** initialize intermediate array
+!
+! *** initialize intermediate array
DO Ie=1,Nxtptv
Ff5phi(Ie) = 0.0D0
END DO
-C
+!
X = Axxx(Ix)
A = Fudgex*X
Phimin = 0.0D0
@@ -271,11 +274,11 @@ C
Phimax = Datan(Const0/X)
IF (Iwhich.EQ.3) Phimax = Dacos(X/Ztan)
IF (Phimin.LT.Phimax) THEN
- CALL Gausqd (Phimin, Phimax, Aphi, Wphi, Nphi,
- * multScat%getNumBeamAreaIntegration())
-C *** Gausqd figures grid for phi-integration
-C
-C *** integrate over phi from Zero to Phimax
+ CALL Gausqd (Phimin, Phimax, Aphi, Wphi, Nphi, &
+ multScat%getNumBeamAreaIntegration())
+! *** Gausqd figures grid for phi-integration
+!
+! *** integrate over phi from Zero to Phimax
DO Iphi=1,Nphi
Phi = Aphi(Iphi)
Cosphi = Dcos(Phi)
@@ -288,24 +291,23 @@ C *** integrate over phi from Zero to Phimax
ELSE
C = (1.0d0-Dexp(-Ccc))/Xtptv(Ie)
END IF
- Ff5phi(Ie) = Ff5phi(Ie) -
- * Const1*(Bb(Ie)-C)*Wphi(Iphi)
+ Ff5phi(Ie) = Ff5phi(Ie) - Const1*(Bb(Ie)-C)*Wphi(Iphi)
END DO
END DO
-C *** END of loop over phi from Phimin(=0) to Phimax
+! *** END of loop over phi from Phimin(=0) to Phimax
END IF
END IF
-C
+!
IF (Iwhich.NE.3) THEN
Phimin = Phimax
Phimax = Datan(Const2/X)
IF (Iwhich.EQ.2) Phimax = Dacos(X/Ztan)
IF (Phimin.LT.Phimax) THEN
- CALL Gausqd (Phimin, Phimax, Aphi, Wphi, Nphi,
- * multScat%getNumBeamAreaIntegration())
-C *** Gausqd figures grid for phi-integration
-C
-C *** integrate over phi from Phimin to Phimax
+ CALL Gausqd (Phimin, Phimax, Aphi, Wphi, Nphi, &
+ multScat%getNumBeamAreaIntegration())
+! *** Gausqd figures grid for phi-integration
+!
+! *** integrate over phi from Phimin to Phimax
DO Iphi=1,Nphi
Phi = Aphi(Iphi)
Cosphi = Dcos(Phi)
@@ -322,17 +324,18 @@ C *** integrate over phi from Phimin to Phimax
Ff5phi(Ie) = Ff5phi(Ie) - D*(Bb(Ie)-C)*Wphi(Iphi)
END DO
END DO
-C *** END of loop over phi from Phimin to Phimax
+! *** END of loop over phi from Phimin to Phimax
END IF
END IF
-C
-C *** add results for this x to earlier results
+!
+! *** add results for this x to earlier results
DO Ie=1,Nxtptv
Hhh(Ie,Iz,Ith) = Hhh(Ie,Iz,Ith) + Ff5phi(Ie)*Wxxx(Ix)
END DO
-C
+!
END DO
-C *** end of loop over X from Xmin to Xmax
-C
+! *** end of loop over X from Xmin to Xmax
+!
RETURN
END
+end module par18_m
\ No newline at end of file
diff --git a/sammy/src/par/mpar19.f b/sammy/src/par/mpar19.f90
similarity index 65%
rename from sammy/src/par/mpar19.f
rename to sammy/src/par/mpar19.f90
index 5a1eb6025..431a56372 100644
--- a/sammy/src/par/mpar19.f
+++ b/sammy/src/par/mpar19.f90
@@ -1,13 +1,14 @@
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Qqqwrt_7 (Xtptvl, Xtptw, Xtptwl, Ftheta, Azzz, Hhh,
- * Sqfb, Dsqfb)
-C
-C *** Qqqwrt performs integration over dz,
-C *** converts to logarithm, and writes results onto Fqqqqq
-C
+!
+module par19_m
+ contains
+!
+! -----------------------------------------------------------------
+!
+ SUBROUTINE Qqqwrt_7 (Xtptvl, Xtptw, Xtptwl, Ftheta, Azzz, Hhh,Sqfb, Dsqfb)
+!
+! *** Qqqwrt performs integration over dz,
+! *** converts to logarithm, and writes results onto Fqqqqq
+!
use fixedi_m
use ifwrit_m
use samxxx_common_m
@@ -15,33 +16,32 @@ C
use namfil_common_m
use MultScatPars_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Xtptvl(Nxtptv), Xtptw(Nxtptw), Xtptwl(Nxtptw),
- * Ftheta(Ntheta), Azzz(Nzzz,Ntheta), Hhh(Nxtptv,Nzzz,*),
- * Sqfb(2,Nxtptv,Nxtptw,Ntheta), Dsqfb(2,Nxtptv,Nxtptw,Ntheta)
- COMMON /Ssssss/ Dthick, Sthick, Dnsty, RS, RB, Costh1,
- * A0, A1, A2, B0, B1, B2, Area
+!
+ DIMENSION Xtptvl(Nxtptv), Xtptw(Nxtptw), Xtptwl(Nxtptw), &
+ Ftheta(Ntheta), Azzz(Nzzz,Ntheta), Hhh(Nxtptv,Nzzz,*), &
+ Sqfb(2,Nxtptv,Nxtptw,Ntheta), Dsqfb(2,Nxtptv,Nxtptw,Ntheta)
+ COMMON /Ssssss/ Dthick,Sthick,Dnsty,RS,RB,Costh1,A0,A1,A2,B0, B1, B2, Area
DATA Zero /0.0d0/
-C
-C
-C *** first, initialize Sqfb and dSqfb
+!
+!
+! *** first, initialize Sqfb and dSqfb
CALL Zero_Array ( Sqfb, multScat%getNumTheta()*Nxtptv*Nxtptw*2)
CALL Zero_Array (dSqfb, multScat%getNumTheta()*Nxtptv*Nxtptw*2)
-C
-C *** Next, generate Xtptw and Xtptwl
+!
+! *** Next, generate Xtptw and Xtptwl
Del = 16.0d0/Nxtptw
Ik = 1 + (7.0d0/Del) + 0.01
DO I=1,Nxtptw
Xtptwl(I) = Del*dFLOAT(I-Ik)
Xtptw(I) = dEXP(Xtptwl(I))
END DO
-C
-C
-C *** Calculate Integ (dz) exp(-N Total z ) uuu for ifb=1
-C *** Integ (dz) exp(-N Total (Sthick-z)) uuu for ifb=2
-C *** and derivatives thereof wrt Total = total cross section = Xtpt(K)
-C *** Note that the weights for z-integration are included in Uwz = U*Wz
-C
+!
+!
+! *** Calculate Integ (dz) exp(-N Total z ) uuu for ifb=1
+! *** Integ (dz) exp(-N Total (Sthick-z)) uuu for ifb=2
+! *** and derivatives thereof wrt Total = total cross section = Xtpt(K)
+! *** Note that the weights for z-integration are included in Uwz = U*Wz
+!
DO Jth=1,multScat%getNumTheta()
DO Iz=1,Nzzz
IF (Azzz(Iz,Jth).NE.Zero) THEN
@@ -53,14 +53,14 @@ C
Exp2x = dEXP(-Xtptw(Ksig)*Cc)
IF (Exp2.NE.Zero .OR. Exp2x.NE.Zero) THEN
DO Jsig=1,Nxtptv
- Sqfb(1,Jsig,Ksig,Jth) = Sqfb(1,Jsig,Ksig,Jth)
- * + Hhh(Jsig,Iz,Jth)*Exp2
- Sqfb(2,Jsig,Ksig,Jth) = Sqfb(2,Jsig,Ksig,Jth)
- * + Hhh(Jsig,Iz,Jth)*Exp2x
- Dsqfb(1,Jsig,Ksig,Jth) = Dsqfb(1,Jsig,Ksig,Jth)
- * - Hhh(Jsig,Iz,Jth)*bb*Exp2
- Dsqfb(2,Jsig,Ksig,Jth) = Dsqfb(2,Jsig,Ksig,Jth)
- * -Hhh(Jsig,Iz,Jth)*cc*Exp2x
+ Sqfb(1,Jsig,Ksig,Jth) = Sqfb(1,Jsig,Ksig,Jth) &
+ + Hhh(Jsig,Iz,Jth)*Exp2
+ Sqfb(2,Jsig,Ksig,Jth) = Sqfb(2,Jsig,Ksig,Jth) &
+ + Hhh(Jsig,Iz,Jth)*Exp2x
+ Dsqfb(1,Jsig,Ksig,Jth) = Dsqfb(1,Jsig,Ksig,Jth) &
+ - Hhh(Jsig,Iz,Jth)*bb*Exp2
+ Dsqfb(2,Jsig,Ksig,Jth) = Dsqfb(2,Jsig,Ksig,Jth) &
+ -Hhh(Jsig,Iz,Jth)*cc*Exp2x
END DO
END IF
END DO
@@ -68,8 +68,8 @@ C
END DO
END DO
CLOSE (UNIT=36)
-C
-C *** Normalize Sqfb, and convert to logarithm thereof
+!
+! *** Normalize Sqfb, and convert to logarithm thereof
Aa = dLOG(2.0d0*Dnsty/Area)
DO Jth=1,multScat%getNumTheta()
DO Ksig=1,Nxtptw
@@ -87,8 +87,8 @@ C *** Normalize Sqfb, and convert to logarithm thereof
END DO
END DO
END DO
-C
-C *** Normalize Dsqfb, & convert to logarithm
+!
+! *** Normalize Dsqfb, & convert to logarithm
DO Jth=1,multScat%getNumTheta()
DO Ksig=1,Nxtptw
Bb = Aa
@@ -105,10 +105,10 @@ C *** Normalize Dsqfb, & convert to logarithm
END DO
END DO
END DO
-C
-C *** Write results onto file 25 to be read later in SAMSSM
- N = Max0(Nxtptv+9, multScat%getNumTheta(),
- * Nxtptv*Nxtptv*multScat%getNumTheta())
+!
+! *** Write results onto file 25 to be read later in SAMSSM
+ N = Max0(Nxtptv+9, multScat%getNumTheta(), &
+ Nxtptv*Nxtptv*multScat%getNumTheta())
CALL Newopn (25, Fqqqqq, 1)
WRITE (25) multScat%getNumTheta(), Nzzz, Nxtptv, Nxtptw
WRITE (25) Rs, Rb, Sthick, Dthick, Dnsty, A1, B1, Costh1, Area
@@ -117,6 +117,7 @@ C *** Write results onto file 25 to be read later in SAMSSM
WRITE (25) Sqfb
WRITE (25) Dsqfb
CLOSE (UNIT=25)
-C
+!
RETURN
END
+end module par19_m
\ No newline at end of file
diff --git a/sammy/src/ref/mcon.F b/sammy/src/ref/mcon.F
index dfbffb0b4..3927cfc9f 100644
--- a/sammy/src/ref/mcon.F
+++ b/sammy/src/ref/mcon.F
@@ -22,6 +22,7 @@ C These are here to replace the common block
use Observable_common_m
C this is not a common block, this contains functions
use mold4_m
+ use par_m
IMPLICIT DOUBLE PRECISION (A-h,o-z)
CHARACTER*10 Samlpt
C
diff --git a/sammy/src/rpi/mrpi0.f b/sammy/src/rpi/mrpi0.f90
similarity index 69%
rename from sammy/src/rpi/mrpi0.f
rename to sammy/src/rpi/mrpi0.f90
index 7bc484d84..5eb4fb943 100644
--- a/sammy/src/rpi/mrpi0.f
+++ b/sammy/src/rpi/mrpi0.f90
@@ -1,8 +1,10 @@
-C
-C
-C
+!
+module rpi_m
+ contains
+!
+!
SUBROUTINE Samrpi_0
-C
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -14,47 +16,48 @@ C
use lbro_common_m
use EndfData_common_m
use AllocateFunctions_m
+ use rpi1_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
real(kind=8),allocatable,dimension(:)::A_Iweigh, A_Iwts, A_Iwtsx
real(kind=8),allocatable,dimension(:)::A_Ix1, A_Ix2, A_Ix21
real(kind=8),allocatable,dimension(:)::A_Idexrp, A_Ixxxrp
-C
-C
+!
+!
WRITE (6,99999)
99999 FORMAT (' *** SAMMY-RPI 15 Nov 07 ***')
Segmen(1) = 'R'
Segmen(2) = 'P'
Segmen(3) = 'I'
Nowwww = 0
-C
+!
CALL Initix
IF (Kplotu.NE.0) Kplotu = 0
-C
+!
Niniso = 1
Kdatb = Ndatmx
-C
-C *** Guesstimate size of array needed for Samrpi
+!
+! *** Guesstimate size of array needed for Samrpi
CALL Estrpi (Kdatb, Npnts)
-C
-C
+!
+!
call setAuxGridOffset(Ndatmn)
-C
-C
+!
+!
CALL Set_Kws
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
call allocate_real_data(A_Iweigh, Kdatb)
-C
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
+!
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
call allocate_real_data(A_Ix1, Kdatb)
call allocate_real_data(A_Ix2 ,Kdatb)
call allocate_real_data(A_Ix21, Kdatb)
-C *** Xcoef generates coefficients (Weight) to be used in broadening
+! *** Xcoef generates coefficients (Weight) to be used in broadening
CALL Xcoef (A_Iweigh, A_Ix1, A_Ix2, A_Ix21, Kdatb)
deallocate(A_Ix1)
deallocate(A_Ix2)
deallocate(A_Ix21)
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
-C
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
+!
N = Npnts
call allocate_real_data(A_Iwtsx, N)
call allocate_real_data(A_Iwts, N)
@@ -74,27 +77,27 @@ C
Kmmrpi = 8
END IF
call allocate_real_data(A_Ixxxrp, N)
-C
-C *** Rpirsl performs resolution-broadening operation
- CALL Rpirsl (I_Iflmsc , A_Icrnch , A_Iprrpi , I_Iflrpi ,
- * A_Iprnbk , I_Iflnbk , A_Iprbgf , I_Iflbgf , I_Indbgf ,
- * A_Ibgfmi , A_Ibgfma , A_Itexbg , A_Iteabg ,
- * A_Ith ,
- * A_Iwsigx , A_Iwdasi , A_Iwdbsi , A_Isigxx , A_Idasig ,
- * A_Idbsig , A_Ivsigx , A_Ivdasi , A_Ivdbsi , A_Iweigh,
- * A_Iwtsx , A_Iwts , A_Idexrp , A_Ixxxrp)
-C
-C
+!
+! *** Rpirsl performs resolution-broadening operation
+ CALL Rpirsl (I_Iflmsc , A_Icrnch , A_Iprrpi , I_Iflrpi , &
+ A_Iprnbk , I_Iflnbk , A_Iprbgf , I_Iflbgf , I_Indbgf , &
+ A_Ibgfmi , A_Ibgfma , A_Itexbg , A_Iteabg , &
+ A_Ith , &
+ A_Iwsigx , A_Iwdasi , A_Iwdbsi , A_Isigxx , A_Idasig , &
+ A_Idbsig , A_Ivsigx , A_Ivdasi , A_Ivdbsi , A_Iweigh, &
+ A_Iwtsx , A_Iwts , A_Idexrp , A_Ixxxrp)
+!
+!
deallocate(A_Iweigh)
deallocate(A_Iwtsx)
deallocate(A_Iwts)
deallocate(A_Idexrp)
deallocate(A_Ixxxrp)
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
-C
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
+!
Jwwwww = 4
Segnam = 'sambrd'
-C
+!
Jjjdop = 0
CALL Write_Commons_Many
IF (Segnam.EQ.'sambrd') THEN
@@ -106,26 +109,26 @@ C
END IF
call setAuxGridOffset(1) ! reset aux grid offset
RETURN
-C
+!
END
-C
-C
-C _______________________________________________________________
-C
+!
+!
+! _______________________________________________________________
+!
SUBROUTINE Estrpi (Kdatb, Npnts)
-C
-C *** PURPOSE -- guesstimate size of array needed for SAMRPI
-C
+!
+! *** PURPOSE -- guesstimate size of array needed for SAMRPI
+!
use fixedi_m
use ifwrit_m
use array_sizes_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
IF (Kwatta.EQ.0) Kwatta = 2
K = Kdatb
-C
+!
K1 = 3*Kdatb
-C
+!
Npnts = Kdatb
N = Numrpi
K = K + K1
@@ -134,3 +137,5 @@ C
I = Idimen (0, 0, '0, 0')
RETURN
END
+
+end module rpi_m
diff --git a/sammy/src/rpi/mrpi1.f b/sammy/src/rpi/mrpi1.f
deleted file mode 100644
index 1b318ab6d..000000000
--- a/sammy/src/rpi/mrpi1.f
+++ /dev/null
@@ -1,208 +0,0 @@
-
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Rpirsl (Iflmsc, Ecrnch, Parrpi, Iflrpi, Parnbk, Iflnbk,
- * Parbgf, Iflbgf, Kndbgf, Bgfmin, Bgfmax, Texbgf, Teabgf,
- * Theory, Wsigxx, Wdasig, Wdbsig, Sigxxx, Dasigx, Dbsigx,
- * Vsigxx, Vdasig, Vdbsig, Weight, Wtsx, Wts, Edxrpi, Xxxrpi)
-C
-C *** PURPOSE -- Form resolution-broadened cross section and derivatives
-C *** using RPI resolution function
-C
- use fixedi_m
- use ifwrit_m
- use samxxx_common_m
- use fixedr_m
- use broad_common_m
- use brdd_common_m
- use rpijnk_common_m
- use rpires_common_m
- use rpirrr_common_m
- use lbro_common_m
- use mxct27_m
- use EndfData_common_m
- use SammyGridAccess_M
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- type(SammyGridAccess)::grid
- DIMENSION Iflmsc(*), Ecrnch(*), Parrpi(*), Iflrpi(*),
- * Parnbk(*), Iflnbk(*), Parbgf(*), Iflbgf(*), Kndbgf(*),
- * Bgfmin(*), Bgfmax(*), Texbgf(*), Teabgf(*),
- * Theory(*),
- * Wsigxx(Nnnsig,*), Wdasig(Nnnsig,Ndaxxx,*),
- * Wdbsig(Nnnsig,Ndbxxx,*), Sigxxx(*), Dasigx(Nnnsig,*),
- * Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*), Vdasig(Nnnsig,Ndaxxx,*),
- * Vdbsig(Nnnsig,Ndbxxx,*), Weight(*), Wtsx(*), Wts(*),
- * Edxrpi(Kxxrpi,*), Xxxrpi(Kmmrpi,*)
-C DIMENSION Iflmsc(Nummsc), Ecrnch(Numrpi-Nnnrpi),
-C * Parrpi(Numrpi), Iflrpi(Numrpi), Parnbk(Numnbk), Iflnbk(Numnbk),
-C * Parbgf(Numbgf), Iflbgf(*), Kndbgf(*), Bgfmin(*), Bgfmax(*),
-C * Theory(Kdat*Numcro),
-C * Wsigxx(.,Kdat), Wdasig(.,.,Kdat),
-C * Wdbsig(.,.,Kdat), Sigxxx(Nnnsig), Dasigx(.,Npar),
-C * Dbsigx(.,Npar), Vsigxx(.,?dat), Vdasig(.,.,?dat),
-C * Vdbsig(.,.,?dat), Weight(Kdatb), Wtsx(Npnts), Wts(Npnts),
-C * Edxrpi(7,Medrpi/7), Xxxrpi(12,Mmmrpi/8=Lother)
-C
-C
- call grid%initialize()
- call grid%setParameters(numcro, ktzero)
- call grid%setToExpGrid(expData)
-
- Iwarn = 0
- Iff_Wts = 0
- Jgbmax = 0
- CALL Read_Cross_Sections (Jgbmax, Kdatb)
-C Note that auxillary energy grid is not re-set in this routine (since Ifff=0)
-C Also that Sigxxx is used as dummy
-C
- CALL Zero_Cross_Sections (Theory, Wsigxx, Wdasig, Wdbsig, Sigxxx,
- * Sigxxx, Sigxxx, Kdat, Kdat, 0)
-C
-C *** Generate non-energy-dependent pieces of parameters
- CALL Gen_Rpi_E_Independent (Parrpi, Iflrpi, Edxrpi, Xxxrpi,
- * Binpdx, 0)
-C
-C *** Initialize limits
- Kc = 2
- Iup = 1
- Ipk = 1
-C
- Itime = 0
- Minrpi = Nnnrpi + 1
- Now = 0
- Mndets = 1
-C *** Begin loop over [experimental] energies
- DO J=1,Kdat
- Jwhich = J
- Em = grid%getEnergy(J, expData)
- IF ((J/10000)*10000.EQ.J) WRITE (6,10001) J
-10001 FORMAT (' *** on data point number', I10)
-C
- CALL Zero_Array (Sigxxx, Nnnsig)
- IF (Ndasig.GT.0) CALL Zero_Array (Dasigx, Nnnsig*Ndasig)
- IF (Ndbsig.GT.0) CALL Zero_Array (Dbsigx, Nnnsig*Ndbsig)
-C
-C ****** Generate parameters for energy Em, and find Elow and Eup
- CALL Gen_Rpi_E_Dependent (Em, Elow, Eup, Parrpi, Ecrnch,
- * Edxrpi, Xxxrpi, Binpdx, Minrpi, Itime)
-C
-C ****** Find number of points Ipnts
- CALL Kount_Points (Elow, Eup, Em)
- IF (Ipnts.GT.Npnts) GO TO 60
-C
- IF (Ipnts.LE.5) THEN
-C
-C ********* No integration possible
- IF (Jjjdop.NE.1) THEN
- CALL Stetr (Sigxxx, Dasigx, Dbsigx, Vsigxx, Vdasig,
- * Vdbsig, Now)
- ELSE
- Igbpk = Ipk - 1
- Ienpk = Ipk - 1
- IF (Igbpk.LE.0) Ienpk = Ipk
- IF (Igbpk.EQ.0) Igbpk = 1
- IF (Ipk.EQ.Kdatb) Igbpk = Igbpk - 1
- IF (Ipk.EQ.Kdatb) Ienpk = Ienpk - 1
- CALL Intrp (Sigxxx, Dasigx, Dbsigx, Vsigxx, Vdasig,
- * Vdbsig, Em, Now, Ienpk)
- END IF
-C
- ELSE
-C
-C ********* Integrate
- CALL Rpi_Broadened (Wts, Weight, Sigxxx, Dasigx,
- * Dbsigx, Vsigxx, Vdasig, Vdbsig, Em, Parrpi, Iflrpi,
- * Ecrnch, Wts_Norm)
- IF (Ksolve.NE.2 .AND. Nfprpi.GT.0) THEN
- CALL Der_Wrt_Rpi (Wtsx, Wts, Weight, Sigxxx,
- * Dbsigx, Vsigxx, Em, Parrpi, Iflrpi, Ecrnch, Wts_Norm)
- END IF
-C
- END IF
-C
-C
- IF (Rpideb) THEN
- WRITE (8,10100) Em, Sigxxx(1)
-10100 FORMAT (1P2G20.10)
- Max_Rpideb = 7
- IF (Max_Rpideb.GT.Ndasig) Max_Rpideb = Ndasig
- WRITE (11,10200) Em, (Dasigx(1,I),I=1,Max_Rpideb)
-10200 FORMAT (F11.6, 1P7G11.3)
- END IF
-C
-C ****** Convert back to cross sections if needed
- IF (Ytotrs) THEN
- IF (Sigxxx(1).EQ.0.0d0) Iwarn = 1
- CALL Cnvrt (Sigxxx, Dasigx, Dbsigx)
- END IF
-C
-C ****** If there is normalization or background, include it
- IF (Ynrmbk) THEN
- IF (Numnbk.GT.0) CALL Norm (Parnbk, Iflnbk, Sigxxx, Dasigx,
- * Dbsigx, Em, Nnnsig)
- IF (Numbgf.GT.0) CALL Bgfrpi (Parbgf, Iflbgf, Kndbgf,
- * Bgfmin, Bgfmax, Texbgf, Teabgf, Sigxxx, Dbsigx, Em,
- * Nnnsig)
- END IF
-C
-C
-cxC ****** Convert to eta
-cx IF (Kcros.EQ.6) CALL Nnneta (Iflmsc, Sigxxx, Dbsigx, Nnnsig, 1)
-C
-C ****** Organize stuff for file 48, if needed
- Jcro = (J-1)*Nnnsig
- DO I=1,Nnnsig
- Jcro = Jcro + 1
- Theory(Jcro) = Sigxxx(I)
- END DO
-C
- Call Store_W (Wsigxx, Wdasig, Wdbsig, Sigxxx, Dasigx, Dbsigx,
- * Nnnsig, Nnniso, J)
- END DO
-C *** End of experimental-energy loop
-C
-C
-C *** If (debugging for partial derivatives) then stop here
-C *** (This is for writing cross sections into binary files that
-C *** can then be used to calculate numerical derivatives)
- IF (Rpideb) THEN
- DO J=1,Kdat
- WRITE (88) grid%getEnergy(J, expData), Wsigxx(1,J)
- WRITE (89) grid%getEnergy(J, expData),
- * (Wdbsig(1,I,J),I=1,Ndbsig)
- END DO
- CLOSE (Unit=88)
- CLOSE (Unit=89)
- STOP '[Stop in Rpirsl in rpi/mrpi1.f]'
- END IF
-C
-C
- IF (Now.NE.0) WRITE (21,99998) Now, Kdat
- IF (Now.NE.0 .AND. Kdebug.NE.0) WRITE (06,99998) Now, Kdat
-99998 FORMAT (' No resolution broadening occurred for ', I5,
- * ' points out of a possible', I8)
-C
- IF (Iwarn.EQ.1) THEN
- WRITE (6,10300)
- WRITE (21,10300)
-10300 FORMAT (
- */,' ############################################################',
- */,' ### ###',
- */,' ### WARNING: You are fitting total cross section in a ###',
- */,' ### situation where there are blacking-out resonances. ###',
- */,' ### This will cause serious numerical problems. ###',
- */,' ### ###',
- */,' ### RECOMMENDATION: Fit transmission data instead. ###',
- */,' ### ###',
- */,' ############################################################',
- */)
- END IF
- call grid%destroy()
- RETURN
-C
- 60 WRITE (6,99999) Npnts, Ipnts
-99999 FORMAT (' Npnts in file mrpi1 is', I5, ' but wants', I5)
- STOP '[Stop in Rpirsl in rpi/mrpi1.f # 2]'
- END
diff --git a/sammy/src/rpi/mrpi1.f90 b/sammy/src/rpi/mrpi1.f90
new file mode 100644
index 000000000..e8eeb9c34
--- /dev/null
+++ b/sammy/src/rpi/mrpi1.f90
@@ -0,0 +1,212 @@
+module rpi1_m
+ contains
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Rpirsl (Iflmsc, Ecrnch, Parrpi, Iflrpi, Parnbk, Iflnbk, &
+ Parbgf, Iflbgf, Kndbgf, Bgfmin, Bgfmax, Texbgf, Teabgf, &
+ Theory, Wsigxx, Wdasig, Wdbsig, Sigxxx, Dasigx, Dbsigx, &
+ Vsigxx, Vdasig, Vdbsig, Weight, Wtsx, Wts, Edxrpi, Xxxrpi)
+!
+! *** PURPOSE -- Form resolution-broadened cross section and derivatives
+! *** using RPI resolution function
+!
+ use fixedi_m
+ use ifwrit_m
+ use samxxx_common_m
+ use fixedr_m
+ use broad_common_m
+ use brdd_common_m
+ use rpijnk_common_m
+ use rpires_common_m
+ use rpirrr_common_m
+ use lbro_common_m
+ use mxct27_m
+ use rpi2_m
+ use rpi3_m
+ use rpi4_m
+ use rpi7_m
+ use EndfData_common_m
+ use SammyGridAccess_M
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+!
+ type(SammyGridAccess)::grid
+ DIMENSION Iflmsc(*), Ecrnch(*), Parrpi(*), Iflrpi(*), &
+ Parnbk(*), Iflnbk(*), Parbgf(*), Iflbgf(*), Kndbgf(*), &
+ Bgfmin(*), Bgfmax(*), Texbgf(*), Teabgf(*), &
+ Theory(*), &
+ Wsigxx(Nnnsig,*), Wdasig(Nnnsig,Ndaxxx,*), &
+ Wdbsig(Nnnsig,Ndbxxx,*), Sigxxx(*), Dasigx(Nnnsig,*), &
+ Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*), Vdasig(Nnnsig,Ndaxxx,*), &
+ Vdbsig(Nnnsig,Ndbxxx,*), Weight(*), Wtsx(*), Wts(*), &
+ Edxrpi(Kxxrpi,*), Xxxrpi(Kmmrpi,*)
+! DIMENSION Iflmsc(Nummsc), Ecrnch(Numrpi-Nnnrpi),
+! * Parrpi(Numrpi), Iflrpi(Numrpi), Parnbk(Numnbk), Iflnbk(Numnbk),
+! * Parbgf(Numbgf), Iflbgf(*), Kndbgf(*), Bgfmin(*), Bgfmax(*),
+! * Theory(Kdat*Numcro),
+! * Wsigxx(.,Kdat), Wdasig(.,.,Kdat),
+! * Wdbsig(.,.,Kdat), Sigxxx(Nnnsig), Dasigx(.,Npar),
+! * Dbsigx(.,Npar), Vsigxx(.,?dat), Vdasig(.,.,?dat),
+! * Vdbsig(.,.,?dat), Weight(Kdatb), Wtsx(Npnts), Wts(Npnts),
+! * Edxrpi(7,Medrpi/7), Xxxrpi(12,Mmmrpi/8=Lother)
+!
+!
+ call grid%initialize()
+ call grid%setParameters(numcro, ktzero)
+ call grid%setToExpGrid(expData)
+
+ Iwarn = 0
+ Iff_Wts = 0
+ Jgbmax = 0
+ CALL Read_Cross_Sections (Jgbmax, Kdatb)
+! Note that auxillary energy grid is not re-set in this routine (since Ifff=0)
+! Also that Sigxxx is used as dummy
+!
+ CALL Zero_Cross_Sections (Theory, Wsigxx, Wdasig, Wdbsig, Sigxxx, &
+ Sigxxx, Sigxxx, Kdat, Kdat, 0)
+!
+! *** Generate non-energy-dependent pieces of parameters
+ CALL Gen_Rpi_E_Independent (Parrpi, Iflrpi, Edxrpi, Xxxrpi, Binpdx, 0)
+!
+! *** Initialize limits
+ Kc = 2
+ Iup = 1
+ Ipk = 1
+!
+ Itime = 0
+ Minrpi = Nnnrpi + 1
+ Now = 0
+ Mndets = 1
+! *** Begin loop over [experimental] energies
+ DO J=1,Kdat
+ Jwhich = J
+ Em = grid%getEnergy(J, expData)
+ IF ((J/10000)*10000.EQ.J) WRITE (6,10001) J
+10001 FORMAT (' *** on data point number', I10)
+!
+ CALL Zero_Array (Sigxxx, Nnnsig)
+ IF (Ndasig.GT.0) CALL Zero_Array (Dasigx, Nnnsig*Ndasig)
+ IF (Ndbsig.GT.0) CALL Zero_Array (Dbsigx, Nnnsig*Ndbsig)
+!
+! ****** Generate parameters for energy Em, and find Elow and Eup
+ CALL Gen_Rpi_E_Dependent (Em, Elow, Eup, Parrpi, Ecrnch, &
+ Edxrpi, Xxxrpi, Binpdx, Minrpi, Itime)
+!
+! ****** Find number of points Ipnts
+ CALL Kount_Points (Elow, Eup, Em)
+ IF (Ipnts.GT.Npnts) GO TO 60
+!
+ IF (Ipnts.LE.5) THEN
+!
+! ********* No integration possible
+ IF (Jjjdop.NE.1) THEN
+ CALL Stetr (Sigxxx, Dasigx, Dbsigx, Vsigxx, Vdasig, Vdbsig, Now)
+ ELSE
+ Igbpk = Ipk - 1
+ Ienpk = Ipk - 1
+ IF (Igbpk.LE.0) Ienpk = Ipk
+ IF (Igbpk.EQ.0) Igbpk = 1
+ IF (Ipk.EQ.Kdatb) Igbpk = Igbpk - 1
+ IF (Ipk.EQ.Kdatb) Ienpk = Ienpk - 1
+ CALL Intrp (Sigxxx, Dasigx, Dbsigx, Vsigxx, Vdasig, &
+ Vdbsig, Em, Now, Ienpk)
+ END IF
+!
+ ELSE
+!
+! ********* Integrate
+ CALL Rpi_Broadened (Wts, Weight, Sigxxx, Dasigx, &
+ Dbsigx, Vsigxx, Vdasig, Vdbsig, Em, Parrpi, Iflrpi, &
+ Ecrnch, Wts_Norm)
+ IF (Ksolve.NE.2 .AND. Nfprpi.GT.0) THEN
+ CALL Der_Wrt_Rpi (Wtsx, Wts, Weight, Sigxxx, &
+ Dbsigx, Vsigxx, Em, Parrpi, Iflrpi, Ecrnch, Wts_Norm)
+ END IF
+!
+ END IF
+!
+!
+ IF (Rpideb) THEN
+ WRITE (8,10100) Em, Sigxxx(1)
+10100 FORMAT (1P2G20.10)
+ Max_Rpideb = 7
+ IF (Max_Rpideb.GT.Ndasig) Max_Rpideb = Ndasig
+ WRITE (11,10200) Em, (Dasigx(1,I),I=1,Max_Rpideb)
+10200 FORMAT (F11.6, 1P7G11.3)
+ END IF
+!
+! ****** Convert back to cross sections if needed
+ IF (Ytotrs) THEN
+ IF (Sigxxx(1).EQ.0.0d0) Iwarn = 1
+ CALL Cnvrt (Sigxxx, Dasigx, Dbsigx)
+ END IF
+!
+! ****** If there is normalization or background, include it
+ IF (Ynrmbk) THEN
+ IF (Numnbk.GT.0) CALL Norm (Parnbk, Iflnbk, Sigxxx, Dasigx, &
+ Dbsigx, Em, Nnnsig)
+ IF (Numbgf.GT.0) CALL Bgfrpi (Parbgf, Iflbgf, Kndbgf, &
+ Bgfmin, Bgfmax, Texbgf, Teabgf, Sigxxx, Dbsigx, Em, &
+ Nnnsig)
+ END IF
+!
+!
+!x! ****** Convert to eta
+!x IF (Kcros.EQ.6) CALL Nnneta (Iflmsc, Sigxxx, Dbsigx, Nnnsig, 1)
+!
+! ****** Organize stuff for file 48, if needed
+ Jcro = (J-1)*Nnnsig
+ DO I=1,Nnnsig
+ Jcro = Jcro + 1
+ Theory(Jcro) = Sigxxx(I)
+ END DO
+!
+ Call Store_W (Wsigxx, Wdasig, Wdbsig, Sigxxx, Dasigx, Dbsigx, &
+ Nnnsig, Nnniso, J)
+ END DO
+! *** End of experimental-energy loop
+!
+!
+! *** If (debugging for partial derivatives) then stop here
+! *** (This is for writing cross sections into binary files that
+! *** can then be used to calculate numerical derivatives)
+ IF (Rpideb) THEN
+ DO J=1,Kdat
+ WRITE (88) grid%getEnergy(J, expData), Wsigxx(1,J)
+ WRITE (89) grid%getEnergy(J, expData), (Wdbsig(1,I,J),I=1,Ndbsig)
+ END DO
+ CLOSE (Unit=88)
+ CLOSE (Unit=89)
+ STOP '[Stop in Rpirsl in rpi/mrpi1.f]'
+ END IF
+!
+!
+ IF (Now.NE.0) WRITE (21,99998) Now, Kdat
+ IF (Now.NE.0 .AND. Kdebug.NE.0) WRITE (06,99998) Now, Kdat
+99998 FORMAT (' No resolution broadening occurred for ', I5, &
+ ' points out of a possible', I8)
+!
+ IF (Iwarn.EQ.1) THEN
+ WRITE (6,10300)
+ WRITE (21,10300)
+10300 FORMAT ( &
+ /,' ############################################################', &
+ /,' ### ###', &
+ /,' ### WARNING: You are fitting total cross section in a ###', &
+ /,' ### situation where there are blacking-out resonances. ###', &
+ /,' ### This will cause serious numerical problems. ###', &
+ /,' ### ###', &
+ /,' ### RECOMMENDATION: Fit transmission data instead. ###', &
+ /,' ### ###', &
+ /,' ############################################################', &
+ /)
+ END IF
+ call grid%destroy()
+ RETURN
+!
+ 60 WRITE (6,99999) Npnts, Ipnts
+99999 FORMAT (' Npnts in file mrpi1 is', I5, ' but wants', I5)
+ STOP '[Stop in Rpirsl in rpi/mrpi1.f # 2]'
+ END
+
+end module rpi1_m
diff --git a/sammy/src/rpi/mrpi2.f b/sammy/src/rpi/mrpi2.f90
similarity index 89%
rename from sammy/src/rpi/mrpi2.f
rename to sammy/src/rpi/mrpi2.f90
index 7a13641bb..c0b97aba8 100644
--- a/sammy/src/rpi/mrpi2.f
+++ b/sammy/src/rpi/mrpi2.f90
@@ -1,14 +1,16 @@
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Gen_Rpi_E_Independent (Parrpi, Iflrpi, Edxrpi,
- * Xxxrpi, Binpdx, Iff)
-C
-C *** Purpose -- Generate energy-independent pieces of resolution
-C *** parameters, and pieces relevant to partial
-C *** wrt (with respect to) those derivatives
-C
+!
+module rpi2_m
+ contains
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Gen_Rpi_E_Independent (Parrpi, Iflrpi, Edxrpi, &
+ Xxxrpi, Binpdx, Iff)
+!
+! *** Purpose -- Generate energy-independent pieces of resolution
+! *** parameters, and pieces relevant to partial
+! *** wrt (with respect to) those derivatives
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -17,37 +19,37 @@ C
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION Parrpi(*), Iflrpi(*), Edxrpi(Kxxrpi,*), Xxxrpi(Kmmrpi,*)
-C
+!
DATA S4ln2 /1.6651092223153954d0/
-C Square root of (4*ln(2)) = Conversion from fwhm to width of Gaussian
+! Square root of (4*ln(2)) = Conversion from fwhm to width of Gaussian
DATA Zero /0.0d0/, Thous /1000.0d0/
-C
+!
IF (Iff.EQ.0) THEN
-C Ddeell = 0.05d0
-C Ddeell = 0.02d0
+! Ddeell = 0.05d0
+! Ddeell = 0.02d0
Ddeell = 0.01d0
-C*** Ppp
+!*** Ppp
Ddeelx(1) = Ddeell*0.1d0
-C*** Tau
+!*** Tau
DO I=2,8
Ddeelx(I) = Ddeell*0.1d0
END DO
-C*** Lambda
+!*** Lambda
DO I=9,13
Ddeelx(I) = Ddeell*0.1d0
END DO
-C*** A1
+!*** A1
DO I=14,20
Ddeelx(I) = Ddeell
END DO
-C*** Tz
+!*** Tz
Ddeelx(21)= Ddeell*0.01d0
-C*** A2,A3,A4,A5
+!*** A2,A3,A4,A5
DO I=22,25
Ddeelx(I) = Ddeell*0.1d0
END DO
END IF
-C
+!
Taua = Zero
Taub = Zero
Tauc = Zero
@@ -84,28 +86,28 @@ C
Iffa1 = 0
Iffa3 = 0
Iffa5 = 0
-C
-C
-C ### (1) Electron Burst, Gaussian, no energy-dependence
-C *** This Ppp assumes input in nanoseconds but work in microseconds
+!
+!
+! ### (1) Electron Burst, Gaussian, no energy-dependence
+! *** This Ppp assumes input in nanoseconds but work in microseconds
Ppp = Parrpi(1)/Thous
IF (Ppp.NE.Zero) THEN
Www = S4ln2/Ppp
-C Sqrt( 4 ln 2 ) / Ppp = Convert from fwhm to 1/width
+! Sqrt( 4 ln 2 ) / Ppp = Convert from fwhm to 1/width
ELSE
Www = Zero
END IF
IF (Numrpi.EQ.1) RETURN
-C
-C ### (2) Chi-squared plus two exponentials
-C ### -- may represent RPI "bounce target" & transmission detector
-C ### -- may represent Geel or nTOF resolution functions
-C
+!
+! ### (2) Chi-squared plus two exponentials
+! ### -- may represent RPI "bounce target" & transmission detector
+! ### -- may represent Geel or nTOF resolution functions
+!
IF (If_Rpi_Chi.NE.0) THEN
-C *** (a) Chi-square distribution with 2(m+1)-degrees of freedom with
-C *** m = 2
-C *** Tau = Time-displacement
+! *** (a) Chi-square distribution with 2(m+1)-degrees of freedom with
+! *** m = 2
+! *** Tau = Time-displacement
Taua = Parrpi(2)/Thous
Taub = Parrpi(3)
Tauc = Parrpi(4)/Thous
@@ -113,19 +115,19 @@ C *** Tau = Time-displacement
Taue = Parrpi(6)/Thous
Tauf = Parrpi(7)/Thous
Taug = Parrpi(8)
-C Tau = Taua*dEXP(-Taub*Em) + Tauc*dEXP(-Taud*Em) + Taue +
-C Tauf*Em**Taug
+! Tau = Taua*dEXP(-Taub*Em) + Tauc*dEXP(-Taud*Em) + Taue +
+! Tauf*Em**Taug
DO I=2,8
IF (Iflrpi(I).NE.0) Iftau = 1
END DO
-C
-C *** LAMBDA = Chi-squared width
+!
+! *** LAMBDA = Chi-squared width
El0 = Parrpi( 9)/Thous
El1 = Parrpi(10)/Thous
El2 = Parrpi(11)/Thous
El3 = Parrpi(12)/Thous
El4 = Parrpi(13)
-C Aaa^{-1} = el0 + el1*ln(em) + el2*(ln(em))**2 + el3*Em**el4
+! Aaa^{-1} = el0 + el1*ln(em) + el2*(ln(em))**2 + el3*Em**el4
IF (Iff.EQ.0) THEN
DO I=9,13
IF (Iflrpi(I).NE.0) Ifaaa = 1
@@ -133,9 +135,9 @@ C Aaa^{-1} = el0 + el1*ln(em) + el2*(ln(em))**2 + el3*Em**el4
END IF
IF (Numrpi.LE.14) RETURN
END IF
-C
+!
IF (If_Rpi_Exp.NE.0) THEN
-C *** (b & c) Two exponentials; first, the multiplier A1
+! *** (b & c) Two exponentials; first, the multiplier A1
A1a = Parrpi(14)*Thous
A1b = Parrpi(15)
A1c = Parrpi(16)*Thous
@@ -143,46 +145,46 @@ C *** (b & c) Two exponentials; first, the multiplier A1
A1e = Parrpi(18)*Thous
A1f = Parrpi(19)*Thous
A1g = Parrpi(20)
-C A1 = A1a*dEXP(-A1b*Em) + A1c*dEXP(-A1d*Em) + A1e + A1f*Em**A1g
+! A1 = A1a*dEXP(-A1b*Em) + A1c*dEXP(-A1d*Em) + A1e + A1f*Em**A1g
DO I=14,20
IF (Iflrpi(I).NE.0) Iffa1 = 1
END DO
-C
-C *** Time shift tz
+!
+! *** Time shift tz
Tz = Parrpi(21)/Thous
-C
-C *** (b) "constants"
+!
+! *** (b) "constants"
A2 = Parrpi(22)
A2true = A2
A3 = Parrpi(23)*Thous
IF (Iflrpi(23).NE.0) Iffa3 = 1
-C *** (c) "constants"
+! *** (c) "constants"
A4 = Parrpi(24)
A4true = A4
A5 = Parrpi(25)*Thous
IF (Iflrpi(25).NE.0) Iffa5 = 1
-C *** (b) & (c) cutoff Time Tzmn
+! *** (b) & (c) cutoff Time Tzmn
Tzmn = Zero
T2b = Zero
T2c = Zero
Qqq = Zero
-C
+!
IF (Medrpi.EQ.0) THEN
-C *** figure T2b = <t>, Tzmn, and Qqq (= normalization) for the two
-C *** exponentials together
+! *** figure T2b = <t>, Tzmn, and Qqq (= normalization) for the two
+! *** exponentials together
IF (Midrpi.NE.0) THEN
-C *** Here center is to be shifted
+! *** Here center is to be shifted
CALL Gen_T2b (Iff)
ELSE
-C *** Here there is no shift
+! *** Here there is no shift
CALL Gen_T2b_0 (Iff)
END IF
-C
+!
ELSE IF (Medrpi.GT.0) THEN
-C *** energy-dependent versions of A3 & A5
-C *** so cannot figure the central shift because it changes with E
+! *** energy-dependent versions of A3 & A5
+! *** so cannot figure the central shift because it changes with E
Ledrpi = Medrpi/7
-C Ledrpi is at most 2
+! Ledrpi is at most 2
Ii = 25
DO LL=1,Ledrpi
Edxrpi(1,LL) = Parrpi(Ii+1)*Thous
@@ -202,8 +204,8 @@ C Ledrpi is at most 2
END DO
END IF
END IF
-C
-C *** "extra" exponentials
+!
+! *** "extra" exponentials
IF (Lother.GT.0) THEN
Ii = 25 + Medrpi
DO LL=1,Lother
@@ -218,23 +220,23 @@ C *** "extra" exponentials
Ii = Ii + 8
END DO
END IF
-C
+!
IF (Nbinpd.GT.0) THEN
Binpdx = dLOG(10.0d0)/dFLOAT(2*Nbinpd)
ELSE
Binpdx = Zero
END IF
-C
+!
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Gen_T2b (Iff)
-C
-C *** Purpose -- generate T2b & T2c
-C
+!
+! *** Purpose -- generate T2b & T2c
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -243,24 +245,24 @@ C
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Zero /0.0d0/, One /1.0d0/
-C
-C *** T2dell(k,j,i)
-C *** Meanings of i: 1=Tz, 2=A2, 3=A3, 4=A4, 5=A5
-C *** j: 1=T2b, 2=Qqq, 3=Tzmn
-C *** k: 1=>(1-Ddeell), 2=>(1+Ddeell)
+!
+! *** T2dell(k,j,i)
+! *** Meanings of i: 1=Tz, 2=A2, 3=A3, 4=A4, 5=A5
+! *** j: 1=T2b, 2=Qqq, 3=Tzmn
+! *** k: 1=>(1-Ddeell), 2=>(1+Ddeell)
IF (Iff.Eq.0) CALL Zero_Array (T2dell, 5*3*2)
A2 = A2true
A4 = A4true
-C
-C
-C *** figure T2b = <t>, Tzmn, and Qqq (= normalization) for the two
-C *** exponentials together
+!
+!
+! *** figure T2b = <t>, Tzmn, and Qqq (= normalization) for the two
+! *** exponentials together
T2b = Zero
T2c = Zero
Qqq = Zero
Tzmn= Zero
-C
-C *** First, A2>0, A4>0
+!
+! *** First, A2>0, A4>0
IF (A2.GT.Zero .AND. A4.GT.Zero) THEN
T2b = A2*(One/A3-Tz)/A3
T2c = A4*(One/A5-Tz)/A5
@@ -297,8 +299,8 @@ C *** First, A2>0, A4>0
T2dell(2,1,5) = A2*(One/A3-Tz)/A3 + A4*(One/Az-Tz)/Az
T2dell(2,2,5) = A2/A3 + A4/Az
END IF
-C
-C *** Next, A2=0, A4>0
+!
+! *** Next, A2=0, A4>0
ELSE IF (A2.EQ.Zero .AND. A4.GT.Zero) THEN
T2c = A4*(One/A5-Tz)/A5
Qqq = A4/A5
@@ -320,19 +322,19 @@ C *** Next, A2=0, A4>0
T2dell(2,1,5) = A4*(One/Az-Tz)/Az
T2dell(2,2,5) = A4/Az
END IF
-C
-C *** A2=0, A4<0 ==> wrong!
+!
+! *** A2=0, A4<0 ==> wrong!
ELSE IF (A2.EQ.Zero .AND. A4.LT.Zero) THEN
STOP '[Stop in Gen_T2b in rpi/mrpi2.f]'
-C
-C *** A2=0, A4=0 ==> don't do anything
+!
+! *** A2=0, A4=0 ==> don't do anything
ELSE IF (A2.EQ.Zero .AND. A4.EQ.Zero) THEN
-C
-C *** A2<0, A4<0 ==> wrong!
+!
+! *** A2<0, A4<0 ==> wrong!
ELSE IF (A2.LT.Zero .AND. A4.LT.Zero) THEN
STOP '[Stop in Gen_T2b in rpi/mrpi2.f # 2]'
-C
-C *** A2>0, A4=0 ==> OK
+!
+! *** A2>0, A4=0 ==> OK
ELSE IF (A2.GT.Zero .and. A4.EQ.Zero) THEN
T2b = A2*(One/A3-Tz)/A3
T2c = Zero
@@ -357,12 +359,12 @@ C *** A2>0, A4=0 ==> OK
T2dell(2,1,3) = A2*(One/Az-Tz)/Az
T2dell(2,2,3) = A2/Az
END IF
-C
-C *** A2<0, A4=0 ==> wrong
+!
+! *** A2<0, A4=0 ==> wrong
ELSE IF (A2.LT.Zero .AND. A4.EQ.Zero) THEN
STOP '[Stop in Gen_T2b in rpi/mrpi2.f # 3]'
-C
-C *** A2>0, A4<0 ==> check options
+!
+! *** A2>0, A4<0 ==> check options
ELSE IF (A2.GT.Zero .AND. A4.LT.Zero) THEN
IF (A5.LE.A3) THEN
IF (Medrpi.GT.0) THEN
@@ -376,15 +378,15 @@ C *** A2>0, A4<0 ==> check options
20100 FORMAT (' error in RPI A2-5 values')
WRITE (6,20150) A2, A3, A4, A5
WRITE (21,20150) A2, A3, A4, A5
-20150 FORMAT (' A2 =', 1PG14.6, ' A3 =', 1PG14.6, /,
- * ' A4 =', 1PG14.6, ' A5 =', 1PG14.6)
+20150 FORMAT (' A2 =', 1PG14.6, ' A3 =', 1PG14.6, /, &
+ ' A4 =', 1PG14.6, ' A5 =', 1PG14.6)
STOP '[Stop in Gen_T2b in rpi/mrpi2.f # 4]'
END IF
ELSE
Az = dLOG(-A4/A2)/(A5-A3)
IF (Az.GT.Zero) Tzmn = Az
END IF
-C *** A2>0, A4<0 and A5>A3
+! *** A2>0, A4<0 and A5>A3
IF (A3.NE.Zero) THEN
E3 = dEXP(-Tzmn*A3)
Oa3 = One/A3
@@ -558,8 +560,8 @@ C *** A2>0, A4<0 and A5>A3
T2dell(2,2,5) = E3*A2*Oa3 + E5*A4*Oaz
T2dell(2,3,5) = Bz
END IF
-C
-C *** A2<0, A4>0 ==> check options
+!
+! *** A2<0, A4>0 ==> check options
ELSE IF (A2.LT.Zero .AND. A4.GT.Zero) THEN
IF (A3.LE.A5) THEN
IF (Medrpi.GT.0) THEN
@@ -578,7 +580,7 @@ C *** A2<0, A4>0 ==> check options
Az = dLOG(-A2/A4)/(A3-A5)
IF (Az.GT.Zero) Tzmn = Az
END IF
-C *** A2<0, A4>0 and A3>A5
+! *** A2<0, A4>0 and A3>A5
E3 = dEXP(-Tzmn*A3)
E5 = dEXP(-Tzmn*A5)
T2b = E3*(One/A3+(Tzmn-Tz))*A2/A3
@@ -680,17 +682,17 @@ C *** A2<0, A4>0 and A3>A5
END IF
END IF
T2b = T2b + T2c
-C
+!
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Gen_T2b_0 (Iff)
-C
-C *** Purpose -- Generate Qqq, Tzmn, etc.
-C
+!
+! *** Purpose -- Generate Qqq, Tzmn, etc.
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -699,24 +701,24 @@ C
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DATA Zero /0.0d0/, One /1.0d0/
-C
-C *** T2dell(k,j,i)
-C *** Meanings of i: 1=tz, 2=A2, 3=A3, 4=A4, 5=A5
-C *** j: 1=t2b, 2=qqq, 3=Tzmn
-C *** k: 1=>(1-Ddeell), 2=>(1+Ddeell)
+!
+! *** T2dell(k,j,i)
+! *** Meanings of i: 1=tz, 2=A2, 3=A3, 4=A4, 5=A5
+! *** j: 1=t2b, 2=qqq, 3=Tzmn
+! *** k: 1=>(1-Ddeell), 2=>(1+Ddeell)
IF (Iff.Eq.0) CALL Zero_Array (T2dell, 5*3*2)
A2 = A2true
A4 = A4true
T2b = Zero
-C
-C
-C *** Figure Tzmn, and Qqq (= normalization) for the two
-C *** exponentials together
+!
+!
+! *** Figure Tzmn, and Qqq (= normalization) for the two
+! *** exponentials together
T2b = Zero
Qqq = Zero
Tzmn= Zero
-C
-C *** First, A2>0, A4>0
+!
+! *** First, A2>0, A4>0
IF (A2.GT.Zero .AND. A4.GT.Zero) THEN
Qqq = A2/A3 + A4/A5
IF (Iff.EQ.0 .AND. Ksolve.NE.2) THEN
@@ -739,8 +741,8 @@ C *** First, A2>0, A4>0
Az = A5*(One+Ddeelx(25))
T2dell(2,2,5) = A2/A3 + A4/Az
END IF
-C
-C *** Next, A2=0, A4>0
+!
+! *** Next, A2=0, A4>0
ELSE IF (A2.EQ.Zero .AND. A4.GT.Zero) THEN
Qqq = A4/A5
IF (Iff.EQ.0 .AND. Ksolve.NE.2) THEN
@@ -753,19 +755,19 @@ C *** Next, A2=0, A4>0
Az = A5*(One+Ddeelx(25))
T2dell(2,2,5) = A4/Az
END IF
-C
-C *** A2=0, A4<0 ==> wrong!
+!
+! *** A2=0, A4<0 ==> wrong!
ELSE IF (A2.EQ.Zero .AND. A4.LT.Zero) THEN
STOP '[Stop in Gen_T2b_0 in rpi/mrpi2.f]'
-C
-C *** A2=0, A4=0 ==> don't do anything
+!
+! *** A2=0, A4=0 ==> don't do anything
ELSE IF (A2.EQ.Zero .AND. A4.EQ.Zero) THEN
-C
-C *** A2<0, A4<0 ==> wrong!
+!
+! *** A2<0, A4<0 ==> wrong!
ELSE IF (A2.LT.Zero .AND. A4.LT.Zero) THEN
STOP '[Stop in Gen_T2b_0 in rpi/mrpi2.f # 2]'
-C
-C *** A2>0, A4=0 ==> OK
+!
+! *** A2>0, A4=0 ==> OK
ELSE IF (A2.GT.Zero .AND. A4.EQ.Zero) THEN
Qqq = A2/A3
IF (Iff.EQ.0 .AND. Ksolve.NE.2) THEN
@@ -780,12 +782,12 @@ C *** A2>0, A4=0 ==> OK
Az = A3*(One+Ddeelx(23))
T2dell(2,2,3) = A2/Az
END IF
-C
-C *** A2<0, A4=0 ==> wrong
+!
+! *** A2<0, A4=0 ==> wrong
ELSE IF (A2.LT.Zero .AND. A4.EQ.Zero) THEN
STOP '[Stop in Gen_T2b_0 in rpi/mrpi2.f # 3]'
-C
-C *** A2>0, A4<0 ==> check options
+!
+! *** A2>0, A4<0 ==> check options
ELSE IF (A2.GT.Zero .AND. A4.LT.Zero) THEN
IF (A5.LE.A3) THEN
IF (Medrpi.GT.0) THEN
@@ -806,7 +808,7 @@ C *** A2>0, A4<0 ==> check options
Az = dLOG(-A4/A2)/(A5-A3)
IF (Az.GT.Zero) Tzmn = Az
END IF
-C *** A2>0, A4<0 and A5>A3
+! *** A2>0, A4<0 and A5>A3
E3 = dEXP(-Tzmn*A3)
E5 = dEXP(-Tzmn*A5)
Qqq = E3*A2/A3 + E5*A4/A5
@@ -884,8 +886,8 @@ C *** A2>0, A4<0 and A5>A3
T2dell(2,2,5) = E3*A2/A3 + E5*A4/Az
T2dell(2,3,5) = Bz
END IF
-C
-C *** A2<0, A4>0 ==> check options
+!
+! *** A2<0, A4>0 ==> check options
ELSE IF (A2.LT.Zero .AND. A4.GT.Zero) THEN
IF (A3.LE.A5) THEN
WRITE (6,20100)
@@ -894,7 +896,7 @@ C *** A2<0, A4>0 ==> check options
Az = dLOG(-A2/A4)/(A3-A5)
IF (Az.GT.Zero) Tzmn = Az
END IF
-C *** A2<0, A4>0 and A3>A5
+! *** A2<0, A4>0 and A3>A5
E3 = dEXP(-Tzmn*A3)
E5 = dEXP(-Tzmn*A5)
Qqq = E3*A2/A3 + E5*A4/A5
@@ -973,6 +975,8 @@ C *** A2<0, A4>0 and A3>A5
T2dell(2,3,5) = Bz
END IF
END IF
-C
+!
RETURN
END
+
+end module rpi2_m
diff --git a/sammy/src/rpi/mrpi3.f b/sammy/src/rpi/mrpi3.f90
similarity index 58%
rename from sammy/src/rpi/mrpi3.f
rename to sammy/src/rpi/mrpi3.f90
index d74948c99..5f6727bf3 100644
--- a/sammy/src/rpi/mrpi3.f
+++ b/sammy/src/rpi/mrpi3.f90
@@ -1,70 +1,73 @@
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Gen_Rpi_E_Dependent (Em, Elow, Eup, Parrpi, Ecrnch,
- * Edxrpi, Xxxrpi, Binpdx, Min, Itime)
-C
-C *** PURPOSE -- Generate the various energy-dependent parameters of
-C *** the RPI resolution-broadening function
-C ***
-C *** Definitions of terms:
-C ***
-C *** Parrpi( 1) = Fwhm of Gaussian for electron burst
-C *** Parrpi( 2) = parameter a in definition of Tau(E) = shift for
-C *** Chi-square
-C *** Parrpi( 3) = b
-C *** Parrpi( 4) = c
-C *** Parrpi( 5) = d
-C *** Parrpi( 6) = e
-C *** Parrpi( 7) = f
-C *** Parrpi( 8) = g
-C *** Parrpi( 9) = parameter Lambda-0 in definition of chi-square width lambda
-C *** Parrpi(10) = 1
-C *** Parrpi(11) = 2
-C *** Parrpi(12) = 3
-C *** Parrpi(13) = 4
-C *** Parrpi(14) = parameter a in definition of A1
-C *** Parrpi(15) = b
-C *** Parrpi(16) = c
-C *** Parrpi(17) = d
-C *** Parrpi(18) = e
-C *** Parrpi(19) = f
-C *** Parrpi(20) = g
-C *** Parrpi(21) = tz = Tzero = t0
-C *** Parrpi(22) = A2 = multiplier for first exponential
-C *** Parrpi(23) = A3 = width for first exponential
-C *** Parrpi(24) = A4 = multiplier for second exponential
-C *** Parrpi(25) = A5 = width for second exponential
-C *** Parrpi(26 to 25+Medrpi) = For energy-dependent A3 and/or A5
-C *** Parrpi(26+Medrpi to Nnnrpi) = "Other" exponentials
-C *** Parrpi(Nnnrpi+1) = Channel width below Ecrnch(1)
-C *** Parrpi(Nnnrpi+2) = Channel width between Ecrnch(1) & Ecrnch(2)
-C *** Parrpi(Nnnrpi+3) = Channel width between Ecrnch(2) & Ecrnch(3)
-C *** ...
-C *** Parrpi(Numrpi) = Channel width between Ecrnch(Numrpi-[Nnnrpi+1]) &
-C *** Ecrnch(Numrpi-Nnnrpi)
-C
+!
+module rpi3_m
+ contains
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Gen_Rpi_E_Dependent (Em, Elow, Eup, Parrpi, Ecrnch, &
+ Edxrpi, Xxxrpi, Binpdx, Min, Itime)
+!
+! *** PURPOSE -- Generate the various energy-dependent parameters of
+! *** the RPI resolution-broadening function
+! ***
+! *** Definitions of terms:
+! ***
+! *** Parrpi( 1) = Fwhm of Gaussian for electron burst
+! *** Parrpi( 2) = parameter a in definition of Tau(E) = shift for
+! *** Chi-square
+! *** Parrpi( 3) = b
+! *** Parrpi( 4) = c
+! *** Parrpi( 5) = d
+! *** Parrpi( 6) = e
+! *** Parrpi( 7) = f
+! *** Parrpi( 8) = g
+! *** Parrpi( 9) = parameter Lambda-0 in definition of chi-square width lambda
+! *** Parrpi(10) = 1
+! *** Parrpi(11) = 2
+! *** Parrpi(12) = 3
+! *** Parrpi(13) = 4
+! *** Parrpi(14) = parameter a in definition of A1
+! *** Parrpi(15) = b
+! *** Parrpi(16) = c
+! *** Parrpi(17) = d
+! *** Parrpi(18) = e
+! *** Parrpi(19) = f
+! *** Parrpi(20) = g
+! *** Parrpi(21) = tz = Tzero = t0
+! *** Parrpi(22) = A2 = multiplier for first exponential
+! *** Parrpi(23) = A3 = width for first exponential
+! *** Parrpi(24) = A4 = multiplier for second exponential
+! *** Parrpi(25) = A5 = width for second exponential
+! *** Parrpi(26 to 25+Medrpi) = For energy-dependent A3 and/or A5
+! *** Parrpi(26+Medrpi to Nnnrpi) = "Other" exponentials
+! *** Parrpi(Nnnrpi+1) = Channel width below Ecrnch(1)
+! *** Parrpi(Nnnrpi+2) = Channel width between Ecrnch(1) & Ecrnch(2)
+! *** Parrpi(Nnnrpi+3) = Channel width between Ecrnch(2) & Ecrnch(3)
+! *** ...
+! *** Parrpi(Numrpi) = Channel width between Ecrnch(Numrpi-[Nnnrpi+1]) &
+! *** Ecrnch(Numrpi-Nnnrpi)
+!
use fixedi_m
use ifwrit_m
use fixedr_m
use rpijnk_common_m
use rpires_common_m
use rpirrr_common_m
+ use rpi2_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
DIMENSION Parrpi(*), Ecrnch(*), Edxrpi(Kxxrpi,*), Xxxrpi(Kmmrpi,*)
-C Parrpi(Numrpi), Ecrnch(Numrpi-Nnnrpi)
-C
+! Parrpi(Numrpi), Ecrnch(Numrpi-Nnnrpi)
+!
DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/, Thous /1000.0d0/
DATA Half /0.5D0/
-C
+!
IF (Nbinpd.GT.0) THEN
Binpdx = dLOG(10.0d0)/dFLOAT(2*Nbinpd)
ELSE
Binpdx = Zero
END IF
-C
+!
Emm = Em
Timem = Ttoe/dSQRT(Emm)
Xxxmax = Zero
@@ -72,8 +75,8 @@ C
Keb = 1
Ktd = 1
Kch = 1
-C
-C ### (1) Electron Burst, Gaussian, no energy-dependence
+!
+! ### (1) Electron Burst, Gaussian, no energy-dependence
IF (Parrpi(1).NE.Zero) Keb = 0
IF (Numrpi.EQ.1) THEN
Tau = Zero
@@ -82,27 +85,27 @@ C ### (1) Electron Burst, Gaussian, no energy-dependence
Ccc = Zero
GO TO 50
END IF
-C
-C
-C ### (2) RPI "bounce target" & transmission detector, a sum of
-C several terms
-C
+!
+!
+! ### (2) RPI "bounce target" & transmission detector, a sum of
+! several terms
+!
T2 = Zero
IF (If_Rpi_Chi.NE.0) THEN
-C
-C *** (2a) chi-square dstrbn with 2(m+1)-degrees of freedom with m=2
-C *** Tau = Time-displacement
- Tau = Taua*dEXP(-Taub*Emm) + Tauc*dEXP(-Taud*Emm) + Taue
- * + Tauf*Emm**Taug
-C
-C *** LAMBDA = Chi-squared width; Aaa = 1/LAMBDA eventually
+!
+! *** (2a) chi-square dstrbn with 2(m+1)-degrees of freedom with m=2
+! *** Tau = Time-displacement
+ Tau = Taua*dEXP(-Taub*Emm) + Tauc*dEXP(-Taud*Emm) + Taue &
+ + Tauf*Emm**Taug
+!
+! *** LAMBDA = Chi-squared width; Aaa = 1/LAMBDA eventually
Dl = dLOG(Emm)
Aaa = El0 + El1*Dl + El2*Dl**2 + El3*Emm**El4
T2a = Zero
IF (Aaa.GT.Zero) THEN
Aaa = One/Aaa
IF (Midrpi.NE.0) THEN
-C *** figure <t> for chi-square part alone when shifting center
+! *** figure <t> for chi-square part alone when shifting center
T2a = 3.0d0/Aaa - Tau
END IF
ELSE IF (Aaa.LT.Zero) THEN
@@ -112,37 +115,37 @@ C *** figure <t> for chi-square part alone when shifting center
T2a = Zero
END IF
END IF
-C
+!
IF (If_Rpi_Exp.NE.0) THEN
IF (Medrpi.EQ.0) THEN
-C *** T2b has already been figured (energy-independent)
+! *** T2b has already been figured (energy-independent)
ELSE
-C *** Figure T2b = <t>, Tzmn, and Qqq (= normalization) for the two
-C *** exponentials together; energy-dependent here
+! *** Figure T2b = <t>, Tzmn, and Qqq (= normalization) for the two
+! *** exponentials together; energy-dependent here
LL = 1
- A3 = Edxrpi(1,LL)*dEXP(-Edxrpi(2,LL)*Em) +
- * Edxrpi(3,LL)*dEXP(-Edxrpi(4,LL)*Em) + Edxrpi(5,LL) +
- * Edxrpi(6,LL)*Em**( Edxrpi(7,LL) )
+ A3 = Edxrpi(1,LL)*dEXP(-Edxrpi(2,LL)*Em) + &
+ Edxrpi(3,LL)*dEXP(-Edxrpi(4,LL)*Em) + Edxrpi(5,LL) + &
+ Edxrpi(6,LL)*Em**( Edxrpi(7,LL) )
IF (Parrpi(23).LT.Zero) A3 = A3*dSQRT(Em)
IF (Medrpi.GT.7) THEN
LL = 2
- A5 = Edxrpi(1,LL)*dEXP(-Edxrpi(2,LL)*Em) +
- * Edxrpi(3,LL)*dEXP(-Edxrpi(4,LL)*Em) + Edxrpi(5,LL) +
- * Edxrpi(6,LL)*Em**( Edxrpi(7,LL) )
+ A5 = Edxrpi(1,LL)*dEXP(-Edxrpi(2,LL)*Em) + &
+ Edxrpi(3,LL)*dEXP(-Edxrpi(4,LL)*Em) + Edxrpi(5,LL) + &
+ Edxrpi(6,LL)*Em**( Edxrpi(7,LL) )
IF (Parrpi(25).LT.Zero) A5 = A5*dSQRT(Em)
END IF
IF (Midrpi.NE.0) THEN
-C *** Here to shift the centroid (for E-dependent A3 & A5)
+! *** Here to shift the centroid (for E-dependent A3 & A5)
CALL Gen_T2b (0)
ELSE
-C *** Here to NOT shift the centroid (for E-dependent A3 & A5)
+! *** Here to NOT shift the centroid (for E-dependent A3 & A5)
CALL Gen_T2b_0 (0)
END IF
END IF
END IF
-C
-C
-C *** (2d) extra exponential terms
+!
+!
+! *** (2d) extra exponential terms
T2d = Zero
Q2d = Zero
Xxxmax = Zero
@@ -151,9 +154,9 @@ C *** (2d) extra exponential terms
Ktd = 0
DO LL=1,Lother
A6 = Xxxrpi(1,LL)
- A7 = Xxxrpi(2,LL)*dEXP(-Xxxrpi(3,LL)*Em) +
- * Xxxrpi(4,LL)*dEXP(-Xxxrpi(5,LL)*Em) + Xxxrpi(6,LL) +
- * Xxxrpi(7,LL)*Em**( Xxxrpi(8,LL) )
+ A7 = Xxxrpi(2,LL)*dEXP(-Xxxrpi(3,LL)*Em) + &
+ Xxxrpi(4,LL)*dEXP(-Xxxrpi(5,LL)*Em) + Xxxrpi(6,LL) + &
+ Xxxrpi(7,LL)*Em**( Xxxrpi(8,LL) )
A7x(LL) = A7
IF (A6.NE.Zero .AND. A7.NE.Zero) THEN
Ac6x(LL) = A6*Www/A7
@@ -169,14 +172,14 @@ C *** (2d) extra exponential terms
IF (Www.NE.Zero) THEN
TwoG7x(LL) = (A7/Www)*Half/Www
ELSE
-C TwoG7x(LL) = Zero but let's store A6 here instead
+! TwoG7x(LL) = Zero but let's store A6 here instead
TwoG7x(LL) = A6
END IF
END DO
END IF
-C
-C
-C *** (2b & 2c) Remember that Qqq is related to [ E3*A2/A3 + E5*A4/A5 ]
+!
+!
+! *** (2b & 2c) Remember that Qqq is related to [ E3*A2/A3 + E5*A4/A5 ]
IF (Qqq.EQ.Zero) THEN
A0 = Zero
A1 = Zero
@@ -193,9 +196,8 @@ C *** (2b & 2c) Remember that Qqq is related to [ E3*A2/A3 + E5*A4/A5 ]
T2 = ( T2a + T2d ) / A0
END IF
ELSE
-C *** (2b & 2c) Two exponentials
- A1 = A1a*dEXP(-A1b*Emm) + A1c*dEXP(-A1d*Emm) + A1e +
- * A1f*Emm**A1g
+! *** (2b & 2c) Two exponentials
+ A1 = A1a*dEXP(-A1b*Emm) + A1c*dEXP(-A1d*Emm) + A1e + A1f*Emm**A1g
IF (Aaa.NE.Zero) THEN
A0 = One + A1* Qqq + Q2d
ELSE
@@ -203,7 +205,7 @@ C *** (2b & 2c) Two exponentials
END IF
IF (Midrpi.NE.0) T2 = (T2a+A1*T2b+T2d)/A0
END IF
-C
+!
Ktd = 0
IF (Aaa.EQ.Zero) THEN
IF (A1.EQ.Zero) THEN
@@ -218,11 +220,11 @@ C
END IF
END IF
END IF
-C
-C
-C ### (3) Time-of-Flight Channel Width
-C *** (II.A.7) & (II.B.14) ***
-C *** find channel width CCC in microseconds for this energy Emm
+!
+!
+! ### (3) Time-of-Flight Channel Width
+! *** (II.A.7) & (II.B.14) ***
+! *** find channel width CCC in microseconds for this energy Emm
IF (Nbinpd.NE.0) THEN
Ccc = Binpdx*Timem
Kch = 0
@@ -244,20 +246,20 @@ C *** find channel width CCC in microseconds for this energy Emm
Ccc = Parrpi(Min)/Thous
Kch = 0
IF (Ccc.EQ.Zero) Kch = 1
-C
+!
IF (A0.EQ.Zero) A0 = One
-C ### end of generating pieces of resolution function
-C
+! ### end of generating pieces of resolution function
+!
50 CONTINUE
-C *** set flag for which of the pieces are to be used
-C *** Note that keb=0 means include burst width, e.g
-C Krpixx = 0 => b, t, c
-C = 1 => b
-C = 2 => t
-C = 3 => c
-C = 4 => b t
-C = 5 => b c
-C = 6 => t c
+! *** set flag for which of the pieces are to be used
+! *** Note that keb=0 means include burst width, e.g
+! Krpixx = 0 => b, t, c
+! = 1 => b
+! = 2 => t
+! = 3 => c
+! = 4 => b t
+! = 5 => b c
+! = 6 => t c
IF (Keb.EQ.0) THEN
IF (Ktd.EQ.0) THEN
IF (Kch.NE.0) THEN
@@ -286,45 +288,45 @@ C = 6 => t c
END IF
END IF
END IF
-C
-C
+!
+!
X2 = Zero
X3 = Zero
X4 = Zero
-C *** find Time Timej associated with this energy Emm
+! *** find Time Timej associated with this energy Emm
Timej = Timem
Time = Timej
-C *** Displace Time by expectation value of Time wrt resolution function:
+! *** Displace Time by expectation value of Time wrt resolution function:
Timej = Timej + T2
X1 = Two*Ppp
IF (Aaa.GT.Zero) X2 = 16.0d0/Aaa
IF (A3 .GT.Zero) X3 = 16.0d0/A3
IF (A5 .GT.Zero) X4 = 16.0d0/A5
-C note that this assumes dEXP(-16.0d0) = Zero
+! note that this assumes dEXP(-16.0d0) = Zero
X5 = (Ccc/Two)*1.001
A = dMAX1(Tau,Tz)
A = X1 + A + X5
Tup = Timej + A
-C *** this should be well beyond the upper time (lower energy) at which
-C *** the function -> zero
-C
-C
-C *** figure lower Time (upper energy) at which function goes back to zero
+! *** this should be well beyond the upper time (lower energy) at which
+! *** the function -> zero
+!
+!
+! *** figure lower Time (upper energy) at which function goes back to zero
A = dMAX1 (X2, X3, X4, Xxxmax)
A = X1 + A + X5
Tlow = Timej - A - T2
if (A.GT.Timej) Tlow = Timej*0.10d0
-C
-C
-C *** find range of energies Eup and Elow for integral for this EM
+!
+!
+! *** find range of energies Eup and Elow for integral for this EM
Eup = (Ttoe/Tlow)**2
Elow = (Ttoe/Tup )**2
-C
+!
Itime = Itime + 1
IF (Itime.EQ.1) THEN
WRITE (21,20000) Em, Timej, A
-20000 FORMAT (' Time for energy', 1PG12.4,' is ',1PG12.4,
- * /, ' Time width (total) is ',1PG12.4)
+20000 FORMAT (' Time for energy', 1PG12.4,' is ',1PG12.4, &
+ /, ' Time width (total) is ',1PG12.4)
IF (X1.NE.Zero) WRITE (21,20100) X1
IF (X2.NE.Zero) WRITE (21,20200) X2
IF (X3.NE.Zero) WRITE (21,20300) X3
@@ -336,13 +338,12 @@ C
IF (Mmmrpi.GT.0) THEN
DO Mmm=1,Lother
WRITE (21,20600) Sother(1,Mmm)
-20600 FORMAT (' Time width associated wth other exponential is',
- * 1PG12.4)
+20600 FORMAT (' Time width associated wth other exponential is',1PG12.4)
END DO
END IF
IF (X5.NE.Zero) WRITE (21,20500) X5
-20500 FORMAT (' Time width associated with detector channel is',
- * 1PG12.4)
+20500 FORMAT (' Time width associated with detector channel is', 1PG12.4)
END IF
RETURN
END
+end module rpi3_m
diff --git a/sammy/src/rpi/mrpi4.f b/sammy/src/rpi/mrpi4.f
deleted file mode 100644
index f0ff7ab74..000000000
--- a/sammy/src/rpi/mrpi4.f
+++ /dev/null
@@ -1,58 +0,0 @@
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Rpi_Broadened (Wts, Weight, Sigxxx, Dasigx,
- * Dbsigx, Vsigxx, Vdasig, Vdbsig, Em, Parrpi, Iflrpi, Ecrnch,
- * Wts_Norm)
-C
- use mrpi5_m
- use fixedi_m
- use ifwrit_m
- use fixedr_m
- use brdd_common_m
- use rpijnk_common_m
- use rpires_common_m
- use rpirrr_common_m
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
- DIMENSION Wts(*), Weight(*), Parrpi(*), Iflrpi(*),
- * Ecrnch(*), Sigxxx(*), Dasigx(Nnnsig,*), Dbsigx(Nnnsig,*),
- * Vsigxx(Nnnsig,*), Vdasig(Nnnsig,Ndaxxx,*),
- * Vdbsig(Nnnsig,Ndbxxx,*)
-C
-C DIMENSION Wts(Ipnts), Weight(Kdatb),
-C * Parrpi(Numrpi), Iflrpi(Numrpi), Ecrnch(Numrpi-Nnnrpi)
-C
- DATA Zero /0.0d0/, One /1.0d0/
-C
- CALL Rpi_Br (Weight, Wts, Wwnorm)
- Wts_Norm = One/Wwnorm
-C
- Sigt = Zero
- DO I=1,Ipnts
- IF (Wts(I).NE.Zero) THEN
- DO N=1,Nnnsig
- Sigxxx(N) = Sigxxx(N) + Wts(I)*Vsigxx(N,I+Kc-1)
- END DO
- IF (Ndasig.GT.0) THEN
- DO Ipar=1,Ndasig
- DO N=1,Nnnsig
- Dasigx(N,Ipar) = Dasigx(N,Ipar) +
- * Wts(I)*Vdasig(N,Ipar,I+Kc-1)
- END DO
- END DO
- END IF
- IF (Ndbsig.GT.0) THEN
- DO Ipar=1,Ndbsig
- DO N=1,Nnnsig
- Dbsigx(N,Ipar) = Dbsigx(N,Ipar) +
- * Wts(I)*Vdbsig(n,ipar,I+Kc-1)
- END DO
- END DO
- END IF
- END IF
- END DO
-C
- RETURN
- END
diff --git a/sammy/src/rpi/mrpi4.f90 b/sammy/src/rpi/mrpi4.f90
new file mode 100644
index 000000000..177109ef2
--- /dev/null
+++ b/sammy/src/rpi/mrpi4.f90
@@ -0,0 +1,61 @@
+!
+module rpi4_m
+ contains
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Rpi_Broadened (Wts, Weight, Sigxxx, Dasigx, &
+ Dbsigx, Vsigxx, Vdasig, Vdbsig, Em, Parrpi, Iflrpi, Ecrnch, &
+ Wts_Norm)
+!
+ use rpi5_m
+ use fixedi_m
+ use ifwrit_m
+ use fixedr_m
+ use brdd_common_m
+ use rpijnk_common_m
+ use rpires_common_m
+ use rpirrr_common_m
+ IMPLICIT DOUBLE PRECISION (a-h,o-z)
+!
+ DIMENSION Wts(*), Weight(*), Parrpi(*), Iflrpi(*), &
+ Ecrnch(*), Sigxxx(*), Dasigx(Nnnsig,*), Dbsigx(Nnnsig,*), &
+ Vsigxx(Nnnsig,*), Vdasig(Nnnsig,Ndaxxx,*), &
+ Vdbsig(Nnnsig,Ndbxxx,*)
+!
+! DIMENSION Wts(Ipnts), Weight(Kdatb),
+! * Parrpi(Numrpi), Iflrpi(Numrpi), Ecrnch(Numrpi-Nnnrpi)
+!
+ DATA Zero /0.0d0/, One /1.0d0/
+!
+ CALL Rpi_Br (Weight, Wts, Wwnorm)
+ Wts_Norm = One/Wwnorm
+!
+ Sigt = Zero
+ DO I=1,Ipnts
+ IF (Wts(I).NE.Zero) THEN
+ DO N=1,Nnnsig
+ Sigxxx(N) = Sigxxx(N) + Wts(I)*Vsigxx(N,I+Kc-1)
+ END DO
+ IF (Ndasig.GT.0) THEN
+ DO Ipar=1,Ndasig
+ DO N=1,Nnnsig
+ Dasigx(N,Ipar) = Dasigx(N,Ipar) + &
+ Wts(I)*Vdasig(N,Ipar,I+Kc-1)
+ END DO
+ END DO
+ END IF
+ IF (Ndbsig.GT.0) THEN
+ DO Ipar=1,Ndbsig
+ DO N=1,Nnnsig
+ Dbsigx(N,Ipar) = Dbsigx(N,Ipar) + &
+ Wts(I)*Vdbsig(n,ipar,I+Kc-1)
+ END DO
+ END DO
+ END IF
+ END IF
+ END DO
+!
+ RETURN
+ END
+end module rpi4_m
diff --git a/sammy/src/rpi/mrpi5.f90 b/sammy/src/rpi/mrpi5.f90
index a0fd4b2c2..3f34b66d2 100644
--- a/sammy/src/rpi/mrpi5.f90
+++ b/sammy/src/rpi/mrpi5.f90
@@ -1,4 +1,4 @@
-module mrpi5_m
+module rpi5_m
contains
!
!
@@ -17,6 +17,7 @@ module mrpi5_m
use rpires_common_m
use rpirrr_common_m
use EndfData_common_m
+ use rpi6_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
@@ -145,6 +146,8 @@ module mrpi5_m
use SammyGridAccess_M
use abcexp_m
use abcerf_m
+ use fexq_m
+ use xerfcx_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
!
type(SammyGridAccess)::grid
@@ -579,56 +582,4 @@ module mrpi5_m
call grid%destroy()
RETURN
end subroutine Ebtdch
-!
-!
-! --------------------------------------------------------------
-!
- DOUBLE PRECISION FUNCTION Fexq (Xx, Yy, Zzz)
-! *** [ ERFC(XX-YY) - ERFC(XX) ] exp(ZZZ**2) sqrt(pi)/(2 YY)
- use aaaerf_m
- use abcerf_m
- IMPLICIT none
- EXTERNAL Qqexp ! in src/fnc/,src/orr/morr5.f
-
- real(8)::xx,yy,zzz,Aa,Aaaa,Bb,Bbb,Cc,Qqexp,Yymin
- integer(4)::N
-
- !Fexq = (erfc(xx-yy) - erfc(xx)) * exp(zzz**2) * sqrtPi/(2.0_8*yy)
- DATA Yymin/0.01d0/
- IF (Yy.LE.Yymin) THEN
- Aaaa = Abcerf (Xx, Yy, Aa, Bb, Cc, N)
- Fexq = Aa
- IF (Zzz.NE.Xx) THEN
- Fexq = Fexq * Qqexp(-(Xx+Zzz)*(Xx-Zzz))
- END IF
- ELSE
- Bbb = Zzz*Zzz
- Aaaa = Aaaerf (Xx, Yy, Bbb, Aa, N)
- Fexq = Aa
- END IF
- RETURN
- end function Fexq
-!
-!
-! --------------------------------------------------------------
-!
- DOUBLE PRECISION FUNCTION Xerfcx (XX)
-!
-! *** PURPOSE -- GENERATE EXP(XX**2) * ERFC(XX) * SQRT(PI) for all xx>0
- use exerfc_m
- IMPLICIT none
-
- real(8) :: xx,Xxmax
-
- Xxmax = 5.01d0
-
- IF (Xx.GT.Xxmax) THEN
- Xerfcx = Asympt (xx)
- ELSE
-! IF (Xx.LE.Xxmax)
- Xerfcx = Exerfc (xx)
- END IF
- RETURN
- END FUNCTION Xerfcx
-!
-end module mrpi5_m
+end module rpi5_m
diff --git a/sammy/src/rpi/mrpi6.f b/sammy/src/rpi/mrpi6.f90
similarity index 79%
rename from sammy/src/rpi/mrpi6.f
rename to sammy/src/rpi/mrpi6.f90
index 32872d002..633ab1a4c 100644
--- a/sammy/src/rpi/mrpi6.f
+++ b/sammy/src/rpi/mrpi6.f90
@@ -1,12 +1,14 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module rpi6_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Onlytd (Weight, Wts, Negative)
-C
-C *** PURPOSE -- Form the weights for resolution broadening when
-C *** only the RPI target-detector function is used
-C
+!
+! *** PURPOSE -- Form the weights for resolution broadening when
+! *** only the RPI target-detector function is used
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -19,24 +21,24 @@ C
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Normal
-C
+!
type(SammyGridAccess)::grid
DIMENSION Weight(*), Wts(*)
-C Weight(Kdatb), Wts(Ipnts)
-C
+! Weight(Kdatb), Wts(Ipnts)
+!
DATA Zero /0.0d0/, Half /0.5d0/, Two /2.0d0/
call grid%initialize()
call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
-C
-C
-C *** initialize
+!
+!
+! *** initialize
CALL Zero_Array (Wts, Ipnts)
Xxxchi = Zero
Xx1 = Zero
Xx2 = Zero
-C
+!
Ittx = 0
Itty = 0
X = Zero
@@ -46,20 +48,20 @@ C
IF (Tzmn.NE.Zero) X = X*dEXP(-A3*Tzmn)
Y = A1*A4
IF (Tzmn.NE.Zero) Y = Y*dEXP(-A5*Tzmn)
-cz Ittx = 0
-cz Itty = 0
+!z Ittx = 0
+!z Itty = 0
END IF
Allmax = Zero
Ittz = 0
- Tt = Zero
- Ttx = Zero
+ Tt = Zero
+ Ttx = Zero
Ajacob_Old = Zero
Normal = .False.
IF (Iff_Wts.EQ.1) Normal = .True.
Iee = 0
-C *** do loop over energies
+! *** do loop over energies
DO Ie=1,Ipnts
-C Time corresponds to Energy(Ie+Kc-1) on aux. grid, Timej to Energy(J) in Resolu
+! Time corresponds to Energy(Ie+Kc-1) on aux. grid, Timej to Energy(J) in Resolu
eIe = grid%getEnergy(Ie+Kc-1, expData)
Time = Ttoe/dSQRT(eIe)
Ajacob = Time/(Two*eIe)
@@ -68,10 +70,10 @@ C Time corresponds to Energy(Ie+Kc-1) on aux. grid, Timej to Energy(J) in
Tt = Timeij + Tz - Tzmn
Ttoldx = Ttx
Ttx = Timeij + Tz
-C
+!
All = Zero
IF (Aaa.NE.Zero .AND. Itdchi.EQ.0) THEN
-C &&& chi-squared function
+! &&& chi-squared function
IF (Normal) THEN
IF (Timeij.LT.-Tau) THEN
Timeij_Old = Timeij
@@ -85,14 +87,14 @@ C &&& chi-squared function
Timeij_Old = Timeij
ELSE
Iex = Ie
- CALL Chisq_Low_E (grid, Wts, Timeij_Old, Ajacob,
- * Ajacob_Old, Iee, Iex, Normal)
+ CALL Chisq_Low_E (grid, Wts, Timeij_Old, Ajacob, &
+ Ajacob_Old, Iee, Iex, Normal)
END IF
END IF
END IF
-C
+!
IF (X.NE.Zero .AND. Tt.GT.Zero-1.0E-14) THEN
-C &&& first exponential
+! &&& first exponential
At = A3*Tt
Xx1 = X*dEXP(-At)
IF (Ittx.EQ.0) THEN
@@ -100,13 +102,13 @@ C &&& first exponential
IF (Ie.GT.1) All = All + Xx1*(Tt-Ttold*Half)/(Tt-Ttold)
IF (Ie.EQ.1) All = All + Xx1*Half
ELSE
-C *** usual case is below
+! *** usual case is below
All = All + Xx1
END IF
END IF
-C
+!
IF (Y.NE.Zero .AND. Tt.GT.Zero-1.0E-14) THEN
-C &&& Second exponential
+! &&& Second exponential
At = A5*Tt
Xx2 = Y*dEXP(-At)
IF (Itty.EQ.0) THEN
@@ -117,17 +119,17 @@ C &&& Second exponential
All = All + Xx2
END IF
END IF
-C
+!
IF (Lother.GT.0 .AND. Ttx.GT.Zero) THEN
-C &&& other exponentials
+! &&& other exponentials
DO LL=1,Lother
A6 = TwoG7x(LL)
A7 = A7x (LL)
At = A7*Ttx
Xx6 = A6*dEXP(-At)
IF (Ittz.EQ.0) THEN
- IF (Ie.GT.1) All = All +
- * Xx6*(Ttx-Ttoldx*Half)/(Ttx-Ttoldx)
+ IF (Ie.GT.1) All = All + &
+ Xx6*(Ttx-Ttoldx*Half)/(Ttx-Ttoldx)
IF (Ie.EQ.1) All = All + Xx6*Half
ELSE
All = All + Xx6
@@ -135,8 +137,8 @@ C &&& other exponentials
END DO
IF (Ittz.EQ.0) Ittz = 1
END IF
-C
-C
+!
+!
Wts(Ie) = Weight(Ie+Kc-1)*All*Ajacob + Wts(Ie)
IF (Timeij.GT.Zero) THEN
IF (All.GT.Allmax) THEN
@@ -152,20 +154,20 @@ C
END IF
END DO
30 CONTINUE
-C
+!
call grid%destroy()
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Chisq_Low_E (grid, Wts, Timeij_Old, Ajacob,
- * Ajacob_Old, Iee, Ie, Normal)
-C
-C *** PURPOSE -- Form the weights for chi-squared part of resolution
-C *** function for Onlytd
-C
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Chisq_Low_E (grid, Wts, Timeij_Old, Ajacob, &
+ Ajacob_Old, Iee, Ie, Normal)
+!
+! *** PURPOSE -- Form the weights for chi-squared part of resolution
+! *** function for Onlytd
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -178,27 +180,27 @@ C
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Normal
-C
+!
type(SammyGridAccess)::grid
DIMENSION Wts(*)
-C Wts(Ipnts)
-C
-C *** COMMON /Q31q21/ is needed for some compilers (Linux, especially)
+! Wts(Ipnts)
+!
+! *** COMMON /Q31q21/ is needed for some compilers (Linux, especially)
COMMON /Q31q21/ Q31, Q21, At
DATA Two /2.0d0/, Three /3.0d0/, Four /4.0d0/, Six /6.0d0/
-C
+!
Iee = Iee + 1
IF (Iee.EQ.1) THEN
-C
-C *** Integral from Timej+Tau to Time=t'(ie)
-C *** where Timej corresponds to energy for broadened sigma
-C *** Time is upper energy limit (E'(ie)) [lower Time limit]
-C *** and t(E'(ie-1)) > Timej+Tau > t(E'(ie))=Time=t'(ie)
-C *** Sigma is found by linear interpolation using t'(ie-1) & t'(ie)
-C ***
-C *** Also, add coefficient of sigma(ie) from integral from E'(ie+1) to
-C *** E'(ie+2) [which integral is done in standard form]
-C
+!
+! *** Integral from Timej+Tau to Time=t'(ie)
+! *** where Timej corresponds to energy for broadened sigma
+! *** Time is upper energy limit (E'(ie)) [lower Time limit]
+! *** and t(E'(ie-1)) > Timej+Tau > t(E'(ie))=Time=t'(ie)
+! *** Sigma is found by linear interpolation using t'(ie-1) & t'(ie)
+! ***
+! *** Also, add coefficient of sigma(ie) from integral from E'(ie+1) to
+! *** E'(ie+2) [which integral is done in standard form]
+!
At = Aaa*(Timeij+Tau)
Q31 = dEXP(-At) *(Six+at*(Six+At*(Three+At)))
Q30 = Six
@@ -219,23 +221,23 @@ C
W = (eIe0-eIe1)*(eIe0-eIe2)
W = (eIe1-eIe2)**3/W
Wts(Ie ) = Wts(Ie) + W*Xxxchi*Ajacob
-C
+!
ELSE IF (Iee.EQ.2) THEN
-C
-C *** Integral from t'(Ie-1) to Time=t'(Ie) [Ie now is 1+Ie_above]
-C *** where Timej corresponds to energy for broadened sigma
-C *** Time is upper energy limit (E'(Ie)) [lower Time limit]
-C *** and Timej+Tau > t(E'(Ie-1)) > t(E'(Ie))=Time=t'(Ie)
-C *** Sigma is found by linear interpolation using t'(Ie-1) & t'(Ie)
-C ***
-C *** Also, add coefficient of Sigma(Ie) from integral
-C *** from E'(Ie) to E'(Ie+1) and from E'(Ie+1) to E'(Ie+2)
-C
-C From Iee=1 case, At = Aaa*(Timeij_Old+Tau)
+!
+! *** Integral from t'(Ie-1) to Time=t'(Ie) [Ie now is 1+Ie_above]
+! *** where Timej corresponds to energy for broadened sigma
+! *** Time is upper energy limit (E'(Ie)) [lower Time limit]
+! *** and Timej+Tau > t(E'(Ie-1)) > t(E'(Ie))=Time=t'(Ie)
+! *** Sigma is found by linear interpolation using t'(Ie-1) & t'(Ie)
+! ***
+! *** Also, add coefficient of Sigma(Ie) from integral
+! *** from E'(Ie) to E'(Ie+1) and from E'(Ie+1) to E'(Ie+2)
+!
+! From Iee=1 case, At = Aaa*(Timeij_Old+Tau)
Atx = Aaa*(Timeij-Timeij_Old)
Bt = At + Atx
- Q312 = Q31 - dEXP(-Bt) *
- * (Six+Bt*(Six+Bt*(Three+Bt)))
+ Q312 = Q31 - dEXP(-Bt) * &
+ (Six+Bt*(Six+Bt*(Three+Bt)))
Q212 = Q21 - dEXP(-Bt) *(Two+Bt*(Two+Bt))
Ad = - Q312 + Q212*Bt
Wts(Ie-1) = Wts(Ie-1) + Ad*Six/Atx * Ajacob_Old
@@ -247,23 +249,23 @@ C From Iee=1 case, At = Aaa*(Timeij_Old+Tau)
eIep1 = grid%getEnergy(Ie+1, expData)
eIen1 = grid%getEnergy(Ie-1, expData)
eIep2 = grid%getEnergy(Ie+2, expData)
- W1 = (eIep0-eIep1 )*
- * (eIep0-eIep2)
+ W1 = (eIep0-eIep1 )* &
+ (eIep0-eIep2)
W1 = (eIep1-eIep2)**3/W1
- W2 = (eIen1-eIep1)/
- * (eIep0-eIen1) +
- * (eIep2-eIep1 )/
- * (eIep0-eIep2) - Four
+ W2 = (eIen1-eIep1)/ &
+ (eIep0-eIen1) + &
+ (eIep2-eIep1 )/ &
+ (eIep0-eIep2) - Four
W2 = (eIep0-eIep1)*W2
Wts(Ie ) = Wts(Ie) + (W1+W2)*Xxxchi*Ajacob
-C
+!
ELSE IF (Iee.EQ.3) THEN
-C *** Here we add coefficient of sigma(Ie)
-C *** from integral from E'(Ie-1) to E'(Ie )
-C *** and integral from E'(Ie ) to E'(Ie+1)
-C *** and integral from E'(Ie+1) to E'(Ie+2)
-C *** (There is no contribution to coefficient from integ from
-C *** E'(Ie-2) to E'(Ie-1) since that's done differently.)
+! *** Here we add coefficient of sigma(Ie)
+! *** from integral from E'(Ie-1) to E'(Ie )
+! *** and integral from E'(Ie ) to E'(Ie+1)
+! *** and integral from E'(Ie+1) to E'(Ie+2)
+! *** (There is no contribution to coefficient from integ from
+! *** E'(Ie-2) to E'(Ie-1) since that's done differently.)
At = Aaa*(Timeij+Tau)
Xxxchi = dEXP(-At)*At**2*Aaa/Two
eIep0 = grid%getEnergy(Ie, expData)
@@ -271,18 +273,18 @@ C *** E'(Ie-2) to E'(Ie-1) since that's done differently.)
eIen1 = grid%getEnergy(Ie-1, expData)
eIep2 = grid%getEnergy(Ie+2, expData)
eIen2 = grid%getEnergy(Ie-2, expData)
- W1 = (eIep0-eIep1)*
- * (eIep0-eIep2)
+ W1 = (eIep0-eIep1)* &
+ (eIep0-eIep2)
W1 = (eIep1-eIep2)**3/W1
- W2 = (eIen1-eIep1)/
- * (eIep0-eIen1) +
- * (eIep2-eIep1)/
- * (eIep0-eIep2) - Four
+ W2 = (eIen1-eIep1)/ &
+ (eIep0-eIen1) + &
+ (eIep2-eIep1)/ &
+ (eIep0-eIep2) - Four
W2 = (eIep0-eIep1)*W2
- W = -(eIen2-eIen1)/
- * (eIep0-eIen2) -
- * (eIep1-eIen1)/
- * (eIep0-eIep1) + Four
+ W = -(eIen2-eIen1)/ &
+ (eIep0-eIen2) - &
+ (eIep1-eIen1)/ &
+ (eIep0-eIep1) + Four
W = (eIep0-eIen1)*W
Wts(Ie ) = Wts(Ie) + (W+W1+W2)*Xxxchi*Ajacob
Normal = .True.
@@ -290,16 +292,16 @@ C *** E'(Ie-2) to E'(Ie-1) since that's done differently.)
END IF
RETURN
END
-C
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Onlyeb (Weight, Wts, Negative)
-C
-C *** PURPOSE -- Form the weights for resolution broadening when
-C *** only the electron burst is included (Gaussian)
-C
+!
+! *** PURPOSE -- Form the weights for resolution broadening when
+! *** only the electron burst is included (Gaussian)
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -311,28 +313,28 @@ C
use EndfData_common_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(SammyGridAccess)::grid
DIMENSION Weight(*), Wts(*)
-C Weight(Kdatb), Wts(Ipnts)
+! Weight(Kdatb), Wts(Ipnts)
DATA Zero /0.0d0/, Two /2.0d0/
-C
-C
-C *** initialize
+!
+!
+! *** initialize
CALL Zero_Array (Wts, Ipnts)
call grid%initialize()
call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
-C
+!
Allmax = Zero
-C *** do loop over energies
+! *** do loop over energies
DO IE=1,Ipnts
eIe = grid%getEnergy(Ie+kc-1, expData)
Time = Ttoe/dSQRT(eIe)
Ajacob = Time/(Two*eIe)
Timeij = Timej - Time
-C
+!
At = Www*Timeij
All = dEXP(-At**2)
Wts(Ie) = Weight(Ie+Kc-1)*All*Ajacob
@@ -354,15 +356,15 @@ C
call grid%destroy()
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Onlych (Weight, Wts, Negative)
-C
-C *** PURPOSE -- Form the weights for resolution broadening when
-C *** only the channel widths contribute
-C
+!
+! *** PURPOSE -- Form the weights for resolution broadening when
+! *** only the channel widths contribute
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -374,22 +376,22 @@ C
use EndfData_common_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(SammyGridAccess)::grid
DIMENSION Weight(*), Wts(*)
-C Weight(Kdatb), Wts(Ipnts)
+! Weight(Kdatb), Wts(Ipnts)
DATA Zero /0.0d0/, Half /0.5d0/, One/ 1.0d0/, Two /2.0d0/
call grid%initialize()
call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
-C
-C
-C *** initialize
+!
+!
+! *** initialize
CALL Zero_Array (Wts, Ipnts)
-C
+!
Timem = Zero
-C *** do loop over energies
+! *** do loop over energies
DO Ie=1,Ipnts
Timem = Time
eIe = grid%getEnergy(Ie+Kc-1, expData)
@@ -398,9 +400,9 @@ C *** do loop over energies
IF (Timeij.GT.-Half*Ccc) GO TO 30
END DO
30 CONTINUE
-C
-C *** Here we've found the lowest energy at which the Weight is non-Zero;
-C *** need to modify Weight to include proper proportion of this interval
+!
+! *** Here we've found the lowest energy at which the Weight is non-Zero;
+! *** need to modify Weight to include proper proportion of this interval
IF (Ie.GT.1) THEN
eIe = grid%getEnergy(Ie-1+Kc-1, expData)
Ajacob = Timem/(Two*eIe )
@@ -416,8 +418,8 @@ C *** need to modify Weight to include proper proportion of this interval
Ajacob = Time/(Two*eIe)
Wts(Ie) = Weight(Ie+Kc-1)*Ajacob * Half
END IF
-C
-C *** Take care of all "normal" points
+!
+! *** Take care of all "normal" points
Iemin = Ie+1
DO Ie=Iemin,Ipnts
Timem = Time
@@ -429,9 +431,9 @@ C *** Take care of all "normal" points
Wts(Ie) = Weight(Ie+Kc-1)*Ajacob
END DO
GO TO 60
-C
+!
50 CONTINUE
-c *** Here the previous energy was below Timeij+Ccc/2, this One is above
+! *** Here the previous energy was below Timeij+Ccc/2, this One is above
Ie = Ie - 1
Timeij = Timej - Timem
Xxxx = Half*Ccc - Timeij
@@ -442,23 +444,22 @@ c *** Here the previous energy was below Timeij+Ccc/2, this One is above
Ajacob = Time/(Two*eIe)
Wts(Ie+1) = Weight(Ie+1+Kc-1)*Wwww**2 * Half * Ajacob
RETURN
-C
+!
60 CONTINUE
Wts(Ie) = Wts(Ie)*Half
call grid%destroy()
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Ebanch (Weight, Wts, Negative)
-C
-C *** PURPOSE -- Form the Weights for resolution broadening when
-C *** the (Gaussian) electron burst and the (square) channel
-C *** widths are included
-C
- use mrpi5_m
+!
+! *** PURPOSE -- Form the Weights for resolution broadening when
+! *** the (Gaussian) electron burst and the (square) channel
+! *** widths are included
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -469,30 +470,30 @@ C
use rpirrr_common_m
use EndfData_common_m
use SammyGridAccess_M
- use mrpi5_m
+ use fexq_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(SammyGridAccess)::grid
DIMENSION Weight(*), Wts(*)
-C Weight(Kdatb), Wts(Ipnts)
-C
+! Weight(Kdatb), Wts(Ipnts)
+!
DATA Zero /0.0d0/, Two /2.0d0/
call grid%initialize()
call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
-C
-C
-C *** initialize
+!
+!
+! *** initialize
CALL Zero_Array (Wts, Ipnts)
-C
+!
Allmax = Zero
-C *** do loop over energies
+! *** do loop over energies
DO Ie=1,Ipnts
eIe = grid%getEnergy(Ie+Kc-1, expData)
Time = Ttoe/dSQRT(eIe)
Ajacob = Time/(Two*eIe)
Timeij = Timej - Time
-C
+!
y = Www*Ccc
X = Www*Timeij + Y/Two
IF (X.LT.Zero) THEN
@@ -519,16 +520,16 @@ C
call grid%destroy()
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Ebantd (Weight, Wts, Negative)
-C
-C *** PURPOSE -- Form the Weights for resolution broadening when
-C *** the (Gaussian) electron burst and the (chi squared
-C *** plus exponential) target-detector are included
-C
+!
+! *** PURPOSE -- Form the Weights for resolution broadening when
+! *** the (Gaussian) electron burst and the (chi squared
+! *** plus exponential) target-detector are included
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -542,21 +543,21 @@ C
use SammyGridAccess_M
use exerfc_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(SammyGridAccess)::grid
DIMENSION Weight(*), Wts(*)
-C Weight(Kdatb), Wts(Ipnts)
-C
+! Weight(Kdatb), Wts(Ipnts)
+!
DATA Zero /0.0d0/, Half /0.5d0/, Two /2.0d0/
call grid%initialize()
call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
-C
-C
-C *** initialize
+!
+!
+! *** initialize
CALL Zero_Array (Wts, Ipnts)
-C
+!
Aww = (Aaa/Www)*Half/Www
Aaawwx = Aww*Aaa**2
Aaaww = Aaawwx*(Two*Sqrtpi)
@@ -576,7 +577,7 @@ C
Cww = Zero
Cccwwx = Zero
END IF
-C
+!
Allmax = Zero
DO Ie=1,Ipnts
eIe = grid%getEnergy(Ie+Kc-1, expData)
@@ -584,9 +585,9 @@ C
Ajacob = Time/(Two*eIe)
Timeij = Timej - Time
All = Zero
-C
+!
IF (Itdchi.NE.1) THEN
-C *** First the chi-squared term
+! *** First the chi-squared term
Time = Timeij + Tau - Aww
X = Www*Time
IF (Time.LE.Zero) THEN
@@ -599,9 +600,9 @@ C *** First the chi-squared term
All = All + Aaawwx*dEXP(-Y**2)*(x-Exerfc(X)*(Half+X**2))
END IF
END IF
-C
+!
IF (Bbbwwx.NE.Zero) THEN
-C *** Now the first exponential term
+! *** Now the first exponential term
Time = Timeij + Tz - Tzmn - Bww/Two
Y = A3*Time
Time = Timeij + Tz - Tzmn - Bww
@@ -613,9 +614,9 @@ C *** Now the first exponential term
END IF
All = All + Bbbwwx*Y
END IF
-C
+!
IF (Cccwwx.NE.Zero) THEN
-C *** Now the second exponential term
+! *** Now the second exponential term
Time = Timeij + Tz - Tzmn - Cww/Two
Y = A5*Time
Time = Timeij + Tz - Tzmn - Cww
@@ -627,9 +628,9 @@ C *** Now the second exponential term
END IF
All = All + Cccwwx*Y
END IF
-C
+!
IF (Lother.GT.0) THEN
-C *** Now the other exponential terms
+! *** Now the other exponential terms
DO LL=1,Lother
A6 = TwoG7x(LL)
A7 = A7x (LL)
@@ -646,8 +647,8 @@ C *** Now the other exponential terms
All = All + A6*y
END DO
END IF
-C
-C
+!
+!
Wts(Ie) = Weight(Ie+Kc-1)*All*Ajacob
IF (Timeij.GT.Zero) THEN
IF (All.GT.Allmax) THEN
@@ -664,21 +665,21 @@ C
END IF
END DO
60 CONTINUE
-C
+!
call grid%destroy()
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Chantd (Weight, Wts, Negative)
-C
-C *** PURPOSE -- Form the Weights for resolution broadening when
-C *** the (square) channel width and the (chi squared
-C *** plus exponential) target-detector are included
-C
+!
+! *** PURPOSE -- Form the Weights for resolution broadening when
+! *** the (square) channel width and the (chi squared
+! *** plus exponential) target-detector are included
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -691,21 +692,21 @@ C
use SammyGridAccess_M
use abcexp_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(SammyGridAccess)::grid
DIMENSION Weight(*), Wts(*)
-C Weight(Kdatb), Wts(Ipnts)
-C
+! Weight(Kdatb), Wts(Ipnts)
+!
DATA Small /0.5d0/, Zero /0.0d0/, One/1.0d0/, Two /2.0d0/
call grid%initialize()
call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
-C
-C
-C *** initialize
+!
+!
+! *** initialize
CALL Zero_Array (Wts, Ipnts)
-C
+!
Ac = Aaa*Ccc
Tt = Tau + Ccc/Two
Tta = tz + Ccc/Two - Tzmn
@@ -732,7 +733,7 @@ C
Aae2x = Zero
A5c = Zero
END IF
-C
+!
Allmax = Zero
DO Ie=1,Ipnts
eIe = grid%getEnergy(Ie+Kc-1, expData)
@@ -740,9 +741,9 @@ C
Ajacob = Time/(Two*eIe)
Timeij = Timej - Time
All = Zero
-C
+!
IF (Itdchi.NE.1) THEN
-C *** First the chi-squared term
+! *** First the chi-squared term
Time = Timeij + Tt
X = Aaa*Time
IF (Time.GT.Zero) THEN
@@ -769,11 +770,11 @@ C *** First the chi-squared term
END IF
END IF
END IF
-C
+!
Time = Timeij + Tta
IF (Time.GT.Zero) THEN
IF (Aae1.NE.Zero) THEN
-C *** Now the first exponential term
+! *** Now the first exponential term
X = A3*Time
IF (Time.LE.Ccc) THEN
IF (X.LT.Small) THEN
@@ -796,9 +797,9 @@ C *** Now the first exponential term
END IF
END IF
END IF
-C
+!
IF (Aae2.NE.Zero) THEN
-C *** Now the second exponential term
+! *** Now the second exponential term
X = A5*Time
IF (Time.LE.Ccc) THEN
IF (X.LT.Small) THEN
@@ -818,11 +819,11 @@ C *** Now the second exponential term
END IF
END IF
END IF
-C
+!
IF (Lother.GT.0) THEN
Time = Timeij + Ttd
IF (Time.GT.Zero) THEN
-C *** Now the other exponential terms
+! *** Now the other exponential terms
DO LL=1,Lother
A6 = TwoG7x(LL)
A7 = A7x (LL)
@@ -848,8 +849,8 @@ C *** Now the other exponential terms
END DO
END IF
END IF
-C
-C
+!
+!
Wts(Ie) = Weight(Ie+Kc-1)*All*Ajacob
IF (Timeij.GT.Zero) THEN
IF (All.GT.Allmax) THEN
@@ -864,10 +865,13 @@ C
END IF
END IF
END IF
-C
+!
END DO
60 CONTINUE
-C
+!
call grid%destroy()
RETURN
END
+
+end module rpi6_m
+
diff --git a/sammy/src/rpi/mrpi7.f b/sammy/src/rpi/mrpi7.f90
similarity index 74%
rename from sammy/src/rpi/mrpi7.f
rename to sammy/src/rpi/mrpi7.f90
index b248d7fe5..5dbb2e67d 100644
--- a/sammy/src/rpi/mrpi7.f
+++ b/sammy/src/rpi/mrpi7.f90
@@ -1,11 +1,13 @@
-C ########## if nnnsig>1 this will not work
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Der_Wrt_Rpi (Wtsx, Wts, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Ecrnch, Wts_Norm)
-C
+! ########## if nnnsig>1 this will not work
+module rpi7_m
+ contains
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Der_Wrt_Rpi (Wtsx, Wts, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Ecrnch, Wts_Norm)
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -14,18 +16,18 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
-C
- DIMENSION Wtsx(*), Wts(*), Weight(*), Parrpi(*),
- * Iflrpi(*), Ecrnch(*), Sigxxx(*), Dbsigx(Nnnsig,*),
- * Vsigxx(Nnnsig,*)
-C
-C DIMENSION Wts(Ipnts), Weight(Kdatb),
-C * Parrpi(Numrpi), Iflrpi(Numrpi), Ecrnch(Numrpi-Nnnrpi)
-C
+!
+!
+ DIMENSION Wtsx(*), Wts(*), Weight(*), Parrpi(*), &
+ Iflrpi(*), Ecrnch(*), Sigxxx(*), Dbsigx(Nnnsig,*), &
+ Vsigxx(Nnnsig,*)
+!
+! DIMENSION Wts(Ipnts), Weight(Kdatb),
+! * Parrpi(Numrpi), Iflrpi(Numrpi), Ecrnch(Numrpi-Nnnrpi)
+!
DATA Zero /0.0d0/, One /1.0d0/
-C
-C
+!
+!
Sigt = Sigxxx(1)
Ksol = Ksolve
Ksolve = 2
@@ -34,95 +36,95 @@ C
Kc = Kc - 1
if (Kc.LT.1) Kc = 1
if (Kc+Ipnts.GT.Kdatb) Ipnts = Kdatb - Kc
-C
+!
Qqa = One
IF (Aaa.EQ.Zero) Qqa = Zero
-C
-C p1=p electron burst FWHM
+!
+! p1=p electron burst FWHM
IF (Iflrpi(1).NE.0) THEN
- CALL Der_Wrt_Ppp (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Sigt, Wts_Norm)
+ CALL Der_Wrt_Ppp (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Sigt, Wts_Norm)
END IF
-C
-C
-C (2a) chi-squared function time-shift
+!
+!
+! (2a) chi-squared function time-shift
IF (Numrpi.EQ.1) GO TO 60
IF (Iftau.NE.0) THEN
- CALL Der_Wrt_Tau (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Sigt, Wts_Norm)
+ CALL Der_Wrt_Tau (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Sigt, Wts_Norm)
END IF
-C
-C
-C (2a) chi-square parameter Lambda
+!
+!
+! (2a) chi-square parameter Lambda
IF (Numrpi.LT.9) GO TO 60
IF (Ifaaa.NE.0) THEN
- CALL Der_Wrt_Lambda (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Sigt, Wts_Norm)
+ CALL Der_Wrt_Lambda (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Sigt, Wts_Norm)
END IF
-C
-C
-C (2b&c) multiplier for exponential functions
+!
+!
+! (2b&c) multiplier for exponential functions
IF (Numrpi.LT.14) GO TO 60
IF (Iffa1.NE.0) THEN
- CALL Der_Wrt_Expon (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
+ CALL Der_Wrt_Expon (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
END IF
-C
-C
-C (2b&c) time-shift for exponentials
-C p21=tz (2b&c) Time-shift for exponentials
+!
+!
+! (2b&c) time-shift for exponentials
+! p21=tz (2b&c) Time-shift for exponentials
Irpi = 21
IF (Numrpi.LT.Irpi) GO TO 60
IF (Iflrpi(Irpi).NE.0) THEN
- CALL Der_Wrt_Tz (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Sigt)
+ CALL Der_Wrt_Tz (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Sigt)
END IF
-C
-C
-C (2b) A2 * exp(-A3*(t-tz))
+!
+!
+! (2b) A2 * exp(-A3*(t-tz))
Irpi = 22
IF (Numrpi.LT.Irpi) GO TO 60
IF (Iflrpi(Irpi).NE.0) THEN
- CALL Der_Wrt_A2 (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
+ CALL Der_Wrt_A2 (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
END IF
-C
+!
Irpi = 23
IF (Numrpi.LT.Irpi) GO TO 60
IF (Iffa3.NE.0) THEN
- CALL Der_Wrt_A3 (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
+ CALL Der_Wrt_A3 (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
END IF
-C
-C
-C (2c) A4 * exp(-A5*(E-tz))
+!
+!
+! (2c) A4 * exp(-A5*(E-tz))
Irpi = 24
IF (Numrpi.LT.Irpi) GO TO 60
IF (Iflrpi(Irpi).NE.0) THEN
- CALL Der_Wrt_A4 (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
+ CALL Der_Wrt_A4 (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
END IF
-C
+!
Irpi = 25
IF (Numrpi.LT.Irpi) GO TO 60
IF (Iffa5.NE.0) THEN
- CALL Der_Wrt_A5 (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
+ CALL Der_Wrt_A5 (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
END IF
-C
-c XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX not right?
-C (2d) Xxxrpi(1) * exp(-q*(E-tz))
+!
+! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX not right?
+! (2d) Xxxrpi(1) * exp(-q*(E-tz))
Irpi = 26 + Medrpi
IF (Numrpi.LT.Irpi) GO TO 60
IF (Mmmrpi.GT.0) THEN
- CALL Der_Wrt_Expxx (Wtsx, Wts, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt, Wts_Norm)
-c XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ CALL Der_Wrt_Expxx (Wtsx, Wts, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt, Wts_Norm)
+! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
END IF
-C
+!
Irpi = Nnnrpi
-C (3) channel width
-cx IF (Numrpi.LE.Nnnrpi) GO TO 60
+! (3) channel width
+!x IF (Numrpi.LE.Nnnrpi) GO TO 60
IF (Numrpi.GT.Nnnrpi) THEN
N = Nnnrpi + 1
DO Ii=N,Numrpi
@@ -134,52 +136,52 @@ cx IF (Numrpi.LE.Nnnrpi) GO TO 60
Irpi = Numrpi
50 CONTINUE
IF (Iflrpi(Irpi).NE.0) THEN
- CALL Der_Wrt_Ecrnch (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Sigt, Irpi, Wts_Norm)
+ CALL Der_Wrt_Ecrnch (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Sigt, Irpi, Wts_Norm)
END IF
END IF
-C
+!
60 CONTINUE
Ksolve = Ksol
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- DOUBLE PRECISION FUNCTION Getder (Sigpls, Sigt, Sigmns, Ddeell,
- * A, Kdebug, Kwarn, Irpi, Em)
+!
+!
+! --------------------------------------------------------------
+!
+ DOUBLE PRECISION FUNCTION Getder (Sigpls, Sigt, Sigmns, Ddeell, &
+ A, Kdebug, Kwarn, Irpi, Em)
use lbro_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DATA Zero /0.0d0/, Half /0.5d0/, Small /0.05d0/, Smal /0.08d0/,
- * One /1.0d0/
+ DATA Zero /0.0d0/, Half /0.5d0/, Small /0.05d0/, Smal /0.08d0/, &
+ One /1.0d0/
IF (A.NE.Zero) THEN
B = Half*(Sigpls-Sigmns)/(Ddeell*A)
ELSE
B = Zero
END IF
Getder = B
- IF ((Rpideb .OR. Kdebug.NE.0) .AND. Kwarn.LE.100. AND. A.NE.Zero
- * .AND. Sigpls.NE.Sigmns) THEN
+ IF ((Rpideb .OR. Kdebug.NE.0) .AND. Kwarn.LE.100. .AND. A.NE.Zero &
+ .AND. Sigpls.NE.Sigmns) THEN
Der1 = (Sigpls-Sigt)/(Ddeell*A)
Der2 = (Sigt-Sigmns)/(Ddeell*A)
IF (B.NE.Zero .AND. Der1.NE.Zero) THEN
- IF (dABS(Der1/B-One).GT.Small .OR. dABS(Der2/B-One).GT.Small
- * .OR. dABS(Der2/Der1-One).GT.Smal) THEN
+ IF (dABS(Der1/B-One).GT.Small .OR. dABS(Der2/B-One).GT.Small &
+ .OR. dABS(Der2/Der1-One).GT.Smal) THEN
Kwarn = Kwarn + 1
- IF (Kwarn.LE.100) WRITE (6,99999) Kwarn, Irpi, Em, Der1,
- * B, Der2
-99999 FORMAT (1X, I3, 'DERIV #', I2, ' --E,D1,D,D2=', 1PG15.8,
- * 3(1PG11.3))
+ IF (Kwarn.LE.100) WRITE (6,99999) Kwarn, Irpi, Em, Der1, &
+ B, Der2
+99999 FORMAT (1X, I3, 'DERIV #', I2, ' --E,D1,D,D2=', 1PG15.8, &
+ 3(1PG11.3))
END IF
END IF
END IF
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
DOUBLE PRECISION FUNCTION Sumupd (Wts, Vsig)
use fixedi_m
use brdd_common_m
@@ -192,14 +194,15 @@ C
Sumupd = A
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Der_Wrt_Ppp (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Sigt, Wts_Norm)
-C
- use mrpi5_m
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Der_Wrt_Ppp (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Sigt, Wts_Norm)
+!
+ use rpi5_m
+ use rpi8_m
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -209,16 +212,15 @@ C
use rpirrr_common_m
use constn_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- EXTERNAL Sumupd
-C
- DIMENSION Wtsx(*), Weight(*), Parrpi(*),
- * Iflrpi(*), Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
-C
+!
+ DIMENSION Wtsx(*), Weight(*), Parrpi(*), &
+ Iflrpi(*), Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
+!
DATA S4ln2 /1.6651092223153954d0/
-C Square root of (4*ln(2)) = Conversion from fwhm to width of Gaussian
+! Square root of (4*ln(2)) = Conversion from fwhm to width of Gaussian
DATA Kwarn /0/, One /1.0d0/, Thous /1000.0d0/
-C
-C p1 = p electron burst FWHM
+!
+! p1 = p electron burst FWHM
Irpi = 1
Jjjder = 1
IF (Krpixx.NE.1 .AND. Krpixx.NE.5) THEN
@@ -253,20 +255,20 @@ C p1 = p electron burst FWHM
END DO
END IF
Www = A
- Der = Getder (Sigpls, Sigt, Sigmns,
- * Ddeelx(1), A, Kdebug, Kwarn, Irpi, Em)
+ Der = Getder (Sigpls, Sigt, Sigmns, &
+ Ddeelx(1), A, Kdebug, Kwarn, Irpi, Em)
Der = Der * Www
ELSE
-c use this more efficient method for Krpixx=1 (Onlyeb_Der)
-c and Krpixx=5 (Ebanch_Der)
-c cannot use this for Krpixx=0 because Ebtdch_Der is not working
-c cannot use this for Krpixx=4 because Ebantd_Der is not working
+! use this more efficient method for Krpixx=1 (Onlyeb_Der)
+! and Krpixx=5 (Ebanch_Der)
+! cannot use this for Krpixx=0 because Ebtdch_Der is not working
+! cannot use this for Krpixx=4 because Ebantd_Der is not working
CALL Rpi_Br_Der (Weight, Wtsx, Wts_Norm, Jjjder)
Der = Sumupd (Wtsx, Vsigxx)
END IF
-C
-C *** Note that Wtsx assume a factor of 1/Www is missing from d(I)/d(www).
-C *** Also note that Www=S4ln2/p and p is the variable of interest.
+!
+! *** Note that Wtsx assume a factor of 1/Www is missing from d(I)/d(www).
+! *** Also note that Www=S4ln2/p and p is the variable of interest.
Der = - Der*Www /Thous/S4ln2
Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
DO N=1,Nnnsig
@@ -274,14 +276,15 @@ C *** Also note that Www=S4ln2/p and p is the variable of interest.
END DO
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Der_Wrt_Tau (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Sigt, Wts_Norm)
-C
- use mrpi5_m
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Der_Wrt_Tau (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Sigt, Wts_Norm)
+!
+ use rpi5_m
+ use rpi8_m
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -290,23 +293,22 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- EXTERNAL Sumupd
-C
- DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*),
- * Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
-C
+!
+ DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*), &
+ Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
+!
DATA Kwarn /0/, Zero /0.0d0/, One /1.0d0/, Thous /1000.0d0/
-C
-C p2=Taua (2a) chi-squared function time-shift
-C p3=Taub Tau = a exp(-bE) + b exp(-dE) + e
-C p4=Tauc + f E^g
-C p5=Taud
-C p6=Taue
-C p7=Tauf
-C p8=Taug
-C
+!
+! p2=Taua (2a) chi-squared function time-shift
+! p3=Taub Tau = a exp(-bE) + b exp(-dE) + e
+! p4=Tauc + f E^g
+! p5=Taud
+! p6=Taue
+! p7=Tauf
+! p8=Taug
+!
Jjjder = 2
-C
+!
IF (Krpixx.GT.7) THEN
CALL Rpi_Br_Der (Weight, Wtsx, Wts_Norm, Jjjder)
Der = Sumupd (Wtsx, Vsigxx)
@@ -329,10 +331,10 @@ C
Tau = A
Timej = B
Irpi = 2
- Der = Getder (Sigpls, Sigt, Sigmns, Ddeell_Tau, A, Kdebug,
- * Kwarn, Irpi, Em)
+ Der = Getder (Sigpls, Sigt, Sigmns, Ddeell_Tau, A, Kdebug, &
+ Kwarn, Irpi, Em)
END IF
-C
+!
Irpi = 2
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = dEXP(-Taub*Em)/Thous
@@ -391,14 +393,15 @@ C
END IF
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Der_Wrt_Lambda (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Sigt, Wts_Norm)
-C
- use mrpi5_m
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Der_Wrt_Lambda (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Sigt, Wts_Norm)
+!
+ use rpi5_m
+ use rpi8_m
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -407,19 +410,18 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- EXTERNAL Sumupd
-C
- DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*),
- * Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
-C
+!
+ DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*), &
+ Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
+!
DATA Kwarn /0/, Zero /0.0d0/, One /1.0d0/, Thous /1000.0d0/
-C
-C p 9=lambda(0)/1000 (2a) chi-square parameter
-C p10=lambda(1)/1000 lambda = lambda(0) + lambda(1) * ln(E) +
-C p11=lambda(2)/1000 lambda(2) *(ln(E))**2
-C p12=lambda(3)/1000 + lambda(3)*E^lambda(4)
-C p13=lambda(4)
-C
+!
+! p 9=lambda(0)/1000 (2a) chi-square parameter
+! p10=lambda(1)/1000 lambda = lambda(0) + lambda(1) * ln(E) +
+! p11=lambda(2)/1000 lambda(2) *(ln(E))**2
+! p12=lambda(3)/1000 + lambda(3)*E^lambda(4)
+! p13=lambda(4)
+!
IF (Krpixx.GT.7) THEN
Jjjder = 3
CALL Rpi_Br_Der (Weight, Wtsx, Wts_Norm, Jjjder)
@@ -442,12 +444,12 @@ C
Aaa = A
Timej = B
Irpi = 9
- Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(9), A, Kdebug,
- * Kwarn, Irpi, Em)
+ Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(9), A, Kdebug, &
+ Kwarn, Irpi, Em)
Der = - Der * Aaa**2
-C because Aaa = 1 / Lambda
+! because Aaa = 1 / Lambda
END IF
-C
+!
Irpi = 9
Dl = dLOG(Em)
IF (Iflrpi(Irpi).NE.0) THEN
@@ -491,14 +493,14 @@ C
END IF
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Der_Wrt_Expon (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
-C
- use mrpi5_m
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Der_Wrt_Expon (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
+!
+ use rpi5_m
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -507,21 +509,20 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- EXTERNAL Sumupd
-C
- DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*),
- * Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
-C
+!
+ DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*), &
+ Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
+!
DATA Kwarn /0/, One /1.0d0/, Thous /1000.0d0/
-C
-C p14=A1a/1000 (2b&c) multiplier for exponential functions is
-C p15=A1b A1 = A exp(-bE) + b exp(-dE) + e
-C p16=A1c/1000 + f E^g
-C p17=A1d
-C p18=A1e/1000
-C p19=A1f/1000
-C p20=A1g
-C
+!
+! p14=A1a/1000 (2b&c) multiplier for exponential functions is
+! p15=A1b A1 = A exp(-bE) + b exp(-dE) + e
+! p16=A1c/1000 + f E^g
+! p17=A1d
+! p18=A1e/1000
+! p19=A1f/1000
+! p20=A1g
+!
Irpi = 14
A = A1
B = Timej
@@ -547,11 +548,11 @@ C
Timej = B
A0 = C
T2 = D
-C
+!
Irpi = 14
- Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(14), A, Kdebug,
- * Kwarn, Irpi, Em)
-C
+ Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(14), A, Kdebug, &
+ Kwarn, Irpi, Em)
+!
Irpi = 14
IF (Iflrpi(Irpi).NE.0) THEN
Fudgex = dEXP(-A1b*Em)*Thous
@@ -610,14 +611,14 @@ C
END IF
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Der_Wrt_Tz ( Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Sigt)
-C
- use mrpi5_m
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Der_Wrt_Tz ( Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Sigt)
+!
+ use rpi5_m
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -626,15 +627,14 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- EXTERNAL Sumupd
-C
- DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*),
- * Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
-C
+!
+ DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*), &
+ Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
+!
DATA Kwarn /0/, Zero /0.0d0/, One /1.0d0/, Thous /1000.0d0/
-C
-C p21=tz*1000 (2b&c) lower limit for exponential Time0
-C
+!
+! p21=tz*1000 (2b&c) lower limit for exponential Time0
+!
Irpi = 21
A = Tz
B = T2b
@@ -664,22 +664,22 @@ C
T2b = B
T2d = C
Timej = F
- Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(21), A, Kdebug,
- * Kwarn, Irpi, Em)
+ Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(21), A, Kdebug, &
+ Kwarn, Irpi, Em)
Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der/Thous
END DO
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Der_Wrt_A2 (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
-C
- use mrpi5_m
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Der_Wrt_A2 (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
+!
+ use rpi5_m
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -688,16 +688,15 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- EXTERNAL Sumupd
-C
- DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*),
- * Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
-C
+!
+ DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*), &
+ Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
+!
DATA Kwarn /0/, One /1.0d0/
-C
-C p22=A2 (2b) A2 * exp(-A3*(t-tz))
-C p23=A3
-C
+!
+! p22=A2 (2b) A2 * exp(-A3*(t-tz))
+! p23=A3
+!
Irpi = 22
A = A2
B = T2b
@@ -735,22 +734,22 @@ C
A0 = E
Timej = F
T2 = H
- Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(22), A, Kdebug,
- * Kwarn, Irpi, Em)
+ Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(22), A, Kdebug, &
+ Kwarn, Irpi, Em)
Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der
END DO
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Der_Wrt_A3 (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
-C
- use mrpi5_m
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Der_Wrt_A3 (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
+!
+ use rpi5_m
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -759,17 +758,16 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- EXTERNAL Sumupd
-C
- DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*),
- * Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
-C
+!
+ DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*), &
+ Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
+!
DATA Kwarn /0/, One /1.0d0/, Thous /1000.0d0/
-C
-C A3 = p23*Thous (2b) A2 * exp(-A3*(t-tz))
-C or A3 = [p26*exp(-p27*Em) + p28*exp(-p29*Em) + p30 + p31*Em^p32]*Thous
-C A3 = A3 * dsqrt(Em) if p23=-2.0
-C
+!
+! A3 = p23*Thous (2b) A2 * exp(-A3*(t-tz))
+! or A3 = [p26*exp(-p27*Em) + p28*exp(-p29*Em) + p30 + p31*Em^p32]*Thous
+! A3 = A3 * dsqrt(Em) if p23=-2.0
+!
Irpi = 23
A = A3
B = T2b
@@ -807,8 +805,8 @@ C
A0 = E
Timej = F
T2 = H
- Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(23), A, Kdebug,
- * Kwarn, Irpi, Em)
+ Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(23), A, Kdebug, &
+ Kwarn, Irpi, Em)
IF (Medrpi.EQ.0) THEN
Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
DO N=1,Nnnsig
@@ -870,14 +868,14 @@ C
END IF
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Der_Wrt_A4 (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
-C
- use mrpi5_m
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Der_Wrt_A4 (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
+!
+ use rpi5_m
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -886,15 +884,14 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- EXTERNAL Sumupd
-C
- DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*),
- * Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
-C
+!
+ DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*), &
+ Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
+!
DATA Kwarn /0/, One /1.0d0/
-C
-C p24=A4 (2c) A4 * exp(-A5*(E-tz))
-C
+!
+! p24=A4 (2c) A4 * exp(-A5*(E-tz))
+!
Irpi = 24
A = A4
B = T2b
@@ -932,22 +929,22 @@ C
A0 = E
Timej = F
T2 = H
- Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(24), A, Kdebug,
- * Kwarn, Irpi, Em)
+ Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(24), A, Kdebug, &
+ Kwarn, Irpi, Em)
Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der
END DO
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Der_Wrt_A5 (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
-C
- use mrpi5_m
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Der_Wrt_A5 (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt)
+!
+ use rpi5_m
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -956,17 +953,16 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- EXTERNAL Sumupd
-C
- DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*),
- * Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
-C
+!
+ DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*), &
+ Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
+!
DATA Kwarn /0/, Zero /0.0d0/, One /1.0d0/, Thous /1000.0d0/
-C
-C A5 = p25*Thous (2c) A4 * exp(-A5*(t-tz))
-C or A5 = [p33*exp(-p34*Em) + p35*exp(-p36*Em) + p37 + p38*Em^p39]*Thous
-C A5 = A5 * dsqrt(Em) if p25=-2.0
-C
+!
+! A5 = p25*Thous (2c) A4 * exp(-A5*(t-tz))
+! or A5 = [p33*exp(-p34*Em) + p35*exp(-p36*Em) + p37 + p38*Em^p39]*Thous
+! A5 = A5 * dsqrt(Em) if p25=-2.0
+!
A = A5
B = T2b
C = Qqq
@@ -1003,8 +999,7 @@ C
A0 = E
Timej = F
T2 = H
- Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(25), A, Kdebug,
- * Kwarn, Irpi, Em)
+ Der = Getder (Sigpls, Sigt, Sigmns, Ddeelx(25), A, Kdebug, Kwarn, Irpi,Em)
IF (Mmmrpi.EQ.0) THEN
Irpi = 25
Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
@@ -1067,14 +1062,15 @@ C
END IF
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Der_Wrt_Expxx (Wtsx, Wts, Weight, Sigxxx,
- * Dbsigx, Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt, Wts_Norm)
-C
- use mrpi5_m
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Der_Wrt_Expxx (Wtsx, Wts, Weight, Sigxxx, &
+ Dbsigx, Vsigxx, Em, Parrpi, Iflrpi, Qqa, Sigt, Wts_Norm)
+!
+ use rpi5_m
+ use rpi8_m
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -1083,21 +1079,20 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- EXTERNAL Sumupd
-C
- DIMENSION Wtsx(*), Wts(*), Weight(*), Parrpi(*),
- * Iflrpi(*), Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
-C
+!
+ DIMENSION Wtsx(*), Wts(*), Weight(*), Parrpi(*), &
+ Iflrpi(*), Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
+!
DATA Kwarn /0/, Zero /0.0d0/, One /1.0d0/, Thous /1000.0d0/
DATA Fraction /0.001d0/
-C
-C (2d) sum over LL { A6 * exp(-A7*(E-tz)) }
-C where A7 is X2*exp(-X3*E)+X4*exp(-X5*E)+X6+X7*E^X8
-C
+!
+! (2d) sum over LL { A6 * exp(-A7*(E-tz)) }
+! where A7 is X2*exp(-X3*E)+X4*exp(-X5*E)+X6+X7*E^X8
+!
Jjjder = 9
Der1 = Zero
Der2 = Zero
-C
+!
DO LL=1,Lother
Irpi = 25 + Medrpi + (LL-1)*8
Ifx = 0
@@ -1105,7 +1100,7 @@ C
IF (Iflrpi(Irpi+Im).NE.0) Ifx = Ifx + 1
END DO
IF (Krpixx.LT.7 .AND. (Ifx.GT.0 .OR. Iflrpi(Irpi+1).GT.0)) THEN
-C
+!
DO Kounter=1,2
A6_Keep = Parrpi(Irpi+1) * Thous
A7_Keep = A7x(LL)
@@ -1172,8 +1167,8 @@ C
END IF
CALL Rpi_Br (Weight, Wts, Wwnorm)
Sigpls = Sumupd (Wts, Vsigxx)
- Der = Getder (Sigpls, Sigt, Sigmns, Fraction, A,
- * Kdebug, Kwarn, Irpi+Kounter, Em)
+ Der = Getder (Sigpls, Sigt, Sigmns, Fraction, A, &
+ Kdebug, Kwarn, Irpi+Kounter, Em)
IF (Kounter.EQ.1) Der1 = Der
IF (Kounter.EQ.2) Der2 = Der
T2d = B
@@ -1201,20 +1196,20 @@ C
IF (Im.EQ.2) THEN
Q = dEXP(-Parrpi(Irpi+3)*Em)
ELSE IF (Im.EQ.3) THEN
- Q = dEXP(-Parrpi(Irpi+3)*Em) *
- * Parrpi(Irpi+2) * (-Em)
+ Q = dEXP(-Parrpi(Irpi+3)*Em) * &
+ Parrpi(Irpi+2) * (-Em)
ELSE IF (Im.EQ.4) THEN
Q = dEXP(-Parrpi(Irpi+4)*Em)
ELSE IF (Im.EQ.5) THEN
- Q = dEXP(-Parrpi(Irpi+5)*Em) *
- * Parrpi(Irpi+4) * (-Em)
+ Q = dEXP(-Parrpi(Irpi+5)*Em) * &
+ Parrpi(Irpi+4) * (-Em)
ELSE IF (Im.EQ.6) THEN
Q = One
ELSE IF (Im.EQ.7) THEN
Q = Em**Parrpi(Irpi+8)
ELSE IF (Im.EQ.8) THEN
- Q = - dlog(Em) * Parrpi(Irpi+7) *
- * Em**Parrpi(Irpi+8)
+ Q = - dlog(Em) * Parrpi(Irpi+7) * &
+ Em**Parrpi(Irpi+8)
ELSE
Q = Zero
END IF
@@ -1225,14 +1220,14 @@ C
END IF
END DO
END IF
-C
+!
ELSE IF (Krpixx.GE.7) THEN
-c **************************************** not understood yet
+! **************************************** not understood yet
Jjjder = Jjjder + 1
Irpi = Irpi + 1
IF (Iflrpi(Irpi).NE.0) THEN
- CALL Rpi_Br_Der (Weight, Wtsx, Wts_Norm,
- * Jjjder)
+ CALL Rpi_Br_Der (Weight, Wtsx, Wts_Norm, &
+ Jjjder)
Der = Sumupd (Wtsx, Vsigxx)
Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
Der = Der*Thous
@@ -1240,7 +1235,7 @@ c **************************************** not understood yet
Dbsigx(N,Kkk) = Der
END DO
END IF
-C
+!
Jjjder = Jjjder + 1
Irpix = Irpi
Ix = 0
@@ -1251,15 +1246,15 @@ C
END IF
END DO
IF (Ix.EQ.1) THEN
- CALL Rpi_Br_Der (Weight, Wtsx, Wts_Norm,
- * Jjjder)
+ CALL Rpi_Br_Der (Weight, Wtsx, Wts_Norm, &
+ Jjjder)
Der = Sumupd (Wtsx, Vsigxx)
DO Im=2,8
Irpi = Irpi + 1
IF (Iflrpi(Irpix).NE.0) THEN
Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
- IF (Im.EQ.2 .OR. Im.EQ.4 .OR. Im.EQ.6 .OR.
- * Im.EQ.7) Der = Der*Thous
+ IF (Im.EQ.2 .OR. Im.EQ.4 .OR. Im.EQ.6 .OR. &
+ Im.EQ.7) Der = Der*Thous
DO N=1,Nnnsig
Dbsigx(N,Kkk) = Der
END DO
@@ -1267,18 +1262,19 @@ C
END DO
END IF
END IF
-C
+!
END DO
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Der_Wrt_Ecrnch (Wtsx, Weight, Sigxxx, Dbsigx,
- * Vsigxx, Em, Parrpi, Iflrpi, Sigt, Irpi, Wts_Norm)
-C
- use mrpi5_m
+!
+!
+! --------------------------------------------------------------
+!
+ SUBROUTINE Der_Wrt_Ecrnch (Wtsx, Weight, Sigxxx, Dbsigx, &
+ Vsigxx, Em, Parrpi, Iflrpi, Sigt, Irpi, Wts_Norm)
+!
+ use rpi5_m
+ use rpi8_m
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -1287,22 +1283,21 @@ C
use rpires_common_m
use rpirrr_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- EXTERNAL Sumupd
-C
- DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*),
- * Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
-C
+!
+ DIMENSION Wtsx(*), Weight(*), Parrpi(*), Iflrpi(*), &
+ Sigxxx(*), Dbsigx(Nnnsig,*), Vsigxx(Nnnsig,*)
+!
DATA Kwarn /0/, One /1.0d0/, Thous /1000.0d0/
-C
-C p[Nnnrpi+1],...=c (3) channel width
-C
+!
+! p[Nnnrpi+1],...=c (3) channel width
+!
IF (Krpixx.GT.7) THEN
Jjjder = 11
CALL Rpi_Br_Der (Weight, Wtsx, Wts_Norm, Jjjder)
Ddd = Sumupd (Wtsx, Vsigxx)
Der = Ddd
-C ******************* Der = Ddd ? not sure, need Der somehow but haven't
-C ******************* spent time to decide what is right
+! ******************* Der = Ddd ? not sure, need Der somehow but haven't
+! ******************* spent time to decide what is right
ELSE
A = Ccc
Ccc = A*(One-Ddeell)
@@ -1312,8 +1307,8 @@ C ******************* spent time to decide what is right
CALL Rpi_Br (Weight, Wtsx, Wwnorm)
Sigpls = Sumupd (Wtsx, Vsigxx)
Ccc = A
- Der = Getder (Sigpls, Sigt, Sigmns, Ddeell, A, Kdebug, Kwarn,
- * Irpi, Em)
+ Der = Getder (Sigpls, Sigt, Sigmns, Ddeell, A, Kdebug, Kwarn, &
+ Irpi, Em)
END IF
Der = Der/Thous
Kkk = Iflrpi(Irpi) - Nvadif - Ndasig
@@ -1322,3 +1317,4 @@ C ******************* spent time to decide what is right
END DO
RETURN
END
+end module rpi7_m
\ No newline at end of file
diff --git a/sammy/src/rpi/mrpi8.f b/sammy/src/rpi/mrpi8.f90
similarity index 81%
rename from sammy/src/rpi/mrpi8.f
rename to sammy/src/rpi/mrpi8.f90
index b35e695d0..6eca2ab3b 100644
--- a/sammy/src/rpi/mrpi8.f
+++ b/sammy/src/rpi/mrpi8.f90
@@ -1,21 +1,24 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module rpi8_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Rpi_Br_Der (Weight, Wtsx, Wts_Norm, Jjjder)
-C
-C *** PURPOSE -- form the derivatives of the resolution-broadening function
-C
+!
+! *** PURPOSE -- form the derivatives of the resolution-broadening function
+!
use brdd_common_m
use rpijnk_common_m
use rpires_common_m
use rpirrr_common_m
+ use rpi9_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
DIMENSION Weight(*), Wtsx(*)
-C Weight(Kdatb), Wtsx(Ipnts)
-C
-C *** ELectron Burst, Target-Detector, and/or CHannel width?
+! Weight(Kdatb), Wtsx(Ipnts)
+!
+! *** ELectron Burst, Target-Detector, and/or CHannel width?
IF (Krpixx.EQ.0) CALL Ebtdch_Der (Weight, Wtsx, Jjjder)
IF (Krpixx.EQ.1) CALL Onlyeb_Der (Weight, Wtsx)
IF (Krpixx.EQ.2) CALL Onlytd_Der (Weight, Wtsx, Jjjder)
@@ -23,22 +26,22 @@ C *** ELectron Burst, Target-Detector, and/or CHannel width?
IF (Krpixx.EQ.4) CALL Ebantd_Der (Weight, Wtsx, Jjjder)
IF (Krpixx.EQ.5) CALL Ebanch_Der (Weight, Wtsx, Jjjder)
IF (Krpixx.EQ.6) CALL Chantd_Der (Weight, Wtsx, Jjjder)
-C
+!
DO I=1,Ipnts
Wtsx(I) = Wtsx(I)*Wts_Norm
END DO
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Ebtdch_Der (Weight, Wtsx, Jjjder)
-C
-C *** PURPOSE -- Form the weights for derivative of the resolution
-C *** broadening when using (Gaussian) burst, RPI resolution,
-C *** and (square) channel width
-C
+!
+! *** PURPOSE -- Form the weights for derivative of the resolution
+! *** broadening when using (Gaussian) burst, RPI resolution,
+! *** and (square) channel width
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -49,30 +52,31 @@ C
use constn_common_m
use EndfData_common_m
use SammyGridAccess_M
- use mrpi5_m
use abcexp_m
+ use fexq_m
+ use xerfcx_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(SammyGridAccess)::grid
DIMENSION Weight(*), Wtsx(*)
-C Weight(Kdatb), Wtsx(Ipnts)
-C
- DATA Zero /0.0d0/, Half /0.5d0/, One /1.0d0/, Two /2.0d0/,
- * Big /10.0d0/, Kstop /0/
-C
-C
+! Weight(Kdatb), Wtsx(Ipnts)
+!
+ DATA Zero /0.0d0/, Half /0.5d0/, One /1.0d0/, Two /2.0d0/, &
+ Big /10.0d0/, Kstop /0/
+!
+!
IF (Kstop.EQ.0) THEN
- STOP'[Stop -- routine Ebtdch_Der is not yet working in mrpi8.f]'
-C *** initialize
+ STOP '[Stop -- routine Ebtdch_Der is not yet working in mrpi8.f]'
END IF
+! *** initialize
call grid%initialize()
call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
-C
+!
CALL Zero_Array (Wtsx, Ipnts)
-C
+!
Aw = Aaa/Www
TwoG = (Aaa/Www)*Half/Www
Ag = (Aaa/Www/Two)**2
@@ -103,7 +107,7 @@ C
Kk2 = 0
Kk3 = 0
Kk6 = 0
-C
+!
DO Ie=1,Ipnts
eIe = grid%getEnergy(Ie+Kc-1, expData)
Time = Ttoe/dSQRT(eIe)
@@ -113,11 +117,11 @@ C
Sum2 = Zero
Sum3 = Zero
Sum6 = Zero
-C
- IF (Itdchi.NE.1 .AND. Kk1.LE.10 .AND. (Jjjder.EQ.2
- * .OR. Jjjder.EQ.3) ) THEN
-C ********* First the chi-squared term (if it's there and if it hasn't yet
-C ********* converged)
+!
+ IF (Itdchi.NE.1 .AND. Kk1.LE.10 .AND. (Jjjder.EQ.2 &
+ .OR. Jjjder.EQ.3) ) THEN
+! ********* First the chi-squared term (if it's there and if it hasn't yet
+! ********* converged)
Time = Timeij + Tau + Ccc/Two
Wt = Www*Time
IF (Time.GE.Zero) THEN
@@ -139,34 +143,34 @@ C ********* converged)
Expb = dEXP(-Aaa*(Fmg-Ccc))
X = Www*Fm2g
IF (X.GT.Zero) THEN
-C *** case 1, X positive
+! *** case 1, X positive
X1 = Xerfcx(X)
IF (X-Wc.GT.Zero) THEN
-C *** case 1a, X positive, X-U also positive
+! *** case 1a, X positive, X-U also positive
X2 = Xerfcx(X-Wc)
- Y = ( Cb2*(Expb*Sqrtpi-Z2*X2/Two) -
- * Cb1*(Expa*Sqrtpi-Z1*X1/Two) )/Ccc
+ Y = ( Cb2*(Expb*Sqrtpi-Z2*X2/Two) - &
+ Cb1*(Expa*Sqrtpi-Z1*X1/Two) )/Ccc
Sum1 = Sum1 + Y
ELSE
-C *** case 1b, X positive, X-U negative
+! *** case 1b, X positive, X-U negative
X2 = Xerfcx(-X+Wc)
- Y = ( Cb2*(Z2*X2/Two) -
- * Cb1*(Expa*Sqrtpi-Z1*X1/Two) )/Ccc
+ Y = ( Cb2*(Z2*X2/Two) - &
+ Cb1*(Expa*Sqrtpi-Z1*X1/Two) )/Ccc
Sum1 = Sum1 + Y
END IF
ELSE
-C *** case 2, X negative
+! *** case 2, X negative
X1 = Xerfcx(-X)
IF (X-Wc.GT.Zero) THEN
-C *** case 2a, X <0, X-Wc >0 ... cannot happen cuz Wc > 0
+! *** case 2a, X <0, X-Wc >0 ... cannot happen cuz Wc > 0
STOP '[STOP in Ebtdch_Der in rpi/mrpi8.f]'
ELSE
-C *** case 2b, X & X-Wc negative
+! *** case 2b, X & X-Wc negative
X2 = Xerfcx(-X+Wc)
Sum1 = (Z2*Cb2*X2-Z1*Cb1*X1)/(Two*Ccc) + Sum1
END IF
END IF
-C
+!
At = (Timeij+Tau)*Aaa
IF (Jjjder.EQ.2) THEN
Sum1 = Sum1*(Two/At-One)*Aaa
@@ -174,16 +178,16 @@ C
Sum1 = Sum1*(-3.0d0+At)*Aaa
END IF
Sum = Sum1
-C *** end of chi-squared term
+! *** end of chi-squared term
END IF
-C
-C
+!
+!
Time = Timeij + Tz - Tzmn + Ccc/Two
-C
- IF (Ac2.NE.Zero .AND. Kk2.LE.10 .AND. (Jjjder.EQ.3 .OR.
- * Jjjder.EQ.4) ) THEN
-C ********* Now the first exponential term (if it's there and if it
-C ********* hasn't yet converged)
+!
+ IF (Ac2.NE.Zero .AND. Kk2.LE.10 .AND. (Jjjder.EQ.3 .OR. &
+ Jjjder.EQ.4) ) THEN
+! ********* Now the first exponential term (if it's there and if it
+! ********* hasn't yet converged)
Wt = Www*Time
IF (Wt.LE.Zero) THEN
Ffexq = Fexq (Wc-Wt, Wc, Zero)
@@ -215,7 +219,7 @@ C ********* hasn't yet converged)
Sum2 = Sum2 + Ac2*Expb*Fxerfc/Two/Wc
END IF
ELSE
-C *** here for "Small" Wc (less than Big)
+! *** here for "Small" Wc (less than Big)
Expa = dEXP(- (Wt**2-A3*Ccc) )
Expb = dEXP(-(Wt-Wc)**2)
Ac = A3*Ccc
@@ -226,8 +230,8 @@ C *** here for "Small" Wc (less than Big)
Y = ( One - dEXP(-A3*Ccc) ) /Wc
END IF
IF (X.LE.Zero) THEN
- IF (Ac2.NE.Zero .AND. Expa.NE.Zero .AND. Y.NE.Zero)
- * THEN
+ IF (Ac2.NE.Zero .AND. Expa.NE.Zero .AND. Y.NE.Zero) &
+ THEN
Fxerfc = Xerfcx(-X)
Sum2 = Sum2 + Ac2*Y*Expa*Fxerfc/Two
END IF
@@ -239,8 +243,8 @@ C *** here for "Small" Wc (less than Big)
IF (Ac2.NE.Zero .AND. Y.NE.Zero) THEN
Fmg = Fm2g + G3
Fxerfc = Xerfcx(X)
- Sum2 = Sum2 +Ac2*y*(dEXP(-A3*(Fmg-Ccc))*Sqrtpi
- * -Expa*Fxerfc/Two)
+ Sum2 = Sum2 +Ac2*y*(dEXP(-A3*(Fmg-Ccc))*Sqrtpi &
+ -Expa*Fxerfc/Two)
END IF
IF (Ac2.NE.Zero .AND. Expb.NE.Zero) THEN
Ffexq = Fexq (X, Wc, X-Wc)
@@ -248,14 +252,14 @@ C *** here for "Small" Wc (less than Big)
END IF
END IF
END IF
-C end of first exponential term
+! end of first exponential term
END IF
-C
-C
- IF (Ac4.NE.Zero .AND. Kk3.LE.10 .AND. (Jjjder.EQ.5 .OR.
- * Jjjder.EQ.6) ) THEN
-C ********* Now the second exponential term (if it's there and if it
-C ********* hasn't yet converged)
+!
+!
+ IF (Ac4.NE.Zero .AND. Kk3.LE.10 .AND. (Jjjder.EQ.5 .OR. &
+ Jjjder.EQ.6) ) THEN
+! ********* Now the second exponential term (if it's there and if it
+! ********* hasn't yet converged)
Wt = Www*Time
IF (Wt.LE.Zero) THEN
Ffexq = Fexq (Wc-Wt, Wc, Zero)
@@ -287,7 +291,7 @@ C ********* hasn't yet converged)
Sum3 = Sum3 + Ac4*Expb*Fxerfc/Two/Wc
END IF
ELSE
-C *** here for "Small" Wc (less than Big)
+! *** here for "Small" Wc (less than Big)
Expa = dEXP(- (Wt**2-A5*Ccc) )
Expb = dEXP(-(Wt-Wc)**2)
Ac = A5*Ccc
@@ -309,27 +313,27 @@ C *** here for "Small" Wc (less than Big)
ELSE
Fmg = Fm2g + G5
Fxerfc = Xerfcx(X)
- Sum3 = Sum3 + Ac4*y*
- * (dEXP(-A5*(Fmg-Ccc))*Sqrtpi-Expa*Fxerfc/Two)
+ Sum3 = Sum3 + Ac4*y* &
+ (dEXP(-A5*(Fmg-Ccc))*Sqrtpi-Expa*Fxerfc/Two)
IF (Expb.NE.Zero .AND. Ac4.NE.Zero) THEN
Ffexq = Fexq (X, Wc, X-Wc)
Sum3 = Sum3 - Ac4*Expb*Ffexq
END IF
END IF
END IF
-C end of second exponential term
+! end of second exponential term
END IF
-C
-C
+!
+!
IF (Lother.GT.0 .AND. Jjjder.GT.8) THEN
-C ********* Now the other exponential terms (if they're there and if
-C ********* they haven't yet converged)
+! ********* Now the other exponential terms (if they're there and if
+! ********* they haven't yet converged)
Time = Timeij + Tz + Ccc/Two
Iqqq = 25 + Mmmrpi
DO Mm=1,Lother
-czzzzzzzz IF (Parrpi(Iqqq+Mm).NE.Zero .AND. Kk6.LE.10 .AND.
-czzzzzzzz * (Jjjder.EQ.8+Mm*2 .OR. Jjjder.EQ.9+Mm*2) ) THEN
-czzzzzzzz A6 = Parrpi(Iqqq+1)
+!zzzzzzzz IF (Parrpi(Iqqq+Mm).NE.Zero .AND. Kk6.LE.10 .AND.
+!zzzzzzzz * (Jjjder.EQ.8+Mm*2 .OR. Jjjder.EQ.9+Mm*2) ) THEN
+!zzzzzzzz A6 = Parrpi(Iqqq+1)
Ac6 = Ac6x (Mm)
TwoG7 = TwoG7x(Mm)
A7 = A7x (Mm)
@@ -365,7 +369,7 @@ czzzzzzzz A6 = Parrpi(Iqqq+1)
Sum6 = Sum6 + Ac6*Expb*Fxerfc/Two/Wc
END IF
ELSE
-C *** here for "Small" Wc (less than Big)
+! *** here for "Small" Wc (less than Big)
Expa = dEXP(- (Wt**2-A7*Ccc) )
Expb = dEXP(-(Wt-Wc)**2)
Ac = A7*Ccc
@@ -376,8 +380,8 @@ C *** here for "Small" Wc (less than Big)
Y = ( One - dEXP(-A7*Ccc) ) /Wc
END IF
IF (X.LE.Zero) THEN
- IF (Ac6.NE.Zero .AND. Expa.NE.Zero .AND.
- * Y.NE.Zero) THEN
+ IF (Ac6.NE.Zero .AND. Expa.NE.Zero .AND. &
+ Y.NE.Zero) THEN
Fxerfc = Xerfcx(-X)
Sum6 = Sum6 + Ac6*y*Expa*Fxerfc/Two
END IF
@@ -389,8 +393,8 @@ C *** here for "Small" Wc (less than Big)
IF (Ac6.NE.Zero .AND. Y.NE.Zero) THEN
Fmg = Fm2g + G7
Fxerfc = Xerfcx(X)
- Sum6 = Sum6 + Ac6*y*(dEXP(-A7*(Fmg-Ccc))*
- * Sqrtpi -Expa*Fxerfc/Two)
+ Sum6 = Sum6 + Ac6*y*(dEXP(-A7*(Fmg-Ccc))* &
+ Sqrtpi -Expa*Fxerfc/Two)
END IF
IF (Ac6.NE.Zero .AND. Expb.NE.Zero) THEN
Ffexq = Fexq (X, Wc, X-Wc)
@@ -404,12 +408,12 @@ C *** here for "Small" Wc (less than Big)
Sum6 = - Sum6 * (Timeij+Tz)
END IF
Sum = Sum6
-czzzzzzzzzzzzzzz END IF
+!!zzzzzzzzzzzzzzz END IF
END DO
-C end of other exponential terms
+! end of other exponential terms
END IF
-C
-C
+!
+!
IF (Kk1.LE.10 .AND. dABS(Sum1).LT.dABS(S1)) THEN
Kk1 = Kk1 + 1
END IF
@@ -426,9 +430,10 @@ C
Kk6 = Kk6 + 1
END IF
S6 = Sum6
-C
+!
Wtsx(Ie) = Weight(Ie+Kc-1)*Sum*Ajacob
END DO
call grid%destroy()
RETURN
END
+end module rpi8_m
diff --git a/sammy/src/rpi/mrpi9.f b/sammy/src/rpi/mrpi9.f90
similarity index 81%
rename from sammy/src/rpi/mrpi9.f
rename to sammy/src/rpi/mrpi9.f90
index 06f9c5316..a22b1a1b1 100644
--- a/sammy/src/rpi/mrpi9.f
+++ b/sammy/src/rpi/mrpi9.f90
@@ -1,13 +1,15 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module rpi9_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Onlytd_Der (Weight, Wtsx, Jjjder)
-C
-C *** PURPOSE -- Form the weights for derivatives wrt resolution
-C *** broadening parameters when only the RPI target-detector
-C *** function is used
-C
+!
+! *** PURPOSE -- Form the weights for derivatives wrt resolution
+! *** broadening parameters when only the RPI target-detector
+! *** function is used
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -19,38 +21,36 @@ C
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
LOGICAL Normal
-C
+!
type(SammyGridAccess)::grid
DIMENSION Weight(*), Wtsx(*)
-C Weight(Kdatb), Wtsx(Ipnts)
-C
- DATA Zero /0.0d0/, Half /0.5d0/, Two /2.0d0/, Three /3.0d0/,
- * Four /4.0d0/, Six /6.0d0/, twl /12.0d0/, tw4 /24.0d0/,
- * One /1.0d0/, Kstop /0/
-C
- IF (Kstop.EQ.0) THEN
- STOP '[ * STOP -- Onlytd_Der is not yet working in mrpi9.f *]'
- END IF
+! Weight(Kdatb), Wtsx(Ipnts)
+!
+ DATA Zero /0.0d0/, Half /0.5d0/, Two /2.0d0/, Three /3.0d0/, &
+ Four /4.0d0/, Six /6.0d0/, twl /12.0d0/, tw4 /24.0d0/, &
+ One /1.0d0/, Kstop /0/
+!
+ IF (Kstop.EQ.0) STOP '[ STOP - Onlytd_Der is not yet working in mrpi9.f]'
call grid%initialize()
call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
-C
-C *** initialize
+!
+! *** initialize
CALL Zero_Array (Wtsx, Ipnts)
IF (Jjjder.NE.2 .AND. Jjjder.NE.3) RETURN
Xxxchi = Zero
Xx1 = Zero
Xx2 = Zero
-C
-C *** More initialization that fussy compilers need; not right yet
+!
+! *** More initialization that fussy compilers need; not right yet
Timeij_Old = Zero
At = Zero
Q11 = Zero
Q21 = Zero
Q31 = Zero
Q41 = Zero
-C
+!
X = A1*A2
IF (Tzmn.NE.Zero) X = X*dEXP(-A3*Tzmn)
Y = A1*A4
@@ -59,13 +59,13 @@ C
Ittx = 0
Itty = 0
Ittz = 0
- Tt = Zero
- Ttx = Zero
+ Tt = Zero
+ Ttx = Zero
Normal = .False.
Iee = 0
-C *** do loop over energies
+! *** do loop over energies
DO 20 Ie=1,Ipnts
-C Time corresponds to Energy(Ie+Kc-1), Timej to Energy(J) in Resolu
+! Time corresponds to Energy(Ie+Kc-1), Timej to Energy(J) in Resolu
eIe = grid%getEnergy(Ie+Kc-1, expData)
Time = Ttoe/dSQRT(eIe)
Ajacob = Time/(Two*eIe)
@@ -74,11 +74,11 @@ C Time corresponds to Energy(Ie+Kc-1), Timej to Energy(J) in Resolu
Tt = Timeij + Tz - Tzmn
Ttoldx = Ttx
Ttx = Timeij + Tz
-C
+!
Sum = Zero
- IF (Aaa.NE.Zero .AND. Itdchi.EQ.0
- * .AND. (Jjjder.EQ.2 .OR. Jjjder.EQ.3)) THEN
-C &&& chi-squared function
+ IF (Aaa.NE.Zero .AND. Itdchi.EQ.0 &
+ .AND. (Jjjder.EQ.2 .OR. Jjjder.EQ.3)) THEN
+! &&& chi-squared function
IF (Normal) THEN
At = Aaa*(Timeij+Tau)
Xxxchi = dEXP(-At)*At**2*Aaa/Two
@@ -92,8 +92,8 @@ C &&& chi-squared function
Timeij_old = Timeij
ELSE
Iee = Iee + 1
- If (Ie.EQ.1) STOP
- * '[STOP missing first term in 0nlytd_Der in mrpi9.f]'
+ If (Ie.EQ.1) STOP &
+ '[STOP missing first term in 0nlytd_Der in mrpi9.f]'
IF (Iee.EQ.1) THEN
At = Aaa*(Timeij+Tau)
Dexpat = dEXP(-At)
@@ -112,8 +112,8 @@ C &&& chi-squared function
Ad = - ad + Two*(Q201-Q101*(At-Atx))
Wtsx(Ie ) = Ad*Six*Aaa/Atx
ELSE IF (Jjjder.EQ.3) THEN
- Q41 = Dexpat *
- * (Tw4+At*(Tw4+At*(Twl+At*(Four+At))))
+ Q41 = Dexpat * &
+ (Tw4+At*(Tw4+At*(Twl+At*(Four+At))))
Q401 = Tw4 - Q41
Ad = -Three*ad + (-Q401+Q301*At)
Wtsx(Ie-1) = Ad*Six*Aaa/Atx
@@ -127,8 +127,8 @@ C &&& chi-squared function
eIe0 = grid%getEnergy(Ie , expData)
eIe1 = grid%getEnergy(Ie+1, expData)
eIe2 = grid%getEnergy(Ie+2, expData)
- W = (eIe0-eIe1)*
- * (eIe0-eIe2)
+ W = (eIe0-eIe1)* &
+ (eIe0-eIe2)
W = (eIe1-eIe2)**3/W
IF (Jjjder.EQ.2) THEN
W = W * Xxxchi*(Two/at-One)*Aaa
@@ -154,8 +154,8 @@ C &&& chi-squared function
Ad = - ad + Two*( Q212-Q112*At)
Wtsx(Ie ) = Ad*Six*Aaa/Atx
ELSE IF (Jjjder.EQ.3) THEN
- Q42 = Dexpat *
- * (Tw4+At*(Tw4+At*(Twl+At*(Four+At))))
+ Q42 = Dexpat * &
+ (Tw4+At*(Tw4+At*(Twl+At*(Four+At))))
Q412 = Q41 - Q42
Ad = -Three*Ad + (-Q412+Q312*(Atx+At))
Wtsx(Ie-1) = Wtsx(Ie-1) + Ad*Six*Aaa/Atx
@@ -170,13 +170,13 @@ C &&& chi-squared function
eIep1 = grid%getEnergy(Ie+1, expData)
eIen1 = grid%getEnergy(Ie-1, expData)
eIep2 = grid%getEnergy(Ie+2, expData)
- W1 = (eIep0-eIep1)*
- * (eIep0-eIep2)
+ W1 = (eIep0-eIep1)* &
+ (eIep0-eIep2)
W1 = (eIep1-eIep2)**3/W1
- W2 = (eIen1-eIep1)/
- * (eIep0-eIen1) +
- * (eIep2-eIep1)/
- * (eIep0-eIep2) - Four
+ W2 = (eIen1-eIep1)/ &
+ (eIep0-eIen1) + &
+ (eIep2-eIep1)/ &
+ (eIep0-eIep2) - Four
W2 = (eIep0-eIep1)*W2
W = W1 + W2
IF (Jjjder.EQ.2) THEN
@@ -193,18 +193,18 @@ C &&& chi-squared function
eIen1 = grid%getEnergy(Ie-1, expData)
eIep2 = grid%getEnergy(Ie+2, expData)
eIen2 = grid%getEnergy(Ie-2, expData)
- W1 = (eIep0-eIep1)*
- * (eIep0-eIep2)
+ W1 = (eIep0-eIep1)* &
+ (eIep0-eIep2)
W1 = (eIep1-eIep2)**3/W1
- W2 = (eIen1-eIep1)/
- * (eIep0-eIen1) +
- * (eIep2-eIep1)/
- * (eIep0-eIep2) - Four
+ W2 = (eIen1-eIep1)/ &
+ (eIep0-eIen1) + &
+ (eIep2-eIep1)/ &
+ (eIep0-eIep2) - Four
W2 = (eIep0-eIep1)*W2
- W = -(eIen2-eIen1)/
- * (eIep0-eIen2) -
- * (eIep1-eIen1)/
- * (eIep0-eIep1) + Four
+ W = -(eIen2-eIen1)/ &
+ (eIep0-eIen2) - &
+ (eIep1-eIen1)/ &
+ (eIep0-eIep1) + Four
W = (eIep0-eIen1)*W
W = W1 + W2 + W
IF (Jjjder.EQ.2) THEN
@@ -221,7 +221,7 @@ C &&& chi-squared function
END IF
IF (Jjjder.NE.2 .AND. Jjjder.NE.3) THEN
IF (X.NE.Zero .AND. Tt.GT.Zero) THEN
-C &&& first exponential
+! &&& first exponential
At = A3*Tt
Xx1 = X*dEXP(-At)
IF (Ittx.EQ.0) THEN
@@ -229,12 +229,12 @@ C &&& first exponential
IF (Ie.GT.1) Sum = Sum + Xx1*(Tt-Ttold*Half)/(Tt-Ttold)
IF (Ie.EQ.1) Sum = Sum + Xx1*Half
ELSE
-C *** usual case is below
+! *** usual case is below
Sum = Sum + Xx1
END IF
END IF
IF (Y.NE.Zero .AND. Tt.GT.Zero) THEN
-C &&& Second exponential
+! &&& Second exponential
At = A5*Tt
Xx2 = Y*dEXP(-At)
IF (Itty.EQ.0) THEN
@@ -246,7 +246,7 @@ C &&& Second exponential
END IF
END IF
IF (Lother.GT.0 .AND. Ttx.GT.Zero) THEN
-C &&& other exponentials
+! &&& other exponentials
Iqqq = 25 + Mmmrpi
DO LL=1,Lother
A6 = Ac6x(Iqqq+1)
@@ -254,8 +254,8 @@ C &&& other exponentials
At = A7*Ttx
Xx6 = A6*dEXP(-At)
IF (Ittz.EQ.0) THEN
- IF (Ie.GT.1) Sum = Sum +
- * Xx6*(Ttx-Ttoldx*Half)/(Ttx-Ttoldx)
+ IF (Ie.GT.1) Sum = Sum + &
+ Xx6*(Ttx-Ttoldx*Half)/(Ttx-Ttoldx)
IF (Ie.EQ.1) Sum = Sum + Xx6*Half
ELSE
Sum = Sum + Xx6
@@ -263,23 +263,23 @@ C &&& other exponentials
END DO
IF (Ittz.EQ.0) Ittz = 1
END IF
-C
+!
END IF
Wtsx(Ie) = Weight(Ie+Kc-1)*Sum*Ajacob + Wtsx(Ie)
20 CONTINUE
-C
+!
call grid%destroy()
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Onlyeb_Der (Weight, Wtsx)
-C
-C *** PURPOSE -- Form the derivatives of the weights for resolution
-C *** broadening when only the electron burst is included
-C
+!
+! *** PURPOSE -- Form the derivatives of the weights for resolution
+! *** broadening when only the electron burst is included
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -290,21 +290,21 @@ C
use EndfData_common_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(SammyGridAccess)::grid
DIMENSION Weight(*), Wtsx(*)
-C Weight(Kdatb), Wtsx(Ipnts)
+! Weight(Kdatb), Wtsx(Ipnts)
DATA Zero /0.0d0/, One /1.0d0/, Two /2.0d0/
-C
-C
-C *** initialize
+!
+!
+! *** initialize
CALL Zero_Array (Wtsx, Ipnts)
call grid%initialize()
call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
-C
+!
Summax = Zero
-C *** do loop over energies
+! *** do loop over energies
DO Ie=1,Ipnts
eIe = grid%getEnergy(Ie+Kc-1, expData)
Time = Ttoe/dSQRT(eIe)
@@ -317,15 +317,15 @@ C *** do loop over energies
call grid%destroy()
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Onlych_Der (Weight, Wtsx, Jjjder)
-C
-C *** PURPOSE -- Form the derivatives of the weights for resolution
-C *** broadening when only the channel widths contribute
-C
+!
+! *** PURPOSE -- Form the derivatives of the weights for resolution
+! *** broadening when only the channel widths contribute
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -336,25 +336,24 @@ C
use EndfData_common_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(SammyGridAccess)::grid
DIMENSION Weight(*), Wtsx(*)
-C Weight(Kdatb), Wtsx(Ipnts)
+! Weight(Kdatb), Wtsx(Ipnts)
DATA Zero /0.0d0/, Half /0.5d0/, One/ 1.0d0/, Two /2.0d0/
DATA Kstop /0/
-C
- IF (Kstop.EQ.0) THEN
- STOP '[STOP -- Onlych_Der not yet ready in mrpi9.f]'
- END IF
+!
+ IF (Kstop.EQ.0) STOP '[STOP -- Onlych_Der not yet ready in mrpi9.f]'
+
call grid%initialize()
call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
-C
-C *** initialize
+!
+! *** initialize
CALL Zero_Array (Wtsx, Ipnts)
-C
+!
Timem = Zero
-C *** do loop over energies
+! *** do loop over energies
DO Ie=1,Ipnts
Timem = Time
eIe = grid%getEnergy(Ie+Kc-1, expData)
@@ -363,9 +362,9 @@ C *** do loop over energies
IF (Timeij.GT.-Half*Ccc) GO TO 30
END DO
30 CONTINUE
-C
-C *** here we've found the lowest energy at which the Weight is non-Zero;
-C *** need to modify Weight to include proper proportion of this interval
+!
+! *** here we've found the lowest energy at which the Weight is non-Zero;
+! *** need to modify Weight to include proper proportion of this interval
IF (Ie.GT.1) THEN
eIe = grid%getEnergy(Ie+Kc-1, expData)
Ajacob = Timem/(Two*eIe)
@@ -381,7 +380,7 @@ C *** need to modify Weight to include proper proportion of this interval
Ajacob = Time/(Two*eIe)
Wtsx(Ie) = Weight(Ie+Kc-1)*Ajacob * Half
END IF
-C
+!
Iemin = Ie + 1
DO IE=Iemin,Ipnts
Timem = Time
@@ -393,9 +392,9 @@ C
Wtsx(Ie) = Weight(Ie+Kc-1)*Ajacob
END DO
GO TO 60
-C
+!
50 CONTINUE
-C *** Here the previous energy was below Timeij+Ccc/2, this one is above
+! *** Here the previous energy was below Timeij+Ccc/2, this one is above
Ie = Ie - 1
Timeij = Timej - Timem
Xxxx = Half*Ccc - Timeij
@@ -406,22 +405,22 @@ C *** Here the previous energy was below Timeij+Ccc/2, this one is above
Ajacob = Time/(Two*eIe)
Wtsx(Ie+1) = Weight(Ie+1+Kc-1)*Wwww**2 * Half * Ajacob
RETURN
-C
+!
60 CONTINUE
Wtsx(Ie) = Wtsx(Ie)*Half
call grid%destroy()
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Ebanch_Der (Weight, Wtsx, Jjjder)
-C
-C *** PURPOSE -- Form the weights for deriv of resolution broadening when
-C *** the (Gaussian) electron burst and the (square) channel
-C *** widths are included
-C
+!
+! *** PURPOSE -- Form the weights for deriv of resolution broadening when
+! *** the (Gaussian) electron burst and the (square) channel
+! *** widths are included
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -432,15 +431,16 @@ C
use EndfData_common_m
use SammyGridAccess_M
use abcexp_m
- use mrpi5_m
+ use rpi5_m
+ use fexq_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(SammyGridAccess)::grid
DIMENSION Weight(*), Wtsx(*)
-C Weight(Kdatb), Wtsx(Ipnts)
+! Weight(Kdatb), Wtsx(Ipnts)
DATA Zero /0.0d0/, Two /2.0d0/
DATA Kstop /0/
-C
+!
CALL Zero_Array (Wtsx, Ipnts)
call grid%initialize()
call grid%setParameters(numcro, ktzero)
@@ -455,15 +455,15 @@ C
IF (Jjjder.EQ.1) THEN
Z = - Two*Wt*Wc
Z = Abcexp (Z, A, B, C, D, N)
-C A = (e^z-1)/z
+! A = (e^z-1)/z
Z = Wt - Wc/Two
E = dEXP(-Z**2)
Z = Wt + Wc/Two
Z = - Two*Wt*Wc*Z*A + Wc
Sum = E*Z/(Ccc*Www)
ELSE IF (Jjjder.GT.9) THEN
- IF (Kstop.EQ.0) STOP
- * '[STOP -- Ebanch not right yet for chan rpi/mrpi9.f]'
+ IF (Kstop.EQ.0) STOP &
+ '[STOP -- Ebanch not right yet for chan rpi/mrpi9.f]'
Wc = Www*Ccc
Wz = Www*Timeij + Wc/Two
IF (Wz.LT.Zero) THEN
@@ -477,24 +477,24 @@ C A = (e^z-1)/z
Sum = -B + E/Two
Sum = Sum * Www/Ccc
ELSE
- STOP
- * '[STOP Jjjder is not specified in Ebanch_Der in mrpi9.f]'
+ STOP &
+ '[STOP Jjjder is not specified in Ebanch_Der in mrpi9.f]'
END IF
Wtsx(Ie) = Weight(Ie+Kc-1)*Sum*Ajacob
END DO
call grid%destroy()
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Ebantd_Der (Weight, Wtsx, Jjjder)
-C
-C *** PURPOSE -- Form the weights for derivs of resolution broadening when
-C *** the (Gaussian) electron burst and the (chi squared
-C *** plus exponential) target-detector are included
-C
+!
+! *** PURPOSE -- Form the weights for derivs of resolution broadening when
+! *** the (Gaussian) electron burst and the (chi squared
+! *** plus exponential) target-detector are included
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -507,25 +507,24 @@ C
use SammyGridAccess_M
use exerfc_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(SammyGridAccess)::grid
DIMENSION Weight(*), Wtsx(*)
-C Weight(Kdatb), Wtsx(Ipnts)
-C
+! Weight(Kdatb), Wtsx(Ipnts)
+!
DATA Zero /0.0d0/, Half /0.5d0/, Two /2.0d0/
-C
+!
DATA Kstop /0/
-C
- IF (Kstop.EQ.0) THEN
- STOP '[Stop -- Ebantd_Der not yet ready rpi/mpri9.f]'
- END IF
+!
+ IF (Kstop.EQ.0) STOP '[Stop -- Ebantd_Der not yet ready rpi/mpri9.f]'
+
call grid%initialize()
call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
-C
-C *** initialize
+!
+! *** initialize
CALL Zero_Array (Wtsx, Ipnts)
-C
+!
Aww = (Aaa/Www)*Half/Www
Aaawwx = Aww*Aaa**2
Aaaww = Aaawwx*(Two*Sqrtpi)
@@ -545,7 +544,7 @@ C
Cww = Zero
Cccwwx = Zero
END IF
-C
+!
Summax = Zero
DO IE=1,Ipnts
eIe = grid%getEnergy(Ie+Kc-1, expData)
@@ -553,9 +552,9 @@ C
Ajacob = Time/(Two*eIe)
Timeij = Timej - Time
Sum = Zero
-C
+!
IF (Itdchi.NE.1) THEN
-C *** First the chi-squared term
+! *** First the chi-squared term
Time = Timeij + Tau - Aww
X = Www*Time
IF (Time.LE.Zero) THEN
@@ -568,9 +567,9 @@ C *** First the chi-squared term
Sum = Sum + Aaawwx*dEXP(-Y**2)*(X-Exerfc(X)*(Half+X**2))
END IF
END IF
-C
+!
IF (Bbbwwx.NE.Zero) THEN
-C *** Now the first exponential term
+! *** Now the first exponential term
Time = Timeij + Tz - Tzmn - Bww/Two
Y = A3*Time
Time = Timeij + Tz - Tzmn - Bww
@@ -582,9 +581,9 @@ C *** Now the first exponential term
END IF
Sum = Sum + Bbbwwx*Y
END IF
-C
+!
IF (Cccwwx.NE.Zero) THEN
-C *** Now the second exponential term
+! *** Now the second exponential term
Time = Timeij + Tz - Tzmn - Cww/Two
Y = A5*Time
Time = Timeij + Tz - Tzmn - Cww
@@ -596,9 +595,9 @@ C *** Now the second exponential term
END IF
Sum = Sum + Cccwwx*y
END IF
-C
+!
IF (Lother.GT.0) THEN
-C *** Now the other exponential terms
+! *** Now the other exponential terms
DO LL=1,Lother
A6 = Ac6x(LL)
A7 = A7x (LL)
@@ -615,7 +614,7 @@ C *** Now the other exponential terms
Sum = Sum + A6*y
END DO
END IF
-C
+!
Wtsx(Ie) = Weight(Ie+Kc-1)*Sum*Ajacob
IF (Timeij.GT.Zero) THEN
IF (Sum.GT.Summax) THEN
@@ -632,21 +631,21 @@ C
END IF
END DO
60 CONTINUE
-C
+!
call grid%destroy()
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Chantd_Der (Weight, Wtsx, Jjjder)
-C
-C *** PURPOSE -- Form the weights for derivs of resolution broadening when
-C *** the (square) channel width and the (chi squared
-C *** plus exponential) target-detector are included
-C
+!
+! *** PURPOSE -- Form the weights for derivs of resolution broadening when
+! *** the (square) channel width and the (chi squared
+! *** plus exponential) target-detector are included
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -658,24 +657,22 @@ C
use SammyGridAccess_M
use abcexp_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(SammyGridAccess)::grid
DIMENSION Weight(*), Wtsx(*)
-C Weight(Kdatb), Wtsx(Ipnts)
-C
+! Weight(Kdatb), Wtsx(Ipnts)
+!
DATA Small /0.5d0/, Zero /0.0d0/, One/1.0d0/, Two /2.0d0/
DATA Kstop /0/
-C
- IF (Kstop.EQ.0) THEN
- STOP '[Stop -- Chantd_Der not yet ready rpi/mrpi9.f]'
- END IF
+!
+ IF (Kstop.EQ.0) STOP '[Stop -- Chantd_Der not yet ready rpi/mrpi9.f]'
call grid%initialize()
call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
-C
-C *** initialize
+!
+! *** initialize
CALL Zero_Array (Wtsx, Ipnts)
-C
+!
Ac = Aaa*Ccc
Tt = Tau + Ccc/Two
Tta = Tz + Ccc/Two - Tzmn
@@ -702,7 +699,7 @@ C
Aae2x = Zero
A5c = Zero
END IF
-C
+!
Summax = Zero
DO Ie=1,Ipnts
eIe = grid%getEnergy(Ie+Kc-1, expData)
@@ -710,9 +707,9 @@ C
Ajacob = Time/(Two*eIe)
Timeij = Timej - Time
Sum = Zero
-C
+!
IF (Itdchi.NE.1) THEN
-C *** First the chi-squared term
+! *** First the chi-squared term
Time = Timeij + Tt
X = Aaa*Time
IF (Time.GT.Zero) THEN
@@ -739,11 +736,11 @@ C *** First the chi-squared term
END IF
END IF
END IF
-C
+!
Time = Timeij + Tta
IF (Time.GT.Zero) THEN
IF (Aae1.NE.Zero) THEN
-C *** Now the first exponential term
+! *** Now the first exponential term
X = A3*Time
IF (Time.LE.Ccc) THEN
IF (X.LT.Small) THEN
@@ -766,9 +763,9 @@ C *** Now the first exponential term
END IF
END IF
END IF
-C
+!
IF (Aae2.NE.Zero) THEN
-C *** Now the second exponential term
+! *** Now the second exponential term
X = A5*Time
IF (Time.LE.Ccc) THEN
IF (X.LT.Small) THEN
@@ -788,7 +785,7 @@ C *** Now the second exponential term
END IF
END IF
END IF
-C
+!
Wtsx(Ie) = Weight(Ie+Kc-1)*Sum*Ajacob
IF (Timeij.GT.Zero) THEN
IF (Sum.GT.Summax) THEN
@@ -803,10 +800,12 @@ C
END IF
END IF
END IF
-C
+!
END DO
60 CONTINUE
-C
+!
call grid%destroy()
RETURN
END
+
+end module rpi9_m
\ No newline at end of file
diff --git a/sammy/src/rpt/mrpt.f b/sammy/src/rpt/mrpt.f
index 3b74a23d0..6789fe362 100644
--- a/sammy/src/rpt/mrpt.f
+++ b/sammy/src/rpt/mrpt.f
@@ -22,7 +22,6 @@ C *** 2 SAM_RPI_TDXXX.ODF -- S1=time, S2=target+detector
C *** 3 SAM_RPI_CHANN.ODF -- S1=time, S2=channel-width component
C
C
- use mrpi5_m
use over_common_m
use oops_common_m
use fixedi_m
@@ -35,6 +34,10 @@ C
use rpirrr_common_m
use partyp_common_m
use EndfData_common_m
+ use rpi2_m
+ use rpi3_m
+ use rpi5_m
+ use par6_m
use GridData_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
diff --git a/sammy/src/rpt/mrpt1.f b/sammy/src/rpt/mrpt1.f
index c3099aa88..5b687cfa8 100644
--- a/sammy/src/rpt/mrpt1.f
+++ b/sammy/src/rpt/mrpt1.f
@@ -152,6 +152,7 @@ C
use rpijnk_common_m
use rpires_common_m
use rpirrr_common_m
+ use rpi6_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
C
CHARACTER*17 Xburst, XtdxxX, Xchann, Yburst, Ytdxxx, Ychann
diff --git a/sammy/src/rst/mrst0.f b/sammy/src/rst/mrst0.f90
similarity index 75%
rename from sammy/src/rst/mrst0.f
rename to sammy/src/rst/mrst0.f90
index baeaf86f0..8c46e3a34 100644
--- a/sammy/src/rst/mrst0.f
+++ b/sammy/src/rst/mrst0.f90
@@ -1,7 +1,9 @@
-C
-C
+!
+module rst_m
+ contains
+!
SUBROUTINE Samrst_0
-C
+!
use oops_common_m
use fixedi_m
use ifwrit_m
@@ -10,40 +12,42 @@ C
use brdd_common_m
use cbro_common_m
use lbro_common_m
+ use rst1_m
use AllocateFunctions_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
real(kind=8),allocatable,dimension(:)::A_IWts
-C
-C
+!
+!
WRITE (6,99999)
99999 FORMAT (' *** SAMMY-RST 2 Jan 08 ***')
Segmen(1) = 'R'
Segmen(2) = 'S'
Segmen(3) = 'T'
Nowwww = 0
-C
+!
CALL Initil
IF (Kplotu.NE.0) Kplotu = 0
-C
-C
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
-C
+!
+!
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
+!
Kdatb = Ndatb
-C *** one ***
+! *** one ***
Kddddd = Ndatb
call allocate_real_data(A_IWts, Kddddd)
-C
-C *** Resolt finds resolution function
+!
+! *** Resolt finds resolution function
CALL Resolt (A_Ibcf , A_Icf2 , A_Iresol , A_Iwts)
-C
-C
+!
+!
deallocate(A_IWts)
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
-C
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
+!
Jwwwww = 4
Jjjdop = 0
CALL Write_Commons_Few
CALL Run ('samend')
RETURN
-C
+!
END
+end module rst_m
diff --git a/sammy/src/rst/mrst1.f b/sammy/src/rst/mrst1.f90
similarity index 71%
rename from sammy/src/rst/mrst1.f
rename to sammy/src/rst/mrst1.f90
index 9efdf38ff..605b3b2e3 100644
--- a/sammy/src/rst/mrst1.f
+++ b/sammy/src/rst/mrst1.f90
@@ -1,11 +1,13 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module rst1_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Resolt (Bcf, Cf2, Eresol, Wts)
-C
-C *** PURPOSE -- FORM RESOLUTION BROADENing function
-C
+!
+! *** PURPOSE -- FORM RESOLUTION BROADENing function
+!
use fixedi_m
use ifwrit_m
use samxxx_common_m
@@ -16,13 +18,15 @@ C
use cbro_common_m
use lbro_common_m
use EndfData_common_m
+ use rst2_m
+ use rst3_m
use SammyGridAccess_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
type(GridData)::grid
DIMENSION Bcf(*), Cf2(*), Eresol(*), Wts(*)
-C
-C *** initialize limits
+!
+! *** initialize limits
Kc = 2
Iup = 1
Ipk = 1
@@ -33,11 +37,11 @@ C *** initialize limits
else
call expData%getGrid(grid, 1)
end if
-C
+!
DO 60 j=1,Nresol
Jj = j
-C
-C *** Choose energy at which to generate plot of resolution function
+!
+! *** Choose energy at which to generate plot of resolution function
Em = Eresol(j)
WRITE (6,10000) Em
WRITE (21,10000) Em
@@ -48,68 +52,67 @@ C *** Choose energy at which to generate plot of resolution function
10100 FORMAT (' Energy is outside Emin,Emax=', 2(1pg14.6))
GO TO 60
END IF
-C
+!
Emm = DBLE(Em)
-C
-C ****** find broadening parameters for energy-dependent Deltal
+!
+! ****** find broadening parameters for energy-dependent Deltal
IF (Kjdell.NE.0) THEN
Deltal = Dell11*Em + Dell00
Bo2 = (0.8164965809277260344600791d0*Deltal/Dist)**2
-C *** 0.816... = sqrt(2/3)
+! *** 0.816... = sqrt(2/3)
END IF
-C
-C ****** FIND INTEGRATION LIMITS AND WIDTHS
+!
+! ****** FIND INTEGRATION LIMITS AND WIDTHS
CALL Wdsinx (Bcf, Cf2, Em, Widgau, Widexp, Wlow, Wup)
-C
+!
Eup = Emm + DBLE(Wup)
Elow = Emm - DBLE(Wlow)
-C
-C ****** find location and extent of integration range
-C *** i.e. find point numbers Kc (min), iup(max), ipk (peak)
+!
+! ****** find location and extent of integration range
+! *** i.e. find point numbers Kc (min), iup(max), ipk (peak)
CALL Kount_Points (Elow, Eup, Em)
-C
+!
IF (Ipnts.GT.Ndatb) THEN
STOP '[STOP in Resolt in rst/mrst1.f]'
END IF
-C
+!
IF (Ipnts.LE.5) THEN
-C ****** too few points, no integration possible
+! ****** too few points, no integration possible
CALL Stett (Em, Ipnts, Ndatb)
ELSE
-C ****** enough points
+! ****** enough points
call grid%setRowOffset(Kc)
- CALL Getrsl (Wts, Widgau, Widexp, Est, Em,
- * Ifirst)
+ CALL Getrsl (Wts, Widgau, Widexp, Est, Em, Ifirst)
CALL Showrs (Wts, Ipnts, Jj)
call grid%setRowOffset(0)
END IF
-C
+!
60 CONTINUE
-C *** no more energies wanted, so stop
-C
+! *** no more energies wanted, so stop
+!
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Stett (Em, Ipnts, Ndatb)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
WRITE (6,10000) Em, Ipnts, Ndatb
-10000 FORMAT (' Too few points for resolution-broadening at energy=',
- * 1PG16.8, 2I5, /)
+10000 FORMAT (' Too few points for resolution-broadening at energy=', &
+ 1PG16.8, 2I5, /)
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Getrsl (Wts, Widgau, Widexp, Est, Em, Ifirst)
-C
-C *** PURPOSE -- FORM THE GAUSSIAN, EXPONENTIAL, OR
-C *** GAUSSIAN+EXPONENTIAL resolution function, AND
-C *** NORMALIZE THEM
-C
+!
+! *** PURPOSE -- FORM THE GAUSSIAN, EXPONENTIAL, OR
+! *** GAUSSIAN+EXPONENTIAL resolution function, AND
+! *** NORMALIZE THEM
+!
use fixedi_m
use ifwrit_m
use fixedr_m
@@ -120,24 +123,24 @@ C
use exerfc_m
use xxerfc_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
DIMENSION Wts(*)
type(SammyGridAccess)::grid
-C DIMENSION Wts(Ipnts)
-C
+! DIMENSION Wts(Ipnts)
+!
DATA Zero /0.0d0/, Half /0.5d0/
call grid%initialize()
call grid%setParameters(numcro, ktzero)
call grid%setToAuxGrid(expData)
-C
-C
-C
-C *** WEIGHTS FOR GAUSSIAN RESOLUTION BROADENING
-C
+!
+!
+!
+! *** WEIGHTS FOR GAUSSIAN RESOLUTION BROADENING
+!
IF (Iesopr.EQ.1) THEN
Ew = Em/Widgau
-C
+!
Y = 85.0D0
DO I=1,Ipnts
eI = grid%getEnergy(I, expData)
@@ -147,10 +150,10 @@ C
Z = dEXP(-Z)
Wts(I) = Z
END DO
-C
-C
-C *** EXPONENTIAL WEIGHTS FOR RESOLUTION BROADENING
-C
+!
+!
+! *** EXPONENTIAL WEIGHTS FOR RESOLUTION BROADENING
+!
ELSE IF (Iesopr.EQ.2) THEN
Y = 100.0D0
Ipnts1 = Ipnts + 1 - Ipke
@@ -158,26 +161,26 @@ C
DO I=1,Ipnts1
eI = grid%getEnergy(Ipke-Kc+I, expData)
Z = eI/DBLE(Widexp) - DBLE(Ew)
-C ????????????????????????????????????? Ipke-Kc+i ????????
+! ????????????????????????????????????? Ipke-Kc+i ????????
IF (Z.GT.Y) Z = Y
Z = dEXP(-Z)
Wts(I) = Z
-C ????????????????????????????????????
+! ????????????????????????????????????
END DO
-C
-C
-C *** GAUSSIAN PLUS EXPONENTIAL WEIGHTS FOR RESOLUTION BROADENING
-C
+!
+!
+! *** GAUSSIAN PLUS EXPONENTIAL WEIGHTS FOR RESOLUTION BROADENING
+!
ELSE IF (Iesopr.EQ.3) THEN
C = Widgau*Half/Widexp
IF (Kexpsh.EQ.1) THEN
Est = Shftge (C, Widgau, Est, Ifirst)
De = Em - Est
ELSE
-C IF (Kexpsh.EQ.0) De = Em
+! IF (Kexpsh.EQ.0) De = Em
De = Em
END IF
-C
+!
Y = DBLE(C*Widgau+De)
DO I=1,Ipnts
eI = grid%getEnergy(I, expData)
@@ -190,24 +193,25 @@ C
IF (A.EQ.Zero) THEN
Z = Zero
ELSE
-C IF (A.NE.Zero)
+! IF (A.NE.Zero)
Z = A * Exerfc(B)
END IF
END IF
-C ******** Should have Z=Z/SQRT(PI) but is normalization so why bother?
+! ******** Should have Z=Z/SQRT(PI) but is normalization so why bother?
Wts(I) = Z
END DO
-C
+!
END IF
-C
-C *** NORMALIZE WEIGHTS
-C
-C S = 1/sqrt(Pi)
+!
+! *** NORMALIZE WEIGHTS
+!
+! S = 1/sqrt(Pi)
S = 0.5641895835477562869480795d0
DO I=1,Ipnts
Wts(I) = Wts(I)*S
END DO
call grid%destroy()
-C
+!
RETURN
END
+end module rst1_m
\ No newline at end of file
diff --git a/sammy/src/rst/mrst2.f b/sammy/src/rst/mrst2.f90
similarity index 88%
rename from sammy/src/rst/mrst2.f
rename to sammy/src/rst/mrst2.f90
index 8b6282253..5ff235cb6 100755
--- a/sammy/src/rst/mrst2.f
+++ b/sammy/src/rst/mrst2.f90
@@ -1,13 +1,15 @@
-C
-C
-C __________________________________________________________________
-C
+!
+module rst2_m
+ contains
+!
+! __________________________________________________________________
+!
SUBROUTINE Showrs (Wts, Ipnts, Jj)
use modf3_M
IMPLICIT DOUBLE PRECISION (a-h,o-z)
procedure (arrayFunc), pointer :: f_ptr => auxEArray
DIMENSION Wts(*)
-C
+!
CHARACTER*17 Xxxxxx(8)
DATA Xxxxxx(1) /'SAMRS1.ODF '/
DATA Xxxxxx(2) /'SAMRS2.ODF '/
@@ -17,10 +19,10 @@ C
DATA Xxxxxx(6) /'SAMRS6.ODF '/
DATA Xxxxxx(7) /'SAMRS7.ODF '/
DATA Xxxxxx(8) /'SAMRS8.ODF '/
-C
-C
+!
+!
Ndat = Ipnts
-C
+!
J = Jj
Nsn = 2
New = 1
@@ -33,3 +35,4 @@ C
CALL Plt_Close (22)
RETURN
END
+end module rst2_m
diff --git a/sammy/src/rst/mrst3.f b/sammy/src/rst/mrst3.f90
similarity index 63%
rename from sammy/src/rst/mrst3.f
rename to sammy/src/rst/mrst3.f90
index acc7dd89e..7280c6f0c 100644
--- a/sammy/src/rst/mrst3.f
+++ b/sammy/src/rst/mrst3.f90
@@ -1,57 +1,58 @@
-C
-C
-C --------------------------------------------------------------
-C
+!
+module rst3_m
+ contains
+!
+! --------------------------------------------------------------
+!
SUBROUTINE Wdsinx (Bcf, Cf2, Ed, Widgau, Widexp, Wlow, Wup)
-C
-C *** PURPOSE -- GENERATE LOWER AND UPPER LIMITS TO RESOLUTION
-C *** INTEGRAL AND THE TWO WIDTHS Widgau AND Widexp
-C
+!
+! *** PURPOSE -- GENERATE LOWER AND UPPER LIMITS TO RESOLUTION
+! *** INTEGRAL AND THE TWO WIDTHS Widgau AND Widexp
+!
use ifwrit_m
use fixedr_m
use broad_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
DIMENSION Bcf(*), Cf2(*)
-C DIMENSION Bcf(Ncf), Cf2(Ncf)
- EXTERNAL Rolowx
+! DIMENSION Bcf(Ncf), Cf2(Ncf)
DATA Zero /0.0d0/
-C
-C
+!
+!
Brdlim = 5.0d0
E = ED
IF (Iesopr.EQ.1) THEN
-C *** GAUSSIAN
+! *** GAUSSIAN
Widgau = Rolowx (Bcf, Cf2, E)
Wlow = Brdlim*Widgau
Wup = Brdlim*Widgau
Widexp = Zero
RETURN
-C
+!
ELSE IF (Iesopr.EQ.2) THEN
-C *** EXPONENTIAL
+! *** EXPONENTIAL
Widgau = Zero
IF (Kedxfw.EQ.0) THEN
Widexp = E*Co2*dSQRT(E)
WRITE (6,10100) Widexp, Co2
WRITE (21,10100) Widexp, Co2
-10100 FORMAT (' Widexp =', 1PG14.6,
- * ' = E*dsqrt(E)*Co2', /,
- * ' where Co2 =', 1PG14.6)
+10100 FORMAT (' Widexp =', 1PG14.6, &
+ ' = E*dsqrt(E)*Co2', /, &
+ ' where Co2 =', 1PG14.6)
ELSE
Widexp = E*Co2
WRITE (6,10000) Widexp, Co2
WRITE (21,10000) Widexp, Co2
-10000 FORMAT (' Widexp =',1PG14.6,' = E**Co2',/,
- * ' where Co2 =', 1PG14.6)
+10000 FORMAT (' Widexp =',1PG14.6,' = E**Co2',/, &
+ ' where Co2 =', 1PG14.6)
END IF
Wlow = 0.5d0*Widexp
Wup = 6.25d0*Widexp
RETURN
-C
+!
ELSE IF (Iesopr.EQ.3) THEN
-C *** CONVOLUTION OF GAUSSIAN AND EXPONENTIAL
+! *** CONVOLUTION OF GAUSSIAN AND EXPONENTIAL
Widgau = Rolowx (Bcf, Cf2, E)
IF (Kedxfw.EQ.0) THEN
Widexp = E*Co2*dSQRT(E)
@@ -72,28 +73,28 @@ C *** CONVOLUTION OF GAUSSIAN AND EXPONENTIAL
Wup = Brdlim*Widgau
END IF
RETURN
-C
+!
ELSE
WRITE (6,20000) Iesopr
20000 FORMAT (' Error in routine Wdsint, Iesopr=', i5)
END IF
-C
+!
END
-C
-C
-C --------------------------------------------------------------
-C
+!
+!
+! --------------------------------------------------------------
+!
DOUBLE PRECISION FUNCTION Rolowx (Bcf, Cf2, E)
-C
-C *** PURPOSE -- GENERATE GAUSSIAN RESOLUTION WIDTH
-C
+!
+! *** PURPOSE -- GENERATE GAUSSIAN RESOLUTION WIDTH
+!
use fixedr_m
use broad_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
-C
+!
DIMENSION Bcf(*), Cf2(*)
-C DIMENSION Bcf(Ncf), Cf2(Ncf)
-C
+! DIMENSION Bcf(Ncf), Cf2(Ncf)
+!
IF (Ncf.NE.0) THEN
Icf = 1
DO N=1,Ncf
@@ -105,22 +106,23 @@ C
Rolowx = E*dSQRT((Ao2+Do2*Cf2(Icf))*E+Bo2)
WRITE (6,10000) Icf, Rolowx, Ao2, Do2, Cf2(Icf), Bo2
WRITE (21,10000) Icf, Rolowx, Ao2, Do2, Cf2(Icf), Bo2
-10000 FORMAT (' In region #', I2, ' Widgau =', 1PG14.6,
- * ' = E*sqrt((Ao2+Do2*Cf2)*E+Bo2)', /,
- * ' where Ao2 =', 1PG14.6, /,
- * ' Do2 =', 1PG14.6, /,
- * ' Cf2 =', 1PG14.6, /,
- * ' and Bo2 =', 1PG14.6)
-C
+10000 FORMAT (' In region #', I2, ' Widgau =', 1PG14.6, &
+ ' = E*sqrt((Ao2+Do2*Cf2)*E+Bo2)', /, &
+ ' where Ao2 =', 1PG14.6, /, &
+ ' Do2 =', 1PG14.6, /, &
+ ' Cf2 =', 1PG14.6, /, &
+ ' and Bo2 =', 1PG14.6)
+!
ELSE
-C
+!
Rolowx = E*dSQRT(Ao2*E+Bo2)
WRITE (6,10100) Rolowx, Ao2, Bo2
-10100 FORMAT (' Widgau =', 1PG14.6,
- * ' = E*sqrt(Ao2*E+Bo2)', /,
- * ' where Ao2 =', 1PG14.6, /,
- * ' and Bo2 =', 1PG14.6)
-C
+10100 FORMAT (' Widgau =', 1PG14.6, &
+ ' = E*sqrt(Ao2*E+Bo2)', /, &
+ ' where Ao2 =', 1PG14.6, /, &
+ ' and Bo2 =', 1PG14.6)
+!
END IF
RETURN
END
+end module rst3_m
\ No newline at end of file
diff --git a/sammy/src/sam/msam.F b/sammy/src/sam/msam.F
index 931c03d1e..663264ac7 100755
--- a/sammy/src/sam/msam.F
+++ b/sammy/src/sam/msam.F
@@ -17,8 +17,12 @@ C
use MultScatPars_common_m
use ExpPars_common_m
use Observable_common_m
+ use acs_m
use ssm_m
use fff_m
+ use rpi_m
+ use rst_m
+ use par_m
use Samdat_0_M
use Samodf_0_m
use Sammas_0_m
diff --git a/sammy/src/sammy/CMakeLists.txt b/sammy/src/sammy/CMakeLists.txt
index d3fac9db9..1e0ea3096 100644
--- a/sammy/src/sammy/CMakeLists.txt
+++ b/sammy/src/sammy/CMakeLists.txt
@@ -17,10 +17,10 @@ APPEND_SET(SAMMY_SOURCES
../sam/msam0.f
../sam/msam_run.f
- ../acs/macs0.f
- ../acs/macs1.f
- ../acs/macs2.f
- ../acs/macs3.f
+ ../acs/macs0.f90
+ ../acs/macs1.f90
+ ../acs/macs2.f90
+ ../acs/macs3.f90
../acs/macs4.f
../acs/macs5.f
../acs/macs6.f
@@ -156,6 +156,8 @@ APPEND_SET(SAMMY_SOURCES
../fnc/abcexp.f90
../fnc/abclog.f90
../fnc/xxerfc.f90
+ ../fnc/fexq.f90
+ ../fnc/xerfcx.f90
../grp/mgrp0.f
../grp/mgrp1.f
@@ -349,26 +351,26 @@ APPEND_SET(SAMMY_SOURCES
../orr/morr5.f
../orr/morr6.f
- ../par/mpar0.f
- ../par/mpar01.f
- ../par/mpar02.f
- ../par/mpar03.f
- ../par/mpar04.f
- ../par/mpar05.f
- ../par/mpar06.f
- ../par/mpar07.f
- ../par/mpar08.f
- ../par/mpar09.f
- ../par/mpar10.f
- ../par/mpar11.f
+ ../par/mpar0.f90
+ ../par/mpar01.f90
+ ../par/mpar02.f90
+ ../par/mpar03.f90
+ ../par/mpar04.f90
+ ../par/mpar05.f90
+ ../par/mpar06.f90
+ ../par/mpar07.f90
+ ../par/mpar08.f90
+ ../par/mpar09.f90
+ ../par/mpar10.f90
+ ../par/mpar11.f90
../par/mpar12.f90
- ../par/mpar13.f
- ../par/mpar14.f
- ../par/mpar15.f
- ../par/mpar16.f
- ../par/mpar17.f
- ../par/mpar18.f
- ../par/mpar19.f
+ ../par/mpar13.f90
+ ../par/mpar14.f90
+ ../par/mpar15.f90
+ ../par/mpar16.f90
+ ../par/mpar17.f90
+ ../par/mpar18.f90
+ ../par/mpar19.f90
../qua/mqua0.f
../qua/mqua1.f
@@ -391,16 +393,16 @@ APPEND_SET(SAMMY_SOURCES
../rec/mrec7.f
../rec/mrec8.f90
- ../rpi/mrpi0.f
- ../rpi/mrpi1.f
- ../rpi/mrpi2.f
- ../rpi/mrpi3.f
- ../rpi/mrpi4.f
+ ../rpi/mrpi0.f90
+ ../rpi/mrpi1.f90
+ ../rpi/mrpi2.f90
+ ../rpi/mrpi3.f90
+ ../rpi/mrpi4.f90
../rpi/mrpi5.f90
- ../rpi/mrpi6.f
- ../rpi/mrpi7.f
- ../rpi/mrpi8.f
- ../rpi/mrpi9.f
+ ../rpi/mrpi6.f90
+ ../rpi/mrpi7.f90
+ ../rpi/mrpi8.f90
+ ../rpi/mrpi9.f90
../rsl/mrsl0.f
../rsl/mrsl1.f90
@@ -412,10 +414,10 @@ APPEND_SET(SAMMY_SOURCES
../rsl/mrsl7.f
- ../rst/mrst0.f
- ../rst/mrst1.f
- ../rst/mrst2.f
- ../rst/mrst3.f
+ ../rst/mrst0.f90
+ ../rst/mrst1.f90
+ ../rst/mrst2.f90
+ ../rst/mrst3.f90
../squ/msqu0.f
--
GitLab