diff --git a/sammy/src/amr/mamr.f b/sammy/src/amr/mamr.f
index c9445bb7f2ba8de6761b3c18f63b166a3069dec0..0b45733656c3306eaed88c966de8067a9c1238ce 100644
--- a/sammy/src/amr/mamr.f
+++ b/sammy/src/amr/mamr.f
@@ -92,34 +92,12 @@ C
Kompct = 0
Iuncer = Idimen (K, 1, 'K, 1')
C
- Ipoint = 1
Krext = Nrext
IF (Nrext.EQ.0) Krext = 1
C *** In samamr, Nowrt=0... in samold, Nowrt=1
Nowrt = 0
C
IF (Ifold.EQ.0) THEN
- N = Max0 ( Numiso, Numdet, Numbrd, Nummsc, 4*Numpmc, Numorr,
- * Nmdets, Numrpi, Numudr, Numbgf, Nvpall_Old, Ntefil*Ntepnt,1)
- M = Max0 ( Numnbk, Numrpi-Nnnrpi, Numudr-Nnnudr, Numbgf,
- * Ntefil*Ntepnt, 1 )
- Idum1 = Idimen (N, 1, 'N, 1')
- Idum2 = Idimen (M, 1, 'M, 1')
- N = (N+1)/2
- Idiot1 = Idimen (N, 1, 'N, 1')
- M = Max0 ( Ngroup, Numnbk, Numpmc, Numbgf, 1 )
- M = (M+1)/2
- Idiot2 = Idimen (M, 1, 'M, 1')
- K = Nvpall
- N = K**2
- M = (K+1)/2
- Ivsqua = Idimen (N, 1, 'Vsqua N , 1')
- Ieival = Idimen (N, 1, 'Eival N , 1')
- Ieivec = Idimen (N, 1, 'Eivec N , 1')
- Izeiv = Idimen (N, 1, 'Zeiv N , 1 ')
- Ideiv = Idimen (K, 1, 'Deiv N , 1 ')
- Iiord = Idimen (M, 1, 'Iord N , 1 ')
- Ikord = Idimen (M, 1, 'Kord N , 1 ')
C
C *** SUB ROUTINE Rdcov READS BINARY FILE CONTAINING INFORMATION FROM
C *** PREVIOUS RUN, INCLUDING COVARIANCE MATRICES, PARAMETER
@@ -138,10 +116,7 @@ C *** VALUES, ETC.
2 A_Iprbgf , I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma ,
3 A_Itexbg , A_Iteabg , A_Iprdtp , I_Ifldtp ,
4 A_Iprusd , I_Iflusd , A_Iprbag , I_Iflbag ,
- * A(Ivrpr ), A(Iallva), A(Ipoint),
- * A(Idum1 ), A(Idum2 ), A(Idiot1), A(Idiot2),
- * A(Ivsqua), A(Ieival), A(Ieivec), A(Izeiv ), A(Ideiv ),
- * A(Iiord ), A(Ikord ),
+ * A(Ivrpr ), A(Iallva),
* Krext , Nowrt , Nvpall_Old)
ELSE
Nsingl = Nres*10
@@ -159,7 +134,7 @@ C *** VALUES, ETC.
* A_Iprbgf , I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma ,
* A_Iprdtp , I_Ifldtp ,
* A_Iprusd , I_Iflusd , A_Iprbag , I_Iflbag ,
- * A(Ia ), A(Ia ), A(Ipoint),
+ * A(Ia ), A(Ia ),
* A(Isingl), Krext, Nowrt, Nsingl, Nvpall_Old)
C
END IF
diff --git a/sammy/src/amx/mamx.f b/sammy/src/amx/mamx.f
index 86c182066cc28e05ad71250d8a249561d4911062..72849535df3a320576a6e0284d904a4baf29b29b 100644
--- a/sammy/src/amx/mamx.f
+++ b/sammy/src/amx/mamx.f
@@ -91,34 +91,12 @@ C
Iuncer = Idimen (K , 1, 'K , 1')
Kompct = 0
C
- Ipoint = 1
Krext = Nrext
IF (Nrext.EQ.0) Krext = 1
C *** in samamr, Nowrt=0... in samold, Nowrt=1
Nowrt = 0
C
IF (Ifold.EQ.0) THEN
- N = Max0 ( Numiso, Numdet, Numbrd, Nummsc, 4*Numpmc, Numorr,
- * Nmdets, Numrpi, Numudr, Numbgf, Nvpall_Old, Ntefil*Ntepnt,1)
- M = Max0 ( Numnbk, Numrpi-Nnnrpi, Numudr-Nnnudr, Numbgf,
- * Ntefil*Ntepnt, 1 )
- Idum1 = Idimen (N, 1, 'N, 1')
- Idum2 = Idimen (M, 1, 'M, 1')
- N = (N+1)/2
- Idiot1 = Idimen (N, 1, 'N, 1')
- M = Max0 ( Ngroup, Numnbk, Numpmc, Numbgf, 1 )
- M = (M+1)/2
- Idiot2 = Idimen (M, 1, 'M, 1')
- K = Nvpall
- N = K**2
- M = (K+1)/2
- Ivsqua = Idimen (N, 1, 'Vsqua N , 1')
- Ieival = Idimen (N, 1, 'Eival N , 1')
- Ieivec = Idimen (N, 1, 'Eivec N , 1')
- Izeiv = Idimen (N, 1, 'Zeiv N , 1 ')
- Ideiv = Idimen (K, 1, 'Deiv N , 1 ')
- Iiord = Idimen (M, 1, 'Iord N , 1 ')
- Ikord = Idimen (M, 1, 'Kord N , 1 ')
C
C *** SUB ROUTINE rdcov READS BINARY FILE CONTAINING INFORMATION FROM
C *** PREVIOUS RUN, INCLUDING COVARIANCE MATRICES, PARAMETER
@@ -138,10 +116,7 @@ C &&& from old/mold2.f
* A_Iprbgf , I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma ,
* A_Itexbg , A_Iteabg , A_Iprdtp , I_Ifldtp ,
* A_Iprusd , I_Iflusd , A_Iprbag , I_Iflbag ,
- * A(Ivrpr ), A(Iallva), A(Ipoint),
- * A(Idum1 ), A(Idum2 ), A(Idiot1), A(Idiot2),
- * A(Ivsqua), A(Ieival), A(Ieivec), A(Izeiv ), A(Ideiv ),
- * A(Iiord ), A(Ikord ),
+ * A(Ivrpr ), A(Iallva),
* Krext , Nowrt , Nvpall_Old)
ELSE
Nsingl = Nres*10
@@ -160,7 +135,7 @@ c &&& from old/mold5.f
* A_Iprbgf , I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma ,
* A_Iprdtp , I_Ifldtp ,
* A_Iprusd , I_Iflusd , A_Iprbag , I_Iflbag ,
- * A(Ia ), A(Ia ), A(Ipoint),
+ * A(Ia ), A(Ia ),
* A(Isingl), Krext, Nowrt, Nsingl, Nvpall_Old)
C
END IF
diff --git a/sammy/src/ang/mang0.f b/sammy/src/ang/mang0.f
index eee08a4d91e2df40103da831a1567e16903fa5dc..4ff442bf3d2e5a863f661e0819bd10f0a58cadef 100644
--- a/sammy/src/ang/mang0.f
+++ b/sammy/src/ang/mang0.f
@@ -69,8 +69,8 @@ C *** Generate differential elastic cross sections from Coefficients of P_L
CALL Diffee (I_Inent , I_Ilspin , A_Izke ,
* A_Izeta , A_Iccoul , A_Idcoul , A_Iangle , A_Idangl , A_Iprmsc ,
* I_Iflmsc , A_Iprnbk , I_Iflnbk , A(Ie ), A(Ieb ),
- * A(Ith ), I_Iisopa , A(Iwsigx), A(Iwdasi), A(Iwdbsi), A(Isigxx),
- * A(Idasig), A(Idbsig), A(Ivsigx), A(Ivdasi), A(Ivdbsi), A(Icccll),
+ * A(Ith ), I_Iisopa , A(Iwsigx), A(Iwdasi), A_Iwdbsi , A(Isigxx),
+ * A(Idasig), A(Idbsig), A(Ivsigx), A(Ivdasi), A_Ivdbsi , A(Icccll),
* A(Ipoly ), A(Itotal), A(Idtota), A(Iprime), A(Ipolyx), A(Icoman),
* I_Ixciso , A_Icmlab , I_Isoqva , A(Isoq ), A(Iruth ), Kdatb, Np)
C
diff --git a/sammy/src/avg/mavg0.f b/sammy/src/avg/mavg0.f
index 0aa3fd491099a84def1a80f4db01eaa8dd65f47b..01b5e861fec82dfce160a06dc75a19596ad813b9 100755
--- a/sammy/src/avg/mavg0.f
+++ b/sammy/src/avg/mavg0.f
@@ -13,7 +13,27 @@ C
use samxxx_common_m
use array_sizes_common_m
use oopsch_common_m
+ use AllocateFunctions_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ real(kind=8),allocatable,dimension(:)::A_Iuncd
+ integer,allocatable,dimension(:)::I_Imin
+ integer,allocatable,dimension(:)::I_Imax
+ real(kind=8),allocatable,dimension(:)::A_Iemn
+ real(kind=8),allocatable,dimension(:)::A_Iemx
+ real(kind=8),allocatable,dimension(:)::A_Ideld
+ real(kind=8),allocatable,dimension(:)::A_Idelu
+ real(kind=8),allocatable,dimension(:)::A_Inorm
+ real(kind=8),allocatable,dimension(:)::A_Idatq
+ real(kind=8),allocatable,dimension(:)::A_Ivarq
+ real(kind=8),allocatable,dimension(:)::A_Itheq
+ real(kind=8),allocatable,dimension(:)::A_Igq
+ real(kind=8),allocatable,dimension(:)::A_Immmq
+ real(kind=8),allocatable,dimension(:)::A_Iunct
+ integer,allocatable,dimension(:)::I_Iic
+ real(kind=8),allocatable,dimension(:)::A_Idel
+ real(kind=8),allocatable,dimension(:)::A_Ixq
+ real(kind=8),allocatable,dimension(:)::A_Idata
+ real(kind=8),allocatable,dimension(:)::A_Ivarda
DIMENSION A(-Msize:Msize)
C
C
@@ -61,12 +81,12 @@ C *** even though it is opposite for other modules
C
CALL Oldopn (Iu2627, Sam26x, 0)
C
- Idata = Idimen (Ndat , 1, 'Idata Ndat , 1')
- Ivarda = Idimen (Ndatt, 1, 'Ivarda Ndatt, 1')
+ call allocate_real_data(A_Idata, Ndat)
+ call allocate_real_data(A_Ivarda, Ndatt)
C
C ******************************************************************
C *** Read experimental data ***************************************
- CALL Get_Exp_Data (A(Idata), A(Ivarda), A(Ivarda), A(Istat),
+ CALL Get_Exp_Data (A_Idata, A_Ivarda, A_Ivarda, A(Istat),
* Ndat, Ndatt, Kdatv, Ifree)
C
C
@@ -84,28 +104,28 @@ C *** now we're done
C
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -<
- Imin = Idimen (Ndatq, 1, 'Imin Ndatq, 1')
- Imax = Idimen (Ndatq, 1, 'Imax Ndatq, 1')
- Iemn = Idimen (Ndatq, 1, 'Iemn Ndatq, 1')
- Iemx = Idimen (Ndatq, 1, 'Iemx Ndatq, 1')
+ call allocate_integer_data(I_Imin, Ndatq)
+ call allocate_integer_data(I_Imax, Ndatq)
+ call allocate_real_data(A_Iemn, Ndatq)
+ call allocate_real_data(A_Iemx, Ndatq)
C
C
- CALL Qrange (A(Iemn), A(Iemx), A, A, Ax, Ndatq, Nxxxxx)
+ CALL Qrange (A_Iemn, A_Iemx, A, A, Ax, Ndatq, Nxxxxx)
C *** SUBROUTINE Qrange reads energy-limits on the averaging bins
C
- Ideld = Idimen (Ndatq , 1, 'Ideld Ndatq , 1')
- Idelu = Idimen (Ndatq , 1, 'Idelu Ndatq , 1')
- Inorm = Idimen (Ndatq , 1, 'Inorm Ndatq , 1')
+ call allocate_real_data(A_Ideld, Ndatq)
+ call allocate_real_data(A_Idelu, Ndatq)
+ call allocate_real_data(A_Inorm, Ndatq)
Ndatqq= (Ndatq*(Ndatq+1))/2
- Idatq = Idimen (Ndatq , 1, 'Idatq Ndatq , 1')
- Ivarq = Idimen (Ndatqq, 1, 'Ivarq Ndatqq, 1')
- Itheq = Idimen (Ndatq , 1, 'Itheq Ndatq , 1')
- Igq = Idimen (Nvpall*Ndatq, 1, 'Igq Nvpall*Ndatq, 1')
- Immmq = Idimen (Ndatqq, 1, 'Immmq Ndatqq, 1')
- Iuncd = Idimen (Ndatq , 1, 'Iuncd Ndatq , 1')
- Iunct = Idimen (Ndatq , 1, 'Iunct Ndatq , 1')
- Iic = Idimen (Ndatq , 1, 'Iic Ndatq , 1')
- Idel = Idimen (Kdat , 1, 'Idel Kdat , 1')
+ call allocate_real_data(A_Idatq, Ndatq)
+ call allocate_real_data(A_Ivarq, Ndatqq)
+ call allocate_real_data(A_Itheq, Ndatq)
+ call allocate_real_data(A_Igq,Nvpall*Ndatq)
+ call allocate_real_data(A_Immmq,Ndatqq)
+ call allocate_real_data(A_Iuncd, Ndatq)
+ call allocate_real_data(A_Iunct, Ndatq)
+ call allocate_integer_data(I_Iic, Ndatq)
+ call allocate_real_data(A_Idel, Kdat)
C
C
C =======================================================================
@@ -114,37 +134,36 @@ C =======================================================================
C
C
Ien = Ienerg
- CALL Getdel (A(Idel), A(Ien), A(Imin), A(Imax), A(Iemn),
- * A(Iemx), A(Ideld), A(Idelu), Ndatq, Kind, Ndat)
+ CALL Getdel (A_Idel, A(Ien), I_Imin, I_Imax, A_Iemn,
+ * A_Iemx, A_Ideld, A_Idelu, Ndatq, Kind, Ndat)
C *** routine Getdel determines Del, Deld, And Delu, based on
C *** type (Kind) specified in the file, read in Tryrng & Range
C
- CALL Xnorm (A(Idel), A(Imin), A(Imax), A(Ideld), A(Idelu),
- * A(Inorm), Ndatq)
+ CALL Xnorm (A_Idel, I_Imin, I_Imax, A_Ideld, A_Idelu,
+ * A_Inorm, Ndatq)
C *** routine Xnorm generates the normalization factors
C
C
- CALL Gen_Avg_Data (A(Idel), A(Imin), A(Imax), A(Ideld),
- * A(Idelu), A(Inorm), A(Idatq), A(Idata), Ndatq)
+ CALL Gen_Avg_Data (A_Idel, I_Imin, I_Imax, A_Ideld,
+ * A_Idelu, A_Inorm, A_Idatq, A_Idata, Ndatq)
C *** sub Gen_Avg_Data generates averaged data Datq
C
N = Kkkidc*Ndatq
IF (N.EQ.0) N = 1
- Ixq = Idimen (N, 1, 'Ixq N , 1')
- CALL Datfix (A(Idel), A(Imin), A(Imax), A(Ideld), A(Idelu),
- * A(Inorm), A(Ivarq), A(Ivarda), A(Iw), A_Ix, A(Ixq), Ndatq,
+ call allocate_real_data(A_Ixq,N)
+ CALL Datfix (A_Idel, I_Imin, I_Imax, A_Ideld, A_Idelu,
+ * A_Inorm, A_Ivarq, A_Ivarda, A(Iw), A_Ix, A_Ixq, Ndatq,
* Ndatt, Numidc, Ifree, Kkkidc, Noffcv, Nidc, Kpup)
C *** routine Datfix generates averaged data cov matrix Varq
- I = Idimen (Ixq, -1, ' Ixq , -1')
+ deallocate(A_Ixq)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ->
C
-
- CALL Qprint (1, A(Iemn), A(Iemx), A(Idatq), A(Ivarq), A(Iuncd),
+ CALL Qprint (1, A_Iemn, A_Iemx, A_Idatq, A_Ivarq, A_Iuncd,
* Ndatq)
C *** Here Qprint prints averaged Data results
C
IF (Ndatq.GT.1) THEN
- CALL Write_Std_and_Corr (A(Ivarq), A(Iuncd), A(Iic), Ndatq)
+ CALL Write_Std_and_Corr (A_Ivarq, A_Iuncd, I_Iic, Ndatq)
C *** Write_Std_and_Corr generates uncertainty, prints correlation
END IF
C
@@ -162,22 +181,22 @@ C
C IF (Knocor.EQ.1) THEN
C *** Here need to regenerate the Del's because different energy scale
Ien = Ienerb
- CALL Getdel (A(Idel), A(Ien), A(Imin), A(Imax), A(Iemn),
- * A(Iemx), A(Ideld), A(Idelu), Ndatq, Kind, Kdat)
- CALL Xnorm (A(Idel), A(Imin), A(Imax), A(Ideld), A(Idelu),
- * A(Inorm), Ndatq)
+ CALL Getdel (A_Idel, A(Ien), I_Imin, I_Imax, A_Iemn,
+ * A_Iemx, A_Ideld, A_Idelu, Ndatq, Kind, Kdat)
+ CALL Xnorm (A_Idel, I_Imin, I_Imax, A_Ideld, A_Idelu,
+ * A_Inorm, Ndatq)
END IF
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -<
- CALL Gen_Avg_Data (A(Idel), A(Imin), A(Imax), A(Ideld),
- * A(Idelu), A(Inorm), A(Itheq), A(Ith), Ndatq)
+ CALL Gen_Avg_Data (A_Idel, I_Imin, I_Imax, A_Ideld,
+ * A_Idelu, A_Inorm, A_Itheq, A(Ith), Ndatq)
C *** sub Gen_Avg_Data averages the theoretical values
C
- CALL Gfix (A(Idel), A(Imin), A(Imax), A(Ideld), A(Idelu),
- * A(Inorm), A(Igq), A_Ig, Ndatq, Kdat)
+ CALL Gfix (A_Idel, I_Imin, I_Imax, A_Ideld, A_Idelu,
+ * A_Inorm, A_Igq, A_Ig, Ndatq, Kdat)
C *** sub Gfix converts from G to Gq (Ie, averages the partial ders)
C
- CALL Thefix (A(Immmq), A(Igq), Ndatq, Ndatqq)
+ CALL Thefix (A_Immmq, A_Igq, Ndatq, Ndatqq)
C *** routine Thefix finds covariance on theoretical cross sections
C *** using covariance on parameters + avg'd partial derivatives
C
@@ -189,24 +208,23 @@ C *** and prints the partial derivatives (sensitivities) into
C *** file SAMSEN.DAT
END IF
C
- CALL Qprint (2, A(Iemn), A(Iemx), A(Itheq), A(Immmq), A(Iunct),
+ CALL Qprint (2, A_Iemn, A_Iemx, A_Itheq, A_Immmq, A_Iunct,
* Ndatq)
C *** here Qprint finds Unct and prints averaged Theory results
C
IF (Ndatq.GT.1) THEN
- CALL Write_Std_and_Corr (A(Immmq), A(Iunct), A(Iic), Ndatq)
+ CALL Write_Std_and_Corr (A_Immmq, A_Iunct, I_Iic, Ndatq)
C *** Write_Std_and_Corr writes correlation matrix
END IF
C
- CALL Both (1, A(Iemn), A(Iemx), A(Idatq), A(Iuncd), A(Itheq),
- * A(Iunct), Ndatq)
+ CALL Both (1, A_Iemn, A_Iemx, A_Idatq, A_Iuncd, A_Itheq,
+ * A_Iunct, Ndatq)
C *** routine Both prints data and Theory side-by-side
C
- IF (K33fil.EQ.1) CALL File33 (A(Iemn), A(Iemx), A(Itheq),
- * A(Immmq), A_Ix, A(Iic), Ndatq)
+ IF (K33fil.EQ.1) CALL File33 (A_Iemn, A_Iemx, A_Itheq,
+ * A_Immmq, A_Ix, I_Iic, Ndatq)
C
C
- I = Idimen (Imin, -1, ' Imin, -1')
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ->
C =======================================================================
C Finished. Now start over with new grouping, if desired.
@@ -227,6 +245,25 @@ C
CALL Again (A, Aaa, Bbb)
CALL Run ('samdat')
END IF
+
+ deallocate(A_Iuncd)
+ deallocate(I_Imin)
+ deallocate(I_Imax)
+ deallocate(A_Iemn)
+ deallocate(A_Iemx)
+ deallocate(A_Ideld)
+ deallocate(A_Idelu)
+ deallocate(A_Inorm)
+ deallocate(A_Idatq)
+ deallocate(A_Ivarq)
+ deallocate(A_Itheq)
+ deallocate(A_Igq)
+ deallocate(A_Immmq)
+ deallocate(A_Iunct)
+ deallocate(I_Iic)
+ deallocate(A_Idel)
+ deallocate(A_Idata)
+ deallocate(A_Ivarda)
RETURN
C
END
diff --git a/sammy/src/blk/Array_sizes_common.f90 b/sammy/src/blk/Array_sizes_common.f90
index 7943f2ae87051b04a3eb7a98a5864aff480b319f..f29661fafe983b236ce2cbf64a326b249a727804 100644
--- a/sammy/src/blk/Array_sizes_common.f90
+++ b/sammy/src/blk/Array_sizes_common.f90
@@ -24,7 +24,8 @@ module array_sizes_common_m
integer, save :: Kvdbss
integer, save :: Iwsigx
integer, save :: Iwdasi
- integer, save :: Iwdbsi
+ real(kind=8),pointer,dimension(:)::A_Iwdbsi
+ real(kind=8),allocatable,dimension(:),target::A_Iwdbsi_r
integer, save :: Iwsigs
real(kind=8),pointer,dimension(:)::A_Iwdass
real(kind=8),allocatable,dimension(:),target::A_Iwdass_r
@@ -38,7 +39,9 @@ module array_sizes_common_m
integer, save :: Idbsis
integer, save :: Ivsigx
integer, save :: Ivdasi
- integer, save :: Ivdbsi
+ real(kind=8),pointer,dimension(:)::A_Ivdbsi
+ real(kind=8),allocatable,dimension(:),target::A_Ivdbsi_r
+ logical::IvdbsiChanged
integer, save :: Ivsigs
integer, save :: Ivdass
real(kind=8),pointer,dimension(:)::A_Ivdass
@@ -69,4 +72,25 @@ contains
A_Iwdass => A_Iwdass_r
IvdassChanged = .false.
end subroutine make_A_Iwdass
+
+ subroutine make_A_Iwdbsi(want)
+ integer::want
+ call allocate_real_data(A_Iwdbsi_r,want)
+ A_Iwdbsi => A_Iwdbsi_r
+ call allocate_real_data(A_Ivdbsi_r,want)
+ A_Ivdbsi => A_Ivdbsi_r
+ IvdbsiChanged = .false.
+ end subroutine make_A_Iwdbsi
+
+ subroutine make_A_Iwdbsi_only(want)
+ integer::want
+
+ if( .not.IvdbsiChanged) then
+ call allocate_real_data(A_Iwdbsi_r,want)
+ A_Iwdbsi => A_Iwdbsi_r
+ else
+ call allocate_real_data(A_Ivdbsi_r,want)
+ A_Iwdbsi => A_Ivdbsi_r
+ end if
+ end subroutine make_A_Iwdbsi_only
end module array_sizes_common_m
diff --git a/sammy/src/clm/mclm0.f b/sammy/src/clm/mclm0.f
index 89e2f86c356ccdb570b9828df275be9e92a1961f..187637327a90297df903d7a1dc6d6c95d975fe9a 100644
--- a/sammy/src/clm/mclm0.f
+++ b/sammy/src/clm/mclm0.f
@@ -99,10 +99,10 @@ C
C *** Dopclm performs CLM Doppler operation
CALL Dopclm ( I_Iflmsc , A_Iprnbk , I_Iflnbk , A_Iprbgf ,
* I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma , A_Itexbg , A_Iteabg ,
- * A(Ie),A(Ieb), A(Ith), A(Iwsigx), A(Iwdasi), A(Iwdbsi), A(Iwsigs),
+ * A(Ie),A(Ieb), A(Ith), A(Iwsigx), A(Iwdasi), A_Iwdbsi , A(Iwsigs),
* A_Iwdass , A_Iwdbss , A(Isigxx), A(Idasig), A(Idbsig), A(Ixsigx),
* A(Ixdasi), A(Ixdbsi), A(Isigsi),
- * A(Idasis), A(Idbsis), A(IVsigx), A(IVdasi), A(IVdbsi), A(IVsigs),
+ * A(Idasis), A(Idbsis), A(IVsigx), A(IVdasi), A_IVdbsi , A(IVsigs),
* A_Ivdass , A_Ivdbss , I_Iisopa , I_Ixciso ,
* A_IbetaGrid, A(Ioscwt), A(Ioscex), A(Ioscsn), A(Ioscco), A(Ibex),
* A(Isexpb), A(Isexxx), A(Isave ), A(Ibs ), A(Iss ), A(Imaxt ),
diff --git a/sammy/src/cro/mcro0.f b/sammy/src/cro/mcro0.f
index d7a9737e7d36f3100aab7bf10a688923c7996b5e..20061fe6e70b1ba6b8d086dc2771063022010e8b 100644
--- a/sammy/src/cro/mcro0.f
+++ b/sammy/src/cro/mcro0.f
@@ -179,7 +179,7 @@ C *** eight ***
CALL Work_Cro (A, I_Iflmsc , A_Iprnbk , I_Iflnbk , A_Iprbgf ,
* I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma , A_Itexbg ,
* A_Iteabg , A(Ienerb), A(Ith ), A(Iwsigx), A(Iwdasi),
- * A(Iwdbsi), A(Isigxx), A(Idasig), A(Idbsig), I_Iisopa ,
+ * A_Iwdbsi , A(Isigxx), A(Idasig), A(Idbsig), I_Iisopa ,
* A(Ipiece), A(Idum ), A_Iadder , A_Iaddcr ,
* I_Inbt , I_Iint , I_Intot )
C *** Sbroutine Work_Cro generates theory and derivatives
diff --git a/sammy/src/dat/mdat0.f b/sammy/src/dat/mdat0.f
index 27111521a617063bb3a35bb4e69d1c6596036e6e..0559a47a32980968224099493715c77d594fd093 100644
--- a/sammy/src/dat/mdat0.f
+++ b/sammy/src/dat/mdat0.f
@@ -12,7 +12,10 @@ C
use rpijnk_common_m
use rpires_common_m
use rpirrr_common_m
+ use AllocateFunctions_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ real(kind=8),allocatable,dimension(:)::A_Iedrpi, A_Ixxrpi
+ real(kind=8),allocatable,dimension(:)::A_J1, A_J2
real(kind=8),target::A(-Msize:Msize)
C
Segmen(1) = 'D'
@@ -40,7 +43,7 @@ C
N = 1
Kxxrpi = 1
END IF
- Iedrpi = Idimen (N, 1, 'N, 1')
+ call allocate_real_data(A_Iedrpi, N)
IF (Mmmrpi.GT.0) THEN
N = Mmmrpi
Kmmrpi = 8
@@ -48,23 +51,27 @@ C
N = 1
Kmmrpi = 1
END IF
- Ixxrpi = Idimen (N, 1, 'N, 1')
+ call allocate_real_data(A_Ixxrpi, N)
N = Nudtim
- J1 = Idimen (N, 1, 'N, 1')
- J2 = Idimen (N, 1, 'N, 1')
+ call allocate_real_data(A_J1, N)
+ call allocate_real_data(A_J2, N)
C *** Extract dimensions and positions in file for energy & data
- I = Idimen (1, 1, '1, 1')
- Ii = Msize/2 - I/2 - 2
- Ix = Idimen (Ii, 1, 'Ii, 1')
+C Data can take all that is left of the array - only used for reading
+ Ix = Idimen (1, 1, '1, 1')
+ Ii = Msize/2 - Ix/2 - 2
Krext = Nrext
IF (Nrext.EQ.0) Krext = 1
CALL Read00 (I_Intot , A_Ibcf , A_Icf2 , A_Idpiso ,
* A_Iprext , I_Iflext , A_Iprorr , A_Icrnch , A_Iedets ,
- * A_Iseses , A_Iesese , A_Iprrpi , A(Iedrpi), A(Ixxrpi),
+ * A_Iseses , A_Iesese , A_Iprrpi , A_Iedrpi, A_Ixxrpi ,
* A_Iprudr , I_Inud_E , I_Inud_T , A_Iude , A_Iudr , A_Iudt ,
- * A(J1), A(J2), A(Ix), Krext, Ii, Iwhich, Mind, Mine, Maxe,
+ * A_J1 , A_J2, A(Ix), Krext, Ii, Iwhich, Mind, Mine, Maxe,
* Maxd, Nmax)
- I = Idimen (J1, -1, 'J1, -1')
+ I = Idimen (Ix, -1, 'J1, -1')
+ deallocate(A_Iedrpi)
+ deallocate(A_Ixxrpi)
+ deallocate(A_J1)
+ deallocate(A_J2)
C
C
C *** GUESSTIMATE ARRAY Sizes
diff --git a/sammy/src/dat/mdat1.f b/sammy/src/dat/mdat1.f
index ed9ecdb8bdf7e051fcbe26d77d610841bc86615d..97e69d38a2b72f3623bc95d8201ca46d13658d18 100644
--- a/sammy/src/dat/mdat1.f
+++ b/sammy/src/dat/mdat1.f
@@ -443,37 +443,51 @@ C
END IF
C
IF (Ndatb.GT.Ndat) THEN
- CALL Findpr (Ndatb, Kk)
Nnnnnn = 0
Ndatdx = 1
C *** Find location directly below Emins === Ndatsx
Ndatsx = 1
- Eee = Emins
- IF (Emins.GT.Emind) CALL Where (Energb, Eee, Kk, Ndatb, Ndatsx)
- IF (Ndatsx.GT.1) Ndatsx = Ndatsx - 1
+ IF (Emins.GT.Emind) THEN
+ call GetLowerBound(Energb, Emins, Ndatb, Ndatsx)
+ IF (Ndatsx.GT.1) Ndatsx = Ndatsx - 1
+ END IF
Ndatrx = Ndatsx
C *** Find location directly below Eminr === Ndatrx
- Eee = Eminr
- IF (Eminr.GT.Emins) CALL Where (Energb, Eee, Kk, Ndatb, Ndatrx)
- IF (Eminr.GT.Emins .AND. Ndatrx.GT.1) Ndatrx = Ndatrx - 1
+ IF (Eminr.GT.Emins) THEN
+ call GetLowerBound(Energb, Eminr, Ndatb, Ndatrx)
+ IF (Ndatrx.GT.1) Ndatrx = Ndatrx - 1
+ END IF
Ndatxx = Ndatrx
C *** Find location directly ABOVE Emin === Ndatxx
- Eee = Emin
- IF (Emin.GT.Eminr) CALL Where (Energb, Eee, Kk, Ndatb, Ndatxx)
+ IF (Emin.GT.Eminr) THEN
+ call GetLowerBound(Energb, Emin, Ndatb, Ndatxx)
+ END IF
C
- Ndatxy = Ndatxx
- Eee = Emax
C *** Find location directly BELOW Emax === Ndatxy
- CALL Where (Energb, Eee, Kk, Ndatb, Ndatxy)
- IF (Ndatxy.GT.1) Ndatxy = Ndatxy - 1
- Ndatry = Ndatxy
+ Ndatxy = Ndatb
+ Idummy = 1
+ Eee = Energb(1)
+ call GetRange(Energb, Eee, Emax, Ndatb, Idummy, Ndatxy)
+ IF (Ndatxy.GT.2) then
+ Ndatxy = Ndatxy - 2 ! to get directly below
+ else
+ Ndatxy = 1
+ end if
+
+ Ndatry = Ndatxy
C *** Find location directly above Emaxr === Ndatry
- Eee = Emaxr
- IF (Emax.LT.Emaxr) CALL Where (Energb, Eee, Kk, Ndatb, Ndatry)
+ IF (Emax.LT.Emaxr) Then
+ Ndatry = Ndatb
+ call GetRange(Energb, Eee, Emaxr, Ndatb, Idummy, Ndatxy)
+ end if
+
Ndatsy = Ndatry
C *** Find location directly above Emaxs === Ndatsy
Eee = Emaxs
- IF (Emaxr.LT.Emaxs) CALL Where (Energb, Eee, Kk, Ndatb, Ndatsy)
+ IF (Emaxr.LT.Emaxs) THEN
+ Ndatsy = Natb
+ call GetRange(Energb, Eee, Emaxs, Ndatb, Idummy, Ndatsy)
+ END if
Ndatdy = Ndatb
C
C *** Now figure how many points in each region
diff --git a/sammy/src/dat/mdat2.f b/sammy/src/dat/mdat2.f
index 5b5f3140514b4fca36b4b39b3ae0425f2251aa98..bdf7617934eadf7d8078b2d398eaa2c30fade6b7 100644
--- a/sammy/src/dat/mdat2.f
+++ b/sammy/src/dat/mdat2.f
@@ -238,81 +238,45 @@ C
C
C
C *** Find positions of Emind, Emin, Emax, Emaxd within {E(I)}
- CALL Findpr (Nmax, Kk)
- NNnnnn = 0
-C
- IF (Iwhich.EQ.2) THEN
-C *** Iwhich=2 => forward in Energy
- X = Emind
- CALL Where (E, X, Kk, Nmax, Mind)
- Mine = Mind
- IF (Mind.GT.1) Mind = Mind - 1
- X = Emin
- IF (Emin.GT.Emind) CALL Where (E, X, Kk, Nmax, Mine)
- X = Emax
- CALL Where (E, X, Kk, Nmax, Maxe)
- IF (Emax.GE.E(Maxe+1)) Maxe = Maxe + 1
- Maxd = Maxe
- X = Emaxd
- IF (Emax.LT.Emaxd) CALL Where (E, X, Kk, Nmax, Maxd)
- IF (Maxd.LT.Nmax) Maxd = Maxd + 1
-C
- IF ( (Emind.NE.Emin .OR. Emaxd.NE.Emax ) .AND.
- * (Emind.LE.E(Mind) .OR. Emaxd.GE.E(Maxd)) ) THEN
-C *** Here we may need to add points above or below the energy
-C *** region, so figure how many
- X = (E(Mind+2)-E(Mind))*0.5D0
- X = (Emin-Emind)/X
- Nnnnnn = X + 1
- X = (E(Maxd)-E(Maxd-2))*0.5D0
- X = (Emaxd-Emax)/X
- Nnnnnn = Nnnnnn + 1 + X
- END IF
-C
- ELSE IF (Iwhich.EQ.1) THEN
-C
-C *** Iwhich=1 => backward in Energy
- X = Emaxd
- CALL Wherex (E, X, KK, Nmax, Mind)
- Mine = Mind
- IF (Mind.GT.1) Mind = Mind - 1
- X = Emax
- IF (Emax.LT.Emaxd) CALL Wherex (E, X, Kk, Nmax, Mine)
- IF (Emax.GE.E(mine) .AND. Mine.GT.1) Mine = Mine - 1
- X = Emin
- CALL Wherex (E, X, Kk, Nmax, Maxe)
- IF (Emin.LE.E(Maxe) .AND. Maxe.LT.Nmax) Maxe = Maxe + 1
- Maxd = Maxe
- X = Emind
- IF (Emin.GT.Emind) CALL Wherex (E, X, Kk, Nmax, Maxd)
- IF (Maxd.LT.Nmax) Maxd = Maxd + 1
- IF (Maxd.GT.Nmax) Maxd = Nmax
-C
- IF ( (Emind.NE.Emin .OR. Emaxd.NE.Emax ) .AND.
- * (Emind.LE.E(Mind) .OR. Emaxd.GE.E(Maxd)) ) THEN
-C *** Here we may need to add points above or below the energy
-C *** region, so figure how many
- X = (E(Mind)-E(Mind+2))*0.5D0
- X = (Emaxd-Emax)/X
- Nnnnnn = X + 1
- X = (E(Maxd-2)-E(Maxd))*0.5d0
- X = (Emin-Emind)/X
- Nnnnnn = Nnnnnn + 1 + X
- END IF
C
- ELSE
-C *** Iwhich=0
- Mine = 1
- Mind = 1
- Maxe = 1
- Maxd = 1
+ ! get index just below for Emind and save in mind
+ ! if Emin > Emind, get the index just below Emin and save in mine
+ ! if emin <= Emind, mine == mind
+ !
+ ! get index just above Emaxd and save in maxd
+ ! if Emax < Emaxd, get the index just above Emax and save in maxe
+ ! if emax >= Emaxd, maxe == maxd
+ mind = 1
+ maxd = nmax
+ IF (Iwhich.EQ.2) THEN !which=2 => increasing in energy
+ call GetRange(E, Emind, Emaxd, Nmax, mind, maxd)
+ ELSE IF (Iwhich.EQ.1) THEN !which=1 => backward in Energy
+ call GetRangeRev(E, Emind, Emaxd, Nmax, mind, maxd)
+ ELSE !Iwhich=0
+ maxd = 1
END IF
-C
+
+ mine = mind
+ maxe = maxd
+ emin1 = max(emin, emind)
+ emax1 = min(emax, emaxd)
+ IF (Iwhich.EQ.2) THEN !which=0 => increasing in energy
+ call GetRange(E, Emin1, Emax1, Nmax, mine, maxe)
+ ELSE IF (Iwhich.EQ.1) THEN !which=1 => backward in Energy
+ call GetRangeRev(E, Emin1, Emax1, Nmax, mine, maxe)
+ ELSE !Iwhich=0
+ maxe = 1
+ IF (Maxe.LT.Nmax) Maxe = Maxe + 1
+ END IF
+
+ ! make sure the range goes one below to ensure all data a loaded
IF (Mine.GT.1) Mine = Mine - 1
- IF (Maxe.LT.Nmax) Maxe = Maxe + 1
- Ndat = Maxe - Mine + 1
+ IF (Mind.GT.1) Mind = Mind - 1
+
+ ndat = maxe - mine + 1
+ ndatb = maxd - mind + 3
+C
IF (Mmdata.EQ.0 .AND. Ksodf.EQ.0) Ndat = Ndat*Nodpoc
- Ndatb = Maxd - Mind + 3
IF (Mmdata.EQ.0 .AND. Ksodf.EQ.0) Ndatb = Ndatb*Nodpoc
C *** Ndatb is a (large enough; ie conservative) estimate of how
C *** many points total will be read in
diff --git a/sammy/src/dat/mdat9.f b/sammy/src/dat/mdat9.f
index 4615fbe16e750b4ec9edc8827ee1015d747f00f3..0678b3c98997eb07d18b2d65c51bfb8b6a176ac0 100755
--- a/sammy/src/dat/mdat9.f
+++ b/sammy/src/dat/mdat9.f
@@ -1,3 +1,52 @@
+ subroutine GetLowerBound(En, Emin, Nn, Ilow)
+ implicit none
+ integer::Nn, Ilow
+ real(kind=8)::En(nn),Emin
+
+ integer::ix, start
+
+ start = Ilow
+ do ix = start, Nn
+ if (Emin.lt.en(ix)) exit
+ Ilow = ix
+ end do
+ end subroutine GetLowerBound
+
+ subroutine GetRange(En, Emin, Emax, Nn, Ilow, Ihigh)
+ implicit none
+ integer::Nn, Ilow, Ihigh
+ real(kind=8)::En(nn),Emin, Emax
+
+ integer::ix, start
+
+ call GetLowerBound(En, Emin, Nn, Ilow)
+
+ start = Ihigh ! want at least one interval
+ do ix = start, Ilow + 1, -1
+ if ( Emax.ge.en(ix)) exit
+ Ihigh = ix
+ end do
+ end subroutine GetRange
+
+ subroutine GetRangeRev(En, Emin, Emax, Nn, Ilow, Ihigh)
+ implicit none
+ integer::Nn, Ilow, Ihigh
+ real(kind=8)::En(nn),Emin, Emax
+
+ integer::ix, start
+
+ start = Ilow
+ do ix = start, Nn
+ if (Emax.gt.en(ix)) exit
+ Ilow = ix
+ end do
+
+ start = Ihigh ! want at least one interval
+ do ix = start, Ilow + 1, -1
+ if ( Emin.le.en(ix)) exit
+ Ihigh = ix
+ end do
+ end subroutine GetRangeRev
C
C
C -----------------------------------------------------------------
@@ -53,40 +102,3 @@ C *** for Nn < 2**K points in En
END IF
RETURN
END
-C
-C
-C -----------------------------------------------------------------
-C
- SUBROUTINE Wherex (En, E, K, Nn, Nwhere)
-C *** Purpose -- Locate position Nwhere, such that
-C *** En(Nwhere) >= E > En(Nwhere+1), monotonically decreasing
-C *** for Nn < 2**K points in En
- DOUBLE PRECISION E, En
- DIMENSION En(Nn)
- N = 1
- IF (E.LT.En(1)) THEN
- N = Nn - 1
- IF (E.GT.En(Nn)) THEN
- M = 2**(K-1)
- N = M + 1
- DO I=1,K
- M = M/2
- IF (E.GT.En(N)) THEN
- N = N - M
- ELSE
- N = N + M
- IF (N.GE.Nn) N = Nn-1
- END IF
- END DO
- IF (N.GT.1 .AND. E.GT.En(N)) N = N - 1
- END IF
- END IF
- Nwhere = N
- IF (Nwhere.EQ.1 .OR. Nwhere.EQ.Nn-1) RETURN
- IF (En(Nwhere).LT.E .OR. E.LT.En(Nwhere+1)) THEN
- WRITE (6,10000) En(Nwhere), E, En(Nwhere+1), Nwhere
-10000 FORMAT (' Problem in Wherex: ', 1P3G14.6, I10)
- STOP '[STOP in Wherex in dat/mdat9.f]'
- END IF
- RETURN
- END
diff --git a/sammy/src/dbd/mdbd0.f b/sammy/src/dbd/mdbd0.f
index 891f38567f18a89bb6824e3f0567d47060b45f4b..77e82e198be00277b507de689325297da9e00763 100644
--- a/sammy/src/dbd/mdbd0.f
+++ b/sammy/src/dbd/mdbd0.f
@@ -59,8 +59,8 @@ C
C *** Dopplr PERFORMS DOPPLER BROADENING OPERATION (HEGA)
CALL Dopplr(A_Idpiso , I_Iflmsc , A_Iprnbk , I_Iflnbk , A_Iprbgf ,
* I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma , A_Itexbg , A_Iteabg ,
- * A(Ie), A(Ieb),A(Ith), A(Iwsigx), A(Iwdasi), A(Iwdbsi), A(Isigxx),
- * A(Idasig), A(Idbsig), A(Ivsigx), A(Ivdasi), A(Ivdbsi), I_Iisopa ,
+ * A(Ie), A(Ieb),A(Ith), A(Iwsigx), A(Iwdasi), A_Iwdbsi , A(Isigxx),
+ * A(Idasig), A(Idbsig), A(Ivsigx), A(Ivdasi), A_Ivdbsi , I_Iisopa ,
* A(Iweigh), A(Iwts) , A)
C
I = Idimen (Iweigh, -1, 'Iweigh, -1')
diff --git a/sammy/src/dex/mdex0.f b/sammy/src/dex/mdex0.f
index 6229c41c91081f33b3899dd97209178d4fabb8e2..42ba618fc393ed596216fabbcfae46208caeea5f 100644
--- a/sammy/src/dex/mdex0.f
+++ b/sammy/src/dex/mdex0.f
@@ -64,8 +64,8 @@ C *** RESOLU PERFORMS RESOLUTION-BROADENING OPERATION
CALL Resolu_Dex ( I_Iflmsc , A_Iprnbk , I_Iflnbk ,
* A_Iprbgf , I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma ,
* A_Itexbg , A_Iteabg , A(Ie), A(Ieb), A(Ith), A(Iwsigx),
- * A(Iwdasi), A(Iwdbsi), A(Isigxx), A(Idasig), A(Idbsig),
- * A(Ivsigx), A(Ivdasi), A(Ivdbsi), A(Iweigh), A(Iwts ))
+ * A(Iwdasi), A_Iwdbsi , A(Isigxx), A(Idasig), A(Idbsig),
+ * A(Ivsigx), A(Ivdasi), A_Ivdbsi , A(Iweigh), A(Iwts ))
C
C
I = Idimen (Iweigh, -1, 'Iweigh, -1')
diff --git a/sammy/src/dex/mdex1.f b/sammy/src/dex/mdex1.f
index 05d5631ed3c9a4a1a02b091c373d0f3a9e81336f..b0f4c6fab6e7343069e6df8648c158cd912d60bb 100644
--- a/sammy/src/dex/mdex1.f
+++ b/sammy/src/dex/mdex1.f
@@ -97,13 +97,27 @@ C
END IF
C
C ****** Find location of Elow
- CALL Where (Energb, ELow, Jdatb, Kdatb, JLow)
+ if (elow.le.energb(1)) then
+ JLow = 1
+ else if ( elow.ge.energb(Kdatb)) then
+ JLow = Kdatb - 1
+ else
+ CALL Where (Energb, ELow, Jdatb, Kdatb, JLow)
+ end if
C This gives Energb(JLow ) =< ELow < Energb(JLow+1)
C but must have Energb(Jlow-1) < Elow =< Energb(Jlow)
IF (Energb(Jlow).LT.Elow) Jlow = Jlow + 1
C
-C *** Find location of Eup
- CALL Where (Energb, Eup, Jdatb, Kdatb, Jup)
+C *** Find location of Eup
+ if (Eup.ge.Energb(Kdatb)) then
+ Jup = Kdatb - 1
+ else
+ Jup = JLow
+ do ix = Jlow, Kdatb - 1 ! want at least one interval
+ if ( Energb(ix).gt.Eup) exit
+ Jup = ix
+ end do
+ end if
C This gives Energb(Jup) =< Eup < Energb(Jup+1) as needed
C
C
diff --git a/sammy/src/dop/mdop0.f b/sammy/src/dop/mdop0.f
index 0b390075eda048905556d95b7ba7ba7646662325..b6bcdc4cbf7ae4e34faee5f4aa3d4595d58c51e4 100644
--- a/sammy/src/dop/mdop0.f
+++ b/sammy/src/dop/mdop0.f
@@ -52,9 +52,9 @@ C
C *** Dopplh performs Doppler broadening operation via Leal-Hwang method
CALL Dopplh(I_Iflmsc , A_Iprnbk , I_Iflnbk , A_Iprbgf , I_Iflbgf ,
* A_Indbgf , A_Ibgfmi , A_Ibgfma , A_Itexbg , A_Iteabg , A(Icoef ),
- * A(Ieb ), A(Ith ), A(Iwsigx), A(Iwdasi), A(Iwdbsi), A(Iwsigs),
+ * A(Ieb ), A(Ith ), A(Iwsigx), A(Iwdasi), A_Iwdbsi , A(Iwsigs),
* A_Iwdass , A_Iwdbss , A(Isigxx), A(Idasig), A(Idbsig), A(Isigsi),
- * A(Idasis), A(Idbsis), A(Ivsigx), A(Ivdasi), A(Ivdbsi), A(Ivsigs),
+ * A(Idasis), A(Idbsis), A(Ivsigx), A(Ivdasi), A_Ivdbsi , A(Ivsigs),
* A_Ivdass , A_Ivdbss , I_Iisopa , Mmmmmm, I2pls1, Ngb, Nss, Ldatb,
* A)
I = Idimen (Icoef, -1, 'Icoef, -1')
diff --git a/sammy/src/fgm/mfgm0.f b/sammy/src/fgm/mfgm0.f
index a2ad6f3966fd751993082013025a832c132055ad..073609b14eb0b23f8574405b90011694f6178eaf 100644
--- a/sammy/src/fgm/mfgm0.f
+++ b/sammy/src/fgm/mfgm0.f
@@ -64,9 +64,9 @@ C *** Dopfgm PERFORMS DOPPLER BROADENING OPERATION
CALL Dopfgm( A_Idpiso , A_Idsiso , I_Iflmsc , A_Iprnbk ,
* I_Iflnbk , A_Iprbgf , I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma ,
* A_Itexbg , A_Iteabg , A(Ie ), A(Ieb ), A(Ith ), A(Iwsigx),
- * A(Iwdasi), A(Iwdbsi), A(Iwsigs), A_Iwdass , A_Iwdbss , A(Isigxx),
+ * A(Iwdasi), A_Iwdbsi , A(Iwsigs), A_Iwdass , A_Iwdbss , A(Isigxx),
* A(Idasig), A(Idbsig), A(Isigsi), A(Idasis), A(Idbsis), A(Ivsigx),
- * A(Ivdasi), A(Ivdbsi), A(Ivsigs), A_Ivdass , A_Ivdbss , I_Iisopa ,
+ * A(Ivdasi), A_Ivdbsi , A(Ivsigs), A_Ivdass , A_Ivdbss , I_Iisopa ,
* A(Iveloc), A(Iwts ), I_Ixciso , A)
C
I = Idimen (Iveloc, -1, 'Iveloc, -1')
diff --git a/sammy/src/grp/mgrp0.f b/sammy/src/grp/mgrp0.f
index 938be0cb3eb42feab76b7affba575afc7211c580..edc54a06ee43ed2c7a77c14d4908e24a9deac8c6 100644
--- a/sammy/src/grp/mgrp0.f
+++ b/sammy/src/grp/mgrp0.f
@@ -14,7 +14,15 @@ C
use brdd_common_m
use cbro_common_m
use lbro_common_m
+ use AllocateFunctions_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
+ real(kind=8),allocatable,dimension(:)::A_Iemn, A_Iemx
+ real(kind=8),allocatable,dimension(:)::A_Iebond, A_Ibonda
+ real(kind=8),allocatable,dimension(:)::A_Iweigh
+ real(kind=8),allocatable,dimension(:)::A_Ix1, A_Ix2, A_Ix21
+ real(kind=8),allocatable,dimension(:)::A_Iemmmq, A_Idum, A_Ic
+ real(kind=8),allocatable,dimension(:)::A_Iwts, A_Iaa, A_Ix3, A_Id
+ integer,allocatable,dimension(:)::I_Ikmn, I_Ikmx, I_Ic
DIMENSION A(-Msize:Msize)
C
C
@@ -45,13 +53,14 @@ C *** and sets Ndatq = number of such ranges & Nbonda = number of points
C *** for "constant" C(E) in Bondarenko formula
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- Iemn = Idimen (Ndatq, 1, 'Emn, Ndatq, 1')
- Iemx = Idimen (Ndatq, 1, 'Emx, Ndatq, 1')
+ Imarker = Idimen (1, 1, 'Marker for memory release')
+ call allocate_real_data(A_Iemn, Ndatq)
+ call allocate_real_data(A_Iemx, Ndatq)
Nbondx = Nbonda
IF (Nbonda.EQ.0) Nbondx = 1
- Iebond = Idimen (Nbondx, 1, 'Ebond, Nbonda, 1')
- Ibonda = Idimen (Nbondx, 1, 'Bonda, Nbonda, 1')
- CALL Qrange (A(Iemn), A(Iemx), A(Iebond), A(Ibonda), Sig000,
+ call allocate_real_data(A_Iebond, Nbondx)
+ call allocate_real_data(A_Ibonda, Nbondx)
+ CALL Qrange (A_Iemn , A_Iemx , A_Iebond , A_Ibonda, Sig000,
* Ndatq, Nbonda)
C *** routine Qrange reads energy-limits on the averaging bins, and
C *** values of Ebonda(I) and Bondar(I) = C(E(I)) = constant for
@@ -63,23 +72,27 @@ C *** GUESSTIMATE SIZE OF ARRAY NEEDED FOR SAMGRP
C
C
C *** one ***
- Iweigh = Idimen (Kdatb, 1, 'Weigh, Kdatb, 1')
+ call allocate_real_data(A_Iweigh, Kdatb)
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
C *** two ***
- Ix1 = Idimen (Kdatb, 1, 'X1 , Kdatb, 1')
- Ix2 = Idimen (Kdatb, 1, 'X2 , Kdatb, 1')
- Ix21 = Idimen (Kdatb, 1, 'X21, Kdatb, 1')
+ 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) as for broadening, also to be
C *** used here for averaging
- CALL Xcoef (A(Ieb), A(Iweigh), A(Ix1), A(Ix2), A(Ix21), Kdatb)
- I = Idimen (Ix1, -1, 'Ix1, -1')
+ CALL Xcoef (A(Ieb), A_Iweigh, A_Ix1, A_Ix2, A_Ix21, Kdatb)
+ deallocate(A_Ix1)
+ deallocate(A_Ix2)
+ deallocate(A_Ix21)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
C
C *** two.1 ***
- Iemmmq = Idimen ((Ndatq*(Ndatq+1))/2, 1,
- * 'Emmmq, (Ndatq*(Ndatq+1))/2, 1')
- Idum = Idimen (Ndatq, 1, 'Dum , Ndatq, 1')
+ call allocate_real_data(A_Iemmmq,(Ndatq*(Ndatq+1))/2)
+C A_Idum is used in plotun in int/mint3.f where it
+C expected to be ndat long. Thus we pick the maximum of ndatq
+C and kdatb
+ call allocate_real_data(A_Idum, max(Ndatq, Kdatb))
C
C *** three ***
Jx = 4 - Kaverg
@@ -89,25 +102,26 @@ C *** three ***
ELSE
Ifintg = Iwsigx
END IF
+
+ ! these are array markers defined in common blocks
Iwsigx = Idimen (Ndatq , 1, 'Wsigxx, Ndatq, 1')
- Iwdasi = Idimen (Ndatq*Ndaxxx, 1, 'Wdasig, Ndatq*Ndaxxx, 1')
- Iwdbsi = Idimen (Ndatq*Ndbxxx, 1, 'Wdbsig, Ndatq*Ndbxxx, 1')
- Iwts = Idimen (Kdatb , 1, 'Wts , Kdatb, 1')
- Iaa = Idimen (Jx*Ngbxxx , 1, 'Aa , Jx*Ngbxxx, 1')
- Ix = Idimen (Ndatq*Nvpall, 1, 'X , Ndatq*Nvpall, 1')
+ Iwdasi = Idimen (Ndatq*Ndaxxx, 1, 'Wdasig, Ndatq*Ndaxxx, 1')
+ call make_A_Iwdbsi_only(Ndatq*Ndbxxx)
+ call allocate_real_data(A_Iwts, Kdatb)
+ call allocate_real_data(A_Iaa, Jx*Ngbxxx)
+ call allocate_real_data(A_Ix3, Ndatq*Nvpall)
C
C *** four ***
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- Ikmn = Idimen (Ndatq, 1, 'Kmn , Ndatq, 1')
- Ikmx = Idimen (Ndatq, 1, 'Kmx , Ndatq, 1')
+ call allocate_integer_data(I_Ikmn, Ndatq)
+ call allocate_integer_data(I_Ikmx, Ndatq)
C *** Grpavg calculates group-averaged cross section
- CALL Grpavg (A(Iiuif), A(Ieb), A(Iemn), A(Iemx), A(Iebond),
- * A(Ibonda), A(Iwsigx), A(Iwdasi), A(Iwdbsi), A(Iweigh),
- * A(Iemmmq), A(Idum), A(Iwts), A(Ivsigx), A(Ivdasi), A(Ivdbsi),
- * A(Ifintg), A(Iaa), A(Ix), A(Ikmn), A(Ikmx), Sig000,
+ CALL Grpavg (A(Iiuif), A(Ieb), A_Iemn , A_Iemx , A_Iebond ,
+ * A_Ibonda , A(Iwsigx), A(Iwdasi), A_Iwdbsi , A_Iweigh,
+ * A_Iemmmq , A_Idum, A_Iwts, A(Ivsigx), A(Ivdasi), A_Ivdbsi ,
+ * A(Ifintg), A_Iaa, A_Ix3, I_Ikmn, I_Ikmx, Sig000,
* Kdatb, Ndatq, Nbonda, Ngbxxx, Jx)
- I = Idimen (Ikmn, -1, 'Release Ikmn, Ikmn, -1')
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
C
IF (Kpasfe.EQ.1) THEN
@@ -119,17 +133,33 @@ C *** file SAMSEN.DAT
END IF
C
C *** five ***
- Ic = Idimen (Ndatq, 1, 'Ic, Ndatq, 1')
+ call allocate_integer_data(I_Ic, Ndatq)
+ call allocate_real_data(A_Ic, Ndatq)
C *** Write_Std_and_Corr prints the uncertainties and correlation matrix
- CALL Write_Std_and_Corr (A(Iemmmq), A(Ix), A(Ic), Ndatq)
+ CALL Write_Std_and_Corr (A_Iemmmq, A_Ix3, I_Ic, Ndatq)
IF (Keivav.EQ.0) THEN
- Id = Idimen (Ndatq**2, 1, 'Id, Ndatq**2, 1')
- CALL Test_Eig_2 (A(Iemmmq), A(Id), Ndatq, 1)
+ call allocate_real_data(A_Id, Ndatq**2)
+ CALL Test_Eig_2 (A_Iemmmq, A_Id, Ndatq, 1)
+ deallocate(A_Id)
END IF
C
- IF (K33fil.EQ.1) CALL File33 (A(Iemn), A(Iemx), A(Iwsigx),
- * A(Iemmmq), A(Ix), A(Ic), Ndatq)
- I = Idimen (Iemn, -1, 'Release Emn, Iemn, -1')
+ IF (K33fil.EQ.1) CALL File33 (A_Iemn, A_Iemx, A(Iwsigx),
+ * A_Iemmmq, A_Ix3, A_Ic, Ndatq)
+ I = Idimen (Imarker, -1, 'Release memory')
+ deallocate(A_Iemn)
+ deallocate(A_Iemx)
+ deallocate(A_Iebond)
+ deallocate(A_Ibonda)
+ deallocate(A_Iweigh)
+ deallocate(A_Iemmmq)
+ deallocate(A_Idum)
+ deallocate(A_Iwts)
+ deallocate(A_Iaa)
+ deallocate(A_Ix3)
+ deallocate(I_Ikmn)
+ deallocate(I_Ikmx)
+ deallocate(I_Ic)
+ deallocate(A_Ic)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
C
I = Idimen (0, 0, '0, 0')
diff --git a/sammy/src/inp/minp02.f b/sammy/src/inp/minp02.f
index b24da0d2c5117313e41fec28c20baba60c11c203..7739bb9a75e25e6ee436111f89daa785cd62430a 100644
--- a/sammy/src/inp/minp02.f
+++ b/sammy/src/inp/minp02.f
@@ -51,6 +51,7 @@ C *** Read channel radius, data type, angles for angular distributions
CALL Gggg78
C
C *** Read spin group definitions (Card Sets 9 and 10, 10.1 or 10.2)
+ If_9 = 0
IF (Kquant.EQ.0) THEN
IF (Krdspn_X.EQ.-1 .OR. Krdspn_X.EQ.1) THEN
CALL Gg10p0 (Ngr, Nnntot, If_9)
diff --git a/sammy/src/int/mint0.f b/sammy/src/int/mint0.f
index 8de443617f8433f66b23cb928d33de1b8734d560..1e1e323fcfd6c651608dc76d2de20dfa46b87050 100644
--- a/sammy/src/int/mint0.f
+++ b/sammy/src/int/mint0.f
@@ -148,7 +148,7 @@ C
C *** Read the cross sections etc
Jgbmax = 0
Kkkdat = 0
- CALL Read_Cross_Sections (A(Iwsigx), A(Iwdasi), A(Iwdbsi),
+ CALL Read_Cross_Sections (A(Iwsigx), A(Iwdasi), A_Iwdbsi ,
* A(Iwsigs), A_Iwdass , A_Iwdbss , A(Ie), Jgbmax, Kkkdat, 1, Iv)
C
IF (Debug) THEN
@@ -178,7 +178,7 @@ C
Nanb = Nnnsig*Ndbsig
Jjjder = Idimen (Nanb, 1, 'Nanb, 1')
Jjjpar = Idimen (Nanb, 1, 'Nanb, 1')
- CALL Out_Deriv (I_Ixciso , A(Iwdbsi), A(Ie), A(Iiuif),
+ CALL Out_Deriv (I_Ixciso , A_Iwdbsi , A(Ie), A(Iiuif),
* A(Jjjder), A(Jjjpar), Nnnsig, Ndbsig, Nanb, Niniso,
* Jgbmax, 1)
END IF
@@ -267,7 +267,7 @@ C
Nanb = Nnnsig*Ndbsig
Jjjder = Idimen (Nanb, 1, 'Nanb, 1')
Jjjpar = Idimen (Nanb, 1, 'Nanb, 1')
- CALL Out_Deriv (I_Ixciso , A(Iwdbsi), A(Ie), A(Iiuif),
+ CALL Out_Deriv (I_Ixciso , A_Iwdbsi , A(Ie), A(Iiuif),
* A(Jjjder), A(Jjjpar), Nnnsig, Ndbsig, Nanb, 1, Ndat, 1)
END IF
END IF
diff --git a/sammy/src/int/mint6.f b/sammy/src/int/mint6.f
index 2d8091d97e510170c2004210c40f548d41589e07..d1e7607a37a29d1ca5501fd20dac932891f5bcbc 100644
--- a/sammy/src/int/mint6.f
+++ b/sammy/src/int/mint6.f
@@ -25,13 +25,13 @@ C *** Read the cross sections etc
Jgbmax = 0
Kkkdat = 0
C ### Usually, read V's and write W's ... but opposite in samint module.
- CALL Read_Cross_Sections (A(Iwsigx), A(Iwdasi), A(Iwdbsi),
+ CALL Read_Cross_Sections (A(Iwsigx), A(Iwdasi), A_Iwdbsi ,
* A(Iwsigs), A_Iwdass , A_Iwdbss , A(Ieb), Jgbmax, Kkkdat, 1, 0)
C
C *** interpolate between points to get results on experimental grid
- CALL Interp (A(Ie), A(Ieb), A(Ivsigx), A(Ivdasi), A(Ivdbsi),
+ CALL Interp (A(Ie), A(Ieb), A(Ivsigx), A(Ivdasi), A_Ivdbsi ,
* A(Ivsigs), A_Ivdass , A_Ivdbss , A(Iwsigx), A(Iwdasi),
- * A(Iwdbsi), A(Iwsigs), A_Iwdass , A_Iwdbss , Jgbmax)
+ * A_Iwdbsi , A(Iwsigs), A_Iwdass , A_Iwdbss , Jgbmax)
C
C *** Write the cross sections and partial derivatives into LPT file
C
@@ -58,7 +58,7 @@ C
Nanb = Nnnsig*Ndbsig
Jjjder = Idimen (Nanb, 1, 'Nanb, 1')
Jjjpar = Idimen (Nanb, 1, 'Nanb, 1')
- CALL Out_Deriv (I_Ixciso , A(Ivdbsi), A(Ie), A(Iiuif),
+ CALL Out_Deriv (I_Ixciso , A_Ivdbsi , A(Ie), A(Iiuif),
* A(Jjjder), A(Jjjpar), Nnnsig, Ndbsig, Nanb, Niniso,
* Ndat, 1)
END IF
diff --git a/sammy/src/mlb/mmlb0.f b/sammy/src/mlb/mmlb0.f
index 121c3e8766185f331b1fdc6698c2d04cd4430449..5167781d952fa99a3d149e006f27f0af1b17d7ab 100644
--- a/sammy/src/mlb/mmlb0.f
+++ b/sammy/src/mlb/mmlb0.f
@@ -117,7 +117,7 @@ C *** Sub Work generates Theory and derivatives
CALL Work_Mlb (A, I_Iflmsc , A_Iprnbk , I_Iflnbk , A_Iprbgf ,
* I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma , A_Itexbg ,
* A_Iteabg , A(Ienerb), A(Ith ), A(Iwsigx), A(Iwdasi),
- * A(Iwdbsi), A(Isigxx), A(Idasig), A(Idbsig), I_Iisopa ,
+ * A_Iwdbsi , A(Isigxx), A(Idasig), A(Idbsig), I_Iisopa ,
* A(Ipiece), A(Idum ), A_Iadder , A_Iaddcr , I_Inbt ,
* I_Iint )
I = Idimen (Inprdr, -1, 'Inprdr, -1')
diff --git a/sammy/src/mso/mmso0.f b/sammy/src/mso/mmso0.f
index 7543ed3734ed995b2b54f3b444df008443530c3b..12134c80a6f537a415c2db23689e324f28c24d38 100644
--- a/sammy/src/mso/mmso0.f
+++ b/sammy/src/mso/mmso0.f
@@ -118,8 +118,8 @@ C
* A(Ixtptv), A(Ixtptw), A(Ifthet), A(Isqfb ), A(Idsqfb),
* A(Iqfb ), A(Idqfb ), A(Idelas), A(Idt),
* A(Idc ), A(Icccll), A(Idddll), A(Iwe ),
- * I_Iisopa , a(Iwsigx), A(Iwdasi), A(Iwdbsi), A(Isigxx),
- * A(Idasig), A(Idbsig), A(Ivsigx), A(Ivdasi), A(Ivdbsi),
+ * I_Iisopa , a(Iwsigx), A(Iwdasi), A_Iwdbsi , A(Isigxx),
+ * A(Idasig), A(Idbsig), A(Ivsigx), A(Ivdasi), A_Ivdbsi ,
* A(Ivsigs), A_Ivdass , A_Ivdbss ,
* A(Itotsi), A(Icapsi), A(Idtots),
* A(Idcaps), A(Irmass), A(Iaaa ), A(Ibbb ), A(Icsx ),
diff --git a/sammy/src/mxw/mmxw0.f b/sammy/src/mxw/mmxw0.f
index e1b7b9fc9ae2d12594545d48fd251e0b96b18f36..113668fcdc3c068821ed56c430d80aedbd3c47ce 100644
--- a/sammy/src/mxw/mmxw0.f
+++ b/sammy/src/mxw/mmxw0.f
@@ -59,8 +59,8 @@ C *** three ***
Isumfl = Idimen (Ndatq, 1, 'Ndatq, 1')
C *** Mxwell calculates Maxwellian-averaged capture cross section
CALL Mxwell (A, A(Ie), A(Ieb), A(Ith), I_Iisopa ,
- * A(Iwsigx), A(Iwdasi), A(Iwdbsi), A(Ivsigx), A(Ivdasi),
- * A(Ivdbsi), A(Idum), A(Idummy), A(Izz), A(Isnorm), A(Isumre),
+ * A(Iwsigx), A(Iwdasi), A_Iwdbsi , A(Ivsigx), A(Ivdasi),
+ * A_Ivdbsi , A(Idum), A(Idummy), A(Izz), A(Isnorm), A(Isumre),
* A(Isumfl), Kdatb, Ndatq, Npnts)
I = Idimen (Izz, -1, 'Izz, -1')
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
@@ -71,7 +71,7 @@ C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
C *** four ***
Ix = Idimen (Ndatq*Nvpall, 1, 'Ndatq*Nvpall, 1')
- CALL Fixcov_Mxw (A(Iiuif), A(Iemmmq), A(Iwdasi), A(Iwdbsi),
+ CALL Fixcov_Mxw (A(Iiuif), A(Iemmmq), A(Iwdasi), A_Iwdbsi ,
* A(Ix), Ndatq, Ndatqq)
I = Idimen (Ix, -1, 'Ix, -1')
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
diff --git a/sammy/src/npv/mnpv9.f b/sammy/src/npv/mnpv9.f
index 6c7bead8dfe29b9a65476aa83a244bfb909ef5e5..47f02cfe45391cd1b444b7d06dcc276609672b32 100644
--- a/sammy/src/npv/mnpv9.f
+++ b/sammy/src/npv/mnpv9.f
@@ -65,8 +65,8 @@ C Allocate the temporary arrays needed
C
C *** Copy Wsigxx into Th and Wd?sig into Gx
C A(Iwsigx) -> A(Ith)
-C ( A(Iwdasi), A(Iwdbsi)) -> A_Igx
- CALL Reorg (A(Ith), A_Igx, A(Iwsigx), A(Iwdasi), A(Iwdbsi), Kdat)
+C ( A(Iwdasi), A_Iwdbsi ) -> A_Igx
+ CALL Reorg (A(Ith), A_Igx, A(Iwsigx), A(Iwdasi), A_Iwdbsi , Kdat)
C
C
IF (Ksolve.NE.2 .OR. Nfpall.GT.Nvpall) THEN
diff --git a/sammy/src/ntg/mntg0.f b/sammy/src/ntg/mntg0.f
index 29f3b6228f872eda709cae8df2d2cec57f0389ff..7bf785a9936f97996e222ef3ca2ff8b08f6d57b6 100644
--- a/sammy/src/ntg/mntg0.f
+++ b/sammy/src/ntg/mntg0.f
@@ -102,8 +102,8 @@ C *** Nddddd = Kdatb
Iwts = Idimen (Nddddd, 1, 'Nddddd, 1')
C *** Calculate integral quantities
CALL Genint ( A, A(Ieb), A(Iconst), I_Iisopa , A(Iwsigx),
- * A(Iwdasi), A(Iwdbsi), A(Iweigh), A(Idum ), A(Iwts ),
- * A(Ivsigx), A(Ivdasi), A(Ivdbsi), A(Iflux ), A(Ieflux),
+ * A(Iwdasi), A_Iwdbsi , A(Iweigh), A(Idum ), A(Iwts ),
+ * A(Ivsigx), A(Ivdasi), A_Ivdbsi , A(Iflux ), A(Ieflux),
* A(Icflux), A(Idflux), Kdatb, Numntg, Many, Nflux)
I = Idimen (Idum, -1, 'Idum, -1')
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
@@ -117,12 +117,12 @@ C *** four ***
Ix = Idimen (N, 1, 'N, 1')
C *** Write theoretical values & derivatives onto SAM30
- CALL Wrntgx (A(Iwsigx), A(Iwdasi), A(Iwdbsi), A(Iuncnt),
+ CALL Wrntgx (A(Iwsigx), A(Iwdasi), A_Iwdbsi , A(Iuncnt),
* A(Iemmmq), A(Ix), Numntg, Numntx, Numoff, Numxxx)
C *** Calculate theoretical covariance matrix for integral quantities
IF (Ksolve.NE.2) THEN
- CALL Fixcov (A(Iiuif), A(Iemmmq), A(Iwdasi), A(Iwdbsi),
+ CALL Fixcov (A(Iiuif), A(Iemmmq), A(Iwdasi), A_Iwdbsi ,
* A(Ix), Numntg, Numxxx)
END IF
I = Idimen (Ix, -1, 'Ix, -1')
diff --git a/sammy/src/ntg/mntg4.f b/sammy/src/ntg/mntg4.f
index 7aef9aae5dc34f3972b4895cbf8cd2a20ed111c0..b28a3be5abd4aa871532fc581d9d53c2c329a8a3 100644
--- a/sammy/src/ntg/mntg4.f
+++ b/sammy/src/ntg/mntg4.f
@@ -243,6 +243,8 @@ C
* Vsigxx(Nnnsig,Nnniso,*), Vdasig(Nnnsig,Ndaxxx,*),
* Vdbsig(Nnnsig,Ndbxxx,Nnniso,*), Isopar(*)
C
+ if (im1.le.0) return ! out of range - assume zero
+
Wsigxx(Kountr) = Wsigxx(Kountr) + Vsigxx(Nnnsig,Iso,Im1)*aa
IF (Nnnsig.EQ.2) Wsigxx(Kountr+1) = Wsigxx(Kountr+1) +
* Vsigxx(1,Iso,Im1)*aa
@@ -278,6 +280,8 @@ C
* Vsigxx(Nnnsig,Nnniso,*), Vdasig(Nnnsig,Ndaxxx,*),
* Vdbsig(Nnnsig,Ndbxxx,Nnniso,*), Isopar(*)
C
+ if (im1.le.0) return ! out of range - assume zero
+
Wsigxx(Kountr) = Wsigxx(Kountr) + Vsigxx(1,Iso,Im1)*Aa
IF (Ndasig.GT.0) THEN
DO Ipar=1,Ndasig
diff --git a/sammy/src/old/ReadCovarianceParts.f90 b/sammy/src/old/ReadCovarianceParts.f90
index c61efe1e3fe5768badcfe990a01bd4f48b6f9cd3..d5c4ceaf5e56ba3a490ed12494a0e3ba2192239c 100644
--- a/sammy/src/old/ReadCovarianceParts.f90
+++ b/sammy/src/old/ReadCovarianceParts.f90
@@ -180,6 +180,9 @@ contains
deallocate(Dummy)
+ ! idropp is user input from card 2. It is number [1,99].
+ ! the factor 0.01d0 is then implied by the input.
+ ! If is only used if 'DROP SMALL of correlation' is specified
Droppp = dFLOAT(Idropp)*0.01d0
IF (Kdropp.EQ.1) THEN
WRITE ( 6,10000) Droppp
diff --git a/sammy/src/old/mold0.f b/sammy/src/old/mold0.f
index a049b1f74e61e4f6c36f938bac7830337da9d9fa..47f8431a6e9aafa38f7ed82ba04d8b940dd9323d 100644
--- a/sammy/src/old/mold0.f
+++ b/sammy/src/old/mold0.f
@@ -39,18 +39,7 @@ C
C
Nt = (K*(K+1))/2
Ivrpr = Idimen (Nt, 1, 'Vrpr Nt, 1')
- Iallvr = Idimen (Nt, 1, 'Allvr Nt, 1')
-
- N = K**2
- M = (K+1)/2
-C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
- Ivsqua = Idimen (N, 1, 'Vsqua N , 1')
- Ieival = Idimen (N, 1, 'Eival N , 1')
- Ieivec = Idimen (N, 1, 'Eivec N , 1')
- Izeiv = Idimen (N, 1, 'Zeiv N , 1 ')
- Ideiv = Idimen (K, 1, 'Deiv N , 1 ')
- Iiord = Idimen (M, 1, 'Iord N , 1 ')
- Ikord = Idimen (M, 1, 'Kord N , 1 ')
+ Iallvr = Idimen (Nt, 1, 'Allvr Nt, 1')
C
Krext = Nrext
IF (Nrext.EQ.0) Krext = 1
@@ -59,20 +48,8 @@ C *** in samamr, Nowrt=0...
C
IF (Ifold.EQ.0) THEN
C
- Ipoint = 1
C *** Sub routine Rdcov reads binary file containing information from
C *** previous run, including covariance matrices & parameter values
- N = Max0 ( Numiso, Numdet, Numbrd, Nummsc, 4*Numpmc, Numorr,
- * Nmdets, Numrpi, Numudr, Numbgf, Nvpall_Old, Ntepnt*Ntefil,1)
- M = Max0 ( Numnbk, Numrpi-Nnnrpi, Numudr-Nnnudr, Numbgf,
- * Ntepnt*Ntefil, 1 )
- Idum1 = Idimen (N, 1, 'Dum1 N, 1')
- Idum2 = Idimen (M, 1, 'Dum2 M, 1')
- N = (N+1)/2
- Idiot1 = Idimen (N, 1, 'Idiot1 N, 1')
- M = Max0 ( Ngroup, Numnbk, Numpmc, Numbgf, 1 )
- M = (M+1)/2
- Idiot2 = Idimen (M, 1, 'Idiot2 M, 1')
C *** Read the COVariance file, extract information
CALL Rdcov ( A_Iprbrd , I_Iflbrd ,
* A_Ipreff , I_Ifleff , A_Iprtru , I_Ifltru , I_Iigrra ,
@@ -88,16 +65,12 @@ C *** Read the COVariance file, extract information
* A_Iprbgf , I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma ,
* A_Itexbg , A_Iteabg , A_Iprdtp , I_Ifldtp ,
* A_Iprusd , I_Iflusd , A_Iprbag , I_Iflbag ,
- * A(Ivrpr ), A(Iallvr), A(Ipoint),
- * A(Idum1 ), A(Idum2 ), A(Idiot1), A(Idiot2),
- * A(Ivsqua), A(Ieival), A(Ieivec), A(Izeiv ), A(Ideiv ),
- * A(Iiord ), A(Ikord ),
+ * A(Ivrpr ), A(Iallvr),
* Krext , Nowrt , Nvpall_Old)
C
ELSE
C
C *** Note that call to Rdcovx should not need updating because obsolete
- Ipoint = 1
Nsingl = Nres*10
Isingl = Idimen (Nsingl, 1, 'Singl Nsingl, 1')
Nsingl = Nsingl*2
@@ -114,7 +87,7 @@ C *** Read the very old COVariance file, extract information
* A_Iprbgf , I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma ,
* A_Iprdtp , I_Ifldtp ,
* A_Iprusd , I_Iflusd , A_Iprbag , I_Iflbag ,
- * A(Ivrpr ), A(Iallvr), A(Ipoint),
+ * A(Ivrpr ), A(Iallvr),
* A(Isingl), Krext, Nowrt, Nsingl, Nvpall_Old)
END IF
C
@@ -147,7 +120,7 @@ C *** Generate associated flags
* I_Ifliso , I_Ifzke , I_Ifzkte , I_Ifzkfe )
C
C *** Organized PUPs
- IF (Numpup.GT.0) CALL Set_Keep (A)
+ IF (Numpup.GT.0) CALL Set_Keep
C
C
IF (Kpara+Kparv.NE.0) THEN
@@ -214,18 +187,21 @@ C
C
C ______________________________________________________________________
C
- SUBROUTINE Set_Keep (A)
+ SUBROUTINE Set_Keep
use oops_common_m
use fixedi_m
use ifwrit_m
use exploc_common_m
use oopsch_common_m
+ use AllocateFunctions_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION A(-Msize:Msize)
- Idiag = Idimen (Nfpall, 1, 'Diag Nfpall, 1')
+ real(kind=8),allocatable,dimension(:)::A_Idiag, A_iupupx
+ real(kind=8),allocatable,dimension(:)::A_Ipupcv, A_Idummy
+
+ call allocate_real_data(A_Idiag, Nfpall)
Nn = (Numpup*(Numpup+1))/2
- iupupx = Idimen (Nfpall, 1, 'Upupx Nfpall, 1')
- Ipupcv = Idimen (Nn , 1, 'Pupcov Nn , 1')
+ call allocate_real_data(A_iupupx, Nfpall)
+ call allocate_real_data(A_Ipupcv, Nn)
Kkrext = Nrext
IF (Kkrext.EQ.0) Kkrext = 1
CALL Bet_Pup( A_Iprbrd , I_Iflbrd , I_Intot ,
@@ -238,7 +214,7 @@ C
* A_Iprrpi , I_Iflrpi , A_Iprudr , I_Ifludr ,
* A_Iprnbk , I_Iflnbk , A_Iprbgf , I_Iflbgf ,
* A_Iprdtp , I_Ifldtp , A_Izkte , A_Izeta ,
- * A(Iupupx), Kkrext)
+ * A_Iupupx , Kkrext)
CALL Rparfl_Pup (I_Iflbrd , A_Idebrd ,
* I_Intot , A_Ibcf , A_Icf2 ,
* I_Ifleff , A_Ideeff , I_Ifltru , A_Idetru ,
@@ -248,18 +224,21 @@ C
* I_Iflorr , A_Ideorr , I_Iflrpi , A_Iderpi ,
* I_Ifludr , A_Ideudr ,
* I_Iflnbk , A_Idenbk , I_Iflbgf , A_Idebgf ,
- * I_Ifldtp , A_Idedtp , A_Iddcov , A(Iwkeep),
+ * I_Ifldtp , A_Idedtp , A_Iddcov , A_Iwkeep ,
* I_Inn , I_Imm , I_Ikk , I_Ill , A_Ivv ,
- * A(Iupupx), A(Idiag ), A(Ipupcv),
+ * A_Iupupx , A_Idiag , A_Ipupcv ,
* A_Iuncs , I_Ijuncs ,
* A_Ipriox , I_Iiprio , I_Ijprio ,
* Noffv , Non , Nuncer , Nprior)
- CALL Reorg_Pup (A_Iupup , A(Iupupx))
+ CALL Reorg_Pup (A_Iupup , A_Iupupx)
IF (Kpupcv.EQ.1) THEN
- Idummy = Idimen (Nn, 1, 'Dummy Nn, 1')
- CALL Rdcov_Pup (A_Iupup , A(Idiag), A(Ipupcv), A(Idummy))
+ call allocate_real_data(A_Idummy, Nn)
+ CALL Rdcov_Pup (A_Iupup , A_Idiag , A_Ipupcv, A_Idummy)
+ deallocate(A_Idummy)
END IF
- CALL Write_Pup_Cov (A(Ipupcv))
- I = Idimen (Iupupx, -1, 'Iupupx, -1')
+ CALL Write_Pup_Cov (A_Ipupcv)
+ deallocate(A_Idiag)
+ deallocate(A_iupupx)
+ deallocate(A_Ipupcv)
RETURN
END
diff --git a/sammy/src/old/mold2.f b/sammy/src/old/mold2.f
index 998ab51ce56c97332fd4d36ad7526b4ef010511a..ae53194ce4dd884241dab05335a562b2a78f53a5 100644
--- a/sammy/src/old/mold2.f
+++ b/sammy/src/old/mold2.f
@@ -109,8 +109,6 @@ C
* Parbgf, Iflbgf, kndbgf, Bgfmin, Bgfmax, Texbgf, Teabgf,
* Pardtp, Ifldtp,
* Parusd, Iflusd, Parbag, Iflbag, Vrpr, Allvr,
- * Point , Dum1 , Dum2 , Idiot1, Idiot2,
- * Vsqua , Eival , Eivec , Zeiv , Deiv , Iord , Kord,
* Krext , Nowrt , Nvpall_Old)
C
use fixedi_m
@@ -126,6 +124,7 @@ C
use SammyResonanceInfo_M
use RMatResonanceParam_M
use ReadCovarianceInfo_m
+ use AllocateFunctions_m
use, intrinsic :: ISO_C_BINDING
C this is not a common block, this contains functions
use mold4_m
@@ -140,6 +139,8 @@ C this is not a common block, this contains functions
type(RMatResonance)::resonance, resonanceNew
real(kind=8) :: Dum3
integer,allocatable,dimension(:)::keeper
+ real(kind=8),allocatable,dimension(:)::Dum1, Dum2
+ integer,allocatable,dimension(:)::Idiot1, Idiot2
type(SammySpinGroupInfo)::spinInfo
logical(C_BOOL)::reduced, inc
C
@@ -158,10 +159,7 @@ C# CHARACTER*6 What
* Parbgf(*), Iflbgf(*), Kndbgf(*), Bgfmin(*), Bgfmax(*),
* Texbgf(Ntepnt,*), Teabgf(Ntepnt,*),
* Pardtp(*), Ifldtp(*), Parusd(*), Iflusd(*),
- * Parbag(*), Iflbag(*), Vrpr(*), Allvr(*),
- * Point( *), Dum1(*), Dum2(*), Idiot1(*), Idiot2(*),
- * Vsqua(Nvpall,*), Eival(Nvpall,*), Eivec(Nvpall,*),
- * Zeiv (Nvpall,*), Deiv(*), Iord(*), Kord(*)
+ * Parbag(*), Iflbag(*), Vrpr(*), Allvr(*)
C
C DIMENSION Parbrd(Numbrd), Iflbrd(Numbrd),
C * Igrrad(Ntotc,Ngroup), Pareff(Numrad), Ifleff(Numrad),
@@ -262,12 +260,16 @@ C# IF (Num1.NE.Numdet) STOP '[N.NE.Numdet in mold2.f]'
* (Ifldet(I),I=1,Numdet), (Igrdet(I),I=1,Ngroup)
ELSE IF (Kallow.EQ.1) THEN
C *** Do not allow values for data-related parameters to change
+ call allocate_integer_data(Idiot1, Numdet)
READ (Iu62) (Pardet(I),I=1,Numdet),
* (Idiot1(I),I=1,Numdet), (Igrdet(I),I=1,Ngroup)
CALL Test_Ifl (Idiot1, Ifldet, Numdet, Nvpall,
* 'Detector Efficiencies ')
ELSE
C *** Do allow values for data-related parameters to change
+ call allocate_real_data(Dum1, Numdet)
+ call allocate_integer_data(Idiot1, Numdet)
+ call allocate_integer_data(Idiot2, Ngroup)
READ (Iu62) (Dum1(I),I=1,Numdet),
* (Idiot1(I),I=1,Numdet), (Idiot2(I),I=1,Ngroup)
CALL Test_Ifl (Idiot1, Ifldet, Numdet, Nvpall,
@@ -292,14 +294,17 @@ C# READ (Iu62) What, Num1, Num2
C *** Do not allow values for data-related parameters to change
READ (Iu62) (Parbrd(I),I=1,Numbrd)
C# READ (Iu62) What, Num1, Num2
+ call allocate_integer_data(Idiot1, Numbrd)
READ (Iu62) Iflbrd(1), (Idiot1(I),I=2,Numbrd)
Idiot1(1) = Iflbrd(1)
CALL Test_Ifl (Idiot1, Iflbrd, Numbrd, Nvpall,
* 'Broadening etc. Parameters ')
ELSE
C *** Do allow values for data-related parameters to change
+ call allocate_real_data(Dum1, Numbrd)
READ (Iu62) Parbrd(1), (Dum1(I),I=2,Numbrd)
C# READ (Iu62) What, Num1, Num2
+ call allocate_integer_data(Idiot1, Numbrd)
READ (Iu62) Iflbrd(1), (Idiot1(I),I=2,Numbrd)
Dum1(1) = Parbrd(1)
Idiot1(1) = Iflbrd(1)
@@ -320,6 +325,8 @@ C# READ (Iu62) What, Num1, Num2
C *** Do not allow values for data-related parameters to change
READ (Iu62) (Parbrd(I),I=1,Numbrd),(Parnbk(I),I=1,Numnbk)
C# READ (Iu62) What, Num1, Num2
+ call allocate_integer_data(Idiot1, Numbrd)
+ call allocate_integer_data(Idiot2, Numnbk)
READ (Iu62) Iflbrd(1), (Idiot1(I),I=2,Numbrd),
* (Idiot2(I),I=1,Numnbk)
Idiot1(1) = Iflbrd(1)
@@ -329,9 +336,13 @@ C# READ (Iu62) What, Num1, Num2
* 'Normalization and Background ')
ELSE
C *** Do allow values for data-related parameters to change
+ call allocate_real_data(Dum1, Numbrd)
+ call allocate_real_data(Dum2, Numnbk)
READ (Iu62) Parbrd(1), (Dum1(I),I=2,Numbrd),
* (Dum2(I),I=1,Numnbk)
C# READ (Iu62) What, Num1, Num2
+ call allocate_integer_data(Idiot1, Numbrd)
+ call allocate_integer_data(Idiot2, Numnbk)
READ (Iu62) Iflbrd(1), (Idiot1(I),I=2,Numbrd),
* (Idiot2(I),I=1,Numnbk)
Dum1(1) = Parbrd(1)
@@ -415,15 +426,18 @@ C *** Do not allow values for data-related parameters to change
C# READ (Iu62) What, Num1, Num2
READ (Iu62) (Nammsc(I),I=1,Nummsc)
C# READ (Iu62) What, Num1, Num2
+ call allocate_integer_data(Idiot1, Nummsc)
READ (Iu62) (Idiot1(I),I=1,Nummsc)
CALL Test_Ifl (Idiot1, Iflmsc, Nummsc, Nvpall,
* 'Miscellaneous Parameters ')
ELSE
C *** Do allow values for data-related parameters to change
+ call allocate_real_data(Dum1, Nummsc)
READ (Iu62) (Dum1(I),I=1,Nummsc)
C# READ (Iu62) What, Num1, Num2
READ (Iu62) (Dumna5(I),I=1,Nummsc)
C# READ (Iu62) What, Num1, Num2
+ call allocate_integer_data(Idiot1, Nummsc)
READ (Iu62) (Idiot1(I),I=1,Nummsc)
CALL Test_Ifl (Idiot1, Iflmsc, Nummsc, Nvpall,
* 'Miscellaneous Parameters ')
@@ -468,12 +482,16 @@ C# IF (Num1.NE. Numpmc ) STOP '[N.NE.Numpmc in mold2.f]'
* ((Iflpmc(J,I),J=1,4),I=1,Numpmc), (Isopmc(I),I=1,Numpmc)
ELSE IF (Kallow.EQ.1) THEN
C *** Do not allow values for data-related parameters to change
+ call allocate_integer_data(Idiot1, 4*Numpmc)
READ (Iu62) ((Parpmc(J,I),J=1,4),I=1,Numpmc),
* (Idiot1(I),I=1,4*Numpmc), (Isopmc(I),I=1,Numpmc)
CALL Test_Ifl (Idiot1, Iflpmc, 4*Numpmc, Nvpall,
* 'Paramagnetic Cross Sections ')
ELSE
C *** Do allow values for data-related parameters to change
+ call allocate_real_data(Dum1, 4*Numpmc)
+ call allocate_integer_data(Idiot1, 4*Numpmc)
+ call allocate_integer_data(Idiot2, Numpmc)
READ (Iu62) (Dum1(I),I=1,4*Numpmc),
* (Idiot1(I),I=1,4*Numpmc), (Idiot2(I),I=1,Numpmc)
CALL Test_Ifl (Idiot1, Iflpmc, 4*Numpmc, Nvpall,
@@ -506,6 +524,7 @@ C# READ (Iu62) What, Num1, Num2
C *** Do not allow values for data-related parameters to change
READ (Iu62) (Parorr(I),I=1,Numorr)
C# READ (Iu62) What, Num1, Num2
+ call allocate_integer_data(Idiot1, Numorr)
READ (Iu62) (Idiot1(I),I=1,Numorr)
C# READ (Iu62) What, Num1, Num2
READ (Iu62) (Ecrnch(I),I=1,Numorr-11)
@@ -521,8 +540,10 @@ C# READ (Iu62) What, Num1, Num2
* 'Oak Ridge Resolution Function ')
ELSE
C *** Do allow values for data-related parameters to change
+ call allocate_real_data(Dum1, max(Numorr, Nmdets))
READ (Iu62) (Dum1(I),I=1,Numorr)
C# READ (Iu62) What, Num1, Num2
+ call allocate_integer_data(Idiot1, Numorr)
READ (Iu62) (Idiot1(I),I=1,Numorr)
CALL Test_Ifl (Idiot1, Iflorr, Numorr, Nvpall,
* 'Oak Ridge Resolution Function ')
@@ -555,12 +576,16 @@ C# IF (Num1.NE. Numrpi ) STOP '[N.NE.Numrpi in mold2.f]'
* (Ecrnch(I),I=1,Numrpi-Nnnrpi)
ELSE IF (Kallow.EQ.1) THEN
C *** Do not allow values for data-related parameters to change
+ call allocate_integer_data(Idiot1, Numrpi)
READ (Iu62) (Parrpi(I),I=1,Numrpi), (Idiot1(I),I=1,Numrpi),
* (Ecrnch(I),I=1,Numrpi-Nnnrpi)
CALL Test_Ifl (Idiot1, Iflrpi, Numrpi, Nvpall,
* 'RPI Resolution Function ')
ELSE
C *** Do allow values for data-related parameters to change
+ call allocate_real_data(Dum1, Numrpi)
+ call allocate_real_data(Dum2, Numrpi)
+ call allocate_integer_data(Idiot1, Numrpi)
READ (Iu62) (Dum1(I),I=1,Numrpi), (Idiot1(I),I=1,Numrpi),
* (Dum2(I),I=1,Numrpi-Nnnrpi)
CALL Test_Ifl (Idiot1, Iflrpi, Numrpi, Nvpall,
@@ -580,12 +605,15 @@ C# IF (Num1.NE. Numudr ) STOP '[N.NE.Numudr in mold2.f]'
* (Ecrnch(I),I=1,Numudr-Nnnudr)
ELSE IF (Kallow.EQ.1) THEN
C *** Do not allow values for data-related parameters to change
+ call allocate_integer_data(Idiot1, Numudr)
READ (Iu62) (Parudr(I),I=1,Numudr), (Idiot1(I),I=1,Numudr),
* (Ecrnch(I),I=1,Numudr-Nnnudr)
CALL Test_Ifl (Idiot1, Ifludr, Numudr, Nvpall,
* 'UDR Resolution Function ')
ELSE
C *** Do allow values for data-related parameters to change
+ call allocate_real_data(Dum1, Numudr)
+ call allocate_integer_data(Idiot1, Numudr)
READ (Iu62) (Dum1(I),I=1,Numudr), (Idiot1(I),I=1,Numudr),
* (Dum2(I),I=1,Numudr-Nnnudr)
CALL Test_Ifl (Idiot1, Ifludr, Numudr, Nvpall,
@@ -614,6 +642,7 @@ C# IF (Num2.NE. Ntefil ) STOP '[N.NE.Ntefil in mold2.f]'
END IF
ELSE IF (Kallow.EQ.1) THEN
C *** Do not allow values for data-related parameters to change
+ call allocate_integer_data(Idiot1, Numbgf)
READ (Iu62) (Parbgf(I),I=1,Numbgf),
* (Idiot1(I),I=1,Numbgf), (Kndbgf(I),I=1,Numbgf),
* (Bgfmin(I),I=1,Numbgf), (Bgfmax(I),I=1,Numbgf), Dist
@@ -629,6 +658,10 @@ C# IF (Num2.NE. Ntefil ) STOP '[N.NE.Ntefil in mold2.f]'
END IF
ELSE
C *** Do allow values for data-related parameters to change
+ call allocate_real_data(Dum1, Numbgf)
+ call allocate_real_data(Dum2, Numbgf)
+ call allocate_integer_data(Idiot1, Numbgf)
+ call allocate_integer_data(Idiot2, Numbgf)
READ (Iu62) (Dum1(I),I=1,Numbgf),
* (Idiot1(I),I=1,Numbgf), (Idiot2(I),I=1,Numbgf),
* (Dum2(I),I=1,Numbgf), (Dum2(I),I=1,Numbgf), Distdum
@@ -640,6 +673,7 @@ C *** Do allow values for data-related parameters to change
C# READ (Iu62) What, Num1, Num2
C# IF (What.NE.'Texbgf') STOP '[What.NE.Texbgf in mold2.f]'
Nte = Ntepnt*Ntefil
+ call allocate_real_data(Dum1, Nte)
READ (Iu62) (Dum1(I),I=1,Nte), (Dum2(I),I=1,Nte)
END IF
END IF
@@ -662,11 +696,14 @@ C *** Do not allow values for data-related parameters to change
C# READ (Iu62) What, Num1, Num2
READ (Iu62) (Namdtp(I),I=1,Numdtp)
C# READ (Iu62) What, Num1, Num2
+ call allocate_integer_data(Idiot1, Numdtp)
READ (Iu62) (Idiot1(I),I=1,Numdtp)
CALL Test_Ifl (Idiot1, Ifldtp, Numdtp, Nvpall,
* 'Data-Reduction Parameters ')
ELSE
C *** Do allow values for data-related parameters to change
+ call allocate_real_data(dum1, Numdtp)
+ call allocate_integer_data(Idiot1, Numdtp)
READ (Iu62) (Dum1(I),I=1,Numdtp)
C# READ (Iu62) What, Num1, Num2
READ (Iu62) (Dumna5(I),I=1,Numdtp)
@@ -723,6 +760,11 @@ C# READ (Iu62,END=100,ERR=100) 'Keeper', Nfpall, 0
C
END IF
C
+ if (allocated(Dum1)) deallocate(Dum1)
+ if (allocated(Dum2)) deallocate(Dum2)
+ if (allocated(Idiot1)) deallocate(Idiot1)
+ if (allocated(Idiot2)) deallocate(Idiot2)
+
CLOSE (UNIT=Iu62)
C *** END OF READING OFF UNIT Iu62
RETURN
@@ -850,19 +892,3 @@ C
END DO
RETURN
END
-C
-C
-C --------------------------------------------------------------
-C
- SUBROUTINE Eiv_Modify (Vrpr, Vsqua, U, Nvpall)
- IMPLICIT DOUBLE PRECISION (a-h,o-z)
- DIMENSION Vrpr(*), Vsqua(Nvpall,*), U(*)
- Ij = 0
- DO I=1,Nvpall
- DO J=1,I
- Ij = Ij + 1
- Vrpr(Ij) = U(J)*Vsqua(J,I)*U(I)
- END DO
- END DO
- RETURN
- END
diff --git a/sammy/src/old/mold5.f b/sammy/src/old/mold5.f
index 44f7e40fd79807a234b8aebf4f4afee85ecf8800..62c312d492f7c47a1779abe1c171c2091a670955 100644
--- a/sammy/src/old/mold5.f
+++ b/sammy/src/old/mold5.f
@@ -13,7 +13,7 @@ C
* Parrpi, Iflrpi, Parnbk, Iflnbk,
* Parbgf, Iflbgf, Kndbgf, Bgfmin, Bgfmax, Pardtp, Ifldtp,
* Parusd, Iflusd, Parbag, Iflbag, Vrpr, Allvr,
- * Point, Single, Krext, Nowrt, Nsingl, Nvpall_Old)
+ * Single, Krext, Nowrt, Nsingl, Nvpall_Old)
C
C Here everything must be read in Single-precision and converted to
C double precision. What a pain!
@@ -54,7 +54,7 @@ C
* Parnbk(*), Iflnbk(*),
* Parbgf(*), Iflbgf(*), Kndbgf(*), Bgfmin(*), Bgfmax(*),
* Pardtp(*), Ifldtp(*), Parusd(*), Iflusd(*),
- * Parbag(*), Iflbag(*), Vrpr(*), Allvr(*), Point(*)
+ * Parbag(*), Iflbag(*), Vrpr(*), Allvr(*)
type(SammySpinGroupInfo)::spinInfo
type(SammyResonanceInfo)::resInfo, resNew
diff --git a/sammy/src/old/mold6.f b/sammy/src/old/mold6.f
index 429bb98754f094216f36b162bcb08d7e2adee91c..ee3441189c7511f25666ceb2172190d4351c0805 100755
--- a/sammy/src/old/mold6.f
+++ b/sammy/src/old/mold6.f
@@ -36,14 +36,14 @@ C
C
Nvpall = Nnpar
call covData%setNumParameters(Nvpall)
- allocate(diag(Nvpall))
+ allocate(Diag(Nvpall))
DO Ipar=1,Nvpall
cov = physCov%getCovariance(Ipar, Ipar)
Diag(Ipar) = dSQRT(cov)
END DO
WRITE (77,10300) (Diag(Ipar),Ipar=1,Nvpall)
10300 FORMAT ((6(1PG11.5)))
- deallocate(diag)
+ deallocate(Diag)
C
C
Ii = 1
diff --git a/sammy/src/orr/morr0.f b/sammy/src/orr/morr0.f
index 47172dfbc2981e57d8b6e4232a4f9846d285dbdb..378a5ecd456f2794a0c6e796d9986ff9b0948aac 100644
--- a/sammy/src/orr/morr0.f
+++ b/sammy/src/orr/morr0.f
@@ -66,8 +66,8 @@ C *** Orresl performs resolution-broadening operation
* I_Iflmsc , A_Iprnbk , I_Iflnbk ,
* A_Iprbgf , I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma ,
* A_Itexbg , A_Iteabg , A(Ieb ), A(Ie ),
- * A(Iwsigx), A(Iwdasi), A(Iwdbsi), A(Isigxx), A(Idasig), A(Idbsig),
- * A(Ivsigx), A(Ivdasi), A(Ivdbsi), A(Iweigh), A(Iwts ),
+ * A(Iwsigx), A(Iwdasi), A_Iwdbsi , A(Isigxx), A(Idasig), A(Idbsig),
+ * A(Ivsigx), A(Ivdasi), A_Ivdbsi , A(Iweigh), A(Iwts ),
* A(Ith ), A(Isgmns), A(Isgpls))
C
C
diff --git a/sammy/src/rec/mrec5.f b/sammy/src/rec/mrec5.f
index 9b5f14df68613fb9b93ab641809fc8d84e113fee..70c634edd3618ca7a413913d1dac07c50ade43d5 100644
--- a/sammy/src/rec/mrec5.f
+++ b/sammy/src/rec/mrec5.f
@@ -90,11 +90,9 @@ C *** Sig2(2,I) is capture cross section (absorption - fission)
Ienerg = Ienerb
Iwsigx = Idimen (Ndatb, 1, 'Ndatb, 1')
Iwdasi = 1
- Iwdbsi = 1
Iwsigs = 1
Ivsigx = Idimen (Ndatb, 1, 'Ndatb, 1')
Ivdasi = 1
- Ivdbsi = 1
Ivsigs = 1
Ksolve = 2
Ndasig = 0
diff --git a/sammy/src/rpi/mrpi0.f b/sammy/src/rpi/mrpi0.f
index 5007667b579412108bdd1f44e9be22768a8f738f..35f15dbde57479c42ef35addd1804861cd3e830e 100644
--- a/sammy/src/rpi/mrpi0.f
+++ b/sammy/src/rpi/mrpi0.f
@@ -75,8 +75,8 @@ C *** Rpirsl performs resolution-broadening operation
* A_Iprnbk , I_Iflnbk , A_Iprbgf , I_Iflbgf , A_Indbgf ,
* A_Ibgfmi , A_Ibgfma , A_Itexbg , A_Iteabg ,
* A(Ie ), A(Ieb ), A(Ith ),
- * A(Iwsigx), A(Iwdasi), A(Iwdbsi), A(Isigxx), A(Idasig),
- * A(Idbsig), A(Ivsigx), A(Ivdasi), A(Ivdbsi), A(Iweigh),
+ * 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
diff --git a/sammy/src/rsl/mrsl0.f b/sammy/src/rsl/mrsl0.f
index 36ab1b8ce2aa6951378021121271c4b4ee312b75..7f81116d2927307be1a0b37a5f4d1897cdba7730 100644
--- a/sammy/src/rsl/mrsl0.f
+++ b/sammy/src/rsl/mrsl0.f
@@ -59,8 +59,8 @@ C *** Resolu PERFORMS RESOLUTION-BROADENING OPERATION
CALL Resolu (A_Ibcf , A_Icf2 , I_Iflmsc , A_Iprnbk ,
* I_Iflnbk , A_Iprbgf , I_Iflbgf , A_Indbgf , A_Ibgfmi ,
* A_Ibgfma , A_Itexbg , A_Iteabg , A(Ie ), A(Ieb ),
- * A(Ith ), A(Iwsigx), A(Iwdasi), A(Iwdbsi), A(Isigxx),
- * A(Idasig), A(Idbsig), A(Ivsigx), A(Ivdasi), A(Ivdbsi),
+ * A(Ith ), A(Iwsigx), A(Iwdasi), A_Iwdbsi , A(Isigxx),
+ * A(Idasig), A(Idbsig), A(Ivsigx), A(Ivdasi), A_Ivdbsi ,
* A(Iweigh), A(Iwts ))
C
C
diff --git a/sammy/src/rsl/mrsl7.f b/sammy/src/rsl/mrsl7.f
index a536be3b5f2c838fa3e878d41e984806fb4934ff..5fda5210d2a90db889d99d641bea698efc3a7fab 100644
--- a/sammy/src/rsl/mrsl7.f
+++ b/sammy/src/rsl/mrsl7.f
@@ -9,7 +9,7 @@ C
C *** one ***
Iwsigx = Idimen (Kwsigx, 1, 'Iwsigx Kwsigx, 1')
Iwdasi = Idimen (Kwdasi, 1, 'Iwdasi Kwdasi, 1')
- Iwdbsi = Idimen (Kwdbsi, 1, 'Iwdbsi Kwdbsi, 1')
+ call make_A_Iwdbsi(Kwdbsi)
Iwsigs = Idimen (Kwsigs, 1, 'Iwsigs Kwsigs, 1')
call make_A_Iwdass(Kwdass)
call make_A_Iwdbss(Kwdbss)
@@ -23,8 +23,11 @@ C
C
Ivsigx = Idimen (Kwsigx, 1, 'Ivsigx Kwsigx, 1')
Ivdasi = Idimen (Kwdasi, 1, 'Ivdasi Kwdasi, 1')
- Ivdbsi = Idimen (Kwdbsi, 1, 'Ivdbsi Kwdbsi, 1')
- Ivsigs = Idimen (Kwsigs, 1, 'Ivsigs Kwsigs, 1')
+C Add the ones back to the dimension that we
+C converted to allocate. This array is reused and re-dimensioned
+C in Samxct_0 in mxct0.f
+ Ivsigs = Idimen (Kwsigs+Kwdbsi+Kwdass+Kwdbss, 1,
+ * 'Ivsigs Kwsigs, 1')
Inext = Idimen (1 , 1, 'Inext 1 , 1')
I = Idimen (Inext, -1, ' Inext, -1')
RETURN
@@ -44,9 +47,17 @@ C *** Set_Kws reverses arrays so that V's are input & W's are output
Ix = Iwdasi
Iwdasi = Ivdasi
Ivdasi = Ix
- Ix = Iwdbsi
- Iwdbsi = Ivdbsi
- Ivdbsi = Ix
+
+ if( IvdbsiChanged) then
+ A_Iwdbsi => A_Iwdbsi_r
+ A_Ivdbsi => A_Ivdbsi_r
+ IvdbsiChanged = .false.
+ else
+ A_Iwdbsi => A_Ivdbsi_r
+ A_Ivdbsi => A_Iwdbsi_r
+ IvdbsiChanged = .true.
+ end if
+
Ix = Iwsigs
Iwsigs = Ivsigs
Ivsigs = Ix
diff --git a/sammy/src/ssm/mssm02.f90 b/sammy/src/ssm/mssm02.f90
index e1680006220886ea7b4fb22bb22c91c85bfcf1c2..45d58ce88b92b0088884f09b8a5eaa85f97c8b52 100644
--- a/sammy/src/ssm/mssm02.f90
+++ b/sammy/src/ssm/mssm02.f90
@@ -44,7 +44,7 @@ module ssm_2_m
Jgbmax = 0
Kkknew = 0
- CALL Read_Cross_Sections (A(Ivsigx), A(Ivdasi), A(Ivdbsi), &
+ CALL Read_Cross_Sections (A(Ivsigx), A(Ivdasi), A_Ivdbsi , &
A(Ivsigs), A_Ivdass , A_Ivdbss , A(Iwe), Jgbmax, Kkknew, 1, Iv)
IF (Kdatb.NE.Kkknew) THEN
WRITE (6,10200) Kdatb, Kkknew, Jgbmax, Iv
@@ -52,7 +52,7 @@ module ssm_2_m
STOP '[STOP in Ssssds in ssm/mssm02.f]'
END IF
!
- CALL Zero_Cross_Sections (A(Ith), A(Iwsigx), A(Iwdasi), A(Iwdbsi), &
+ CALL Zero_Cross_Sections (A(Ith), A(Iwsigx), A(Iwdasi), A_Iwdbsi , &
A(Isigxx), A(Isigxx), A(Isigxx), Kk, Kdatb, 0)
!
IF (Kwssms.EQ.1) CALL Newopn (15, Sam15x, 1)
diff --git a/sammy/src/ssm/mssm03.f90 b/sammy/src/ssm/mssm03.f90
index 53712221aabafd2d6cc2dfe4d84ca57e3f87fa30..ba9a890fde0abe467ded08b5610232a35c329b80 100644
--- a/sammy/src/ssm/mssm03.f90
+++ b/sammy/src/ssm/mssm03.f90
@@ -43,7 +43,7 @@ module ssm_3_m
Nn = N
Y0 = Zero
CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
- A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Ivdasi), A_Ivdbsi , Energb, Totsig, Capsig, &
A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
!
@@ -175,7 +175,7 @@ module ssm_3_m
IF (Ksolve.NE.2) CALL Zero_Array (A(Idyyy1), Nx)
!
CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
- A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Ivdasi), A_Ivdbsi , Energb, Totsig, Capsig, &
A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
!
@@ -338,7 +338,7 @@ module ssm_3_m
IF (Ksolve.NE.2) CALL Zero_Array (A(Idyyy1), Nx)
!
CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
- A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Ivdasi), A_Ivdbsi , Energb, Totsig, Capsig, &
A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
!
@@ -505,7 +505,7 @@ module ssm_3_m
CALL Zero0_1f (A, Yyy1fb, Y0, Yyy1, Nx)
!
CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
- A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Ivdasi), A_Ivdbsi , Energb, Totsig, Capsig, &
A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
!
@@ -672,7 +672,7 @@ module ssm_3_m
CALL Zero0_1f (A, Yyy1fb, Y0, Yyy1, Nx)
!
CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
- A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Ivdasi), A_Ivdbsi , Energb, Totsig, Capsig, &
A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
!
diff --git a/sammy/src/ssm/mssm04.f90 b/sammy/src/ssm/mssm04.f90
index d1bb6de4bdc5d03be8c27cd7b6e3d057b99f16b9..12a4ea9c1839210d790895cf1f15c0dfcf21e615 100644
--- a/sammy/src/ssm/mssm04.f90
+++ b/sammy/src/ssm/mssm04.f90
@@ -58,7 +58,7 @@ module ssm_4_m
CALL Zero0_2i (A, Y0, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx)
!
CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
- A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Ivdasi), A_Ivdbsi , Energb, Totsig, Capsig, &
A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
!
@@ -240,7 +240,7 @@ module ssm_4_m
CALL Zero0_2i (A, Y0, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx)
!
CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
- A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Ivdasi), A_Ivdbsi , Energb, Totsig, Capsig, &
A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
!
@@ -428,7 +428,7 @@ module ssm_4_m
CALL Zero0_2f (A, Yyy1fb, Y0, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx)
!
CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
- A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Ivdasi), A_Ivdbsi , Energb, Totsig, Capsig, &
A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
!
@@ -616,7 +616,7 @@ module ssm_4_m
CALL Zero0_2f (A, Yyy1fb, Y0, Yyy1, Yyy2, Yyy2q, Y2bbbb, Y2bbbq, Nx)
!
CALL Getcrs (A(Icccll), A(Idddll), I_Iisopa , A(Ivsigx), &
- A(Ivdasi), A(Ivdbsi), Energb, Totsig, Capsig, &
+ A(Ivdasi), A_Ivdbsi , Energb, Totsig, Capsig, &
A(Idtots), A(Idcaps), Ee, Elastic, Nx, Nn, Istop)
IF (Istop.EQ.1) GO TO 80
!
diff --git a/sammy/src/ssm/mssm22.f90 b/sammy/src/ssm/mssm22.f90
index 2a718f12892dd2a8a35a64ebf24b22ede480db90..0669e74469cb18f1e6ad9993a86d47a562cf306c 100644
--- a/sammy/src/ssm/mssm22.f90
+++ b/sammy/src/ssm/mssm22.f90
@@ -28,7 +28,7 @@
END IF
!
IF (Another_Process_Will_Happen) THEN
- CALL Store_W (A(Iwsigx), A(Iwdasi), A(Iwdbsi), &
+ CALL Store_W (A(Iwsigx), A(Iwdasi), A_Iwdbsi , &
A(Isigxx), A(Idasig), A(Idbsig), 1, 1, Kkkdat)
ELSE
IF (Numnbk.GT.0) CALL Norm (A_Iprnbk , I_Iflnbk , &
@@ -36,7 +36,7 @@
IF (Numbgf.GT.0) CALL Bgfrpi (A_Iprbgf , I_Iflbgf , A_Indbgf , &
A_Ibgfmi , A_Ibgfma , A_Itexbg , A_Iteabg , A(Isigxx), &
A(Idbsig), Em, 1)
- CALL Store_W (A(Iwsigx), A(Iwdasi), A(Iwdbsi), &
+ CALL Store_W (A(Iwsigx), A(Iwdasi), A_Iwdbsi , &
A(Isigxx), A(Idasig), A(Idbsig), 1, 1, Kkkdat)
END IF
RETURN
@@ -67,15 +67,15 @@
Kkkmin = Kdatmn - 1
Iw = 0
CALL Write_Cross_Sections (Energb, A(Iwsigx), A(Iwdasi), &
- A(Iwdbsi), A(Iwe), A(Iwe), A(Iwe), 1, Kkkdat, Kkkmin, Iw)
+ A_Iwdbsi , A(Iwe), A(Iwe), A(Iwe), 1, Kkkdat, Kkkmin, Iw)
!
ELSE
! ELSE IF (.NOT.Another_Process_Will_Happen) THEN
! *** need to reorder such that keep only the energies in the
! *** experimental grid; may need to interpolate
CALL Reorder_Energy (Energy, Energb, A(Iwsigx), A(Iwdasi), &
- A(Iwdbsi), A(Ith), Kdatmn, Kdatmx, Kkkdat)
- IF (Ksolve.NE.2) CALL Write_W_48 (A(Iwdasi), A(Iwdbsi), 1, Kkkdat)
+ A_Iwdbsi , A(Ith), Kdatmn, Kdatmx, Kkkdat)
+ IF (Ksolve.NE.2) CALL Write_W_48 (A(Iwdasi), A_Iwdbsi , 1, Kkkdat)
END IF
Ndatmx = Kkkdat
!
diff --git a/sammy/src/udr/mudr0.f b/sammy/src/udr/mudr0.f
index a938d0cc943d9b55ee4c38045e2165c9b239458a..e94cadbda2b84246c733180dca61b9dad1546c39 100644
--- a/sammy/src/udr/mudr0.f
+++ b/sammy/src/udr/mudr0.f
@@ -63,8 +63,8 @@ C *** Udr_Resl PERFORMS RESOLUTION-BROADENING OPERATION
* I_Iflmsc , A_Iprnbk , I_Iflnbk ,
* A_Iprbgf , I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma ,
* A_Itexbg , A_Iteabg , A(Ieb), A(Ie),
- * A(Iwsigx), A(Iwdasi), A(Iwdbsi), A(Isigxx), A(Idasig), A(Idbsig),
- * A(Ivsigx), A(Ivdasi), A(Ivdbsi), A(Iwts),
+ * A(Iwsigx), A(Iwdasi), A_Iwdbsi , A(Isigxx), A(Idasig), A(Idbsig),
+ * A(Ivsigx), A(Ivdasi), A_Ivdbsi , A(Iwts),
* A(Ith ), A(Isgmns), A(Isgpls))
C
C
diff --git a/sammy/src/xct/mxct0.f b/sammy/src/xct/mxct0.f
index 362bd9ac282082975121c735cafdf54f603129f8..00191e6f11c101a2b0a2d2361f1107df4569e371 100644
--- a/sammy/src/xct/mxct0.f
+++ b/sammy/src/xct/mxct0.f
@@ -329,7 +329,7 @@ C
CALL Work ( A, I_Iflmsc , A_Iprnbk , I_Iflnbk ,
* A_Iprbgf , I_Iflbgf , A_Indbgf , A_Ibgfmi , A_Ibgfma ,
* A_Itexbg , A_Iteabg , A(Ienerb), A(Ith ), A(Iwsigx),
- * A(Iwdasi), A(Iwdbsi), A(Iwsigs), A_Iwdass , A_Iwdbss ,
+ * A(Iwdasi), A_Iwdbsi , A(Iwsigs), A_Iwdass , A_Iwdbss ,
* A(Isigxx), A(Idasig), A(Idbsig), A(Isigsi), A(Idasis),
* A(Idbsis), I_Iisopa , A(Ipiece), A(Idum ), A_Iadder ,
* A_Iaddcr , I_Inbt , I_Iint , A(Iedrcp), A(Icdrcp),