      SUBROUTINE ROMBER (B,PRECIS,ITDONE,FINTG,K,X)
C
C     TO INTEGRATE F(X) FROM X = A TO X = B
C
C         A = LOWER LIMIT = 0.0
C         B = UPPER LIMIT
C         NOSIG = NUMBER OF CORRECT SIGNIFICANT DIGITS DESIRED
C                 (NOT MORE THAN 7) = 5
C         PRECIS = 0.0  UPON RETURN, PRECIS = ACTUAL NUMBER
C                       OF SIGNIFICANT DIGITS ATTAINED
C         NUM = MAXIMUM NUMBER OF HALVINGS OF B-A TO BE MADE
C               (NOT MORE THAN 99) = 15
C         PROGRAMMER MUST ALSO PROGRAM SUBROUTINE FUNCT(F,X)
C         GIVING F AS THE DESIRED FUNCTION OF X, UPON
C         DEMAND OF ROMBER
C         UPON RETURN FROM ROMBER, THE VALUE OF THE INTEGRAL
C         WILL BE FOUND IN FINTG
C         IT IS CUSTOMARY TO MEASURE THE PRECISION OF LARGE NUMBERS IN
C     TERMS OF NUMBER OF SIGNIFICANT DIGITS AND THE ACCURACY OF SMALL
C     NUMBERS IN TERMS OF NUMBER OF SIGNIFICANT DECIMALS.  TO CONFORM
C     TO THIS PRACTICE, THE SUBROUTINE TERMINATES WHEN EITHER OF THESE
C     CONDITIONS IS MET.
C
      DIMENSION   X(6)
      DIMENSION   FAAAA(20),FAAAB(20)
C
      FAAAC = 0.00001
      IAAAA = 1
      FAAAD = B
      X(1)  = 0.0
      ASSIGN 100 TO IRET
      GO TO (1000,2000,3000), K
  100 CONTINUE
      FAAAE = F
      X(1)  = B
      ASSIGN 200 TO IRET
      GO TO (1000,2000,3000), K
  200 CONTINUE
      FAAAE = FAAAE+F
      FAAAA(1) = 0.5*FAAAD*FAAAE
 9988 FAAAD = 0.5*FAAAD
      IAAAC = 2**(IAAAA-1)
      FAAAE = 0.0
      IAAAD = 0
 9986 IAAAD = IAAAD + 1
      FAAAF = IAAAD
      X(1)  = (2.0*FAAAF-1.0)*FAAAD
      ASSIGN 300 TO IRET
      GO TO (1000,2000,3000), K
  300 CONTINUE
      FAAAE = FAAAE+F
      IF (IAAAD .LT. IAAAC) GO TO 9986
      FAAAB(1) = 0.5*FAAAA(1)+FAAAD*FAAAE
      IAAAA = IAAAA+1
      DO 9985 IAAAD = 2,IAAAA
      FAAAG = 4.0**(IAAAD-1)
      FAAAH = FAAAG-1.0
      IAAAF = IAAAD-1
 9985 FAAAB(IAAAD) = (FAAAG*FAAAB(IAAAF)-FAAAA(IAAAF))/FAAAH
      IAAAC = 2*IAAAC+1
      DIFF  = FAAAB(IAAAA)- FAAAA(IAAAA-1)
      IF (ABS(DIFF) - ABS(FAAAC*FAAAB(IAAAA))) 9979,9981,9981
 9981 DO 9980 IAAAD = 1,IAAAA
 9980 FAAAA(IAAAD) = FAAAB(IAAAD)
      IF (IAAAA .LT. 15) GO TO 9988
 9979 PRECIS = DIFF
      ITDONE = IAAAA - 1
      FINTG  = FAAAB(IAAAA)
      RETURN
C
C     THIS CODE REPLACES F4
C
 1000 CONTINUE
      IF (X(1) .EQ. 0.0) GO TO 1020
      DEN = X(3) - X(2)*X(5) + X(2)*X(5)*COS(X(1))+X(2)*X(4)*SIN(X(1))
      F   = X(1)**(X(6)-1.0)* SIN(X(1))**2 / DEN
 1010 GO TO IRET, (100,200,300)
 1020 F = 0.0
      GO TO 1010
C
C     THIS CODE REPLACES F5
C
 2000 CONTINUE
      IF (X(1) .EQ. 0.0) GO TO 2020
      DEN = X(3) - X(2)*X(5) + X(2)*X(5)*COS(X(1))+X(2)*X(4)*SIN(X(1))
      F   = X(1)**(X(6)-1.0)*2. *SIN(X(1))*COS(X(1))/DEN
 2010 GO TO IRET, (100,200,300)
 2020 F = 0.0
      GO TO 2010
C
C     THIS CODE REPLACES F6
C
 3000 CONTINUE
      DEN = X(3) - X(2)*X(5) + X(2)*X(5)*COS(X(1))+X(2)*X(4)*SIN(X(1))
      IF (X(6) .EQ. 1.0) CONST = 1.0
      IF (X(6) .NE. 1.0) CONST = X(1)**(X(6) - 1.0)
      IF (DEN  .EQ. 0.0) GO TO 3020
      F = CONST*COS(X(1))**2 / DEN
 3010 GO TO IRET, (100,200,300)
 3020 F = 0.0
      GO TO 3010
      END


 SUBROUTINE j2syie(nstre,nn,nq,yield,sgefe,pymat,coefn,coefm,coenm,&
&                  yistr)
 !------------------------------------------------------------------------------
 !
 !     this routine compute the yield FUNCTION of the j2 shell plasticity model
 !
 !     input:
 !       sgefe(nstre): actual efective stress (diagonalized base)
 !       pymat(nn)=<2/3>, <1/3,1> o <1/3,1,2> matrix
 !       coefn : square of plastic modulus for membrane
 !       coefm : square of plastic modulus  for bending
 !       coenm : plastic modulus product
 !       yistr : yield stress
 !    output:
 !       yield(2): yield functions for two surface
 !
 !------------------------------------------------------------------------------
 IMPLICIT NONE
 INTEGER (kind=4) nstre,nn,nq
 REAL   (kind=8) yield(2),sgefe(*),pymat(*),coefn,coefm,coenm,yistr

 INTEGER i,j
 REAL (kind=8) valu1,valu2,coefq

 coefq = 2*coefn
 valu1 = 0d0
 valu2 = 0d0
 DO i = 1,nn
   j = i+nn
   valu1 = valu1 + sgefe(i)*sgefe(i)*pymat(i)*coefn                &
&                + sgefe(j)*sgefe(j)*pymat(i)*coefm
   valu2 = valu2 + sgefe(i)*sgefe(j)*pymat(i)*coenm
 END DO
 DO i = nq,nstre
   valu1 = valu1 + sgefe(i)*sgefe(i)*coefq
 END DO
 yield(1) = valu1/2d0 + valu2 - yistr**2/3d0
 yield(2) = valu1/2d0 - valu2 - yistr**2/3d0
 RETURN
 END SUBROUTINE j2syie

 !------------------------------------------------------------------------------
 SUBROUTINE j2sflw(nstre,nn,nq,flows,sgefe,pymat,coefn,coefm,coenm,&
&                  signo)
 !------------------------------------------------------------------------------
 !
 !     compute actual flow rule of j2 shell plasticity
 !
 !     input:
 !       sgefe(nstre): actual efective stress (diagonalized base)
 !       pymat(nn)=<2/3>, <1/3,1> o <1/3,1,2> matrix
 !       coefn : plastic thickness for membrane
 !       coefm : plastic modulus  for bending
 !       coenm : plastic thickness for shear
 !    output:
 !       flows(nstre,2): flow rule for each surface
 !
 !------------------------------------------------------------------------------
 IMPLICIT NONE
 INTEGER (kind=4) nstre,nn,nq
 REAL (kind=8) flows(nstre,2),sgefe(*),pymat(*),coefn,coefm,coenm, &
&              signo(2)

 INTEGER i,j,iyiel
 REAL (kind=8) coefq

 coefq = 2.0d0*coefn
 DO iyiel = 1,2
   DO i = 1,nn
     j = i+nn
     flows(i,iyiel) = sgefe(i)*pymat(i)*coefn +                    &
&                     sgefe(j)*pymat(i)*coenm*signo(iyiel)
     flows(j,iyiel) = sgefe(i)*pymat(i)*coenm*signo(iyiel) +       &
&                     sgefe(j)*pymat(i)*coefm
   END DO
   DO i = nq,nstre
     flows(i,iyiel) = sgefe(i)*coefq
   END DO
 END DO
 RETURN
 END SUBROUTINE j2sflw

 !------------------------------------------------------------------------------
 SUBROUTINE j2sdia(nn,strsg)
 !------------------------------------------------------------------------------
 !
 !     transform tensor from cartesian to diagonalized base
 !
 !------------------------------------------------------------------------------
 IMPLICIT NONE
 INTEGER (kind=4) nn
 REAL    (kind=8) strsg(*)

 REAL (kind=8) str11,str22
 REAL (kind=8),PARAMETER  :: root2 = 1.414213562373095

 SELECT CASE (nn)

 CASE (2)         !axilsymmetric shell
   str11 = strsg(1)
   str22 = strsg(2)
   strsg(1) = ( str11+str22)/root2
   strsg(2) = ( str11-str22)/root2
   str11 = strsg(3)
   str22 = strsg(4)
   strsg(3) = ( str11+str22)/root2
   strsg(4) = ( str11-str22)/root2

 CASE (3)        !3-D shell
   str11 = strsg(1)
   str22 = strsg(2)
   strsg(1) = ( str11+str22)/root2
   strsg(2) = (-str11+str22)/root2
   str11 = strsg(4)
   str22 = strsg(5)
   strsg(4) = ( str11+str22)/root2
   strsg(5) = (-str11+str22)/root2

 END SELECT
 RETURN
 END SUBROUTINE j2sdia

 !------------------------------------------------------------------------------
 SUBROUTINE j2scar(nn,strsg)
 !------------------------------------------------------------------------------
 !
 !     transform tensor from diagonalized to cartesian base
 !
 !------------------------------------------------------------------------------
 IMPLICIT NONE
 INTEGER (kind=4) nn
 REAL (kind=8) strsg(*)

 REAL (kind=8) str11,str22
 REAL (kind=8),PARAMETER  :: root2=1.414213562373095

 SELECT CASE (nn)

 CASE (2)
   str11 = strsg(1)
   str22 = strsg(2)
   strsg(1)=( str11+str22)/root2
   strsg(2)=( str11-str22)/root2
   str11 = strsg(3)
   str22 = strsg(4)
   strsg(3)=( str11+str22)/root2
   strsg(4)=( str11-str22)/root2

 CASE (3)
   str11 = strsg(1)
   str22 = strsg(2)
   strsg(1) = (str11-str22)/root2
   strsg(2) = (str11+str22)/root2
   str11 = strsg(4)
   str22 = strsg(5)
   strsg(4) = (str11-str22)/root2
   strsg(5) = (str11+str22)/root2

 END SELECT
 RETURN
 END SUBROUTINE j2scar


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Spergel-Press WIMP heat transport module !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

! Contains the functions used in the Spergel Press section of transgen.f90. These are:
!	-nx_isothermal: Calculates the WIMP density in the Spergel-Press scheme
! 	-Etrans_sp: calculates the WIMP transported energy (eps_x) given the WIMP temperature (Tx)
!	-Tx_integral: to be used in newtons_meth
!	-newtons_meth: solves Tx_integral=0 which defines Tx

! All units are cgs except tab_r and tab_dr
! I apologize for the long function calls.

module spergelpressmod
use capmod
implicit none

double precision, parameter :: kB=1.38064852d-16, mnucg=1.6726219e-24

contains

function nx_isothermal(T_x, Nwimps)
implicit none
double precision, intent(in) :: T_x, Nwimps
double precision :: nx_isothermal(nlines)
double precision :: n_0, mxg
double precision :: R(nlines), phi(nlines)
! Calculates the isothermal wimp number density using eq. (2.25) in https://arxiv.org/pdf/0809.1871.pdf

r = tab_r*Rsun ! cm
phi = -tab_vesc**2/2.d0 ! erg/g
mxg = mdm*1.782662d-24

! WIMP number density in isothermal approximation
nx_isothermal = exp(-mxg*phi/kB/T_x)
n_0 = Nwimps/trapz(r, 4.d0*pi*r**2.d0*nx_isothermal, nlines) ! Normalize so that integral(nx) = Nwimps
nx_isothermal = n_0*nx_isothermal

if (any(isnan(nx_isothermal))) print *, "NAN encountered in nx_isothermal"

return
end function

function Etrans_sp(T_x, sigma_N, Nwimps, niso)
implicit none
! Calculates WIMP transported energy (erg/g/s) using eq. (2.40) in https://arxiv.org/pdf/0809.1871.pdf

integer, intent(in) :: niso
double precision, intent(in) :: T_x, Nwimps
double precision, intent(in) :: sigma_N(niso)
double precision :: n_0, mxg
double precision :: R(nlines), phi(nlines), n_nuc(niso,nlines)
double precision :: n_x(nlines), species_indep(nlines), species_dep(nlines), sigma_nuc(niso)
double precision :: Etrans_sp(nlines)
integer :: i, j
! T_x in K, sigma_N in cm^2,

R = tab_r*Rsun ! R in cm
phi = -tab_vesc**2/2.d0 ! phi in erg/g
mxg = mdm*1.782662d-24 ! WIMP mass in g
! n_nuc in cm^-3
do i=1,niso
	n_nuc(i,:) = tab_mfr(:,i)*tab_starrho/AtomicNumber(i)/mnucg ! tab_starrho in gcm^-3
enddo

sigma_nuc = 2.d0*sigma_N ! Total WIMP-nucleus cross section in cm^2v. Only works for q/v independent cross-sections

! isothermal WIMP number density in cm^-3.
n_x = nx_isothermal(T_x, Nwimps)

! Separate calc into species dependent and independent factors
species_indep = 8.0d0*sqrt(2.d0/pi)*kB**(3.d0/2.d0)*n_x*(T_x-tab_T)/tab_starrho ! The species independent part

! Now sum over species to get the species dependent factor
species_dep=0.d0
do i=1,niso
	species_dep = species_dep + sigma_nuc(i)*n_nuc(i,:)*mxg*mnucg*AtomicNumber(i)/((mxg+mnucg*AtomicNumber(i))**2)* &
		sqrt(tab_T/(mnucg*AtomicNumber(i)) + T_x/mxg)
enddo

Etrans_sp = species_indep*species_dep ! erg/g/s

!! Useful when troubleshooting
!open(55, file="/home/luke/summer_2021/mesa/test_files/Etrans_sp_params.txt")
!write(55,*) "scalar params: T_x=", T_x, "m_x=", mxg, "m_nuc=", mnucg, "sigma_nuc=", sigma_nuc(1), &
!	"nlines=", nlines, "niso=", niso
!do i=1,nlines
!	write(55,*) R(i), tab_T(i), n_x(i), Etrans_sp(i) !n_x(i), tab_starrho(i), n_nuc(1,i), species_indep(i), phi(i)
!enddo
!close(55)

return
end function

function Tx_integral(T_x, sigma_N, Nwimps, niso)
implicit none
! Calculates the Tx defining integral

integer, intent(in) :: niso
double precision, intent(in) :: T_x, Nwimps
double precision, intent(in) :: sigma_N(niso)
double precision :: R(nlines), integrand(nlines)
double precision :: Tx_integral
! integrand units: erg/cm/s
R = tab_r*Rsun

integrand = 4*pi*R**2*tab_starrho*Etrans_sp(T_x, sigma_N, Nwimps, niso)

! integral is Etrans_tot (erg/s)
Tx_integral = trapz(R, integrand, nlines)

return
end function

function newtons_meth(f, sigma_N, Nwimps, niso, guess_1, guess_2, reltolerance)
! Performs Newton's method to solve Tx_integral(T_x)=0 for T_x (the function returns T_x)
! The parameter f is the Tx_integral function
implicit none

integer, intent(in) :: niso
double precision :: f ! Tx_integral
double precision, intent(in) :: Nwimps, reltolerance, guess_1, guess_2
double precision, intent(in) :: sigma_N(niso)
double precision :: x_1, x_2, x_3, f1, f2, error
double precision :: newtons_meth
! m_x and m_p in grams, T_x, T_star in Kelvin, sigma in cm^2, n_nuc, n_x in cm^-3

! x_1 and x_2 are temperatures (K)
x_1 = guess_1
x_2 = guess_2
error = reltolerance + 1	! So that the first iteration is executed

! Newton's method loop
do while (error > reltolerance)
	! Update x_3 using Newton's method formula
	f1 = f(x_1, sigma_N, Nwimps, niso)
	f2 = f(x_2, sigma_N, Nwimps, niso)
	x_3 = x_2 - f2*(x_2-x_1)/(f2 - f1)
	error = abs(x_3-x_2)/x_2
	x_1 = x_2
	x_2 = x_3
enddo

newtons_meth = x_3 ! The solution to the nonlinear equation

return
end function

function binary_search(f, sigma_N, Nwimps, niso, guess_1, guess_2, reltolerance)
integer, intent(in) :: niso
integer :: i
double precision :: f ! Tx_integral
double precision, intent(in) :: Nwimps, reltolerance, guess_1, guess_2
double precision, intent(in) :: sigma_N(niso)
double precision :: x_1, x_2, x_3, f1, f2, f3, error
double precision :: binary_search

! x_1 and x_2 are temperatures (K)
x_1 = guess_1
x_2 = guess_2
error = reltolerance + 1.d0	! So that the first iteration is executed

! Binary search loop
i = 0
do while (error > reltolerance)
	x_3 = (x_1 + x_2)/2.d0
	f1 = f(x_1, sigma_N, Nwimps, niso)
	f2 = f(x_2, sigma_N, Nwimps, niso)
	f3 = f(x_3, sigma_N, Nwimps, niso)
	if (f3 == 0.d0) then
		exit
	else if (f1*f3 .gt. 0) then ! if f1 and f3 have the same sign
		x_1 = x_3
	else if (f2*f3 .gt. 0) then
		x_2 = x_3
	endif
	error = abs(x_2-x_1)/x_2
	i = i + 1
enddo

binary_search = x_3

return
end function

subroutine fourier_smooth(x, y, x_even, y_even, cutoff, noise_indicator, nlines, lensav, ierr)
! Cuts out the high frequency components of y. E.g. if cutoff=0.05, the top 95% of frequency components are cut
! Also returns a "noise indicator" - The sum of the frequency components above the cutoff
integer, intent(in) :: nlines, lensav
integer :: ierr, i
double precision, intent(in) :: x(nlines), x_even(nlines), cutoff
double precision, intent(inout) :: y(nlines)
double precision, intent(out) :: noise_indicator
double precision :: y_even(nlines), work(nlines), wsave(lensav), bcoeff(nlines), ccoeff(nlines), dcoeff(nlines)
double precision :: ispline, denominator

! Make evenly spaced y array
call spline(x, y, bcoeff, ccoeff, dcoeff, nlines)
do i=1,nlines
	y_even(i) = ispline(x_even(i), x, y, bcoeff, ccoeff, dcoeff, nlines)
enddo

! Compute FFT of y
call dfft1i (nlines, wsave, lensav, ierr)  !Initialize (required by fftpack)
if (ierr /= 0) print *, "FFT initializer 'dfft1i' failed with error ", ierr

call dfft1f(nlines, 1, y_even, nlines, wsave, lensav, work, nlines, ierr) ! Take FFT
if (ierr /= 0) print *, "Forward FFT calculator 'dfft1f' failed with error ", ierr
! dTdr_even is now the array Fourier components of dTdr_even (the way fftpack works)

noise_indicator = 0.d0
! Take the ratio of high frequency components to low frequency components as a measure of how noisy the data is
do i=int(cutoff*nlines),nlines
	noise_indicator = noise_indicator + abs(y_even(i))
enddo
do i=1,int(cutoff*nlines)
	denominator = denominator + abs(y_even(i))
enddo
noise_indicator = noise_indicator/denominator

! Cut out top 100*(1-cutoff)% of Fourier components
do i=1,nlines
	if (i > int(cutoff*nlines)) then
		y_even(i) = 0.d0
	endif
enddo

! Rebuild y with high frequency components cut out
call dfft1b(nlines, 1, y_even, nlines, wsave, lensav, work, nlines, ierr)
if (ierr /= 0) print *, "Backward FFT calculator 'dfft1b' failed with error ", ierr

! Evaluate y on original grid (ie go convert y_even --> y)
call spline(x_even, y_even, bcoeff, ccoeff, dcoeff, nlines)
do i=1,nlines
	y(i) = ispline(x(i), x_even, y_even, bcoeff, ccoeff, dcoeff, nlines)
enddo

end subroutine

function rolling_avg(y, nlines)
! Takes a 1D array f of length N, returns an array of length N whose ith entry
! is the average of f(i) and its 4 nearest neighbours
integer, intent(in) ::  nlines
double precision, intent(in) :: y(nlines)
integer :: i, j
double precision :: rolling_avg(nlines)

do i=5,nlines-4
    rolling_avg(i) = 0.d0
    do j=-4,4
        rolling_avg(i) = rolling_avg(i) + y(i+j)
    enddo
    rolling_avg(i) = rolling_avg(i)/9.d0
enddo
! do boundary values manually
rolling_avg(1) = (y(1)+y(2)+y(3))/3.d0
rolling_avg(2) = (y(1)+y(2)+y(3)+y(4))/4.d0
rolling_avg(3) = (y(1)+y(2)+y(3)+y(4)+y(5)+y(6))/6.d0
rolling_avg(4) = (y(1)+y(2)+y(3)+y(4)+y(5)+y(6)+y(7)+y(8))/8.d0
rolling_avg(nlines-1) = (y(nlines-7)+y(nlines-6)+y(nlines-5)+y(nlines-4) &
							+y(nlines-3)+y(nlines-2)+y(nlines-1)+y(nlines))/8.d0
rolling_avg(nlines-1) = (y(nlines-5)+y(nlines-4)+y(nlines-3)+y(nlines-2)+y(nlines-1)+y(nlines))/6.d0
rolling_avg(nlines-1) = (y(nlines-3)+y(nlines-2)+y(nlines-1)+y(nlines))/4.d0
rolling_avg(nlines) = (y(nlines-2)+y(nlines-1)+y(nlines))/3.d0

return
end function

end module spergelpressmod


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief solve of : [M] x [x] = [b], CG algorithm based with Diagonal preconditioning
!>    @param[in] N_I lengths of I dimension of local matrix [M]
!>    @param[in] N_J lengths of J dimension of local matrix [M]
!>    @param[in] N_K lengths of K dimension of local matrix [M]
!>    @param[in,out] x solution vector [x], on start = start vector
!>    @param[in] b right side, vector [b]
!>    @param[in] depsilon precision criteria to break iterations
!>    @param[in] max_It max iteration number
!>    @param[in] criteria precision criteria mode to break iterations\n
!>    - 0 : relative stopping crit.: ||[res]||       < depsilon*||[res0]||\n
!>    - 1 : absolute stopping crit.: ||[res]||       < depsilon\n
!>    - 2 : maximum  stopping crit.: max(abs([res])) < depsilon\n
!>    first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
!>    @param[in] mbc_mask boundary condition pattern (mask)
!>    @param[in] MA 1. diagonal of the system matrix [M]
!>    @param[in] MB 2. diagonal of the system matrix [M]
!>    @param[in] MC 3. diagonal of the system matrix [M]
!>    @param[in] MD 4. diagonal of the system matrix [M]
!>    @param[in] ME 5. diagonal of the system matrix [M]
!>    @param[in] MF 6. diagonal of the system matrix [M]
!>    @param[in] MG 7. diagonal of the system matrix [M]
!>    @param[out] locTMP local temporary vectors
!>    @param[out] dnrm normalisation vector, temporary use
!>    @param[in] ismpl local sample index
!>    @details
!>    solve of : [M] x [x] = [b]\n
!>    [M] is s.p.d. Matrix, only used in 'omp_MVP'\n
!>    Technics :\n
!>               - use reverse communication technics.\n
!>                 each vector should be dense full without any hole,\n
!>                 ( you can copy your elements from your structure to a \n
!>                 temporary dense full vector, befor you use this algorithm \n
!>                 and give the correct number of elements in 'N' ).\n
!>                 if you have setup all vectors by a specific composition,\n
!>                 each vector (x,b,r,...) on the same thread should use\n
!>                 the same composition (same structure for all vectors on\n
!>                 one thread).\n
      SUBROUTINE omp_sym_solve_diag(n_i,n_j,n_k,x,b,depsilon,mbc_mask, &
          max_it,criteria,ma,mb,mc,md,me,mf,mg,loctmp,dnrm,ismpl)
        use mod_OMP_TOOLS
        use mod_blocking_size
        IMPLICIT NONE
        INCLUDE 'OMP_TOOLS.inc'

!     N    : length of all vector x, r, z, s, b, p, q
!     ld_N : leading dimension of [locTMP]
        INTEGER n, n_i, n_j, n_k, max_it, ismpl

!     thread stuff
        INTEGER tanz, tpos

!     vector x and b for [M]x[x]=[b]
!     res0 ^= ||res0||, start residuel, given for 'criteria=0'
        DOUBLE PRECISION x(n_i*n_j*n_k), b(n_i*n_j*n_k)
        DOUBLE PRECISION res0
        CHARACTER mbc_mask(n_i*n_j*n_k)
        DOUBLE PRECISION ma(n_i*n_j*n_k), mb(n_i*n_j*n_k), &
          mc(n_i*n_j*n_k)
        DOUBLE PRECISION md(n_i*n_j*n_k), me(n_i*n_j*n_k), &
          mf(n_i*n_j*n_k)
        DOUBLE PRECISION mg(n_i*n_j*n_k)

!     definitions of 'work' and 'locTMP'
        INCLUDE 'pre_cg.inc'
!       locTMP   : space for local vectors, using to exchange data with
!                  'matrix-vector-product'(MVP) and 'pre-conditioners'(L/R),
!                  for definitions see more in 'pre_bicgstab.inc'
        DOUBLE PRECISION loctmp(n_i*n_j*n_k,max_loctmp)
        DOUBLE PRECISION dnrm(n_i*n_j*n_k)

!     Pre_CG stuff
!     work     : control variable : what is to do out of this subroutine,
!                see more discription in 'pre_cg.inc',
!                on startup should set to 'work=START'
        INTEGER work

!     break with enough precision
        DOUBLE PRECISION depsilon

        INTEGER criteria
!     openmp-shared variables
        INTEGER ipar(5), iii
        DOUBLE PRECISION, ALLOCATABLE :: rpar(:)
        LOGICAL lpar(1)

!     full number of elements
        n = n_i*n_j*n_k
        res0 = 1.D+99

!**************************************************************

!     start values
        work = start

!$OMP  parallel &
!$OMP num_threads(Tlevel_1) &
!$OMP default(shared) &
!$OMP private(tanz,tpos,iii)
!$      call omp_binding(ismpl)

        CALL omp_part(n,tpos,tanz)

!$OMP master
        iii = 6 + 4*omp_get_num_of_threads()
        ALLOCATE(rpar(iii))
        CALL set_dval(iii,0.D0,rpar)
!      allocate(rpar(6 +4 *OMP_GET_NUM_of_THREADS()))
!$OMP end master
!     normalise the linear system, use [dnrm] to normalise the system
        CALL norm_linsys(tanz,mbc_mask(tpos),b(tpos),x(tpos),ma(tpos), &
          mb(tpos),mc(tpos),md(tpos),me(tpos),mf(tpos),mg(tpos), &
          dnrm(tpos))
!$OMP barrier

!     preload ([M]x[x]) in [s]
        CALL omp_mvp(n_i,n_j,n_k,x,loctmp(1,s),ma,mb,mc,md,me,mf,mg)
!     implicit barrier here

10      CONTINUE

!     cg-routines without Pre-Cond.
!     step : is the return-lable for pre_cg()
        CALL pre_cg(tanz,x(tpos),b(tpos),n,loctmp(tpos,1),depsilon, &
          dnrm(tpos),max_it,criteria,res0,work,ipar,rpar,lpar)
!     implicit barrier here

        IF ((work==mvp) .OR. (work==mvpx)) THEN
!       solve: [M]x[z]=[r] -> [z]:=[A^-1]x[r]
!       here [M] can be a substituted Matrix [T] -> solve: [T]x[z]=[r]
          CALL diagprco(n,md,loctmp(1,r),loctmp(1,z))
!$OMP   barrier

!       [s]:=[M]x[z]
          CALL omp_mvp(n_i,n_j,n_k,loctmp(1,z),loctmp(1,s),ma,mb,mc, &
            md,me,mf,mg)
!       implicit barrier here
        END IF

!     [v]:=[M]x[x], for advanced precision
        IF (work==mvpx) CALL omp_mvp(n_i,n_j,n_k,x,loctmp(1,v),ma,mb, &
          mc,md,me,mf,mg)
!     implicit barrier here

!     precision not enough ?
        IF ((work/=fine) .AND. (work/=abort)) GO TO 10

!$OMP  end parallel

        DEALLOCATE(rpar)

!**************************************************************

        RETURN
      END


SUBROUTINE mesh_size(element,nod,nels,nn,nxe,nye,nze)
!  Used in many subroutines
!  This subroutine returns the number of elements (nels) and the number
!  of nodes (nn) in a 2-d geometry-created mesh.
!
 IMPLICIT NONE
 !element: [string] triangle quadrilateral hexahedron
 CHARACTER(LEN=15),INTENT(IN)::element
 !  nod  : [integer] number of nodes per element
 !  nie  : [integer] elements counting in i-direction
 INTEGER,INTENT(IN)::nod,nxe,nye
 INTEGER,INTENT(IN),OPTIONAL::nze
 !  nels : [integer] total number of elements
 !  nn   : [integer] total number of nodes in problem
 INTEGER,INTENT(OUT)::nels,nn
 IF(element=="triangle")THEN
   nels=nxe*nye*2
   IF(nod==3)nn=(nxe+1)*(nye+1)
   IF(nod==6)nn=(2*nxe+1)*(2*nye+1)
   IF(nod==10)nn=(3*nxe+1)*(3*nye+1)
   IF(nod==15)nn=(4*nxe+1)*(4*nye+1)
 ELSE IF(element=="quadrilateral")THEN
   nels=nxe*nye
   IF(nod==4)nn=(nxe+1)*(nye+1)
   IF(nod==5)nn=(nxe+1)*(nye+1)+nxe*nye
   IF(nod==8)nn=(2*nxe+1)*(nye+1)+(nxe+1)*nye
   IF(nod==9)nn=(2*nxe+1)*(2*nye+1)
 ELSE IF(element=="hexahedron")THEN
   nels=nxe*nye*nze
   IF(nod==8)nn=(nxe+1)*(nye+1)*(nze+1)
   IF(nod==14)nn=4*nxe*nye*nze+2*(nxe*nye+nye*nze+nze*nxe)+nxe+nye+nze+1
   IF(nod==20)nn=((2*nxe+1)*(nze+1)+(nxe+1)*nze)*(nye+1)+                 &
     (nxe+1)*(nze+1)*nye
 END IF
RETURN
END SUBROUTINE mesh_size


        program OISM1
C Ocean model small mode number 1: Reff=0.1mic sigma=0.4
        character*10 ipa1
        real xtau,n(20),k(20),wldisc(20)
        real rad(22),dvdlnr(22)
        real cij1,cij2,rm1,rm2,rst1,rst2
	real pi,cte,tmp1,tmp2
      data wldisc /0.350,0.400,0.412,0.443,0.470,0.488,0.515,0.550,
     s             0.590,0.633,0.670,0.694,0.760,0.860,1.240,1.536,
     s             1.650,1.950,2.250,3.750/
        data n/1.45,1.45,1.45,1.45,1.45,1.45,1.45,1.45,
     s         1.45,1.45,1.45,1.45,
     s         1.45,1.45,1.43,1.43,1.43,1.43,1.43,1.43/
        data k/0.0035,0.0035,0.0035,0.0035,0.0035,
     s         0.0035,0.0035,0.0035,0.0035,0.0035,
     s         0.0035,0.0035,0.0035,0.0035,0.0035,
     s         0.0035,0.0035,0.0035,0.0035,0.0035/
        data rad /0.050000,0.065604,0.086077,0.112939,0.148184,
     &  0.194429,0.255105,0.334716,0.439173,0.576227,0.756052,
     &  0.991996,1.301571,1.707757,2.240702,2.939966,3.857452,
     &  5.061260,6.640745,8.713145,11.432290,15.000000/
        pi=atan(1.)*4.0
	cte=sqrt(2*pi)
	rm1=1.48
	rst1=0.60
	cij1=1.0
	write(6,*) "22"
	do i=1,22
	tmp1=exp(-(log(rad(i))-log(rm1))**2./2./rst1/rst1)
	dvdlnr(i)=cij1*tmp1/cte/rst1
	write(6,*) rad(i),dvdlnr(i)
	enddo
	write(6,101) (n(i),i=1,20)
	write(6,102) (k(i),i=1,20)
 101    format(20(F10.5,1X))
 102    format(20(F10.7,1X))
	stop
	end


*     MB03XZ EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZER
      PARAMETER        ( ZER = 0.0D0 )
      COMPLEX*16       ZERO, ONE
      PARAMETER        ( ZERO = (0.0D0,0.0D0), ONE = (1.0D0,0.0D0) )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 100 )
      INTEGER          LDA, LDAE, LDAS, LDGE, LDQG, LDQGE, LDQGS, LDRES,
     $                 LDU1, LDU2, LDWORK, LZWORK
      PARAMETER        ( LDA   = 2*NMAX, LDAE  = 2*NMAX, LDAS  = NMAX,
     $                   LDGE  = 2*NMAX, LDQG  = 2*NMAX, LDQGE = 2*NMAX,
     $                   LDQGS  = NMAX,  LDRES = 2*NMAX, LDU1  = 2*NMAX,
     $                   LDU2   = 2*NMAX,
     $                   LDWORK = 20*NMAX*NMAX + 12*NMAX + 2,
     $                   LZWORK = 12*NMAX - 2 )
*     .. Local Scalars ..
      CHARACTER*1      BALANC, JOB, JOBU
      INTEGER          I, ILO, INFO, J, M, N
      DOUBLE PRECISION TEMP
*     .. Local Arrays ..
      COMPLEX*16       A(LDA, 2*NMAX), AE(LDAE, 2*NMAX), AS(LDAS, NMAX),
     $                 GE(LDGE, 2*NMAX), QG(LDQG, 2*NMAX+1),
     $                 QGE(LDQGE, 2*NMAX+1), QGS(LDQGS, NMAX+1),
     $                 RES(LDRES,2*NMAX), U1(LDU1,2*NMAX),
     $                 U2(LDU2,  2*NMAX), ZWORK(LZWORK)
      DOUBLE PRECISION DWORK(LDWORK), SCALE(NMAX), WI(2*NMAX),
     $                 WR(2*NMAX)
      LOGICAL          BWORK(2*NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION DLAPY2, MA02JZ, ZLANGE
      EXTERNAL         DLAPY2, LSAME, MA02JZ, ZLANGE
*     .. External Subroutines ..
      EXTERNAL         MA02EZ, MB03XZ, MB04DZ, ZCOPY, ZGEMM, ZLACPY,
     $                 ZLASET
*     ..Intrinsic Functions..
      INTRINSIC        DBLE, DCMPLX, DIMAG
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  N, BALANC, JOB, JOBU
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         M = 2*N
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         CALL ZLACPY( 'All', N, N, A, LDA, AS, LDAS )
         READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N )
         CALL ZLACPY( 'All', N, N+1, QG, LDQG, QGS, LDQGS )
*        Compute the eigenvalues and the transformed Hamiltonian matrix.
         CALL MB03XZ( BALANC, JOB, JOBU, N, A, LDA, QG, LDQG, U1, LDU1,
     $                U2, LDU2, WR, WI, ILO, SCALE, DWORK, LDWORK,
     $                ZWORK, LZWORK, BWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 10  I = 1, M
               WRITE ( NOUT, FMT = 99996 ) I, WR(I), WI(I)
   10       CONTINUE
            IF ( LSAME( JOB, 'S' ).OR.LSAME( JOB, 'G' ) ) THEN
               WRITE ( NOUT, FMT = 99995 )
               DO 20  I = 1, M
                  WRITE ( NOUT, FMT = 99992 ) ( A(I,J), J = 1,M )
   20          CONTINUE
            END IF
            IF ( LSAME( JOB, 'G' ) ) THEN
               WRITE ( NOUT, FMT = 99994 )
               DO 30  I = 1, M
                  WRITE ( NOUT, FMT = 99992 ) ( QG(I,J), J = 1,M )
   30          CONTINUE
            END IF
*
            IF ( LSAME( JOB, 'G' ).AND.LSAME( JOBU, 'U' ) ) THEN
*              Compute the residual of the formula (4) in MB03XZ.
               CALL MB04DZ( BALANC, N, AS, LDAS, QGS, LDQGS, I, DWORK,
     $                      INFO )
               CALL ZLASET( 'Lower', M-1, M-1, ZERO, ZERO, A(2,1), LDA )
               CALL MA02EZ( 'Upper', 'Conjugate', 'Not skew', M, QG,
     $                      LDQG )
*              Compute Ae, Ge, and Qe.
               DO 60  J = 1, N
                  DO 40  I = 1, N
                     AE(I,J) = DCMPLX( ZER, DIMAG( AS(I,J) ) )
   40             CONTINUE
                  DO 50  I = 1, N
                     AE(I+N,J) = -DCMPLX( ZER, DBLE( AS(I,J) ) )
   50             CONTINUE
   60          CONTINUE
*
               DO 90  J = 1, N
                  DO 70  I = 1, N
                     AE(I,J+N) = -AE(I+N,J)
   70             CONTINUE
                  DO 80  I = 1, N
                     AE(I+N,J+N) = AE(I,J)
   80             CONTINUE
   90          CONTINUE
*
               DO 120  J = 1, N+1
                  DO 100  I = 1, N
                     QGE(I,J) = DCMPLX( ZER, DIMAG( QGS(I,J) ) )
  100             CONTINUE
                  DO 110  I = J, N
                     QGE(I+N,J) = -DCMPLX( ZER, DBLE( QGS(I,J) ) )
  110             CONTINUE
  120          CONTINUE
*
               DO 150  J = 1, N
                  DO 130  I = 1, J
                     QGE(I,J+N+1) = DCMPLX( ZER, DBLE( QGS(I,J+1) ) )
  130             CONTINUE
                  DO 140  I = 1, N
                     QGE(I+N,J+N+1) = QGE(I,J+1)
  140             CONTINUE
  150          CONTINUE
               CALL ZCOPY( N, QGE, 1, QGE(N+1,N+1), 1 )
               CALL MA02EZ( 'Lower', 'Transpose', 'Not Skew', N,
     $                      QGE(N+1,1), LDQGE )
               CALL MA02EZ( 'Upper', 'Transpose', 'Not Skew', N,
     $                      QGE(1,N+2), LDQGE )
*
               CALL ZLACPY( 'Upper', M, M, QGE(1,2), LDQGE, GE, LDGE )
               CALL MA02EZ( 'Upper', 'Transpose', 'Skew', M, GE, LDGE )
               CALL MA02EZ( 'Lower', 'Transpose', 'Skew', M, QGE,
     $                      LDQGE )
*              Compute the residual of the (1,1) block in (4).
               CALL ZGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                     AE, LDAE, U1, LDU1, ZERO, RES, LDRES )
               CALL ZGEMM( 'No Transpose', 'No Transpose', M, M, M,
     $                     -ONE, GE, LDGE, U2, LDU2, ONE, RES, LDRES )
               CALL ZGEMM( 'No Transpose', 'No Transpose', M, M, M,
     $                     -ONE, U1, LDU1, A, LDA, ONE, RES, LDRES )
               TEMP = ZLANGE( 'Frobenius', M, M, RES, LDRES, DWORK )
*              Compute the residual of the (1,2) block in (4).
               CALL ZGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                     AE, LDAE, U2, LDU2, ZERO, RES, LDRES )
               CALL ZGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                     GE, LDGE, U1, LDU1, ONE, RES, LDRES )
               CALL ZGEMM( 'No Transpose', 'No Transpose', M, M, M,
     $                     -ONE, U1, LDU1, QG, LDQG, ONE, RES, LDRES )
               CALL ZGEMM( 'No Transpose', 'Conj Transpose', M, M, M,
     $                     ONE, U2, LDU2, A, LDA, ONE, RES, LDRES )
               TEMP = DLAPY2( TEMP, ZLANGE( 'Frobenius', M, M, RES,
     $                                      LDRES, DWORK ) )
*              Compute the residual of the (2,1) block in (4).
               CALL ZGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                     QGE, LDQGE, U1, LDU1, ZERO, RES, LDRES )
               CALL ZGEMM( 'Transpose', 'No Transpose', M, M, M,
     $                     -ONE, AE, LDAE, U2, LDU2, ONE, RES, LDRES )
               CALL ZGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                     U2, LDU2, A, LDA, ONE, RES, LDRES )
               TEMP = DLAPY2( TEMP, ZLANGE( 'Frobenius', M, M, RES,
     $                                      LDRES, DWORK ) )
*              Compute the residual of the (2,2) block in (4).
               CALL ZGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                     QGE, LDQGE, U2, LDU2, ZERO, RES, LDRES )
               CALL ZGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $                     AE, LDAE, U1, LDU1, ONE, RES, LDRES )
               CALL ZGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $                     U2, LDU2, QG, LDQG, ONE, RES, LDRES )
               CALL ZGEMM( 'No Transpose', 'Conj Transpose', M, M, M,
     $                     ONE, U1, LDU1, A, LDA, ONE, RES, LDRES )
               TEMP = DLAPY2( TEMP, ZLANGE( 'Frobenius', M, M, RES,
     $                                      LDRES, DWORK ) )
               WRITE ( NOUT, FMT = 99989 ) TEMP
            END IF
*
            IF ( .NOT.LSAME( JOB, 'E' ).AND.LSAME( JOBU, 'U' ) ) THEN
               WRITE ( NOUT, FMT = 99993 )
               DO 160  I = 1, M
                  WRITE ( NOUT, FMT = 99992 )
     $               ( U1(I,J), J = 1,M ), ( U2(I,J), J = 1,M )
  160          CONTINUE
               DO 170  I = 1, M
                  WRITE ( NOUT, FMT = 99992 )
     $               ( -U2(I,J), J = 1,M ), ( U1(I,J), J = 1,M )
  170          CONTINUE
               WRITE ( NOUT, FMT = 99988 ) MA02JZ( .FALSE., .FALSE., M,
     $                 U1, LDU1, U2, LDU2, RES, LDRES )
            END IF
            IF ( LSAME( BALANC, 'S' ).OR.LSAME( BALANC, 'B' ) ) THEN
               WRITE ( NOUT, FMT = 99991 )
               DO 180  I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) I, SCALE(I)
  180          CONTINUE
            END IF
         END IF
      END IF
*
99999 FORMAT (' MB03XZ EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB03XZ = ',I2)
99997 FORMAT (' The eigenvalues are',//'   i',6X,
     $        'WR(i)',6X,'WI(i)',/)
99996 FORMAT (I4,3X,F8.4,3X,F8.4)
99995 FORMAT (/' The transformed matrix S is')
99994 FORMAT (/' The transformed matrix G is')
99993 FORMAT (/' The unitary symplectic factor U is')
99992 FORMAT (20(1X,F9.4,SP,F9.4,S,'i '))
99991 FORMAT (/' The diagonal scaling factors are ',//'   i',6X,
     $        'SCALE(i)',/)
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' Residual: || i*He*U - U*Hc ||_F = ',G9.2)
99988 FORMAT (/' Orthogonality of U: || U^H U - I ||_F = ',G9.2)
      END


subroutine forces(xf,grav,fict)

! Calculate both real (ie, gravity and whatnot)
! and fictitious (ie, coriolis and centrifugal) forces.
!-------------------------------------------------------------
! GLOBALS
use global
use sweeps

IMPLICIT NONE

! LOCALS
INTEGER :: n
REAL(kind=8) :: sinxf0
REAL(kind=8), DIMENSION(maxsweep) :: grav, fict, xf

!--------------------------------------------------------------

if(sweep=='x') then

  if(ngeom==0) then  ! CARTESIAN

    do n = nmin-4, nmax+5
      grav(n) = 0.
      fict(n) = 0.
    enddo

  else if(ngeom==1) then  ! CYLINDRICAL R

    do n = nmin-4, nmax+5
      grav(n) = 0.
      fict(n) = v(n)*v(n)/xf(n)
    enddo

  else if(ngeom==2) then  ! SPHERICAL R

    do n = nmin-4, nmax+5
      grav(n) = 0.0
      if (xf(n)/=0.0) then
        fict(n) = (w(n)*w(n)+v(n)*v(n))/xf(n)
      else
        fict(n) = 0.0
      endif
    enddo

  endif

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
else if(sweep=='y') then

  if(ngeom==0) then  ! CARTESIAN

    do n = nmin-4, nmax+5
      grav(n) = 0.
      fict(n) = 0.
    enddo

  else if(ngeom==1) then  ! CYLINDRICAL R (2D)

    do n = nmin-4, nmax+5
      grav(n) = 0.
      if (xf(n)/=0.0) then
        fict(n) = v(n)*v(n)/xf(n)
      else
        fict(n) = 0.0
      endif
    enddo

  else if(ngeom==3) then  ! CYLINDRICAL THETA

    do n = nmin-4, nmax+5
      grav(n) = 0.
      fict(n) = -u(n)*w(n) / radius
    enddo

  else if(ngeom==4) then  ! SPHERICAL THETA

    do n = nmin-4, nmax+5
      fict(n) = -u(n)*w(n) / radius
      sinxf0 = sin(xf(n))
      if(abs(sinxf0)>1.0e-5) then
        fict(n) = fict(n)+v(n)*v(n)/radius*cos(xf(n))/sinxf0
      endif
      grav(n) = 0.
   enddo

  endif

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
else

  if(ngeom==0) then  ! CARTESIAN OR CYLINDRICAL

     do n = nmin-4, nmax+5
       grav(n) = 0.
       fict(n) = 0.
     enddo

  else if(ngeom==5) then  ! SPHERICAL PHI

    do n = nmin-4, nmax+5
      grav(n) = 0.0
      fict(n) = -u(n)*v(n)/radius*stheta - u(n)*w(n)/radius*cos(theta)
    enddo

  endif

endif

return
end


        subroutine idd_diffsnorm0(m,n,matvect,p1t,p2t,p3t,p4t,
     1                            matvect2,p1t2,p2t2,p3t2,p4t2,
     2                            matvec,p1,p2,p3,p4,
     3                            matvec2,p12,p22,p32,p42,
     4                            its,snorm,u,u1,u2,v,v1,v2)
c
c       routine idd_diffsnorm serves as a memory wrapper
c       for the present routine. (Please see routine idd_diffsnorm
c       for further documentation.)
c
        implicit none
        integer m,n,its,it,k
        real*8 snorm,enorm,p1t,p2t,p3t,p4t,p1t2,p2t2,p3t2,p4t2,
     1         p1,p2,p3,p4,p12,p22,p32,p42,u(m),u1(m),u2(m),
     2         v(n),v1(n),v2(n)
        external matvect,matvec,matvect2,matvec2
c
c
c       Fill the real and imaginary parts of each entry
c       of the initial vector v with i.i.d. random variables
c       drawn uniformly from [-1,1].
c
        call id_srand(n,v)
c
        do k = 1,n
          v(k) = 2*v(k)-1
        enddo ! k
c
c
c       Normalize v.
c
        call idd_enorm(n,v,enorm)
c
        do k = 1,n
          v(k) = v(k)/enorm
        enddo ! k
c
c
        do it = 1,its
c
c         Apply a and a2 to v, obtaining u1 and u2.
c
          call matvec(n,v,m,u1,p1,p2,p3,p4)
          call matvec2(n,v,m,u2,p12,p22,p32,p42)
c
c         Form u = u1-u2.
c
          do k = 1,m
            u(k) = u1(k)-u2(k)
          enddo ! k
c
c         Apply a^T and (a2)^T to u, obtaining v1 and v2.
c
          call matvect(m,u,n,v1,p1t,p2t,p3t,p4t)
          call matvect2(m,u,n,v2,p1t2,p2t2,p3t2,p4t2)
c
c         Form v = v1-v2.
c
          do k = 1,n
            v(k) = v1(k)-v2(k)
          enddo ! k
c
c         Normalize v.
c
          call idd_enorm(n,v,snorm)
c
          if(snorm .gt. 0) then
c
            do k = 1,n
              v(k) = v(k)/snorm
            enddo ! k
c
          endif
c
          snorm = sqrt(snorm)
c
        enddo ! it
c
c
        return
        end


! { dg-do run }
!
! PR 40646: [F03] array-valued procedure pointer components
!
! Original test case by Charlie Sharpsteen <chuck@sharpsteen.net>
! Modified by Janus Weil <janus@gcc.gnu.org>

module bugTestMod
  implicit none
  type:: boundTest
    procedure(returnMat), pointer, nopass:: test
  end type boundTest
contains
  function returnMat( a, b ) result( mat )
    integer:: a, b
    double precision, dimension(a,b):: mat
    mat = 1d0
  end function returnMat
end module bugTestMod

program bugTest
  use bugTestMod
  implicit none
  type( boundTest ):: testObj
  double precision, dimension(2,2):: testCatch
  testObj%test => returnMat
  testCatch = testObj%test(2,2)
  print *,testCatch
  if (sum(testCatch)/=4) call abort()
  print *,testObj%test(3,3)
  if (sum(testObj%test(3,3))/=9) call abort()
end program bugTest

! { dg-final { cleanup-modules "bugTestMod" } }


module grid_module

  use datatypes_module

  implicit none

  ! for indexing the conservative state arrays
  integer, parameter :: URHO = 1
  integer, parameter :: UMX = 2
  integer, parameter :: UENER = 3

  ! for indexing the primitive variable arrays
  integer, parameter :: QRHO = 1
  integer, parameter :: QU = 2
  integer, parameter :: QP = 3

  integer, parameter :: NVAR = 3

  integer, parameter :: MOL_STAGES = 2

  real(dp_t), allocatable :: x(:)

  real(dp_t) :: dx

  integer :: ilo, ihi
  integer :: qx

  integer :: a_lo, a_hi

contains

  subroutine init_grid(ng)

    use runtime_params_module

    implicit none

    integer, intent(in) :: ng

    integer :: i

    qx = nx + 2*ng

    ilo = 0
    ihi = nx-1

    a_lo = -ng
    a_hi = nx+ng-1

    dx = (xmax - xmin)/nx

    allocate(x(a_lo:a_hi))

    do i = ilo-ng, ihi+ng
       x(i) = (dble(i) + 0.5_dp_t)*dx + xmin
    enddo

  end subroutine init_grid

  subroutine fill_ghost(U)
    ! just do zero-gradient

    implicit none

    integer :: n

    real(dp_t), intent(inout) :: U(a_lo:a_hi, NVAR)

    do n = 1, NVAR
       U(:ilo-1,n) = U(ilo,n)
    enddo

    do n = 1, NVAR
       U(ihi+1:,n) = U(ihi,n)
    enddo

  end subroutine fill_ghost

end module grid_module


      subroutine real_default(r1,r2,r3)
          implicit none
          real, intent(in) :: r1
          real, intent(inout) :: r2
          real, intent(out) :: r3
          r3 = r1 + r2
      end subroutine
      subroutine real_x_len(r10,r11,r12,r13,r14,r15)
          implicit none
          real*4, intent(in) :: r10
          real*4, intent(inout) :: r11
          real*4, intent(out) :: r12
          real*8, intent(in) :: r13
          real*8, intent(inout) :: r14
          real*8, intent(out) :: r15
          r12 = r10 + r11
          r15 = r13 + r14
      end subroutine
      subroutine real_kind_x(r7,r8,r9,r10,r11,r12)
          implicit none
          real(kind=4), intent(in) :: r7
          real(kind=4), intent(inout) :: r8
          real(kind=4), intent(out) :: r9
          real(kind=8), intent(in) :: r10
          real(kind=8), intent(inout) :: r11
          real(kind=8), intent(out) :: r12
          r9 = r7 + r8
          r12 = r11 + r10
      end subroutine
      ! subroutine real_kind_call(r1,r2,r3,r4,r5,r6)
          ! implicit none
          ! real(kind=kind(0.0)), intent(in) :: r1
          ! real(kind=kind(0.0)), intent(inout) :: r2
          ! real(kind=kind(0.0)), intent(out) :: r3
          ! real(kind=kind(0.0D0)), intent(in) :: r4
          ! real(kind=kind(0.0D0)), intent(inout) :: r5
          ! real(kind=kind(0.0D0)), intent(out) :: r6
          ! r3 = r2 + r1
          ! r6 = r4 + r5
      ! end subroutine
      ! subroutine real_srk_call(r1,r2,r3,r4,r5,r6,r7,r8,r9)
          ! implicit none
          ! real(kind=selected_real_kind(1)), intent(in) :: r1
          ! real(kind=selected_real_kind(1)), intent(inout) :: r2
          ! real(kind=selected_real_kind(1)), intent(out) :: r3
          ! real(kind=selected_real_kind(7)), intent(in) :: r4
          ! real(kind=selected_real_kind(7)), intent(inout) :: r5
          ! real(kind=selected_real_kind(7)), intent(out) :: r6
          ! real(kind=selected_real_kind(14)), intent(in) :: r7
          ! real(kind=selected_real_kind(14)), intent(inout) :: r8
          ! real(kind=selected_real_kind(14)), intent(out) :: r9
          ! r3 = r1 + r2
          ! r6 = r4 + r5
          ! r9 = r7 + r8
      ! end subroutine


! { dg-do run }
!
! Test for pr52413
!

program test_frac

  real :: y
  y=fraction (-2.0)
  if (fraction (-2.0) /= -0.5) STOP 1
  if (fraction (-0.0) /= 0.0) STOP 2
  if (sign(1.0, fraction(-0.0)) /= -1.0) STOP 3
  if (fraction (-2.0_8) /=  -0.5) STOP 4

end program test_frac


subroutine NPZD_N2  ! Add N2 fixation, use P as the limiting element
use bio_MOD
implicit none
integer :: k
real    :: NO3,PO4,PHY, ZOO, DETn,DETp,DIA
real    :: par_, muNet,muDIA
real    :: Kp, gmax, mz,KPO4
real    :: QN, Qp, bI0, KFe_, N2P_phy, theta_DIA
real    :: pp_NDn,pp_PDp,Res_DIA,Mort_DIA
real, parameter :: N2P_dia = 45. ! N:P ratio of diazotrophs
real, parameter :: N2C_dia = 0.2  ! N:C ratio of diazotrophs
real, parameter :: P2C_dia = N2C_dia/N2P_dia ! P:C ratio of diazotrophs
real, parameter :: Q0p     = 3D-3 ! Subsistence P quota of ordinary phyto.
real, parameter :: Lnifdet = 0.05 ! Diazotroph mortality   rate
real, parameter :: RDN     = 0.1  ! Regeneration rate of detritus to DIN
real            :: Lnifdin = 0.17*16

Lnifdin=params(iLnifp)  ! Diazotroph respiration rate
Kp  = params(iKPHY)
gmax= params(igmax)
mz  = params(imz)
!bI0 = 10**params(ibI0B)
bI0 = 0.
KPO4= params(iKN)/16d0
if (do_IRON) KFe = params(iKFe)

DO k = 1, nlev
   tf_p= TEMPBOL(Ep,Temp(k))
   NO3 = Vars(iNO3,   k)
   PO4 = Vars(iPO4,   k)
   PHY = Vars(iPHY(1),k)
   ZOO = Vars(iZOO,   k)
   DETn= Vars(iDET,   k)  ! Detritus N
   DETp= Vars(iDETp,  k)  ! Detritus P

   ! Add diazotrophs:
   DIA = Vars(iDIA,   k)

   ! Check whether in the MLD or not
   if (k .lt. N_MLD) then
      par_ = PAR(k)
   else
      par_ = PARavg
   endif
   Varout(oPAR_,k)=par_
   ! Calculate nondiazotroph growth rate if not considering mixing
   CALL MONOD(Temp(k), PAR(k), NO3,PO4,params(imu0),params(iQ0N),   &
               Q0p, params(iaI0_C),                                 &
               bI0, params(iKN), KPO4, DFe(k), KFe_,         &
               muNet, QN, QP, Varout(oTheta(1),k),                  &
               Varout(oSI(1),k), Varout(oLno3(1),k))

   ! Calculate diazotroph growth rate if not considering mixing
   call nif_growth(PO4,PAR(k),Temp(k),wstr0(1),muDIA,theta_DIA)

   ! Unit of PHY: mM P
   Varout(oPPt,k)=(PHY*muNet/QP + DIA*muDIA/P2C_dia)*12d0

   ! Calculate nondiazo growth rate, theta, and QN based on environmental conditions
   CALL MONOD(Temp(k), par_, NO3, PO4, params(imu0),params(iQ0N),  &
        Q0p,  params(iaI0_C), &
        bI0,  params(iKN), KPO4, DFe(k), KFe_,              &
        muNet,Varout(oQN(1),k),Varout(oQP(1),k),Varout(oTheta(1),k), &
        Varout(oSI(1),k), Varout(oLno3(1),k))

   N2P_phy = Varout(oQN(1),k)/Varout(oQP(1),k)  !N:P of normal phytoplankton

   ! Calculate diazotroph growth rate if not considering mixing
   call nif_growth(PO4,par_,Temp(k),wstr0(1),muDIA,theta_DIA)

   ! Correct the unit of growth rate
   muNet = muNet*dtdays

   Varout(oDIAu,k)=muDIA
   muDIA = muDIA*dtdays

   ! The total amount of phytoplankton grazed by zooplankton (molN;gmax is the maximal specific ingestion rate!)
   tf_z  = TEMPBOL(Ez,Temp(k))  ! Temperature effect of zooplankton
   gbar  = grazing(grazing_formulation,Kp,PHY) !Functional response of zooplankton
   INGES = gmax*tf_z*dtdays * gbar   !Specific ingestion rate of zooplankton
   Zmort = ZOO*ZOO*dtdays*mz*tf_z  !Mortality term for ZOO

   !Zooplankton excretion rate (-> DOM)
   RES = INGES*(1d0-GGE-unass)

   !ZOOPLANKTON EGESTION (-> POM)
   EGES = INGES*unass

  ! For production/destruction matrix:
  pp_NDn = dtdays*RDN*DETn*tf_z
  pp_PDp = dtdays*params(iRDN_P)*DETp*tf_z
  pp_NZ  = ZOO*RES
  pp_DZ  = ZOO*EGES+Zmort
  pp_ZP  = ZOO*INGES

  ! Respiration of diazotrophs (DIA -> DIP):
  Res_DIA  = Lnifdin*tf_p*dtdays*DIA**2

  ! Mortality of diazotrophs (DIA -> POP):
  Mort_DIA = Lnifdet*tf_p*dtdays*DIA

  ! N as the unit:
  Varout(oDET,k)  = (DETn + pp_DZ*N2P_phy) - pp_NDn + Mort_DIA*N2P_dia

  ! P as the unit
  Varout(oDETp,k) = (DETp + pp_DZ)- pp_PDp + Mort_DIA

  Varout(oNO3,k)  = (NO3+pp_NDn+pp_NZ*N2P_phy+Res_DIA*N2P_dia) &
                  - PHY*muNet*N2P_phy   ! N as the unit

  Varout(oPO4,k)  = (PO4+pp_PDp+pp_NZ        +Res_DIA) &
                  - PHY*muNet-DIA*muDIA ! P as the unit

  Varout(oPHY(1),k)    = PHY*(1d0 + muNet)-pp_ZP
  Varout(oZOO,k)       = (ZOO+pp_ZP)-pp_DZ-pp_NZ
  Varout(oDIA,k)       = DIA*(1d0 + muDIA)-Mort_DIA-Res_DIA

  Varout(omuNet(1), k) = muNet/dtdays
  Varout(oGraz(1), k)  = pp_ZP/PHY/dtdays
  Varout(oZ2N,k)   = pp_NZ/dtdays
  Varout(oD2N,k)   = pp_ND/dtdays
  Varout(oCHLt,k)  = PHY/Varout(oQP(1),k)*Varout(otheta(1),k) &
                   + DIA/P2C_dia*theta_DIA
  Varout(oCHL(1),k)= Varout(oCHLt,k)

  ! Total particulate organic nitrogen (PON)
  Varout(oPON,k)=(Varout(oZOO,k)+Varout(oPHY(1),k))*N2P_phy &
            +     Varout(oDET,k)+Varout(oDIA,k)*N2P_dia

  ! Total POP:
  Varout(oPOP,k)=Varout(oZOO,k)+Varout(oPHY(1),k) + Varout(oDETp,k) + Varout(oDIA,k)
Enddo
return
End subroutine NPZD_N2


C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 06.01.02/04                           *
C  *    TEST TITLE : Effect of local and global            *
C  *                 transformations in a single structure *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

C composition type
C                preconcatenate  postconcatenate  replace
      INTEGER    PCPRE,          PCPOST,          PCREPL
      PARAMETER (PCPRE = 0,      PCPOST = 1,      PCREPL = 2)

      REAL       A1(4,4), A2(4,4), A3(4,4), A4(4,4), A5(4,4)
      REAL       A6(3,3), A7(3,3), PPMX(1), PPMY(1), PPMZ(1)
      REAL       EX1COM(4,4), EX2COM(4,4), TMPMAT(4,4)

      LOGICAL    SPHDIS

C  Set up arbitrary matrices:

      DATA A1 / 0.6400,  -0.2158,  -0.3232,  -0.1398,
     1         -0.3405,   0.9041,  -0.1562,   0.2284,
     2         -0.3458,  -0.1908,   0.6289,  -0.2234,
     3         -0.2107,   0.2571,  -0.1183,   1.3633  /

      DATA A2 / 0.7066,   0.2092,  -0.0416,  -0.3792,
     1         -0.0907,   0.7405,  -0.1633,  -0.2249,
     2         -0.3822,   0.1112,   0.6808,   0.0086,
     3         -0.1183,  -0.1777,   0.0448,   0.9750  /

      DATA A3 / 0.7061,  -0.2336,  -0.2953,  -0.2673,
     1         -0.2344,   0.8280,  -0.2632,  -0.2501,
     2          0.2709,   0.0524,   0.6326,  -0.1435,
     3          0.3407,   0.3902,   0.1875,   1.2520  /

      DATA A4 / 0.8168,  -0.2033,  -0.3886,  -0.2358,
     1          0.1839,   1.1356,  -0.3802,  -0.3262,
     2          0.1461,   0.0644,   0.7139,   0.2245,
     3          0.0835,  -0.1778,  -0.3036,   0.8549  /

      DATA A5 / 0.6428,   0.3743,   0.1195,   0.0006,
     1         -0.2039,   1.3347,  -0.0378,   0.1513,
     2          0.3480,  -0.2931,   1.3423,   0.2051,
     3         -0.2744,  -0.2590,   0.0819,   1.2317  /

      DATA A6 / 0.9153,   0.3884,   0.3859,
     1          0.0327,   1.3789,  -0.3846,
     2          0.3814,   0.0693,   0.9099  /

      DATA A7 / 0.9528,   0.1134,  -0.3495,
     1          0.3002,   1.2937,   0.1857,
     2         -0.2830,   0.3916,   0.8847  /

C  Throughout, use incremental spatial search (ISS) to test the
C  effects of the current global and local modelling
C  transformations.  The search reference point (SRP) is based on
C  an MC location of (3,4,5), adjusted to account for the expected
C  transformation.
      DATA  PPMX / 3.0 /, PPMY / 4.0 /, PPMZ / 5.0 /

      CALL INITGL ('06.01.02/04')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)

      IF (.NOT. SPHDIS(123)) THEN
         CALL INMSG ('Skipping test because implementation '     //
     1               'apparently uses non-Euclidean metric for ' //
     2               'search distance.')
         GOTO 666
      ENDIF

C  Set up structure #101:
      CALL POPST  (101)
      CALL PPM3   (1, PPMX,PPMY,PPMZ)
      CALL PSLMT3 (A1, PCREPL)
      CALL PPM3   (1, PPMX,PPMY,PPMZ)
      CALL PSLMT3 (A2, PCPOST)
      CALL PPM3   (1, PPMX,PPMY,PPMZ)
      CALL PSLMT3 (A3, PCPRE)
      CALL PPM3   (1, PPMX,PPMY,PPMZ)
      CALL PSGMT3 (A4)
      CALL PPM3   (1, PPMX,PPMY,PPMZ)
      CALL PSLMT3 (A5, PCREPL)
      CALL PPM3   (1, PPMX,PPMY,PPMZ)
      CALL PSGMT  (A6)
      CALL PPM3   (1, PPMX,PPMY,PPMZ)
      CALL PSLMT  (A7, PCPOST)
      CALL PPM3   (1, PPMX,PPMY,PPMZ)
      CALL PCLST

      CALL SETMSG ('16 17 19', 'At the start of a traversal, the ' //
     1             'current global and local modelling '           //
     2             'transformations should both be set to the '    //
     3             'identity matrix.')
C   expected composite transformation = identity matrix
      CALL IDMAT  (4, EX1COM)
      CALL COMTOK (EX1COM, '101,1')

      CALL SETMSG ('8 16 17', '<Set local transformation 3>, with ' //
     1             'REPLACE, should replace the current local '     //
     2             'modelling transformation with the specified '   //
     3             'matrix.')
C   expected composite transformation = A1
      CALL ECOM3  (EX1COM, A1, EX2COM)
      CALL COMTOK (EX2COM, '101,3')

      CALL SETMSG ('8 16 17', '<Set local transformation 3>, with '   //
     1             'POSTCONCATENATE, should replace the current '     //
     2             'local modelling transformation with the product ' //
     3             'of the specified matrix and its former value.')
C   expected composite transformation = A2 x A1
      CALL ECOM3  (A2, EX2COM, EX1COM)
      CALL COMTOK (EX1COM, '101,5')

      CALL SETMSG ('8 16 17', '<Set local transformation 3>, with '   //
     1             'PRECONCATENATE, should replace the current '      //
     2             'local modelling transformation with the product ' //
     3             'of its former value and the specified matrix.')
C   expected composite transformation = A2 x A1 x A3
      CALL ECOM3  (EX1COM, A3, EX2COM)
      CALL COMTOK (EX2COM, '101,7')

      CALL SETMSG ('15 16 17', '<Set global transformation 3> '   //
     1             'should replace the current global modelling ' //
     2             'transformation with the specified matrix.')
C   expected composite transformation = A4 x A2 x A1 x A3
      CALL ECOM3  (A4, EX2COM, EX1COM)
      CALL COMTOK (EX1COM, '101,9')

      CALL SETMSG ('8 16 17', '<Set local transformation 3>, with '  //
     1             'REPLACE, should be able to replace the current ' //
     2             'local modelling transformation with the '        //
     3             'specified matrix several times in one structure.')
C   expected composite transformation = A4 x A5
      CALL ECOM3  (A4, A5, EX1COM)
      CALL COMTOK (EX1COM, '101,11')

      CALL SETMSG ('15 16 17 18', '<Set global transformation> '  //
     1             'should replace the current global modelling ' //
     2             'transformation with the suitably expanded '   //
     3             'version of the specified matrix.')
C   expected composite transformation = expanded-A6 x A5
      CALL EXP34  (A6, TMPMAT)
      CALL ECOM3  (TMPMAT, A5, EX1COM)
      CALL COMTOK (EX1COM, '101,13')

      CALL SETMSG ('8 16 17 18', '<Set local transformation>, with '  //
     1             'POSTCONCATENATE, should replace the current '     //
     2             'local modelling transformation with the product ' //
     3             'of the suitably expanded version of the '         //
     4             'specified matrix and its former value.')
C   expected composite transformation = expanded-A6 x expanded-A7 x A5
      CALL EXP34  (A7, EX1COM)
      CALL ECOM3  (TMPMAT, EX1COM, EX2COM)
      CALL ECOM3  (EX2COM, A5, EX1COM)
      CALL COMTOK (EX1COM, '101,15')

666   CONTINUE
      CALL ENDIT
      END


! random_generators.f90 --
!     Collection of pseudo-random number generators
!
!     Reference:
!     Good Practice in (Pseudo) Random Number
!     Generation for Bioinformatics Applications
!     by David Jones, UCL Bioinformatics Group
!     http://www.cs.ucl.ac.uk/staff/d.jones/GoodPracticeRNG.pdf
!
!     TODO:
!     Use /dev/urandom if possible to initialise the seed
!     Export the seed via prng_get_seed for later use
!
module random_generators
    implicit none

    integer, parameter :: xdefault = 123456789
    integer, parameter :: ydefault = 234567891
    integer, parameter :: zdefault = 345678912
    integer, parameter :: wdefault = 456789123

    type prng_jkiss32
        logical :: init = .true.
        integer :: x, y, z, w, c
    end type prng_jkiss32

    private :: prng_jkiss32_random_integer_base
    integer, parameter, private :: dp = kind(1.0d0)

    !
    ! Subroutines
    !
    interface prng_random
        module procedure prng_jkiss32_random_real
        module procedure prng_jkiss32_random_double
!        module procedure prng_jkiss32_random_real1d
        module procedure prng_jkiss32_random_integer
    end interface

    !
    ! Functions
    !
!    interface prng_rnd
!        module procedure prng_jkiss32_rnd_real
!        module procedure prng_jkiss32_rnd_integer
!    end interface

contains

! prng_jkiss32_init --
!     Imitialise the PRNG object
!
! Arguments:
!     prng          Object to be initialised
!     xinit, ...    Four values for the initialisation (all optional)
!
subroutine prng_jkiss32_init( prng, xinit, yinit, zinit, winit )
    type(prng_jkiss32), intent(inout) :: prng
    integer, intent(in), optional     :: xinit
    integer, intent(in), optional     :: yinit
    integer, intent(in), optional     :: zinit
    integer, intent(in), optional     :: winit

    integer                           :: i
    integer                           :: xset
    integer                           :: yset
    integer                           :: zset
    integer                           :: wset
    real                              :: time
    real(kind=dp)                     :: r        ! Double precision to ensure
                                                  ! all bits are used
    integer                           :: rint

    if ( present(xinit) ) then
        xset = xinit
    else
        call system_clock( count = xset )
    endif

    if ( present(yinit) ) then
        yset = yinit
    else
        call cpu_time( time )
        yset = nint( mod( time, 1.0 ) * huge(1) )
    endif

    if ( present(zinit) ) then
        zset = zinit
    else
        call random_number( r )
        zset = nint( r * huge(1) )
    endif

    if ( present(winit) ) then
        wset = winit
    else
        call random_number( r )
        wset = nint( r * huge(1) )
    endif

    prng%init = .false.
    prng%x    = xset
    prng%y    = yset
    prng%z    = zset
    prng%w    = wset

    !
    ! For good measure
    !
    do i = 1,100
        call prng_jkiss32_random_integer_base( prng, rint )
    enddo
end subroutine prng_jkiss32_init

! prng_random_integer_base --
!     Return a random integer between -huge(1) and huge(1)
!
! Arguments:
!     prng          PRNG object
!     rint          Random integer
!
! Note:
!     This is the routine that does the actual work -
!     to avoid recursive calls
!
subroutine prng_jkiss32_random_integer_base( prng, rint )
    type(prng_jkiss32), intent(inout) :: prng
    integer, intent(out)              :: rint

    integer                           :: t

    prng%y = ieor( prng%y, ishft( prng%y,  5 ) )
    prng%y = ieor( prng%y, ishft( prng%y, -7 ) )
    prng%y = ieor( prng%y, ishft( prng%y, 22 ) )

    t      = prng%z +prng%w + prng%c
    prng%z = prng%w
    prng%c = merge( 1, 0, t < 0 )
    prng%w = iand( t, 2147483647 )

    prng%x = prng%x + 1411392427

    rint   = prng%x + prng%y + prng%w

end subroutine prng_jkiss32_random_integer_base

! prng_random_integer --
!     Return a random integer between -huge(1) and huge(1)
!
! Arguments:
!     prng          PRNG object
!     rint          Random integer
!
! Note:
!     If the PRNG object has not been initialised
!     yet, it is done here.
!
subroutine prng_jkiss32_random_integer( prng, rint )
    type(prng_jkiss32), intent(inout) :: prng
    integer, intent(out)              :: rint

    if ( prng%init ) then
        call prng_jkiss32_init( prng, xdefault, ydefault, zdefault, wdefault )
    endif

    call prng_jkiss32_random_integer_base( prng, rint )

end subroutine prng_jkiss32_random_integer

! prng_random_real --
!     Return a random real between -huge(1) and huge(1)
!
! Arguments:
!     prng          PRNG object
!     rreal         Random single-precision real (between 0 and 1)
!
! Note:
!     If the PRNG object has not been initialised
!     yet, it is done here.
!
subroutine prng_jkiss32_random_real( prng, rreal )
    type(prng_jkiss32), intent(inout) :: prng
    real, intent(out)                 :: rreal

    integer                           :: rint

    if ( prng%init ) then
        call prng_jkiss32_init( prng, xdefault, ydefault, zdefault, wdefault )
    endif

    call prng_jkiss32_random_integer_base( prng, rint )

    rreal = rint / 4294967296.0_dp + 0.5_dp

end subroutine prng_jkiss32_random_real

! prng_random_double --
!     Return a random double precision real between -huge(1) and huge(1)
!
! Arguments:
!     prng          PRNG object
!     rdble         Random double-precision real (between 0 and 1)
!
! Note:
!     If the PRNG object has not been initialised
!     yet, it is done here.
!
subroutine prng_jkiss32_random_real( prng, rdble )
    type(prng_jkiss32), intent(inout) :: prng
    real(kind=dp), intent(out)        :: rdble

    integer                           :: rint1, rint2

    if ( prng%init ) then
        call prng_jkiss32_init( prng, xdefault, ydefault, zdefault, wdefault )
    endif

    call prng_jkiss32_random_integer_base( prng, rint1 )
    call prng_jkiss32_random_integer_base( prng, rint2 )

    rint1 = rint1 / 2**6
    rint2 = rint2 / 2**5

    rdble = (rint1 * 134217728.0_dp + rint2) / 9007199254740992.0_dp

end subroutine prng_jkiss32_random_real

end module random_generators

program test_prng
    use random_generators

    implicit none

    type(prng_jkiss32) :: prng
    integer            :: i
    integer            :: j
    integer            :: x
    real               :: r

     do i = 1,100
         call prng_random( prng, j )
         call prng_random( prng, r )
         write(*,*) i, j, r
     enddo
end program test_prng


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> This module provides a function for stationary heat analysis
module m_heat_solve_main
contains

  subroutine heat_solve_main(hecMESH, hecMAT, hecMESHmpc, hecMATmpc, fstrPARAM, fstrHEAT, ISTEP, iterALL, next_time, delta_time)
    use m_fstr
    use m_heat_mat_ass_conductivity
    use m_heat_mat_ass_capacity
    use m_heat_mat_ass_boundary
    use m_solve_lineq
    implicit none
    integer(kind=kint) :: i, iterALL, ISTEP, bup_n_dof
    real(kind=kreal)   :: delta_time, next_time
    type(hecmwST_local_mesh)  :: hecMESH
    type(hecmwST_matrix)      :: hecMAT
    type(fstr_heat)           :: fstrHEAT
    type(fstr_param)          :: fstrPARAM
    type(hecmwST_local_mesh), pointer :: hecMESHmpc
    type(hecmwST_matrix), pointer :: hecMATmpc
    logical :: is_congerged

    iterALL = 0
    do
      iterALL = iterALL + 1
      hecMAT%X = 0.0d0

      call heat_mat_ass_conductivity(hecMESH, hecMAT, fstrHEAT, fstrHEAT%beta)
      if(fstrHEAT%is_steady == 0) call heat_mat_ass_capacity(hecMESH, hecMAT, fstrHEAT, delta_time)
      call heat_mat_ass_boundary(hecMESH, hecMAT, hecMESHmpc, hecMATmpc, fstrHEAT, next_time, delta_time)

      hecMATmpc%Iarray(97) = 1 !Need numerical factorization
      bup_n_dof = hecMESH%n_dof
      hecMESH%n_dof = 1
      call solve_LINEQ(hecMESHmpc, hecMATmpc)
      hecMESH%n_dof = bup_n_dof
      call hecmw_mpc_tback_sol(hecMESH, hecMAT, hecMATmpc)

      do i = 1, hecMESH%n_node
        fstrHEAT%TEMPC(i) = fstrHEAT%TEMP(i)
        fstrHEAT%TEMP (i) = hecMAT%X(i)
      enddo

      call heat_check_convergence(hecMESH, fstrHEAT, fstrPARAM, ISTEP, iterALL, is_congerged)

      if(is_congerged .or. fstrHEAT%is_iter_max_limit) exit
    enddo
  end subroutine heat_solve_main

  subroutine heat_check_convergence(hecMESH, fstrHEAT, fstrPARAM, ISTEP, iterALL, is_congerged)
    use m_fstr
    implicit none
    integer(kind=kint) :: i, iterALL, iter_max, ISTEP
    real(kind=kreal)   :: val, iter_eps
    type(hecmwST_local_mesh)  :: hecMESH
    type(fstr_heat)           :: fstrHEAT
    type(fstr_param)          :: fstrPARAM
    logical :: is_congerged

    is_congerged = .false.
    fstrHEAT%is_iter_max_limit = .false.
    iter_max = fstrPARAM%itmax(ISTEP)
    iter_eps = fstrPARAM%eps(ISTEP)

    val = 0.0d0
    do i = 1, hecMESH%nn_internal
      val = val + (fstrHEAT%TEMP(i) - fstrHEAT%TEMPC(i))**2
    enddo
    call hecmw_allREDUCE_R1(hecMESH, val, hecmw_sum)
    val = dsqrt(val)

    if(hecMESH%my_rank == 0)then
      write(*,'(i8,1pe16.6)') iterALL, val
    endif

    if(val < iter_eps)then
      if(hecMESH%my_rank == 0) write(IMSG,*) ' !!! CONVERGENCE ACHIEVED '
      is_congerged = .true.
    endif

    if(iter_max <= iterALL)then
      if(hecMESH%my_rank == 0) write(*,*) ' !!! ITERATION COUNT OVER : MAX = ', iter_max
      fstrHEAT%is_iter_max_limit = .true.
    endif
  end subroutine heat_check_convergence
end module m_heat_solve_main


program main
  implicit none

  integer,parameter :: n = 1000
  real(KIND=4),allocatable,dimension(:) :: a,b
  real(KIND=4) :: c
  integer :: i
  real(KIND=8) :: sum

  allocate(a(n),b(n))
  c = 2.0

  do i = 1, n
     a(i) = 10.0
  end do
!$acc data copyin(a) copyout(b)
!$acc kernels
!$acc loop independent
  do i = 1, n
     b(i) = a(i) + c
  end do
!$acc end kernels
!$acc end data
  sum = 0.d0
  do i = 1, n
     sum = sum + b(i)
  end do

  print *, sum/n
  deallocate(a,b)

end program main


! { dg-do run }
! { dg-options "-fipa-pta -fno-tree-ccp -fno-tree-forwprop -g" }

program main
  implicit none
  call test ((/ 3, 4, 5 /), f ((/ 3, 4, 5 /)))
contains
  subroutine test (expected, x)
    integer, dimension (:,:,:) :: x
    integer, dimension (3) :: expected
    integer :: i, i1, i2, i3
    do i = 1, 3
      if (size (x, i) .ne. expected (i)) call abort
    end do
    do i1 = 1, expected (1)
      do i2 = 1, expected (2)
        do i3 = 1, expected (3)
          if (x (i1, i2, i3) .ne. i1 + i2 * 10 + i3 * 100) call abort
        end do
      end do
    end do
  end subroutine test

  function f (x)
    integer, dimension (3) :: x
    integer, dimension (x(1), x(2), x(3)) :: f
    integer :: i1, i2, i3
    do i1 = 1, x(1)
      do i2 = 1, x(2)
        do i3 = 1, x(3)
          f (i1, i2, i3) = i1 + i2 * 10 + i3 * 100
        end do
      end do
    end do
  end function f
end program main


*> \brief \b CLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLADIV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       COMPLEX FUNCTION CLADIV( X, Y )
*
*       .. Scalar Arguments ..
*       COMPLEX            X, Y
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CLADIV := X / Y, where X and Y are complex.  The computation of X / Y
*> will not overflow on an intermediary step unless the results
*> overflows.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] X
*> \verbatim
*>          X is COMPLEX
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*>          Y is COMPLEX
*>          The complex scalars X and Y.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complexOTHERauxiliary
*
*  =====================================================================
      COMPLEX FUNCTION CLADIV( X, Y )
*
*  -- LAPACK auxiliary routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      COMPLEX            X, Y
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      REAL               ZI, ZR
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLADIV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          AIMAG, CMPLX, REAL
*     ..
*     .. Executable Statements ..
*
      CALL SLADIV( REAL( X ), AIMAG( X ), REAL( Y ), AIMAG( Y ), ZR,
     $             ZI )
      CLADIV = CMPLX( ZR, ZI )
*
      RETURN
*
*     End of CLADIV
*
      END


!>Module randdp: double precision random number generation
!!
!!   Nick Maclaren's double precision random number generator.
!!   This version, which is compatible with Lahey's ELF90 compiler,
!!   is by Alan Miller ( alan @ vic.cmis.csiro.au, www.vic.cmis.csiro.au/~alan )
!!
!!   Latest revision - 18 December 1997
!!
!!   Copyright (C) 1992  N.M. Maclaren
!!   Copyright (C) 1992  The University of Cambridge
!!
!!   This software may be reproduced and used freely, provided that all
!!   users of it agree that the copyright holders are not liable for any
!!   damage or injury caused by use of this software and that this
!!   condition is passed onto all subsequent recipients of the software,
!!   whether modified or not.

module mod_randdp
  !Replaces COMMON /randpp/ and defines dp
  implicit none

  integer, parameter, public :: dp=SELECTED_REAL_KIND(15,60)
  REAL(dp), save, public :: poly(101), other, offset
  integer, save, public :: index

contains

  !*******************************************************************************
  !> Subroutine sdprnd - seeds random number generator in this processor using integer input
  !Input: iseed
  !Output: poly(1:101), other, offset, index
  !*******************************************************************************
  subroutine sdprnd (iseed)

    integer, intent(in) :: iseed
    !Local variables
    real(dp) :: x
    real(dp), parameter :: xmod = 1000009711.0_dp, ymod = 33554432.0_dp
    integer :: ix, iy, iz, i
    logical, save :: inital = .true.

    !ISEED should be set to an integer between 0 and 9999 inclusive;
    !a value of 0 will initialise the generator only if it has not already been done.
    if(inital .or. iseed /=0) then
      inital = .false.
    else
      return  !<The following statements are no longer executed
    end if

    !INDEX must be initialised to an integer between 1 and 101 inclusive,
    !POLY(1...N) to integers between 0 and 1000009710 inclusive (not all 0),
    !and OTHER to a non-negative proper fraction with denominator 33554432.
    !It uses the Wichmann-Hill generator to do this.

    ix = mod(abs(iseed), 10000) + 1
    iy = 2*ix + 1
    iz = 3*ix + 1
    do i = -10,101
      if(i >= 1) then
        poly(i) = aint(xmod*x)
      end if
      ix = mod(171*ix, 30269)
      iy = mod(172*iy, 30307)
      iz = mod(170*iz, 30323)
      x = mod(dble(ix)/30269.0_dp + dble(iy)/30307.0_dp + dble(iz)/30323.0_dp, 1.0_dp)
    end do
    other = aint(ymod*x)/ymod
    offset = 1.0_dp/ymod
    index = 1

    return
  end subroutine sdprnd

  !*******************************************************************************
  !>Function dprand - generates a double precision random number between 0 and 1
  !*******************************************************************************
  function dprand() result(fn_val)

    real(dp) :: fn_val  !Output
    !Local variables
    real(dp) :: x, y
    !N.B. ymod has been removed from the previous DATA statement; it caused a fatal error as it is not used.
    real(dp), parameter :: xmod = 1000009711.0_dp, xmod2 = 2000019422.0_dp, xmod4 = 4000038844.0_dp
    real(dp), parameter :: tiny = 1.0E-17_dp,  zero = 0.0_dp, one = 1.0_dp
    integer :: n
    logical, save :: inital = .true.

    !This returns a uniform (0,1) random number, with extremely good uniformity properties.
    !It assumes that real(dp) provides at least 33 bits of accuracy, and uses a power of two base.
    if(inital) then
      call sdprnd(0)
      inital = .false.
    end if

    !See [Knuth] for why this implements the algorithm described in the paper.
    !Note that this code is tuned for machines with fast real(dp), but slow multiply and divide; many, many other options are possible.
    n = index - 64  !n=-63?
    if(n <= 0) then
      n = n + 101 !n=38?
    end if
    x = poly(index) + poly(index)
    x = xmod4 - poly(n) - poly(n) - x - x - poly(index)
    if(x < zero) then
      if(x < -xmod) then
        x = x + xmod2
      end if
      if(x < zero) then
        x = x + xmod
      end if
    else
      if(x >= xmod2) then
        x = x - xmod2
        if(x >= xmod) then
          x = x - xmod
        end if
      end if
      if(x >= xmod) then
        x = x - xmod
      end if
    end if
    poly(index) = x
    index = index + 1
    if(index > 101) then
      index = index - 101
    end if

    !Add in the second generator modulo 1, and force to be non-zero.
    !The restricted ranges largely cancel themselves out.
    do
      y = 37.0_dp*other + offset
      other = y - aint(y)
      if(other /= zero) then
        exit
      end if
    end do

    x = x/xmod + other
    if(x >= one) then
      x = x - one
    end if
    fn_val = x + tiny

    return
  end function dprand

end module mod_randdp


module m_Parameters
  use m_TypeDef
  use m_LogInfo
  implicit none
  private

  ! Flow type option
  integer,parameter,public:: FT_CH=1  ! Channel
  integer,parameter,public:: FT_HC=2  ! Half channel
  integer, public,save:: FlowType
  real(RK),public,save:: ubulk
  logical,public,save :: IsUxConst
  logical,public,save:: IsUseCRF
  real(RK),public::PrGradAver,uCRF

  ! mesh options
  real(RK),public,save::xlx, yly, zlz  ! domain length in three directions
  integer,public,save::nxp,nyp,nzp     ! grid point number in three directions
  integer,public,save::nxc,nyc,nzc     ! grid center number in three directions. nxc = nxp-1

  integer,parameter,public:: x_pencil=1
  integer,parameter,public:: y_pencil=2
  integer,parameter,public:: z_pencil=3
  integer,parameter,public:: xm_dir=1  ! x- direction
  integer,parameter,public:: xp_dir=2  ! x+ direction
  integer,parameter,public:: ym_dir=3  ! y- direction
  integer,parameter,public:: yp_dir=4  ! y+ direction
  integer,parameter,public:: zm_dir=5  ! z- direction
  integer,parameter,public:: zp_dir=6  ! z+ direction

  ! Physical properties
  real(RK),save,public:: xnu                    ! Kinematic viscosity
  real(RK),save,public:: FluidDensity           ! Fluid density
  real(RK),dimension(3),save,public:: gravity   ! Gravity or  other constant body forces (if any)

  ! Time stepping scheme and Projection method options
  integer,parameter,public:: FI_AB2 =1          !  AB2 for convective term
  integer,parameter,public:: FI_RK2 =2          !  RK2 for convective term
  integer,parameter,public:: FI_RK3 =3          !  RK3 for convective term
  real(RK),save,public:: dt         ! current time step
  real(RK),save,public:: dtMax      ! Maxium time step
  real(RK),save,public:: SimTime    ! Real simulation time
  integer,save,public :: iCFL       ! Use CFL condition to change time step dynamically( 1: yes, 2:no ).
  real(RK),save,public:: CFLc       ! CFL parameter
  integer,save,public::  itime      ! current time step
  integer,save,public::  ifirst     ! First iteration
  integer,save,public::  ilast      ! Last iteration
  integer,save,public::  iadvance
  integer,save,public::  ischeme
  real(RK),dimension(3),save,public :: pmGammaConst
  real(RK),dimension(3),save,public :: pmThetaConst
  real(RK),dimension(3),save,public :: pmAlphaConst
  real(RK),save,public::pmGamma
  real(RK),save,public::pmTheta
  real(RK),save,public::pmAlpha
  real(RK),save,public::pmAlphaC
  real(RK),save,public::pmBeta
  real(RK),save,public::pmBetaT
#ifdef ScalarFlow
  real(RK),save,public::pmBetaSc
#endif

  ! FFTW_option
  integer,save,public:: FFTW_plan_type

  ! Boundary conditions
  real(RK),public,dimension(6):: uxBcValue
  real(RK),public,dimension(6):: uyBcValue
  real(RK),public,dimension(6):: uzBcValue

  ! I/O, Statistics
  integer,public,save:: ivstats            ! time step interval for statistics calculation
  integer,public,save:: SaveVisu           ! Output visulizing file frequency
  integer,public,save:: BackupFreq         ! Output Restarting file frequency
  integer,public,save:: SaveStat           ! Output Statistics file frequency

  logical,public,save::       RestartFlag  ! restart or not
  character(64),public,save:: RunName      ! Run name
  character(64),public,save:: Res_Dir      ! Result directory
  character(64),public,save:: RestartDir   ! Restart directory
  integer,public,save:: Cmd_LFile_Freq= 1  ! report frequency in the terminal
  integer,public,save:: LF_file_lvl   = 5  ! logfile report level
  integer,public,save:: LF_cmdw_lvl   = 3  ! terminal report level

  ! Decomp2d options
  integer,public,save:: p_row,p_col

  ! limited velocity and div
  real(RK),public,save:: vel_limit
  real(RK),public,save:: div_limit

#ifdef ScalarFlow
  !=== Scalar Options ===!
  ! Scalar boundary conditions
  ! -1: Dirichlet Bc. C     = F
  ! -2: Neumann Bc.   dC/dy = S
  ! -3: Robin Bc.     dC/dy + S*C = F
  ! y-,  y+
  real(RK),public,save:: SDiffCoe ! Scalar Diffusivity Coefficient
  real(RK),public,save:: Scalar_InitValue
  real(RK),public,dimension(3):: GravityEffVec,FallingVelVec
  integer, public,dimension(2):: ScalarBcOption
  real(RK),public,dimension(4):: ScalarBcValues !(F_b,F_t,S_b,S_t)
#endif

  public:: ReadAndInitParameters,DumpReadedParam,PMcoeUpdate
contains

  !******************************************************************
  ! InitParameters
  !******************************************************************
  subroutine ReadAndInitParameters(chFile)
    implicit none
    character(*),intent(in)::chFile

    ! locals
    integer:: nUnitFile,myistat
    NAMELIST/BasicParam/FlowType,ubulk,xlx,yly,zlz,nxp,nyp,nzp,xnu,dtMax,iCFL,CFLc,ifirst,ilast,  &
                        ischeme,FFTW_plan_type,gravity,uxBcValue,uyBcValue,uzBcValue,ivstats,     &
                        BackupFreq,SaveStat,SaveVisu,IsUxConst,IsUseCRF,uCRF,RestartFlag,         &
                        RunName,Res_Dir,RestartDir,Cmd_LFile_Freq,LF_file_lvl,LF_cmdw_lvl,p_row,  &
                        p_col,vel_limit,div_limit,FluidDensity
#ifdef ScalarFlow
    real(RK)::RealTemp
    real(RK)::FallingVel    !Particle Settling Velocity.
    real(RK)::GravityEff    !Effective Gravity magnitude. g_eff=Rg=(rho_s-rho_f)/rho_f*g for gravity flow.
    real(RK)::SchmidtNumber !Schmidt number for gravity flow (Or Prandtl number somewhere). Sc= nu/K, where K is the diffusivity coefficient
    real(RK),dimension(3)::GravityDir ! Unit gravity vector
    NAMELIST/ScalarFlowOptions/SchmidtNumber,Scalar_InitValue,GravityEff,GravityDir,FallingVel,ScalarBcOption,ScalarBcValues
#endif

    nUnitFile = GetFileUnit()
    open(unit=nUnitFile, file=chFile, status='old',form='formatted',IOSTAT=myistat )
    if(myistat/=0) then
      print*,"Cannot open file: "//trim(chFile); STOP
    endif
    read(nUnitFile, nml=BasicParam)
#ifdef ScalarFlow
    rewind(nUnitFile)
    read(nUnitFile, nml=ScalarFlowOptions)
#endif
    close(nUnitFile,IOSTAT=myistat)

    nxc= nxp-1
    nyc= nyp-1
    nzc= nzp-1
    if(mod(nxc,2)/=0   .or.  mod(nzc,2)/=0) then
      print*,'mod(nxc,2)/=0 || mod(nzc,2)/=0 WRONG';STOP
    endif
    if(FlowType==FT_CH .and. mod(nyc,2)/=0) then
      print*,'mod(nyc,2)/=0 For channel geomotry. WRONG';STOP
    endif
    if(IsUseCRF) then
      uxBcValue= uxBcValue -uCRF
    else
      uCRF= zero
    endif

    if(ischeme==FI_AB2) then
      iadvance = 1
      pmGammaConst = (/ three/two, zero, zero/)
      pmThetaConst = (/     -half, zero, zero/)
    elseif(ischeme==FI_RK2) then
      iadvance = 2
      pmGammaConst = (/ half,  one, zero/)
      pmThetaConst = (/ zero,-half, zero/)
    elseif(ischeme==FI_RK3) then
      iadvance = 3
      pmGammaConst = (/ eight/fifteen,       five/twelve,    three/four/)
      pmThetaConst = (/          zero,  -seventeen/sixty,  -five/twelve/)
    else
      print*,"Time scheme WRONG!!! ischeme=",ischeme; STOP
    endif
    pmAlphaConst = pmGammaConst + pmThetaConst

#ifdef ScalarFlow
    RealTemp=sqrt(GravityDir(1)*GravityDir(1)+GravityDir(2)*GravityDir(2)+GravityDir(3)*GravityDir(3))
    if(RealTemp>1.0E-10_RK) then
      GravityDir=GravityDir/RealTemp
    else
      GravityDir=[zero, -one, zero]
    endif
    SDiffCoe=xnu/SchmidtNumber
    GravityEffVec=GravityDir*GravityEff
    FallingVelVec=GravityDir*FallingVel
    FallingVelVec(1)=FallingVelVec(1)+uCRF
#endif
  end subroutine ReadAndInitParameters

  !******************************************************************
  ! DumpReadedParam
  !******************************************************************
  subroutine DumpReadedParam()
    implicit none

    ! locals
    NAMELIST/BasicParam/FlowType,ubulk,xlx,yly,zlz,nxp,nyp,nzp,xnu,dtMax,iCFL,CFLc,ifirst,ilast,  &
                        ischeme,FFTW_plan_type,gravity,uxBcValue,uyBcValue,uzBcValue,ivstats,     &
                        BackupFreq,SaveStat,SaveVisu,IsUxConst,IsUseCRF,uCRF,RestartFlag,         &
                        RunName,Res_Dir,RestartDir,Cmd_LFile_Freq,LF_file_lvl,LF_cmdw_lvl,p_row,  &
                        p_col,vel_limit,div_limit,FluidDensity
#ifdef ScalarFlow
    NAMELIST/ScalarFlowOptions/SDiffCoe,Scalar_InitValue,GravityEffVec,FallingVelVec,ScalarBcOption,ScalarBcValues
#endif

    write(MainLog%nUnit, nml=BasicParam)
#ifdef ScalarFlow
    write(MainLog%nUnit, nml=ScalarFlowOptions)
#endif
  end subroutine DumpReadedParam

  !******************************************************************
  ! PMcoeUpdate
  !******************************************************************
  subroutine PMcoeUpdate(ns)
    implicit none
    integer,intent(in)::ns

    pmGamma = pmGammaConst(ns) * dt
    pmTheta = pmThetaConst(ns) * dt
    pmAlpha = pmAlphaConst(ns) * dt
    pmBeta  = half * pmAlphaConst(ns) *xnu * dt
#ifdef ScalarFlow
    pmBetaSc= half * pmAlphaConst(ns) *SDiffCoe * dt
#endif
    SimTime=SimTime+dt*real(pmAlphaConst(ns),RK)

    pmAlphaC= pmAlphaConst(ns)              ! for pressure gradient purpose only
    if(ns==1) PrGradAver=zero
  end subroutine PMcoeUpdate

end module m_Parameters