-
Wiarda, Dorothea authoredWiarda, Dorothea authored
Code owners
Assign users and groups as approvers for specific file changes. Learn more.
mnpv9.f 6.19 KiB
C
C
C --------------------------------------------------------------
C
SUBROUTINE Prepare_Storage (A, Nnndat, Kkkidc, Numidc,
* Nidc, Kdat)
C
C *** Purpose -- Create the arrays Th, G, X, in lowest possible storage
C *** location so that other needed arrays will not wipe out
C *** the storage
C
use over_common_m
use oops_common_m
use fixedi_m
use ifwrit_m
use exploc_common_m
use samxxx_common_m
use array_sizes_common_m
use oopsch_common_m
use namfil_common_m
use AllocateFunctions_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
real(kind=8),allocatable,dimension(:)::A_Igx
DIMENSION A(-Msize:Msize)
C
C
IF (Ntgrlq.GT.0) THEN
C *** Open SAM30.DAT for integral quantities, read dimensions
CALL Oldopn (30, Sam30x, 1)
READ (30) Nnndat
CLOSE (UNIT=30)
ELSE
Nnndat = Kdat*Numcro
END IF
C
C *** Reorganize array storage
Nig = Nvpall*Nnndat
IF (Nig .EQ.0) Nig = 1
IF (Ksolve.EQ.2) Nig = 1
Nix = Kkkidc*Nnndat
IF (Nix.EQ.0) Nix = 1
N = Nnpar*Nnndat
IF (N.EQ.0) N = 1
Kgx = N
C
C Ensure all arrays are dimensions large enough
IF (Ksolve.NE.2 .OR. Nfpall.GT.Nvpall) THEN
CALL SetGStorage (A(Iiuif), Nig, Nix, Kgx,
* Kkkidc, Numidc, Kdat, Nidc)
END IF
! theoretical data start at Iwsigx or Ivsigx
IF (Iwsigx.LT.Ivsigx) THEN
I = Idimen (Iwsigx, -1, '1 Iwsigx, -1') ! release memory for Iwsigx
ELSE
I = Idimen (Ivsigx, -1, '1 Ivsigx, -1') ! release memory for Ivsigx
END IF
Ith = Idimen (Nnndat, 1, 'Ith Nnndat, 1')
C Allocate the temporary arrays needed
call allocate_real_data(A_Ig, nig)
call allocate_real_data(A_Ix, nix)
call allocate_real_data(A_igx, Kgx)
C
C *** Copy Wsigxx into Th and Wd?sig into Gx
C A(Iwsigx) -> A(Ith)
C ( A(Iwdasi), A_Iwdbsi ) -> A_Igx
if (Ith.ne.Iwsigx) then
N = Kdat*Numcro DO I=1,N
A(Ith + I -1) = A(Iwsigx + I -1)
END DO
end if
CALL Reorg ( A_Igx, A(Iwdasi), A_Iwdbsi , Kdat)
C
C
IF (Ksolve.NE.2 .OR. Nfpall.GT.Nvpall) THEN
C *** Put A_Igx into A_Ig
C That is: reorder derivatives from A_Igx in correct order into A_Ig
CALL Setg (A(Iiuif), A_Ig, A_Ix, A_Igx,
* Kkkidc, Numidc, Kdat, Nidc)
END IF
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
C
IF (Ksolve.NE.2 .AND. Nvpdtp.NE.0) THEN
Igtild = Idimen (Nvpdtp*Kdat, 1, 'Igtild Nvpdtp*Kdat, 1')
CALL Read_Data_Red_Par (A_Ig, A_Ix, A(Igtild),
* Nnndat, Kkkidc, Numidc, Nidc)
END IF
deallocate(A_Igx)
C
RETURN
END
C
C
C --------------------------------------------------------------
C
SUBROUTINE Get_Organized (A)
C
C *** Purpose -- Read arrays, etc, in preparation for Bayes
C
use oops_common_m
use fixedi_m
use ifwrit_m
use exploc_common_m
use samxxx_common_m
use EndfData_common_m
IMPLICIT NONE
REAL(KIND=8):: A(-Msize:Msize)
integer::i, ie, idimen
external idimen
Ksolve = Ks_Res
IF (Kgenpd.EQ.1) Ksolve = 2
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
IF (Ksolve.NE.2) THEN
call covData%saveOrigUParam()
END IF
C
RETURN
END
C
C
C --------------------------------------------------------------
C
SUBROUTINE Get_Idc (A, Iw, Istat, Numidc, Ifree, Kkkidc,
* N1, N2, Nnndat, Kdat)
use oops_common_m
use fixedi_m
use ifwrit_m
use exploc_common_m
use oopsch_common_m
use namfil_common_m
use array_sizes_common_m
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION A(-Msize:Msize) Iw = 1
Istat = 1
Ifree = 0
C
IF (Kidcxx.EQ.1) THEN
C *** Here prepare derivatives for implicit data covariance matrix
C *** when part of idcm is generated directly by SAMMY from
C *** normalization and background parameters
Jidc1 = Kkkidc**2
Iw = Idimen (Jidc1, 1, 'Iw Jidc1, 1')
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
Ie = Idimen (Kdat , 1, 'Ie Kdat , 1')
IF (N1.GT.0) THEN
Jidc4 = 6
Ip1 = Idimen (Jidc4, 1, 'Ip1 Jidc4, 1')
Iw1 = Idimen (Jidc4, 1, 'Iw1 Jidc4, 1')
ELSE
Jidc4 = 1
Ip1 = 1
Iw1 = 1
END IF
IF (N2.GT.0) THEN
Jidc5 = N2
Ip2 = Idimen (Jidc5, 1, 'Ip2 Jidc5, 1')
Ik2 = Idimen (Jidc5, 1, 'Ik2 Jidc5, 1')
Ibn = Idimen (Jidc5, 1, 'Ibn Jidc5, 1')
Ibm = Idimen (Jidc5, 1, 'Ibm Jidc5, 1')
ELSE
Jidc5 = 1
Ip2 = 1
Ik2 = 1
Ibn = 1
Ibm = 1
END IF
CALL Findxx (A(Ith), A(Iw), A_Ix, A(Ie), A(Ip1), A(Iw1),
* A(Ip2), A(Ik2), A(Ibn), A(Ibm), N1, N2, Numidc, Kkkidc,
* Kdat)
I = Idimen (Ie, -1, ' Ie, -1')
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
C
ELSE IF (Kidcxx.EQ.2) THEN
C *** Here when user-supplied Implicit Data Covariance Matrix plus
C *** (maybe) PUPs
Jidc1 = Kkkidc**2
Iw = Idimen (Jidc1, 1, 'Iw Jidc1, 1')
Istat = Idimen (Kdat , 1, 'Istat Kdat , 1')
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <
Ie = Idimen (Ndat, 1, 'Ie Ndat, 1')
CALL Read_Cov_Idc (A(Iw), A_Ix, A(Istat), A(Ie), Numidc,
* Kkkidc, Ndat, Ifree, Numcro)
C *** reads user-supplied IDC
I = Idimen (Ie, -1, ' Ie, -1')
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - >
CLOSE (UNIT=30)
C
ELSE IF (Numpup.GT.0) THEN
C *** Here PUPs are used, but no other kind of IDCM
Jidc1 = Numpup**2
Iw = Idimen (Jidc1, 1, 'Iw Jidc1, 1')
CALL Zero_Array (A(Iw), Jidc1)
Istat = Idimen (1, 1, 'Istat 1, 1')
C
ELSE
Istat = Idimen (1, 1, 'Istat 1, 1')
END IF
C
RETURN
END