      subroutine somm2 (dr,dp,dpas,da,rnrm,m,np)
c Modified to use complex p and q.  SIZ 4/91
c Modified to use double simpson integration ALA 3/97
c integration by the method of simpson of dp*dr from
c 0 to r=rnrm  with proper end corrections
c dpas=exponential step;
c for r in the neighborhood of zero dp=cte*r**da
c **********************************************************************
      implicit double precision (a-h,o-z)
      dimension dr(*)
      dimension  dp(*)

      mm = m + 1
      d1=dble(da)+mm
      da=0.0
      db=0.0
c      np-2=inrm -point of grid just below rnrm
      a1=log(rnrm/dr(np-2)) / dpas
      a2=a1**2/8.0d0
      a3=a1**3/12.0d0
      do 70 i=1,np
         if (i.eq.1) then
            dc=dp(i) *dr(i)**mm*9.0d0/24.0d0
         elseif (i.eq.2) then
            dc=dp(i) *dr(i)**mm*28.0d0/24.0d0
         elseif (i.eq.3) then
            dc=dp(i)*dr(i)**mm*23.0d0/24.0d0
         elseif (i.eq.np-3) then
            dc=dp(i)*dr(i)**mm*(25.0d0/24.0d0-a2+a3)
         elseif (i.eq.np-2) then
            dc=dp(i)*dr(i)**mm*(0.5d0+a1-3*a2-a3)
         elseif (i.eq.np-1) then
            dc=dp(i)*dr(i)**mm*(-1.0d0/24.0d0+5*a2-a3)
         elseif (i.eq.np) then
            dc=dp(i)*dr(i)**mm*(-a2+a3)
         else
c           like trapesoidal rule
            dc=dp(i)*dr(i)**mm
         endif
         da=da+dc
   70 continue
      da=dpas*da

c     add initial point (r=0) correction
      dd=exp(dpas)-1.0
      db=d1*(d1+1.0)*dd*exp((d1-1.0)*dpas)
      db=dr(1)*(dr(2)**m)/db
      dd=(dr(1)**mm)*(1.0+1.0/(dd*(d1+1.0)))/d1
      da=da+dd*dp(1)-db*dp(2)
      return
      end


module interp
    implicit none
    save

    !   interpolation initialisation arrays

    real, allocatable :: zp_bCurv_R(:), zp_bCurv_phi(:), zp_bCurv_z(:), &
        zp_bGrad_R(:), zp_bGrad_phi(:), zp_bGrad_z(:), &
        zp_bR(:), zp_bPhi(:), zp_bz(:), zp_bDotGradB(:), &
        zp_psi(:)
    real :: sigma = 0.0

contains
    subroutine init_interp ()
        use gc_terms
        use eqdsk
        implicit none

        integer :: islpsw, iErr
        real, allocatable :: temp(:)
        real :: zx1(nh), zxm(nh), zy1(nw), zyn(nw), &
            zxy11, zxym1, zxy1n, zxymn
        islpsw  = 255
        allocate ( zp_bCurv_R(3*nw*nh), &
            zp_bCurv_phi(3*nw*nh), &
            zp_bCurv_z(3*nw*nh),&
            temp(nh+nh+nw), &
            zp_bGrad_R(3*nw*nh), &
            zp_bGrad_phi(3*nw*nh), &
            zp_bGrad_z(3*nw*nh), &
            zp_bDotGradB(3*nw*nh), &
            zp_bR(3*nw*nh), zp_bPhi(3*nw*nh), zp_bz(3*nw*nh), &
            zp_psi(3*nw*nh) )

        !   psi

        call surf1 ( nw, nh, r, z, psizr, nw, zx1, zxm, &
            zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
            zp_psi, temp, sigma, iErr)

        !   b field

        call surf1 ( nw, nh, r, z, bR, nw, zx1, zxm, &
            zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
            zp_bR, temp, sigma, iErr)
        call surf1 ( nw, nh, r, z, bPhi, nw, zx1, zxm, &
            zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
            zp_bPhi, temp, sigma, iErr)
        call surf1 ( nw, nh, r, z, bz, nw, zx1, zxm, &
            zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
            zp_bz, temp, sigma, iErr)

        !   curvature

        call surf1 ( nw, nh, r, z, bCurvature_R, nw, zx1, zxm, &
            zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
            zp_bCurv_R, temp, sigma, iErr)
        call surf1 ( nw, nh, r, z, bCurvature_phi, nw, zx1, zxm, &
            zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
            zp_bCurv_phi, temp, sigma, iErr)
        call surf1 ( nw, nh, r, z, bCurvature_z, nw, zx1, zxm, &
            zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
            zp_bCurv_z, temp, sigma, iErr)

        !   gradient

        call surf1 ( nw, nh, r, z, bGradient_R, nw, zx1, zxm, &
            zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
            zp_bGrad_R, temp, sigma, iErr)
        call surf1 ( nw, nh, r, z, bGradient_phi, nw, zx1, zxm, &
            zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
            zp_bGrad_phi, temp, sigma, iErr)
        call surf1 ( nw, nh, r, z, bGradient_z, nw, zx1, zxm, &
            zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
            zp_bGrad_z, temp, sigma, iErr)

        !   bDotGraB

        call surf1 ( nw, nh, r, z, bDotGradB, nw, zx1, zxm, &
            zy1, zyn, zxy11, zxym1, zxy1n, zxymn, islpsw, &
            zp_bDotGradB, temp, sigma, iErr)

    end subroutine init_interp

end module interp


      SUBROUTINE MB02SZ( N, H, LDH, IPIV, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute an LU factorization of a complex n-by-n upper
C     Hessenberg matrix H using partial pivoting with row interchanges.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix H.  N >= 0.
C
C     H       (input/output) COMPLEX*16 array, dimension (LDH,N)
C             On entry, the n-by-n upper Hessenberg matrix to be
C             factored.
C             On exit, the factors L and U from the factorization
C             H = P*L*U; the unit diagonal elements of L are not stored,
C             and L is lower bidiagonal.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= max(1,N).
C
C     IPIV    (output) INTEGER array, dimension (N)
C             The pivot indices; for 1 <= i <= N, row i of the matrix
C             was interchanged with row IPIV(i).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, U(i,i) is exactly zero. The
C                   factorization has been completed, but the factor U
C                   is exactly singular, and division by zero will occur
C                   if it is used to solve a system of equations.
C
C     METHOD
C
C     The factorization has the form
C        H = P * L * U
C     where P is a permutation matrix, L is lower triangular with unit
C     diagonal elements (and one nonzero subdiagonal), and U is upper
C     triangular.
C
C     This is the right-looking Level 2 BLAS version of the algorithm
C     (adapted after ZGETF2).
C
C     REFERENCES
C
C     -
C
C     NUMERICAL ASPECTS
C                                2
C     The algorithm requires 0( N ) complex operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TB01FX by A.J. Laub, University of
C     Southern California, United States of America, May 1980.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000,
C     Jan. 2005.
C
C     KEYWORDS
C
C     Frequency response, Hessenberg form, matrix algebra.
C
C     ******************************************************************
C
C     .. Parameters ..
      COMPLEX*16        ZERO
      PARAMETER         ( ZERO = ( 0.0D+0, 0.0D+0 ) )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDH, N
C     .. Array Arguments ..
      INTEGER           IPIV(*)
      COMPLEX*16        H(LDH,*)
C     .. Local Scalars ..
      INTEGER           J, JP
C     .. External Functions ..
      DOUBLE PRECISION  DCABS1
      EXTERNAL          DCABS1
C     .. External Subroutines ..
      EXTERNAL          XERBLA, ZAXPY, ZSWAP
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     ..
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -3
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02SZ', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      DO 10 J = 1, N
C
C        Find pivot and test for singularity.
C
         JP = J
         IF ( J.LT.N ) THEN
            IF ( DCABS1( H( J+1, J ) ).GT.DCABS1( H( J, J ) ) )
     $         JP = J + 1
         END IF
         IPIV( J ) = JP
         IF( H( JP, J ).NE.ZERO ) THEN
C
C           Apply the interchange to columns J:N.
C
            IF( JP.NE.J )
     $         CALL ZSWAP( N-J+1, H( J, J ), LDH, H( JP, J ), LDH )
C
C           Compute element J+1 of J-th column.
C
            IF( J.LT.N )
     $         H( J+1, J ) = H( J+1, J )/H( J, J )
C
         ELSE IF( INFO.EQ.0 ) THEN
C
            INFO = J
         END IF
C
         IF( J.LT.N ) THEN
C
C           Update trailing submatrix.
C
            CALL ZAXPY( N-J, -H( J+1, J ), H( J, J+1 ), LDH,
     $                  H( J+1, J+1 ), LDH )
         END IF
   10 CONTINUE
      RETURN
C *** Last line of MB02SZ ***
      END


!   --------------------------------------------------------------------
!   DMET DELUX 2000	Subrutine	konstanter
!   --------------------------------------------------------------------
!   HENSIKT :
!   Beregner konstantverdier for begge lektere, slik som andre
!   arealmoment og metasenter
!
!   METODE :
!   Leser lektergeometri fra inputfil, og beregner andre arealmoment,
!   og begge metasentre for begge lektere. Sender verdiene tilbake til
!   transfer-subrutine
!
!   KALLESEKVENS:
!   CALL konstanter(L,Br,D,H,M,GML,I33,I55,rho,g,nl)
!
!   PARAMETERE:
!   Navn	I/O	Type			Innhold/Beskrivelse
!   ....................................................................
!   n		I	heltall			antall frekvensintervaller
!   nl		I/O	heltall			antall lektere
!   g		I/O	flyttall		tyngdelfeltsakselerasjon
!   L		I/O	heltalls vektor		lengde på lekter
!   B		I/O 	heltalls vektor		bredde på lekter
!   D		I/O	flyttalls vektor	dypgang på lekter
!   H		I/O	flyttalls vektor	dybde i riss for lekter
!   M		I/O	flyttalls vektor	masse lekter
!   GML		I/O	flyttalls vektor	langskips metasenter
!   I33		I/O	flyttall vektor		andre arealmoment tverrskips
!   I55		I/O	flyttalls vektor	andre arealmoment langskips
!   pi		I/O	flyttall		pi
!   rho		I/O	flyttal			tetthet sjøvann
!   g		I/O	flyttall		tyngdeakselerasjonen!
!
!   INTERNE VARIABLE:
!   Navn			Funksjon
!   .....................................................................
!   i,j				tellevariabler
!   KG			    	tyngdepunkt lekter
!   KB				volumsenter lekter
!   V				volumdeplasement
!
!   SUBRUTINER:
!   Navn			Funksjonsbeskrivelse
!   .....................................................................
!   konstanter			beregner metasenter og andre arealmomenter
!   akalk			beregner tilleggmasse i hiv
!   bckalk			beregner demping og fjærkoeffisienter
!   h3kalk			beregner transferfunksjoner hiv
!   h5kalk			beregner transferfunksjoner stamp
!   fasekalk			beregner fasevinkel for bevegelser
!
!   LESEFILER:
!   Navn			Eventuell beskrivelse
!   .....................................................................
!   konstantinput.txt		inneholder lektergeometri
!
!   --------------------------------------------------------------------
!
!   Programmert av:	     Tor Erik Larsen
!   Dato/Versjon  : 	     27.04.15 / 1.0
!
!   --------------------------------------------------------------------

!Starter subrutiner og erklærer alle variabler og konstanter
SUBROUTINE konstanter(L,Br,D,H,M,GML,I33,I55,rho,g,nl)
IMPLICIT NONE

!Erklærer variable og parametere, skriver kontroll til skjerm
INTEGER i,j,nl
REAL,DIMENSION(1:nl)::L,Br,D,H,GML,I33,I55,M,V
REAL,DIMENSION(1:nl)::KG,KB,BML
REAL::rho,g

!Leser inn lektergeometri fra input-fil, skriver ut kontroll til skjerm
OPEN(20,FILE="konstantinput.txt",ACTION="READ",STATUS="UNKNOWN")
DO j = 1,nl
   READ(20,*) L(j),Br(j),D(j),H(j)
END DO
CLOSE(20)

!Beregner andre arealmoment for begge lektere, skriver ut kontroll
!Setter lekterfribord til dobbel dypgang
DO j=1,nl
   V(j)   = L(j)*Br(j)*D(j)
   M(j)   = rho*V(j)
   I33(j) = L(j) * Br(j)**3 / 12.0
   I55(j) = M(j) * ( (L(j)**2 / 12.0) + H(j)**2)
   KG(j)  = D(j)
   KB(j)  = D(j) / 2.0
   BML(j) = L(j)**2 / (12.0*D(j))
   GML(j) = KB(j) + BML(j) - KG(j)
END DO

!Gir tilbake kontroll og avslutter subrutine
RETURN
END SUBROUTINE


! ---------------------------------------------------------------- Get_Abs_FAS
      subroutine Get_Abs_FAS(
     : ts, sps, npts_smc, dc_remove,
     : taper_front, taper_back, signnpw2, nzpad, npw2, df_fft,
     : itype, ipow, df_in, smooth_param, df_smooth,
     : specify_frequencies,
     : freq_param, f_intrp_low, f_intrp_high, log_spaced_f,
     : freq_out, fas_out, nfreq_out, df_out)

!INPUT:  ts, sps, npts_smc, dc_remove,
!        taper_front, taper_back, signnpw2,
!        itype, ipow, df_in, smooth_param,
!        specify_frequencies,
!        freq_param, f_intrp_low, f_intrp_high, log_spaced_f,
!        freq_out, nfreq_out (if specify_frequencies = Y)

!OUPUT:  nzpad, npw2, df_fft, df_smooth,
!        freq_out, fas_out, nfreq_out, df_out

! NOTE: if specify_frequencies = Y, then nfreq_out, freq_out contains
! the specified (input) number of frequencies and the specified frequencies.

!!
!! Meaning of smoothing input parameters
!!
!! NO SMOOTHING
!! itype = 0
!! SMOOTHING OVER EQUALLY SPACED FREQUENCIES
!! itype = 1: box weighting function
!!   smooth_param = width of box weighting function (Hz)
!! itype = 2: triangular weighting function
!!   smooth_param = width of triangular weighting function (Hz)
!! SMOOTHING OVER LOGARITHMICALLY SPACED FREQUENCIES
!! itype = 3: box weighting function
!!   smooth_param = xi, which is the fraction of a decade for the
!!                  box weighting function
!! itype = 4: triangular weighting function
!!   smooth_param = xi, which is the fraction of a decade for the
!!                  triangular weighting function
!! itype = 5: Konno and Ohmachi weighting function (see BSSA 88, 228-241)
!!   smooth_param = xi, which is the fraction of a decade spanned by the
!!                  first zero crossings for the
!!                  Konno and Ohmachi weighting function
!!
!! ipow = power of FAS to be smoothed (2 = smoothing energy spectrum)
!!
!! df_smooth: Note: need df_smooth for linearly-spaced smoothers,
!! and generally it should be the df from the fft.  The reason for
!! including it as an input parameter is to "fool" the
!! program to do smoothing over a specified number of points by
!! setting df = 1 and smooth_param = number of points (including
!! points with zero weight at ends; e.g., smooth_param = 5 will
!! give a smoother with weights 0, 1/4, 2/4, 1/4, 0; smooth_param
!! should be odd).
 !
!!smoothing: itype, ipow, df_smooth (0 = FFT df), smooth_param:
!  1  2 1.0 15.0
!!specify frequencies? (y/n):
!  N
!!frequency specification:
!!  If specify_frequencies = Y, then enter the number
!!    of frequencies followed by the specific frequency values.
!!  If specify_frequencies = N, then enter interpolation information
!!    df_intrp(0=FFT freqs), f_intrp_low, f_intrp_high,
!!    log-spaced(0=F,1=T; integer). NOTE: if log-spaced_f = T, then
!!    interpret df_intrp as the number of frequencies
!   0.0 0.0 50.0 0
!!character string to append to filename:
!   .fs
!!Output in smc format (Y,N)?
!! ***IMPORTANT NOTE: Output cannot be in smc format if use log-spaced frequencies
!! because programs such as smc2asc have not been modified to deal with log-spaced
!! frequency.

! Dates: 04/21/08 - Written by D.M. Boore, patterned after SMC2FS2
!        06/10/08 - Skip out of loop if reset nfreq_out because freq_out(j) .gt. fnyq
!        02/09/10 - Replace prctnfrnttaper with length of tapers at front and back.
!                 - Reorder input slightly
!        02/10/10 - Replaced "go to 8888" with "exit"
!        02/15/10 - Allow specification of individual frequencies.
!                 - Renamed 'freq' to 'freq_fft' and 'nfreq_fas' to 'nfreq_fft'.
!                 - Deleted code before allocate statement specifying
!                   mspct and n4fas_alloc
!        03/16/10 - Change df_intrp to freq_param in input argument list (because
!                   freq_param is not always the frequency spacing, it may be
!                   less confusing to use freq_param than df_intrp).
!        07/01/13 - Add deallocate statement

c
c Dimension and declaration statements:

      real fas_out(*), freq_out(*), ts(*)
      real fas(:), freq_fft(:)
      allocatable :: fas, freq_fft

      character specify_frequencies*(*)

      integer npts, nfreq_out, nc_f_smc
      real tskip, tlength, ftaper
      real df_intrp, f_intrp_low, f_intrp_high
      real df_smooth, signnpw2
      real t_smc, t_fft, freq_param

      logical dc_remove, log_spaced_f

      call get_npw2(npts_smc,signnpw2,npw2)

      allocate( fas(npw2), freq_fft(npw2) )

! Now read the data from the files:

      dt = 1.0/sps
      t_smc = float(npts_smc)*dt

      fnyq = 0.5*sps

! Compute the Fourier spectra:

      CALL Abs_Spectra(ts, dt, npts_smc, dc_remove,
     :  taper_front, taper_back, fas, npw2, signnpw2,
     :  df_fft, nzpad)

      t_fft = float(npw2)*dt

      nfreq_fft = npw2/2

! Set up the frequency array for output:

! First set up the frequency array for the spectra:

      DO j = 1, nfreq_fft
        freq_fft(j) = float(j-1)*df_fft
      END DO

      IF (specify_frequencies(1:1) == 'Y') THEN  ! If 'Y', then nfreq_out, freq_out
                                            ! have been specified by the calling program
        df_out = -1.0
        m_start = -1
        m_stop  = -1

      ELSE

        IF (freq_param == 0.0) THEN  ! use fft frequencies, between f_intrp_low and f_intrp_high

          m_start = 1
          call locate(freq_fft, nfreq_fft, f_intrp_low, m_start)

          call locate(freq_fft, nfreq_fft, f_intrp_high, m_stop)

          IF (m_stop > nfreq_fft) THEN
            m_stop = nfreq_fft
          END IF

          nfreq_out = m_stop - m_start + 1
          DO j = 1, nfreq_out
            freq_out(j) = freq_fft(j + m_start - 1)
          END DO
          df_out = df_fft

        ELSE                       ! use interpolated frequencies

          IF (log_spaced_f) THEN
            nfreq_out = int(freq_param)
            dlogf = alog10(f_intrp_high/f_intrp_low)/
     :              float(nfreq_out-1)
            DO j = 1, nfreq_out
              freq_out(j) = f_intrp_low*10.0**(float(j-1) * dlogf)
            END DO
            df_out = -1.0
            m_start = -1
            m_stop = -1
          ELSE
            df_intrp = freq_param
            nfreq_out = int((f_intrp_high-f_intrp_low)/df_intrp + 1.1)
            DO j = 1, nfreq_out
              freq_out(j) = float(j-1) * df_intrp + f_intrp_low
            END DO
            df_out = df_intrp
            m_start = -1
            m_stop = -1
          END IF

        END IF

      END IF

      DO j = 1, nfreq_out
        IF(freq_out(j) .gt. fnyq) THEN
          nfreq_out = j -1
          print *, ' ****ATTENTION********* '
          print *, '   nfreq_out has been reset so that'//
     :            ' it is less than the Nyquist frequency'
          print *, ' ****ATTENTION********* '
          EXIT
        END IF
      END DO

! Smooth and interpolate the spectra

      IF (df_in .eq. 0.0) THEN
        df_smooth = df_fft
      ELSE
        df_smooth = df_in
      END IF

      CALL Smooth_interpolate (freq_fft, fas, nfreq_fft,
     :                         freq_out, fas_out, nfreq_out,
     :                         itype, ipow, df_smooth, smooth_param,
     :                         freq_param, m_start, m_stop)

      deallocate( fas, freq_fft )

      RETURN
      END

! ---------------------------------------------------------------- Get_Abs_FAS

      include 'get_npw2.for'
      include 'fork.for'
      include 'tprfrctn.for'
      include 'dcdt.for'
      include 'zeropad.for'
      include 'abs_spectra.for'
      include 'smooth_interpolate.for'


module stomata_mod
  implicit none
  private
  public :: stomfs, stomrs, stomc

contains

  !
  ! stomfs function replaces STOMFS subroutine
  !

      real pure function stomfs (sc, sol)
        implicit none
        real, intent(in) :: sc, sol

        ! The exponential function for solar radiation -- Albert Olioso

        stomfs = 1 / (1 - exp(-1 / sc * sol))
      end function stomfs

  !
  ! stomrs function replaces the STOMRS subroutine
  !

     real pure function stomrs (ft,tf,rmin,mintemp,maxtemp,psisup,psiwc,b1,b2,psie,psice,fs)
       implicit none

       real, intent(in) :: ft, tf, rmin, mintemp, maxtemp, b1, b2
       real, intent(in) :: psisup, psiwc, psie, psice, fs
       real :: fpsice

       ! This program calculates stomatal resistance coefficients are initialized in
       ! stmcof.for (referenced file does not exist -TJC)

       if ( tf .GT. mintemp .AND. tf .LT. maxtemp ) then
         if ( psisup.GT. psiwc ) then
           fpsice = 1 + b1 * psie
         else
           fpsice = 1 + b1 * psice + b2 * ( psice - psie )
         end if
       else
         stomrs = 5000
  !       PRINT*, 'TEMPERATURE IS LESS THAN OR GREATER THAN THE'
  !       PRINT*, 'CRITICAL TEMPERATURE -- STOMATAL RESISTANCE '
  !       PRINT*, 'SET EQUAL TO 5000 S M-1'
         return
       end if

       stomrs = rmin * fs * fpsice * ft

     end function stomrs

  !
  ! stomc function replaces the STOMC subroutine
  !

     real pure function stomc (ft,rmin,b1,psice,fs)
       implicit none

       real, intent(in) :: ft, rmin, b1, psice, fs
       real :: fpsice

       ! Calclates the critical stomatal resistance  for the ground water potential

       fpsice = 1 + b1 * psice
       stomc = rmin * fs * fpsice * ft

     end function stomc

end module stomata_mod


      SUBROUTINE HISTAB(IPAIR,J,PMIN,RSTAB)
*
*
*       Hierarchical stability condition.
*       ---------------------------------
*
      INCLUDE 'common6.h'
      REAL*8  XX(3,3),VV(3,3)
*
*
*       Define KS & c.m. indices and save IPAIR for RETURN.
      I1 = 2*IPAIR - 1
      I2 = I1 + 1
      I = N + IPAIR
      JPAIR = IPAIR
*
*       Evaluate semi-major axis & eccentricity of inner binary.
      SEMI = -0.5D0*BODY(I)/H(IPAIR)
      ECC2 = (1.0D0 - R(IPAIR)/SEMI)**2 + TDOT2(IPAIR)**2/(BODY(I)*SEMI)
      ECC = SQRT(ECC2)
*
*       Form stability ratio (Eggleton & Kiseleva, Ap.J. 455, 640, 1995).
*     Q = BODY(I)/BODY(J)
*     Q1 = MAX(BODY(I2)/BODY(I1),BODY(I1)/BODY(I2))
*     Q3 = Q**0.33333
*     Q13 = Q1**0.33333
*       Note sign error in third term of Eq. (2).
*     AR = 1.0 + 3.7/Q3 - 2.2/(1.0 + Q3) + 1.4/Q13*(Q3 - 1.0)/(Q3 + 1.0)
*
*       Save hierarchical stability separation in COMMON variable.
*     PCRIT = AR*SEMI*(1.0D0 + ECC)
*
*       Determine the outer eccentricity.
      RIJ2 = 0.0
      VIJ2 = 0.0
      RDOT = 0.0
      DO 5 K = 1,3
          RIJ2 = RIJ2 + (X(K,I) - X(K,J))**2
          VIJ2 = VIJ2 + (XDOT(K,I) - XDOT(K,J))**2
          RDOT = RDOT + (X(K,I) - X(K,J))*(XDOT(K,I) - XDOT(K,J))
    5 CONTINUE
      RIJ = SQRT(RIJ2)
      A1 = 2.0/RIJ - VIJ2/(BODY(I) + BODY(J))
*
*       Exit on hyperbolic orbit.
      IF (A1.LT.0.0) THEN
          PMIN = 1.0
          RSTAB = 0.0
          GO TO 20
      END IF
*
      SEMI1 = 1.0/A1
      ECC2 = (1.0 - RIJ/SEMI1)**2 + RDOT**2/(SEMI1*(BODY(I) + BODY(J)))
      ECC1 = SQRT(ECC2)
      PMIN = SEMI1*(1.0 - ECC1)
*
*       Evaluate the basic stability condition without fudge factor.
      Q = BODY(J)/BODY(I)
      IF (ECC1.LT.1.0) THEN
          XFAC = (1.0 + Q)*(1.0 + ECC1)/SQRT(1.0 - ECC1)
      ELSE
          XFAC = 40.0*(1.0 + Q)
      END IF
      PCRIT = 2.8*XFAC**0.4*SEMI
*
*       Exit if stability value falls outside practical limits.
      IF ((PCRIT.GT.1.5*PMIN.OR.PCRIT.LT.0.5*PMIN).AND.J.LE.N) THEN
          RSTAB = PCRIT
          GO TO 20
      END IF
*
*       Choose the most active triple in case of two binaries.
      JJ = J
      IF (J.GT.N) THEN
          SEMI2 = -0.5D0*BODY(J)/H(J-N)
*       Adopt 10% fudge factor with linear dependence on smallest ratio.
          YFAC = 1.0 + 0.1*MIN(SEMI2/SEMI,SEMI/SEMI2)
          IF (SEMI2.GT.SEMI) THEN
              ECC2 = (1.0 - R(J-N)/SEMI2)**2 +
     &                             TDOT2(J-N)**2/(BODY(J)*SEMI2)
              ECC = SQRT(ECC2)
              SEMIZ = SEMI2
              SEMI2 = SEMI
              SEMI = SEMIZ
              IPAIR = J - N
              I1 = 2*IPAIR - 1
              I2 = I1 + 1
              JJ = I
              I = J
          END IF
      ELSE
          YFAC = 1.0
      END IF
*
*       Resolve weakly perturbed binary (prevent X(K,I1) = X(K,I2)).
      IF (GAMMA(IPAIR).LT.GMIN.OR.X(1,I1).EQ.X(1,I2)) THEN
          CALL RESOLV(IPAIR,1)
      END IF
*
*       Determine inclination for triple configuration (NB! radians).
      DO 10 K = 1,3
          XX(K,1) = X(K,I1)
          XX(K,2) = X(K,I2)
          XX(K,3) = X(K,JJ)
          VV(K,1) = XDOT(K,I1)
          VV(K,2) = XDOT(K,I2)
          VV(K,3) = XDOT(K,JJ)
  10  CONTINUE
      CALL INCLIN(XX,VV,X(1,I),XDOT(1,I),ANGLE)
*
*       Employ the improved stability criterion for doubtful cases.
      RSTAB = stability(BODY(I1),BODY(I2),BODY(JJ),ECC,ECC1,ANGLE)*SEMI
*       Note: the present stability routine includes inclination!
*     RSTAB = YFAC*RSTAB
      PCRIT = RSTAB
      IPAIR = JPAIR
*
   20 RETURN
*
      END


program atom_U
use dftatom, only: dp, stop_error, get_atom_orb, &
    atom_lda
implicit none

! Atomic number:
integer :: Z
! Mesh parameters:
real(dp), parameter :: r_min = 1e-7_dp, r_max = 50.0_dp, a = 2.7e6_dp
integer :: NN

integer :: i, n_orb
character, parameter :: l_names(0:3) = (/ "s", "p", "d", "f" /)
real(dp) :: E_tot
real(dp), parameter :: reigen_eps = 1e-10_dp
real(dp), parameter :: mixing_eps = 5e-9_dp
integer, allocatable, dimension(:) :: no, lo
real(dp), allocatable, dimension(:) :: fo, ks_energies
real(dp), allocatable :: orbitals(:, :)
real(dp), allocatable :: R(:), Rp(:), V_tot(:), density(:)

Z = 92
NN = 5500
n_orb = get_atom_orb(Z)
allocate(ks_energies(n_orb), no(n_orb), &
    lo(n_orb), fo(n_orb), orbitals(NN+1, n_orb), R(NN+1), V_tot(NN+1), &
    density(NN+1), Rp(NN+1))
call atom_lda(Z, r_min, r_max, a, NN, no, lo, fo, ks_energies, E_tot, &
    R, Rp, V_tot, density, orbitals, reigen_eps, 100, mixing_eps, &
    0.5_dp, 200, .true.)

print *, "Z=", Z, "N=", NN
print '("E_tot=", F18.6)', E_tot
print *, "state    E            occupancy"
do i = 1, size(ks_energies)
    print "(I1, A, ' ', F18.6, '   ', F6.3)", no(i), l_names(lo(i)), &
        ks_energies(i), fo(i)
end do
print *, "Print the first 10 values of the 1st and 2nd orbitals:"
print *, orbitals(:10, 1)
print *, orbitals(:10, 2)

end program


      SUBROUTINE sgefa1 (A, LDA, N, IPVT, INFO)
      USE LIPREC, ONLY: WP => SP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER LDA, N, INFO
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(LDA,N) :: A

      CALL sgefa (A, LDA, N, IPVT, INFO)

      END SUBROUTINE sgefa1

      SUBROUTINE dgefa1 (A, LDA, N, IPVT, INFO)
      USE LIPREC, ONLY: WP => DP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER LDA, N, INFO
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(LDA,N) :: A

      CALL dgefa (A, LDA, N, IPVT, INFO)

      END SUBROUTINE dgefa1

#ifndef CRAY
      SUBROUTINE sgefa (A, LDA, N, IPVT, INFO)
      USE LIPREC, ONLY: WP => SP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER LDA, N, INFO
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(LDA,N) :: A
C-----------------------------------------------
C   L O C A L   V A R I A B L E S
C-----------------------------------------------
      REAL(WP), PARAMETER :: ZERO = 0, ONE = 1
      INTEGER :: J, K, KP1, L, NM1
      INTEGER, DIMENSION(1) :: ISAMAX
      REAL(WP) :: ELEMENT
C-----------------------------------------------
c
c     sgefa factors a real matrix by gaussian elimination.
c
c     sgefa is usually called by sgeco, but it can be called
c     directly with a saving in time if rcond  is not needed.
c     (time for sgeco) = (1 + 9/n)*(time for sgefa) .
c
c     on ENTRY
c
c        a       REAL(lda, n)
c                the matrix to be factored.
c
c        lda     INTEGER
c                the leading dimension of the array  a .
c
c        n       INTEGER
c                the order of the matrix  a .
c
c     on RETURN
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    INTEGER(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k).eq.0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that sgesl or sgedi will divide by zero
c                     if called.  use  rcond  in sgeco for a reliable
c                     indication of singularity.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c
c
c     gaussian elimination with partial pivoting
c
      info = 0
      nm1 = n - 1
      IF (nm1 .ge. 1) THEN
         DO k = 1, nm1
            kp1 = k + 1
c
c         find l = pivot index
c
            isamax = MAXLOC(ABS(a(k:n,k)))
            l = isamax(1) + k - 1
C           l = IDAMAX(n-k+1,a(k,k),1) + k - 1
            ipvt(k) = l
c

c         zero pivot implies this column already triangularized
c
            IF (a(l,k) .ne. zero) THEN
c
c           interchange if necessary
c
               IF (l .ne. k) THEN
                  element = a(l,k)
                  a(l,k) = a(k,k)
                  a(k,k) = element
               END IF
c
c         compute multipliers
c
               element = -one/a(k,k)
!              CALL bla_scal(n-k,element,a(k+1,k),1)
               a(k+1:n,k) = element*a(k+1:n,k)
c
c           row elimination with column indexing
c
               DO j = kp1, n
                 element = a(l,j)
                 IF (l .ne. k) THEN
                    a(l,j) = a(k,j)
                    a(k,j) = element
                 END IF
!                CALL bla_axpy(n-k,element,a(k+1,k),1,a(k+1,j),1)
                 a(k+1:n,j) = a(k+1:n,j) + element*a(k+1:n,k)
               END DO

            ELSE
               info = k
            END IF
         END DO
      END IF
      ipvt(n) = n
      IF (a(n,n) .eq. zero) info = n

      END SUBROUTINE sgefa

      SUBROUTINE dgefa (A, LDA, N, IPVT, INFO)
      USE LIPREC, ONLY: WP => DP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER LDA, N, INFO
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(LDA,N) :: A
C-----------------------------------------------
C   L O C A L   V A R I A B L E S
C-----------------------------------------------
      REAL(WP), PARAMETER :: ZERO = 0, ONE = 1
      INTEGER :: J, K, KP1, L, NM1
      INTEGER, DIMENSION(1) :: ISAMAX
      REAL(WP) :: ELEMENT
C-----------------------------------------------
c
c     sgefa factors a REAL matrix by gaussian elimination.
c
c     sgefa is usually called by sgeco, but it can be called
c     directly with a saving in time IF  rcond  is not needed.
c     (time for sgeco) = (1 + 9/n)*(time for sgefa) .
c
c     on ENTRY
c
c        a       REAL(lda, n)
c                the matrix to be factored.
c
c        lda     INTEGER
c                the leading DIMENSION of the array  a .
c
c        n       INTEGER
c                the order of the matrix  a .
c
c     on RETURN
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  WHERE
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    INTEGER(n)
c                an INTEGER vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k).eq.0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that sgesl or sgedi will divide by zero
c                     if called.  use  rcond  in sgeco for a reliable
c                     indication of singularity.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c
c
c     gaussian elimination with partial pivoting
c
      info = 0
      nm1 = n - 1
      IF (nm1 .ge. 1) THEN
         DO k = 1, nm1
            kp1 = k + 1
c
c         find l = pivot INDEX
c
            isamax = MAXLOC(ABS(a(k:n,k)))
            l = isamax(1) + k - 1
C           l = IDAMAX(n-k+1,a(k,k),1) + k - 1
            ipvt(k) = l
c

c         zero pivot implies this column already triangularized
c
            IF (a(l,k) .ne. zero) THEN
c
c           interchange if necessary
c
               IF (l .ne. k) THEN
                  element = a(l,k)
                  a(l,k) = a(k,k)
                  a(k,k) = element
               END IF
c
c         compute multipliers
c
               element = -one/a(k,k)
!              CALL bla_scal(n-k,element,a(k+1,k),1)
               a(k+1:n,k) = element*a(k+1:n,k)
c
c           row elimination with column indexing
c
               DO j = kp1, n
                 element = a(l,j)
                 IF (l .ne. k) THEN
                    a(l,j) = a(k,j)
                    a(k,j) = element
                 END IF
!                CALL bla_axpy(n-k,element,a(k+1,k),1,a(k+1,j),1)
                 a(k+1:n,j) = a(k+1:n,j) + element*a(k+1:n,k)
               END DO

            ELSE
               info = k
            END IF
         END DO
      END IF
      ipvt(n) = n
      IF (a(n,n) .eq. zero) info = n

      END SUBROUTINE dgefa
#endif


    MODULE cdf_nc_chisq_mod
!----------------------------------------------------------------------

!                             cdf_nc_chisq_mod
!                             *=*=*=*=*=*=*=*=

!  -  SUBROUTINE CDF_NC_CHISQ(WHICH, CUM, CCUM, X, DF, PNONC, STATUS,
!                             CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CUM_NC_CHISQ(X, DF, PNONC, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CCUM_NC_CHISQ(X, DF, PNONC, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION INV_NC_CHISQ(CUM, CCUM, DF, PNONC, STATUS,
!                                         CHECK_INPUT)

!                             The Distribution
!                             ================

!    The noncentral chi-squared distribution is the sum of DF independent
!     normal distributions with unit standard deviations, but possibly
! non-zero means . Let the mean of the ith normal be delta_i. Then PNONC =
!                             Sigma_i delta_i.

!                                Arguments
!                                =========

!  - INTEGER, INTENT(IN) :: WHICH. Integer indicating which of the next
!    three arguments is to be calculated.
!     1.  CUM and CCUM
!     2.  DF
!     3.  PNONC
!  - REAL (dpkind), OPTIONAL :: CUM. The CDF of the noncentral chi-squared
!    distribution.
!  Range: [ 0:1-10^-10 ]
!  - REAL (dpkind), OPTIONAL :: CCUM. One minus the CDF of the noncentral
!    chi-squared distribution.
!  Range: [ 10^-10:1 ]
!  - REAL (dpkind) :: X. The upper limit of integration of the noncentral
!    chi-squared distribution. (The lower limit is 0.) Range: [ 0:10^100 ]
!  - REAL (dpkind) :: DF. The degrees of freedom of the noncentral
!    chi-squared distribution.
!  Input Range: [ 10^-3:10^10 ]
!  - REAL (dpkind) :: PNONC. The noncentrality parameter.
!  Range: [ 0:10^4 ]
!  - INTEGER, OPTIONAL, INTENT(OUT) :: STATUS. Return code. Possible values:
!      0 Problem solved successfully
!     -1 WHICH outside input range
!     -2 CUM outside range
!     -3 CCUM outside range
!     -4 X outside range
!     -5 DF outside range
!     -6 PNONC outside range
!      3 CUM + CCUM is not nearly one
!     10 no solution for cdf_chisq called in local_cum_nc_chisq
!    -50 Answer (if any) is below the lower search bound
!     50 Answer (if any) is above the upper search bound
!  - LOGICAL, INTENT(IN), OPTIONAL :: CHECK_INPUT. If PRESENT and
!       .TRUE. input argument values are not checked for validity.

!  NOTE: CUM and CCUM must add to (nearly) one.
! ----------------------------------------------------------------------
! .. Use Statements ..
      USE biomath_constants_mod
      USE biomath_mathlib_mod
      USE cdf_aux_mod
! ..
! .. Default Accessibility ..
      PRIVATE
! ..
! .. Public Statements ..
      PUBLIC :: ccum_nc_chisq, cdf_nc_chisq, cum_nc_chisq, inv_nc_chisq
! ..
! .. Parameters ..
      REAL (dpkind), PARAMETER :: ten4 = 1.0E4_dpkind
      REAL (dpkind), PARAMETER :: tiny = 1.0E-100_dpkind
! ..
    CONTAINS

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

      FUNCTION ccum_nc_chisq(x,df,pnonc,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: ccum_nc_chisq
! ..
! .. Scalar Arguments ..
        REAL (dpkind) :: df, pnonc, x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_nc_chisq(which=1,ccum=ccum_nc_chisq,x=x,df=df, &
          pnonc=pnonc,status=status,check_input=check_input)

        RETURN

      END FUNCTION ccum_nc_chisq

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

      SUBROUTINE cdf_nc_chisq(which,cum,ccum,x,df,pnonc,status, &
          check_input)
! .. Use Statements ..
        USE zero_finder
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum
        REAL (dpkind), INTENT (INOUT) :: df, pnonc, x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        INTEGER, INTENT (IN) :: which
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Local Structures ..
! .. Local Arrays
        TYPE (zf_locals) :: local
! ..
! .. Local Scalars ..
        REAL (dpkind) :: fx, local_ccum, local_cum, try_ccum, try_cum
        INTEGER :: zf_status
        LOGICAL :: has_status, local_check_input, match_cum
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
! .. Local Arrays ..
        REAL (dpkind) :: params(6)
! ..
        has_status = PRESENT(status)

! status = 0 means NO error

        IF (has_status) THEN
          status = 0
        END IF

        CALL check_complements(cum,ccum,the_non_central_chi_square%name, &
          'cum','ccum',local_cum,local_ccum,set_values=(which/=1), &
          bad_status=3,status=status)

        IF (has_status) THEN
          IF (status/=0) THEN
            RETURN
          END IF
        END IF

        params(1) = local_cum
        params(2) = local_ccum
        params(3) = x
        params(4) = df
        params(5) = pnonc

        IF (PRESENT(check_input)) THEN
          local_check_input = check_input
        ELSE
          local_check_input = .TRUE.
        END IF

        IF (local_check_input) THEN
          CALL validate_parameters(the_non_central_chi_square,which, &
            params,status)

          IF (has_status) THEN
            IF (status/=0) THEN
              RETURN
            END IF
          END IF

        END IF

!==========
! Calculate answers
!==========

        IF (which>1) match_cum = (local_cum<=half)

        SELECT CASE (which)

        CASE (1)
! Solve for CDF

          CALL local_cum_nc_chisq(x,df,pnonc,local_cum,local_ccum,status)

          IF (PRESENT(cum)) cum = local_cum
          IF (PRESENT(ccum)) ccum = local_ccum

        CASE (2)
! Solve for x

          x = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_non_central_chi_square,3,local)

          DO
            CALL rc_step_zf(zf_status,x,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_nc_chisq(x,df,pnonc,try_cum,try_ccum,status)

            IF (has_status) THEN
              IF (status/=0) THEN
                RETURN
              END IF
            END IF

            IF (match_cum) THEN
              fx = try_cum - local_cum
            ELSE
              fx = try_ccum - local_ccum
            END IF

          END DO

        CASE (3)
! Solve for df

          df = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_non_central_chi_square,4,local)

          DO
            CALL rc_step_zf(zf_status,df,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_nc_chisq(x,df,pnonc,try_cum,try_ccum,status)

            IF (has_status) THEN
              IF (status/=0) THEN
                RETURN
              END IF
            END IF

            IF (match_cum) THEN
              fx = try_cum - local_cum
            ELSE
              fx = try_ccum - local_ccum
            END IF

          END DO

        CASE (4)
! Solve for pnonc

          pnonc = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_non_central_chi_square,5,local)

          DO
            CALL rc_step_zf(zf_status,pnonc,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_nc_chisq(x,df,pnonc,try_cum,try_ccum,status)

            IF (has_status) THEN
              IF (status/=0) THEN
                RETURN
              END IF
            END IF

            IF (match_cum) THEN
              fx = try_cum - local_cum
            ELSE
              fx = try_ccum - local_ccum
            END IF

          END DO

        END SELECT

        IF (has_status) THEN
! Set the status of the zero finder
          CALL cdf_finalize_status(local,status)
        END IF

        RETURN

      END SUBROUTINE cdf_nc_chisq

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

      FUNCTION cum_nc_chisq(x,df,pnonc,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: cum_nc_chisq
! ..
! .. Scalar Arguments ..
        REAL (dpkind) :: df, pnonc, x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_nc_chisq(which=1,cum=cum_nc_chisq,x=x,df=df,pnonc=pnonc, &
          status=status,check_input=check_input)

        RETURN

      END FUNCTION cum_nc_chisq

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

      FUNCTION inv_nc_chisq(cum,ccum,df,pnonc,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: inv_nc_chisq
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum
        REAL (dpkind) :: df, pnonc
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_nc_chisq(2,cum,ccum,inv_nc_chisq,df,pnonc,status, &
          check_input)

        RETURN

      END FUNCTION inv_nc_chisq

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

      SUBROUTINE local_cum_nc_chisq(x,df,pnonc,cum,ccum,status)
!----------------------------------------------------------------------
!                    Cumulative Non-Central Chi Square distribution

!                              Function

!     Computes the integral from 0 to x for the Non-Central
!     Chi-square distribution.

!                              Arguments

!     x    --> upper limit of integration
!     df   --> degrees of freedom
!     pnonc --> non-centrality parameter of the distribution
!     cum  <-- Cumulative chi-square distribution.
!     ccum <-- Compliment of Cumulative distribution.
!     status <-- status of the computation.
!                Set to 10 if cdf_chisq has no answer.

!                              Method

!     Uses  formula  26.4.25   of  Abramowitz  and  Stegun, Handbook  of
!     Mathematical    Functions,  US   NBS   (1966)    to calculate  the
!     non-central chi-square.
!----------------------------------------------------------------------
! .. Use Statements ..
        USE cdf_chisq_mod
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (OUT) :: ccum, cum
        REAL (dpkind) :: df, pnonc, x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
! ..
! .. Local Scalars ..
        REAL (dpkind) :: adj, centaj, centwt, chid2, df0, dfd2, lcntaj, &
          lcntwt, lfact, pcent, pterm, sum, sumadj, term, wt, xnonc
        INTEGER :: chisq_status, i, icent
! ..
! .. Intrinsic Functions ..
        INTRINSIC EXP, INT, LOG, MIN, PRESENT, REAL
! ..
        IF (x<=zero) THEN
          cum = zero
          ccum = one

          RETURN
        END IF

        IF (pnonc<=1.0E-10_dpkind) THEN

!     When non-centrality parameter is (essentially) zero,
!     use cumulative chi-square distribution

          CALL cdf_chisq(which=1,cum=cum,ccum=ccum,x=x,df=df, &
            status=chisq_status)

          IF (chisq_status/=0) THEN
! cdf_chisq has NO answer.

            IF (PRESENT(status)) THEN
              status = 10
            ELSE
              WRITE (*,*) 'Error in local_cum_nc_chisq call to cdf_chisq'
              WRITE (*,*) 'Status: ', chisq_status

              STOP 'Error in local_cum_nc_chisq call to cdf_chisq'
            END IF
          END IF

          RETURN

        END IF

        xnonc = half*pnonc
!***********************************************************************

!     The following code calcualtes the weight, chi-square, and
!     adjustment term for the central term in the infinite series.
!     The central term is the one in which the poisson weight is
!     greatest.  The adjustment term is the amount that must
!     be subtracted from the chi-square to move up two degrees
!     of freedom.

!***********************************************************************
        icent = INT(xnonc)

        IF (icent==0) icent = 1

        chid2 = half*x

!     Calculate central weight term

        lfact = alngam(REAL(icent+1,kind=dpkind))
        lcntwt = (-xnonc) + icent*LOG(xnonc) - lfact
        centwt = EXP(lcntwt)

!     Calculate central chi-square
! DMS dg = df + 2*icent, could be > upper bound for the Chi-squared df

        df0 = dg(icent)

        df0 = MIN(df0,the_chi_square%parameters(4)%high_bound)

        CALL cdf_chisq(which=1,cum=pcent,ccum=ccum,x=x,df=df0, &
          status=chisq_status)

        IF (chisq_status/=0) THEN
! cdf_chisq has NO answer.

          IF (PRESENT(status)) THEN
            status = 10
            RETURN
          ELSE
            WRITE (*,*) 'Error in local_cum_nc_chisq call to cdf_chisq'
            WRITE (*,*) 'Status: ', chisq_status

            STOP 'Error in local_cum_nc_chisq call to cdf_chisq'
          END IF
        END IF

! Calculate central adjustment term

        dfd2 = half*df0
        lfact = alngam(one+dfd2)
        lcntaj = dfd2*LOG(chid2) - chid2 - lfact
        centaj = EXP(lcntaj)
        sum = centwt*pcent

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

!     Sum backwards from the central term towards zero.
!     Quit whenever either
!     (1) the zero term is reached, or
!     (2) the term gets small relative to the sum, or

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

        sumadj = zero
        adj = centaj
        wt = centwt
        i = icent

        GO TO 20

10      CONTINUE
        IF (qsmall(term) .OR. i==0) GO TO 30
20      CONTINUE

        dfd2 = half*dg(i)

!     Adjust chi-square for two fewer degrees of freedom.
!     The adjusted value ends up in PTERM.

        adj = adj*dfd2/chid2
        sumadj = sumadj + adj
        pterm = pcent + sumadj

!     Adjust Poisson weight for J decreased by one

        wt = wt*(i/xnonc)
        term = wt*pterm
        sum = sum + term
        i = i - 1
        GO TO 10

30      CONTINUE
        sumadj = centaj
!***********************************************************************

!     Now sum forward from the central term towards infinity.
!     Quit when either
!     (1) the term gets small relative to the sum, or

!***********************************************************************
        adj = centaj
        wt = centwt
        i = icent

        GO TO 50

40      CONTINUE

        IF (qsmall(term)) GO TO 60

!     Update weights for next higher J

50      CONTINUE
        wt = wt*(xnonc/(i+1))

!     Calculate PTERM and add term to sum

        pterm = pcent - sumadj
        term = wt*pterm
        sum = sum + term

!     Update adjustment term for DF for next iteration

        i = i + 1
        dfd2 = half*dg(i)
        adj = adj*chid2/dfd2
        sumadj = sumadj + adj
        GO TO 40

60      CONTINUE
        cum = sum
        ccum = half + (half-cum)

        RETURN

      CONTAINS

!.....................................................................

        FUNCTION dg(i)
! .. Function Return Value ..
          REAL (dpkind) :: dg
! ..
! .. Scalar Arguments ..
          INTEGER, INTENT (IN) :: i
! ..
          dg = df + two*REAL(i,kind=dpkind)

        END FUNCTION dg

!.....................................................................

        FUNCTION qsmall(xx)
! .. Function Return Value ..
          LOGICAL :: qsmall
! ..
! .. Parameters ..
          REAL (dpkind), PARAMETER :: eps = 1.0E-5_dpkind
! ..
! .. Scalar Arguments ..
          REAL (dpkind), INTENT (IN) :: xx
! ..
          qsmall = sum < 1.0E-20_dpkind .OR. xx < eps*sum

        END FUNCTION qsmall

!.....................................................................

      END SUBROUTINE local_cum_nc_chisq

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

    END MODULE cdf_nc_chisq_mod


!Crown Copyright 2012 AWE.
!
! This file is part of CloverLeaf.
!
! CloverLeaf is free software: you can redistribute it and/or modify it under
! the terms of the GNU General Public License as published by the
! Free Software Foundation, either version 3 of the License, or (at your option)
! any later version.
!
! CloverLeaf is distributed in the hope that it will be useful, but
! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
! details.
!
! You should have received a copy of the GNU General Public License along with
! CloverLeaf. If not, see http://www.gnu.org/licenses/.

!>  @brief Fortran viscosity kernel.
!>  @author Wayne Gaudin
!>  @details Calculates an artificial viscosity using the Wilkin's method to
!>  smooth out shock front and prevent oscillations around discontinuities.
!>  Only cells in compression will have a non-zero value.

MODULE viscosity_kernel_module

CONTAINS

  SUBROUTINE viscosity_kernel(x_min,x_max,y_min,y_max,    &
                              celldx,celldy,              &
                              density0,                   &
                              pressure,                   &
                              viscosity,                  &
                              xvel0,                      &
                              yvel0                       )

    IMPLICIT NONE

    INTEGER     :: x_min,x_max,y_min,y_max
    REAL(KIND=8), DIMENSION(x_min-2:x_max+2)                     :: celldx
    REAL(KIND=8), DIMENSION(y_min-2:y_max+2)                     :: celldy
    REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2)     :: density0
    REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2)     :: pressure
    REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2)     :: viscosity
    REAL(KIND=8), DIMENSION(x_min-2:x_max+3,y_min-2:y_max+3)     :: xvel0,yvel0

    INTEGER       :: j,k
    REAL(KIND=8)  :: ugrad,vgrad,grad2,pgradx,pgrady,pgradx2,pgrady2,grad     &
      ,ygrad,pgrad,xgrad,div,strain2,limiter,dirx,diry

    !$OMP PARALLEL

    !$OMP DO PRIVATE(ugrad,vgrad,div,strain2,pgradx,pgrady,pgradx2,pgrady2,limiter,pgrad,xgrad,ygrad,grad,grad2,dirx,diry)
    DO k=y_min,y_max
      DO j=x_min,x_max
        ugrad=(xvel0(j+1,k  )+xvel0(j+1,k+1))-(xvel0(j  ,k  )+xvel0(j  ,k+1))

        vgrad=(yvel0(j  ,k+1)+yvel0(j+1,k+1))-(yvel0(j  ,k  )+yvel0(j+1,k  ))

        div = (celldx(j)*(ugrad)+  celldy(k)*(vgrad))

        strain2 = 0.5_8*(xvel0(j,  k+1) + xvel0(j+1,k+1)-xvel0(j  ,k  )-xvel0(j+1,k  ))/celldy(k) &
          + 0.5_8*(yvel0(j+1,k  ) + yvel0(j+1,k+1)-yvel0(j  ,k  )-yvel0(j  ,k+1))/celldx(j)

        pgradx=(pressure(j+1,k)-pressure(j-1,k))/(celldx(j)+celldx(j+1))
        pgrady=(pressure(j,k+1)-pressure(j,k-1))/(celldy(k)+celldy(k+1))

        pgradx2 = pgradx*pgradx
        pgrady2 = pgrady*pgrady

        limiter = ((0.5_8*(ugrad)/celldx(j))*pgradx2+(0.5_8*(vgrad)/celldy(k))*pgrady2+strain2*pgradx*pgrady)  &
          /MAX(pgradx2+pgrady2,1.0e-16_8)

        IF ((limiter.GT.0.0).OR.(div.GE.0.0))THEN
          viscosity(j,k) = 0.0
        ELSE
          dirx=1.0_8
          IF(pgradx.LT.0.0) dirx=-1.0_8
          pgradx = dirx*MAX(1.0e-16_8,ABS(pgradx))
          diry=1.0_8
          IF(pgradx.LT.0.0) diry=-1.0_8
          pgrady = diry*MAX(1.0e-16_8,ABS(pgrady))
          pgrad = SQRT(pgradx**2+pgrady**2)
          xgrad = ABS(celldx(j)*pgrad/pgradx)
          ygrad = ABS(celldy(k)*pgrad/pgrady)
          grad  = MIN(xgrad,ygrad)
          grad2 = grad*grad

          viscosity(j,k)=2.0_8*density0(j,k)*grad2*limiter*limiter
        ENDIF

      ENDDO
    ENDDO
  !$OMP END DO

  !$OMP END PARALLEL

  END SUBROUTINE viscosity_kernel

END MODULE viscosity_kernel_module


*DECK SNRM2
      REAL FUNCTION SNRM2 (N, SX, INCX)
C***BEGIN PROLOGUE  SNRM2
C***PURPOSE  Compute the Euclidean length (L2 norm) of a vector.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A3B
C***TYPE      SINGLE PRECISION (SNRM2-S, DNRM2-D, SCNRM2-C)
C***KEYWORDS  BLAS, EUCLIDEAN LENGTH, EUCLIDEAN NORM, L2,
C             LINEAR ALGEBRA, UNITARY, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C
C     --Output--
C    SNRM2  single precision result (zero if N .LE. 0)
C
C     Euclidean norm of the N-vector stored in SX with storage
C     increment INCX .
C     If N .LE. 0, return with result = 0.
C     If N .GE. 1, then INCX must be .GE. 1
C
C     Four Phase Method using two built-in constants that are
C     hopefully applicable to all machines.
C         CUTLO = maximum of  SQRT(U/EPS)  over all known machines.
C         CUTHI = minimum of  SQRT(V)      over all known machines.
C     where
C         EPS = smallest no. such that EPS + 1. .GT. 1.
C         U   = smallest positive no.   (underflow limit)
C         V   = largest  no.            (overflow  limit)
C
C     Brief Outline of Algorithm.
C
C     Phase 1 scans zero components.
C     Move to phase 2 when a component is nonzero and .LE. CUTLO
C     Move to phase 3 when a component is .GT. CUTLO
C     Move to phase 4 when a component is .GE. CUTHI/M
C     where M = N for X() real and M = 2*N for complex.
C
C     Values for CUTLO and CUTHI.
C     From the environmental parameters listed in the IMSL converter
C     document the limiting values are as follows:
C     CUTLO, S.P.   U/EPS = 2**(-102) for  Honeywell.  Close seconds are
C                   Univac and DEC at 2**(-103)
C                   Thus CUTLO = 2**(-51) = 4.44089E-16
C     CUTHI, S.P.   V = 2**127 for Univac, Honeywell, and DEC.
C                   Thus CUTHI = 2**(63.5) = 1.30438E19
C     CUTLO, D.P.   U/EPS = 2**(-67) for Honeywell and DEC.
C                   Thus CUTLO = 2**(-33.5) = 8.23181D-11
C     CUTHI, D.P.   same as S.P.  CUTHI = 1.30438D19
C     DATA CUTLO, CUTHI /8.232D-11,  1.304D19/
C     DATA CUTLO, CUTHI /4.441E-16,  1.304E19/
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SNRM2
      INTEGER NEXT
      REAL SX(*), CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, ONE
      SAVE CUTLO, CUTHI, ZERO, ONE
      DATA ZERO, ONE /0.0E0, 1.0E0/
C
      DATA CUTLO, CUTHI /4.441E-16,  1.304E19/
C***FIRST EXECUTABLE STATEMENT  SNRM2
      IF (N .GT. 0) GO TO 10
         SNRM2  = ZERO
         GO TO 300
C
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N * INCX
C
C                                                 BEGIN MAIN LOOP
C
      I = 1
   20    GO TO NEXT,(30, 50, 70, 110)
   30 IF (ABS(SX(I)) .GT. CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      XMAX = ZERO
C
C                        PHASE 1.  SUM IS ZERO
C
   50 IF (SX(I) .EQ. ZERO) GO TO 200
      IF (ABS(SX(I)) .GT. CUTLO) GO TO 85
C
C                                PREPARE FOR PHASE 2.
C
      ASSIGN 70 TO NEXT
      GO TO 105
C
C                                PREPARE FOR PHASE 4.
C
  100 I = J
      ASSIGN 110 TO NEXT
      SUM = (SUM / SX(I)) / SX(I)
  105 XMAX = ABS(SX(I))
      GO TO 115
C
C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
C
   70 IF (ABS(SX(I)) .GT. CUTLO) GO TO 75
C
C                     COMMON CODE FOR PHASES 2 AND 4.
C                     IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.
C
  110 IF (ABS(SX(I)) .LE. XMAX) GO TO 115
         SUM = ONE + SUM * (XMAX / SX(I))**2
         XMAX = ABS(SX(I))
         GO TO 200
C
  115 SUM = SUM + (SX(I)/XMAX)**2
      GO TO 200
C
C                  PREPARE FOR PHASE 3.
C
   75 SUM = (SUM * XMAX) * XMAX
C
C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)
C
   85 HITEST = CUTHI / N
C
C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.
C
      DO 95 J = I,NN,INCX
      IF (ABS(SX(J)) .GE. HITEST) GO TO 100
   95    SUM = SUM + SX(J)**2
      SNRM2 = SQRT( SUM )
      GO TO 300
C
  200 CONTINUE
      I = I + INCX
      IF (I .LE. NN) GO TO 20
C
C              END OF MAIN LOOP.
C
C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
C
      SNRM2 = XMAX * SQRT(SUM)
  300 CONTINUE
      RETURN
      END


!==============================================================================!
  subroutine Distribute_Nodes(dom, grid, b, w, is, js, ks, ie, je, ke)
!------------------------------------------------------------------------------!
!   Places the nodes on the line defined with local block position             !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Const_Mod,  only: HUGE
  use Domain_Mod, only: Domain_Type
  use Grid_Mod,   only: Grid_Type
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Domain_Type)   :: dom
  type(Grid_Type)     :: grid
  integer, intent(in) :: b, is, js, ks, ie, je, ke
  real,    intent(in) :: w
!----------------------------------[Calling]-----------------------------------!
  real :: atanh
!-----------------------------------[Locals]-----------------------------------!
  integer :: n, ni, nj, nk, i, j, k, node, case
  real    :: x0, y0, z0, delx, dely, delz, t, dt, ddt, pr, xi
!==============================================================================!

  ni = dom % blocks(b) % resolutions(1)
  nj = dom % blocks(b) % resolutions(2)
  nk = dom % blocks(b) % resolutions(3)

  x0   = grid % xn(grid % n_nodes+(ks-1)*ni*nj+(js-1)*ni+is)
  y0   = grid % yn(grid % n_nodes+(ks-1)*ni*nj+(js-1)*ni+is)
  z0   = grid % zn(grid % n_nodes+(ks-1)*ni*nj+(js-1)*ni+is)
  delx = grid % xn(grid % n_nodes+(ke-1)*ni*nj+(je-1)*ni+ie) - x0
  dely = grid % yn(grid % n_nodes+(ke-1)*ni*nj+(je-1)*ni+ie) - y0
  delz = grid % zn(grid % n_nodes+(ke-1)*ni*nj+(je-1)*ni+ie) - z0

  n = max( (ie-is), (je-js),  (ke-ks) )

  !-------------------------!
  !   Linear distribution   !
  !-------------------------!
  if(w  > 0.0) then
    ddt = ( 2.0*(1.0-w) ) / ( 1.0*n*(1.0*n-1.0)*(1.0+w) )
    t=0.0
    do i=is,ie
      do j=js,je
        do k=ks,ke
          if( ie .ne. is ) then
            dt=1.0/(1.0*n)+(1.0*i-0.5*(1.0*n+1)) * ddt
            t=t+dt
            node = grid % n_nodes + (k-1)*ni*nj + (j-1)*ni + i+1
            if( (i  < ie).and.(grid % xn(node) .eq. HUGE) ) then
              grid % xn(node) = x0 + t*delx
              grid % yn(node) = y0 + t*dely
              grid % zn(node) = z0 + t*delz
            end if
          end if
          if( je .ne. js ) then
            dt=1.0/(1.0*n)+(1.0*j-0.5*(1.0*n+1)) * ddt
            t=t+dt
            node = grid % n_nodes + (k-1)*ni*nj + (j-0)*ni + i
            if( (j  < je).and.(grid % xn(node) .eq. HUGE) ) then
              grid % xn(node) = x0 + t*delx
              grid % yn(node) = y0 + t*dely
              grid % zn(node) = z0 + t*delz
            end if
          end if
          if( ke .ne. ks ) then
            dt=1.0/(1.0*n)+(1.0*k-0.5*(1.0*n+1)) * ddt
            t=t+dt
            node = grid % n_nodes + (k-0)*ni*nj + (j-1)*ni + i
            if( (k  < ke).and.(grid % xn(node) .eq. HUGE) ) then
              grid % xn(node) = x0 + t*delx
              grid % yn(node) = y0 + t*dely
              grid % zn(node) = z0 + t*delz
            end if
          end if
        end do
      end do
    end do

  !-----------------------------!
  !   Hyperbolic distribution   !
  !-----------------------------!
  else
    case = 0
    if     ((w  >  -0.5).and.(w <=  -0.25)) then
      pr = 1.0 - abs(0.5 - abs(w))
      case = 1
    else if((w >=  -0.75).and.(w  <  -0.5)) then
      pr = 1.0 - abs(0.5 - abs(w))
      case = 2
    else
      pr = -w
      case = 3
    end if

    do i=is,ie
      do j=js,je
        do k=ks,ke
          if( ie .ne. is ) then
            if(case .eq. 1) xi = -1.0*(1.0*i)/(1.0*n)
            if(case .eq. 2) xi =  1.0 - 1.0*(1.0*i)/(1.0*n)
            if(case .eq. 3) xi = -1.0 + 2.0*(1.0*i)/(1.0*n)
            node = grid % n_nodes + (k-1)*ni*nj + (j-1)*ni + i+1
            if( (i  < ie).and.(grid % xn(node) .eq. HUGE) ) then
              if    (case .eq. 1) then
                grid % xn(node) = x0 - (tanh(xi*atanh(pr))/pr)*delx
                grid % yn(node) = y0 - (tanh(xi*atanh(pr))/pr)*dely
                grid % zn(node) = z0 - (tanh(xi*atanh(pr))/pr)*delz
              elseif(case .eq. 2) then
                grid % xn(node) = x0  &
                                + delx - (tanh(xi*atanh(pr))/pr)*delx
                grid % yn(node) = y0  &
                                + dely - (tanh(xi*atanh(pr))/pr)*dely
                grid % zn(node) = z0  &
                                + delz - (tanh(xi*atanh(pr))/pr)*delz
              elseif(case .eq. 3) then
                grid % xn(node) = x0  &
                                + 0.5*(1.0+tanh(xi*atanh(pr))/pr)*delx
                grid % yn(node) = y0  &
                                + 0.5*(1.0+tanh(xi*atanh(pr))/pr)*dely
                grid % zn(node) = z0  &
                                + 0.5*(1.0+tanh(xi*atanh(pr))/pr)*delz
              end if
            end if
          end if
          if( je .ne. js ) then
            if(case .eq. 1) xi = -1.0*(1.0*j)/(1.0*n)
            if(case .eq. 2) xi =  1.0 - 1.0*(1.0*j)/(1.0*n)
            if(case .eq. 3) xi = -1.0 + 2.0*(1.0*j)/(1.0*n)
            node = grid % n_nodes + (k-1)*ni*nj + (j-0)*ni + i
            if( (j  < je).and.(grid % xn(node) .eq. HUGE) ) then
              if    (case .eq. 1) then
                grid % xn(node) = x0 - (tanh(xi*atanh(pr))/pr)*delx
                grid % yn(node) = y0 - (tanh(xi*atanh(pr))/pr)*dely
                grid % zn(node) = z0 - (tanh(xi*atanh(pr))/pr)*delz
              elseif(case .eq. 2) then
                grid % xn(node) = x0  &
                                + delx - (tanh(xi*atanh(pr))/pr)*delx
                grid % yn(node) = y0  &
                                + dely - (tanh(xi*atanh(pr))/pr)*dely
                grid % zn(node) = z0  &
                                + delz - (tanh(xi*atanh(pr))/pr)*delz
              elseif(case .eq. 3) then
                grid % xn(node) = x0  &
                                + 0.5*(1.0+tanh(xi*atanh(pr))/pr)*delx
                grid % yn(node) = y0  &
                                + 0.5*(1.0+tanh(xi*atanh(pr))/pr)*dely
                grid % zn(node) = z0  &
                                + 0.5*(1.0+tanh(xi*atanh(pr))/pr)*delz
              end if
            end if
          end if
          if( ke .ne. ks ) then
            if(case .eq. 1) xi = -1.0*(1.0*k)/(1.0*n)
            if(case .eq. 2) xi =  1.0 - 1.0*(1.0*k)/(1.0*n)
            if(case .eq. 3) xi = -1.0 + 2.0*(1.0*k)/(1.0*n)
            node = grid % n_nodes + (k-0)*ni*nj + (j-1)*ni + i
            if( (k  < ke).and.(grid % xn(node) .eq. HUGE) ) then
              if    (case .eq. 1) then
                grid % xn(node) = x0 - (tanh(xi*atanh(pr))/pr)*delx
                grid % yn(node) = y0 - (tanh(xi*atanh(pr))/pr)*dely
                grid % yn(node) = z0 - (tanh(xi*atanh(pr))/pr)*delz
              elseif(case .eq. 2) then
                grid % xn(node) = x0  &
                                + delx - (tanh(xi*atanh(pr))/pr)*delx
                grid % yn(node) = y0  &
                                + dely - (tanh(xi*atanh(pr))/pr)*dely
                grid % zn(node) = z0  &
                                + delz - (tanh(xi*atanh(pr))/pr)*delz
              elseif(case .eq. 3) then
                grid % xn(node) = x0  &
                                + 0.5*(1.0+tanh(xi*atanh(pr))/pr)*delx
                grid % yn(node) = y0  &
                                + 0.5*(1.0+tanh(xi*atanh(pr))/pr)*dely
                grid % zn(node) = z0  &
                                + 0.5*(1.0+tanh(xi*atanh(pr))/pr)*delz
              end if
            end if
          end if
        end do
      end do
    end do

  end if

  end subroutine


    subroutine DCC(subset1, subset2, dsub1, dsub2, drij, rij )
    implicit none
    ! define external variables
    integer,intent(in):: drij
    ! dsub1 and dsub2 are the size of subset1 and subset2
    ! drij is the size of unbiased(unpadded) subset2 size
    real(8),intent(in), dimension(:, :, :) :: subset1
    real(8),intent(in), dimension(:, :, :) :: subset2
    real(8),intent(out), dimension(0:drij-1, 0:drij-1, 0:drij-1):: rij
    ! define internal variables
    integer :: x, y, z, padrad, dsub1, dsub2
    real(8) :: temp1_sqare_sum, temp2_sqare_sum, nomi,deno
    real(8), dimension(0:dsub1-1,0:dsub1-1,0:dsub1-1) :: temp1_mis
    real(8), dimension(0:dsub1-1,0:dsub1-1,0:dsub1-1) :: temp2
    real(8), dimension(0:dsub1-1,0:dsub1-1,0:dsub1-1) :: temp2_mis
    real(8), dimension(0:dsub1-1,0:dsub1-1,0:dsub1-1) :: A
    !dsub1 = size(subset1,1) ! get the size of subset1 in first dimension
    !dsub2 = size(subset2,1) ! get the size of subset2 in first dimension
    !loopping index
    padrad = (dsub1 - 1)/2
    temp1_mis = subset1 - sum(subset1)/dsub1/dsub1/dsub1
    !temp1_mis_pack = PACK(temp1_mis,.TRUE.)
    temp1_sqare_sum = sum(temp1_mis**2)
    !$OMP PARALLEL DO
    do z = padrad,padrad+drij-1,1
        do y = padrad,padrad+drij-1,1
            do x = padrad,padrad+drij-1,1
                temp2(:,:,:) = subset2(x+1-padrad:x+1+padrad, y+1-padrad:y+1+padrad, z+1-padrad:z+1+padrad)
                temp2_mis = temp2-sum(temp2)/dsub1/dsub1/dsub1
                temp2_sqare_sum = sum(temp2_mis**2)
                A= temp1_mis*temp2_mis
                nomi = sum(A)
                ! adding the if condition to check the zeros of division
                if((temp1_sqare_sum==0.0).OR.(temp2_sqare_sum==0.0))then
                    rij(x-padrad,y-padrad,z-padrad) = 2.0
                else
                    deno = sqrt(temp1_sqare_sum)*sqrt(temp2_sqare_sum)
                    !if(isnan(nomi/deno))then
                    !rij(x-padrad,y-padrad,z-padrad) = (x-padrad)
                    !else
                    !1.0-nomi/deno
                    rij(x-padrad,y-padrad,z-padrad) = 1.0-nomi/deno
                    !end if
                end if
            enddo
        enddo
    enddo
    !$OMP END PARALLEL DO
    end subroutine


!=====================================================================!
! Main Program for testing the integrators on different test problems
!=====================================================================!

#include "scalar.fpp"

program main

  use utils , only : real_part

  ! Integrators
  use bdf_integrator , only : BDF
  use abm_integrator , only : ABM

  ! Residual and functions
  use pendulum_class, only : pendulum
  use pendulum_functions_class, only : time_period
  use smd_functions_class    , only : kinetic_energy

  implicit none

  ! Declare integrators
  type(BDF) :: bdfobj
  type(ABM) :: abmobj

  ! Physics and function
  type(pendulum), target :: pend
  type(time_period), target :: time
  type(kinetic_energy) , target :: KE

  ! Design variable array
  type(scalar), allocatable :: x(:), dfdx(:), dfdxtmp(:)
  type(scalar) :: fval, ftmp
  type(scalar) :: tend
  type(integer) :: k

  ! Use different step sizes for real and complex mode arithmetic
#if defined USE_COMPLEX
  real(dp) :: dh = 1.0d-16
#else
  real(dp) :: dh = 1.0d-7
#endif

  integer, parameter :: max_order = 3
  integer, parameter :: num_vars = 1

  allocate(X(num_vars), dfdx(num_vars), dfdxtmp(num_vars))

  adjoint: block

    fval    = 0.0d0
    X       = 0.0d0
    dfdx    = 0.0d0
    dfdxtmp = 0.0d0
    x(1)    = 0.25d0

    ! Initialize the system
    call pend % initialize("pendulum", num_state_vars = 1, num_design_vars = size(x))
    bdfobj = BDF(system = pend, tfinal = 1.0d0, h=1.0d-3, max_bdf_order = 2, second_order = .true.)
    call bdfobj % evalFuncGrad(num_func=1, func = time,  num_dv = size(x), x = x, fvals = fval, dfdx = dfdx)
    call bdfobj % writeSolution("period.dat.25")
    call bdfobj % writeAdjointSolution("period-adjoint.dat.25", bdfobj % time,  bdfobj% mu, bdfobj % psi, bdfobj % phi)
    call bdfobj % evalFDFuncGrad(num_func=1, func = time,  num_dv = size(x), x = x, fvals = fval, dfdx= dfdxtmp, dh=dh)
    call bdfobj % finalize()
    call pend % finalize()

    print *, "fval         = ", real_part(fval)
    print *, "Adjoint dfdx = ", real_part(dfdx)
    print *, "FD      dfdx = ", real_part(dfdxtmp)
    print *, "Error        = ", abs(dfdxtmp-dfdx)
    print *, "Rel. Error   = ", abs(real_part(dfdxtmp)-real_part(dfdx))/real_part(dfdxtmp)

  end block adjoint

  ! Test kinetic energy
  adjoint_ke: block

    fval    = 0.0d0
    X       = 0.0d0
    dfdx    = 0.0d0
    dfdxtmp = 0.0d0
    x(1)    = 0.25d0

    ! Initialize the system
    call pend % initialize("pendulum", num_state_vars = 1, num_design_vars = size(x))
    bdfobj = BDF(system = pend, tfinal = 1.0d0, h=1.0d-3, max_bdf_order = 2, second_order = .true.)

    call bdfobj % evalFuncGrad(num_func=1, func = KE,  num_dv = size(x), x = x, fvals = fval, dfdx = dfdx)
    call bdfobj % writeSolution("ke.dat.25")
    call bdfobj % writeAdjointSolution("ke-adjoint.dat.25", bdfobj % time,  bdfobj% mu, bdfobj % psi, bdfobj % phi)
    call bdfobj % evalFDFuncGrad(num_func=1, func = KE,  num_dv = size(x), x = x, fvals = fval, dfdx= dfdxtmp, dh=dh)
    call bdfobj % finalize()

    call pend % finalize()

    print *, "fval         = ", real_part(fval)
    print *, "Adjoint dfdx = ", real_part(dfdx)
    print *, "FD      dfdx = ", real_part(dfdxtmp)
    print *, "Error        = ", abs(dfdxtmp-dfdx)
    print *, "Rel. Error   = ", abs(real_part(dfdxtmp)-real_part(dfdx))/real_part(dfdxtmp)

  end block adjoint_ke

  deallocate(X,dfdx,dfdxtmp)

end program main


program BVESolidBody
!******************************************************************************
!	Peter A. Bosler
!	Department of Mathematics
!	University of Michigan
!	pbosler@umich.edu
!
!******************************************************************************
!
!	This program solves the barotropic vorticity equation for the case of rigid rotation about the z-axis.
!
!	Bosler, P.A., "Particle Methods for Geophysical Flow on the Sphere," PhD Thesis; the University of Michigan, 2013.
!
!----------------
use NumberKindsModule
use LoggerModule
use SphereMeshModule
use RefineRemeshModule
use TracerSetupModule
use VTKOutputModule
use BVESetupModule
use BVEDirectSumModule

implicit none

include 'mpif.h'

!
!	mesh variables
!
type(SphereMesh) :: sphere
integer(kint) :: panelKind, initNest, AMR, nTracer, problemKind
!
!	time stepping variables
!
type(BVERK4Data) :: bveRK4
real(kreal) :: t, dt, tfinal
integer(kint) :: timesteps, timeJ
!
!	tracer variables
!
type(tracerSetup) :: cosBell
real(kreal) :: h0, RR, lat0, lon0
integer(kint) :: tracerID
!
!	vorticity variables
!
type(BVESetup) :: solidBody
!
!	refinement variables
!
type(RefinementSetup) :: tracerRefine
real(kreal) :: tracerMaxTol, tracerVarTol
integer(kint) :: refinementLimit

type(RefinementSetup) :: vortRefine
real(kreal) :: circMaxTol, vortVarTol
!
!	remeshing variables
!
integer(kint) :: remeshInterval, remeshCounter
!
!	User input
!
character(len = 128) :: namelistInputFile = 'bveSolidBody.namelist'
integer(kint) :: readStat
!
!	Output variables
!
type(VTKSource) :: vtkOut
character(len = 128) :: vtkRoot, vtkFile, outputDir, jobPrefix
character(len = 56 ) :: amrString
integer(kint) :: frameCounter, frameOut
!
!	logging
!
type(Logger) :: exeLog
character(len=28) :: logKey
character(len=128) :: logString
!
!	general and mpi variables
!
integer(kint) :: i, j, k
integer(kint) :: mpiErrCode
integer(kint), parameter  :: BROADCAST_INT_SIZE = 5, BROADCAST_REAL_SIZE = 6
integer(kint) :: broadcastIntegers(BROADCAST_INT_SIZE)
real(kreal) :: broadcastReals(BROADCAST_REAL_SIZE)

namelist /sphereDefine/ panelKind, initNest, AMR, tracerMaxTol, tracerVarTol, refineMentLimit, circMaxTol, vortVarTol
namelist /timeStepping/ tfinal, dt,  remeshInterval
namelist /fileIO/ outputDir, jobPrefix, frameOut

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	PROGRAM START
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
call MPI_INIT(mpiErrCode)
call MPI_COMM_SIZE(MPI_COMM_WORLD,numProcs,mpiErrCode)
call MPI_COMM_RANK(MPI_COMM_WORLD,procRank,mpiErrCode)

call InitLogger(exeLog,procRank)
!
!	read user input from namelist file, broadcast to all processes
!
call ReadNameListFile(procRank)
call MPI_BCAST(broadcastIntegers,BROADCAST_INT_SIZE,MPI_INTEGER,0,MPI_COMM_WORLD,mpiErrCode)
panelKind = broadcastIntegers(1)
AMR = broadcastIntegers(2)
initNest = broadcastIntegers(3)
refinementLimit = broadcastIntegers(4)
remeshInterval = broadcastIntegers(5)

call MPI_BCAST(broadcastReals,BROADCAST_REAL_SIZE,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,mpiErrCode)
tracermaxTol = broadcastReals(1)
tracerVarTol = broadcastReals(2)
tfinal = broadcastReals(3)*ONE_DAY ! convert tfinal to seconds
circMaxTol = broadcastReals(4)
vortVarTol = broadcastReals(5)
dt = broadcastReals(6) * ONE_DAY

!
!	define test case in accordance with Williamson et al., JCP 1992, test case 1
!
problemKind = BVE_SOLVER
nTracer = 1
h0 = 1000.0_kreal	! height of cosine bell center
lat0 = 0.0_kreal	! latitude of cosine bell center
lon0 = 3.0_kreal*PI/2.0_kreal ! longitude of cosine bell center
RR = EARTH_RADIUS/3.0_kreal ! radius of cosine bell
tracerID = 1
call New(cosBell, COS_BELL_NINT, COS_BELL_NREAL)
call InitCosineBellTracer(cosBell,lat0,lon0,RR,h0,tracerID)

call New(solidBody,SOLID_BODY_NINT,SOLID_BODY_NREAL)
call InitSolidBodyRotation(solidBody,OMEGA)

!
!	initialize sphere
!
call New(sphere,panelKind,initNest,AMR,nTracer,problemKind)
call SetCosineBellTracerOnMesh(sphere,cosBell)
call SetSolidBodyRotationOnMesh(sphere,solidBody)
if ( AMR > 0 ) then
	call New(tracerRefine,refinementLimit,tracermaxTol,tracerVarTol,TRACER_REFINE,tracerID)
	call New(vortRefine,refinementLimit,circMaxTol,vortVarTol,RELVORT_REFINE)
	call InitialRefinement(sphere,tracerRefine,SetCosineBellTracerOnMesh, cosBell, &
						   vortRefine, SetSolidBodyRotationOnMesh,solidBody)
	if ( panelKind == QUAD_PANEL) then
		write(amrString,'(A,I1,A,I0.2)') 'quadAMR_',initNest,'to',initNest+refinementLimit
	endif
else
	call New(tracerRefine)
	call New(vortRefine)
	if ( panelKind == QUAD_PANEL ) then
		write(amrString,'(A,I1,A)') 'quadUnif',initNest,'_'
	endif
endif
!
!	initialize output, output t = 0 data
!
frameCounter = 0
if ( procRank == 0 ) then
	call LogStats(sphere,exeLog,'initial mesh :')
	write(vtkRoot,'(A,A,A,A,A)') trim(outputDir), '/vtkOut/',trim(jobPrefix),trim(amrString),'_'
	write(vtkFile,'(A,I0.4,A)') trim(vtkRoot),frameCounter,'.vtk'

	call New(vtkOut,sphere,vtkFile,'sbRot')
	call VTKOutput(vtkOut,sphere)
	frameCounter = frameCounter + 1
endif
!
!	intialize timestepping
!
call New(bveRK4,sphere,numProcs)
timesteps = floor(tfinal/dt)
t = 0.0_kreal
remeshCounter = 0
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	RUN THE PROBLEM
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do timeJ = 0, timesteps - 1
	!
	!	remesh if necessary
	!
	if ( mod(timeJ+1,remeshInterval) == 0 ) then
		remeshCounter = remeshCounter + 1
		!
		!	delete objects associated with old mesh
		!
		call Delete(bveRK4)
		call Delete(vtkOut)
		!
		! build new mesh
		!
		call LagrangianRemesh(sphere, SetSolidBodyRotationOnMesh, solidBody, vortRefine, &
									  SetCosineBellTracerOnMesh, cosBell, tracerRefine, &
									  tracerRefine)
		!
		!	create new associated objects
		!
		call New(bveRK4,sphere,numProcs)
		call New(vtkOut,sphere,vtkFile,'sbRot')

		write(logString,'(A,I4)') 'remesh ', remeshCounter
		if ( procRank == 0 ) call LogStats(sphere,exelog,trim(logString))
	endif
	!
	!	advance timestep
	!
	call BVERK4Timestep(bveRK4, sphere, dt, procRank, numProcs)

	t = real(timeJ+1,kreal)*dt
	!
	!	output timestep data
	!
	if ( procRank == 0 .AND. mod(timeJ+1,frameOUt) == 0  ) then
		call LogMessage(exeLog,TRACE_LOGGING_LEVEL,'day = ',t/ONE_DAY)
		write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), frameCounter, '.vtk'
		call UpdateFileName(vtkOut,vtkFile)
		call VTKOutput(vtkOut,sphere)
		frameCounter = frameCounter + 1
	endif
enddo
!
!	output final data
!

! TO DO : output final data requested by Test case 1

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	Clear memory and Finalize
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
call Delete(bveRK4)
if ( procRank == 0 ) call Delete(vtkOut)
call Delete(vortRefine)
call Delete(tracerRefine)
call Delete(cosBell)
call Delete(solidBody)
call Delete(exeLog)
call MPI_FINALIZE(mpiErrCode)

contains

subroutine ReadNamelistfile(rank)
	integer(kint), intent(in) :: rank
	if ( rank == 0 ) then
		open(unit = READ_UNIT, file = namelistInputFile, status = 'OLD', action = 'READ',iostat= readStat)
			if ( readstat /= 0 ) then
				stop 'cannot read namelist file.'
			endif
			read(READ_UNIT,nml=sphereDefine)
			rewind(READ_UNIT)
			read(READ_UNIT,nml=timestepping)
			rewind(READ_UNIT)
			read(READ_UNIT,nml=fileIO)

			broadcastIntegers(1) = panelKind
			broadcastIntegers(2) = AMR
			broadcastIntegers(3) = initNest
			broadcastIntegers(4) = refinementLimit
			broadcastIntegers(5) = remeshInterval

			broadcastReals(1) = tracerMaxTol
			broadcastReals(2) = tracerVarTol
			broadcastReals(3) = tfinal
			broadcastReals(4) = circMaxTol
			broadcastReals(5) = vortVarTol
			broadcastReals(6) = dt
	endif
end subroutine

subroutine InitLogger(alog,rank)
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	if ( rank == 0 ) then
		call New(aLog,DEBUG_LOGGING_LEVEL)
	else
		call New(aLog,WARNING_LOGGING_LEVEL)
	endif
        write(logKey,'(A,I0.2,A)') 'EXE_LOG',procRank,' : '
end subroutine

end program


      PROGRAM min_cost
      IMPLICIT NONE

      INTEGER (KIND=8),PARAMETER::n_line=2601
      INTEGER (KIND=8):: i
      REAL    (KIND=8):: Naa_av,Nbb_av,Nab_av,Jbb_av,Jab_av
      REAL    (KIND=8):: compt,cost_av,delJbb,delJab

      REAL (KIND=8),DIMENSION(n_line) :: Jbb,Jab,FNaa,FNbb,FNab,cost

!!!=======================================================================================
!!!=======================================================================================
      OPEN(unit=12,file='average_thermal.dat')
      OPEN(unit=13,file='average_thermal_min.dat')
      OPEN(unit=14,file='average_thermal_plot.dat')

      compt=0. ; Jbb_av=0.; Jab_av=0. ; cost_av=0.

      DO i=1,n_line
            READ(12,*)Jbb(i),Jab(i),Naa_av,Nbb_av,Nab_av,FNaa(i),FNbb(i),FNab(i),cost(i)

            IF (cost(i)<1.) THEN
                  WRITE(13,'(F8.4,3X,F8.4,4X,F16.4)') Jbb(i),Jab(i),cost(i)
                  WRITE(*,'(F8.4,3X,F8.4,4X,F16.4)') Jbb(i),Jab(i),cost(i)

                  compt=compt+1.
                  Jbb_av=Jbb_av+Jbb(i)
                  Jab_av=Jab_av+Jab(i)
                  cost_av=cost_av+cost(i)

            END IF

            WRITE(14,'(F8.4,3X,F8.4,4X,F16.4)') Jbb(i),Jab(i),cost(i)

      END DO

      Jbb_av=Jbb_av/compt
      Jab_av=Jab_av/compt
      cost_av=cost_av/compt

!!!=======================================================================================
!!! Tinh delJbb, delJab

      delJbb=0. ; delJab=0.
      DO i=1,n_line
            IF (cost(i)<1.) THEN
                  delJbb=delJbb+(Jbb(i)-Jbb_av)**2.
                  delJab=delJab+(Jab(i)-Jab_av)**2.
            END IF

      END DO

      delJbb=sqrt(delJbb/compt)
      delJab=sqrt(delJab/compt)

      WRITE(13,*)'Jbb_av:',Jbb_av,'Jab_av:',Jab_av,'delJbb:',delJbb,'delJab:',delJab,'cost_av:',cost_av
      WRITE(*,*)'Jbb_av:',Jbb_av,'Jab_av:',Jab_av,'delJbb:',delJbb,'delJab:',delJab,'cost_av:',cost_av

      CLOSE(12)
      CLOSE(13)
      CLOSE(14)

!!!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!!!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      END PROGRAM min_cost


      double precision function nloratiotopdecay(mt,mb,mw,gamw)
************************************************************************
*     Authors: R.K. Ellis and J. Campbell, February 2012               *
*                                                                      *
*     ratio NLO/LO for the width of the top quark, including the       *
*     effect of the bottom quark mass.                                 *
*                                                                      *
*     Formula is taken from Eq. (27) of                                *
*                                                                      *
*     \bibitem{Czarnecki:1990kv}                                       *
*     A.~Czarnecki,                                                    *
*     ``QCD corrections to the decay t ---> W b                        *
*       in dimensional regularization,''                               *
*     Phys.\ Lett.\ B {\bf 252}, 467 (1990).                           *
*     %%CITATION = PHLTA,B252,467;%%                                   *
*                                                                      *
*     Formula has been improved in order to have a                     *
*     smooth mb -> 0 limit (in agreement with topwidth.f)              *
*                                                                      *
************************************************************************

C formula taken from Eq.(27) of
c---  %\cite{Czarnecki:1990kv}
c---  \bibitem{Czarnecki:1990kv}
c---  A.~Czarnecki,
c---  %``QCD corrections to the decay t ---> W b in dimensional regularization,''
c---  Phys.\ Lett.\ B {\bf 252}, 467 (1990).
c---- %%CITATION = PHLTA,B252,467;%%
      implicit none
      include 'zerowidth.f'
      double precision mb,mt,mt1,mw,om,omsq,lo,ho,be,besq,
     & Gamma0,Gamma0int,asGamma1,asGamma1int,dgauss,
     & xlo,xhi,xi,gamw,ga
      double precision cachemass,cacheratio,tiny
      data cachemass,cacheratio,tiny/0d0,0d0,1d-8/
      common/transfer/mt1,besq,xi,ga
      save cachemass,cacheratio,tiny
!$omp threadprivate(cachemass,cacheratio,tiny,/transfer/)
      external Gamma0int,asGamma1int

c--- check to see if result has already been computed
      if (abs(mt*mw-mb-cachemass) .lt. tiny) then
        nloratiotopdecay=cacheratio
        return
      endif

      mt1=mt
      om=mw/mt
      be=mb/mt
      ga=gamw/mw
      xi=(mt/mw)**2
      besq=be**2
      omsq=om**2

      if (zerowidth) then
        lo=Gamma0(mt,besq,omsq)
        ho=asGamma1(mt,besq,omsq)
      else
        xlo=0d0
        xhi=(1d0-be)**2
        lo=dgauss(Gamma0int,xlo,xhi,tiny)
        ho=dgauss(asGamma1int,xlo,xhi,tiny)
      endif

      nloratiotopdecay=ho/lo

c--- set-up caching variables
      cachemass=mt*mw-mb
      cacheratio=nloratiotopdecay

      return
      end


module rhs_mod

  use derivatives_mod
  use fft_mod
  use decomp_2d

  implicit none
  include 'mpif.h'

  private

  public :: add2rhs_ddx, add2rhs_ddy, add2rhs_ddz
  public :: add2rhs_ddy_notrans

contains

  subroutine add2rhs_ddx(u,rhs,vector)
    implicit none

    TYPE(DECOMP_INFO),intent(in) :: vector
    !use local indexes
    real(rprec),dimension(vector%xsz(1),vector%xsz(2),vector%xsz(3)),intent(inout) :: u
    real(rprec),dimension(vector%xsz(1),vector%xsz(2),vector%xsz(3)),intent(inout) :: rhs

    real(rprec), allocatable, dimension(:,:,:) :: dudx

    integer :: j,k

    real(rprec) :: test_time

    call alloc_x(dudx,vector)

    test_time = mpi_wtime()
    !compute FT in x to compute the derivative
    !$OMP PARALLEL DO
    do k=1,vector%xsz(3)
       do j=1,vector%xsz(2)
          call ddx(dudx(:,j,k),u(:,j,k))
       enddo
    enddo
    !$OMP END PARALLEL DO
    test_time = mpi_wtime() - test_time

    !write(*,*) 'FFT on x',test_time

    rhs = rhs + dudx

    deallocate(dudx)

  end subroutine add2rhs_ddx

  subroutine add2rhs_ddy(u,rhs,vector)
    implicit none

    TYPE(DECOMP_INFO),intent(in) :: vector
    !use local indexes
    real(rprec),dimension(vector%xsz(1),vector%xsz(2),vector%xsz(3)),intent(inout) :: u
    real(rprec),dimension(vector%xsz(1),vector%xsz(2),vector%xsz(3)),intent(inout) :: rhs

    real(rprec), allocatable, dimension(:,:,:) :: u_4y
    real(rprec), allocatable, dimension(:,:,:) :: dudy_4x, dudy_4y

    integer :: i,k

    real(rprec) :: test_time

    call alloc_y(u_4y,vector)
    call alloc_x(dudy_4x,vector)
    call alloc_y(dudy_4y,vector)

    call transpose_x_to_y(u,u_4y)

    test_time = mpi_wtime()
    !compute FT in y to compute the derivative
    !$OMP PARALLEL DO
    do k=1,vector%ysz(3)
       do i=1,vector%ysz(1)
          call ddy(dudy_4y(i,:,k),u_4y(i,:,k))
       enddo
    enddo
    !$OMP END PARALLEL DO
    test_time = mpi_wtime() - test_time

    !write(*,*) 'FFT on y',test_time

    call transpose_y_to_x(u_4y,u)
    call transpose_y_to_x(dudy_4y,dudy_4x)

    rhs = rhs + dudy_4x

    deallocate(u_4y)
    deallocate(dudy_4x)
    deallocate(dudy_4y)

  end subroutine add2rhs_ddy

  subroutine add2rhs_ddy_notrans(u,rhs,vector)
    implicit none

    TYPE(DECOMP_INFO),intent(in) :: vector
    !use local indexes
    real(rprec),dimension(vector%xsz(1),vector%xsz(2),vector%xsz(3)),intent(inout) :: u
    real(rprec),dimension(vector%xsz(1),vector%xsz(2),vector%xsz(3)),intent(inout) :: rhs

    real(rprec), allocatable, dimension(:,:,:) :: dudy

    integer :: i,k

    real(rprec) :: test_time

    call alloc_x(dudy,vector)

    test_time = mpi_wtime()
    !compute FT in y to compute the derivative
    !$OMP PARALLEL DO
    do k=1,vector%ysz(3)
       do i=1,vector%ysz(1)
          call ddy(dudy(i,:,k),u(i,:,k))
       enddo
    enddo
    !$OMP END PARALLEL DO
    test_time = mpi_wtime() - test_time

    !write(*,*) 'FFT on y',test_time

    rhs = rhs + dudy

    deallocate(dudy)

  end subroutine add2rhs_ddy_notrans

  subroutine add2rhs_ddz(u,rhs,vector)
    implicit none

    TYPE(DECOMP_INFO),intent(in) :: vector
    !use local indexes
    real(rprec),dimension(vector%xsz(1),vector%xsz(2),vector%xsz(3)),intent(inout) :: u
    real(rprec),dimension(vector%xsz(1),vector%xsz(2),vector%xsz(3)),intent(inout) :: rhs

    real(rprec), allocatable, dimension(:,:,:) :: dudz
    real(rprec), allocatable, dimension(:,:,:) :: dudz_halo

    integer :: k

    real(rprec) :: test_time

    call alloc_x(dudz,vector)

    call ddz_uv_4x(dudz,u,vector)
    call update_halo(dudz,dudz_halo,level=1)

    test_time = mpi_wtime()
    !$OMP PARALLEL DO
    do k=1,vector%xsz(3)
       rhs(:,:,k)=rhs(:,:,k)+0.5_rprec*(dudz_halo(1:vector%xsz(1),1:vector%xsz(2),k-1)+ &
            dudz_halo(1:vector%xsz(1),1:vector%xsz(2),k))
    end do
    !$OMP END PARALLEL DO
    test_time = mpi_wtime() - test_time

    !write(*,*) 'DF on z',test_time

    deallocate(dudz)
  end subroutine add2rhs_ddz

  subroutine add2rhs_ddz_nohalo(u,rhs,vector)
    implicit none

    TYPE(DECOMP_INFO),intent(in) :: vector
    !use local indexes
    real(rprec),dimension(vector%xsz(1),vector%xsz(2),vector%xsz(3)),intent(inout) :: u
    real(rprec),dimension(vector%xsz(1),vector%xsz(2),vector%xsz(3)),intent(inout) :: rhs

    real(rprec), allocatable, dimension(:,:,:) :: dudz

    integer :: k

    call alloc_x(dudz,vector)

    call ddz_uv_4x(dudz,u,vector)

    !$OMP PARALLEL DO
    do k=2,vector%xsz(3)
       rhs(:,:,k)=rhs(:,:,k)+0.5_rprec*(dudz(1:vector%xsz(1),1:vector%xsz(2),k-1)+ &
            dudz(1:vector%xsz(1),1:vector%xsz(2),k))
    end do
    !$OMP END PARALLEL DO

    deallocate(dudz)

  end subroutine add2rhs_ddz_nohalo

end module rhs_mod


chapter ix. example comparing the b-representation of a cubic  f  with
c  its values at knot averages.
c  from  * a practical guide to splines *  by c. de boor
c
      integer i,id,j,jj,n,nm4
      real bcoef(23),d(4),d0(4),dtip1,dtip2,f(23),t(27),tave(23),x
c	     the taylor coefficients at  0  for the polynomial	f  are
      data d0 /-162.,99.,-18.,1./
c
c		  set up knot sequence in the array  t .
      n = 13
      do 5 i=1,4
	 t(i) = 0.
    5	 t(n+i) = 10.
      nm4 = n-4
      do 6 i=1,nm4
    6	 t(i+4) = float(i)
c
      do 50 i=1,n
c	 use nested multiplication to get taylor coefficients  d  at
c		t(i+2)	from those at  0 .
	 do 20 j=1,4
   20	    d(j) = d0(j)
	 do 21 j=1,3
	    id = 4
	    do 21 jj=j,3
	       id = id-1
   21	       d(id) = d(id) + d(id+1)*t(i+2)
c
c		 compute b-spline coefficients by formula (9).
	 dtip1 = t(i+2) - t(i+1)
	 dtip2 = t(i+3) - t(i+2)
	 bcoef(i) = d(1) + (d(2)*(dtip2-dtip1)-d(3)*dtip1*dtip2)/3.
c
c		   evaluate  f	at corresp. knot average.
	 tave(i) = (t(i+1) + t(i+2) + t(i+3))/3.
	 x = tave(i)
   50	 f(i) = d0(1) + x*(d0(2) + x*(d0(3) + x*d0(4)))
c
      print 650, (i,tave(i), f(i), bcoef(i),i=1,n)
  650 format(45h  i   tave(i)	   f at tave(i)      bcoef(i)//
     *	     (i3,f10.5,2f16.5))
					stop
      end


    MODULE blas_dense_red_op

      ! Fortran 95 Bindings Generic Interface Blocks
      ! .  for section 2.8.2 -- Reduction Operations
      ! .  using external procedures.
      ! Written on 14 December 2000
      ! .  Zohair Maany and Sven Hammarling, NAG Central Office.

      PRIVATE
      PUBLIC :: dot, norm, sum, min_val, max_val, amin_val, amax_val, sumsq

      INTERFACE dot
        ! x and y must have same shape
        SUBROUTINE dot_d(x,y,r,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:), y(:)
          REAL (wp), INTENT (INOUT) :: r
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE dot_d
        SUBROUTINE dot_z(x,y,r,conj,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_conj_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:), y(:)
          COMPLEX (wp), INTENT (INOUT) :: r
          TYPE (blas_conj_type), INTENT (IN), OPTIONAL :: conj
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE dot_z
        SUBROUTINE dot_s(x,y,r,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:), y(:)
          REAL (wp), INTENT (INOUT) :: r
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE dot_s
        SUBROUTINE dot_c(x,y,r,conj,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_conj_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:), y(:)
          COMPLEX (wp), INTENT (INOUT) :: r
          TYPE (blas_conj_type), INTENT (IN), OPTIONAL :: conj
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE dot_c
      END INTERFACE

      INTERFACE norm
        FUNCTION norm_d(x,norm)
          USE blas_operator_arguments, ONLY : blas_norm_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:)
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          REAL (wp) :: norm_d
        END FUNCTION norm_d
        FUNCTION norm_z(x,norm)
          USE blas_operator_arguments, ONLY : blas_norm_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:)
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          REAL (wp) :: norm_z
        END FUNCTION norm_z
        FUNCTION norm_s(x,norm)
          USE blas_operator_arguments, ONLY : blas_norm_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:)
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          REAL (wp) :: norm_s
        END FUNCTION norm_s
        FUNCTION norm_c(x,norm)
          USE blas_operator_arguments, ONLY : blas_norm_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:)
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          REAL (wp) :: norm_c
        END FUNCTION norm_c
      END INTERFACE

      INTERFACE sum
        FUNCTION sum_d(x)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp) :: sum_d
        END FUNCTION sum_d
        FUNCTION sum_z(x)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:)
          COMPLEX (wp) :: sum_z
        END FUNCTION sum_z
        FUNCTION sum_s(x)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp) :: sum_s
        END FUNCTION sum_s
        FUNCTION sum_c(x)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:)
          COMPLEX (wp) :: sum_c
        END FUNCTION sum_c
      END INTERFACE

      INTERFACE min_val
        SUBROUTINE min_val_d(x,k,r)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (OUT) :: r
          INTEGER, INTENT (OUT) :: k
        END SUBROUTINE min_val_d
        SUBROUTINE min_val_s(x,k,r)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (OUT) :: r
          INTEGER, INTENT (OUT) :: k
        END SUBROUTINE min_val_s
      END INTERFACE

      INTERFACE max_val
        SUBROUTINE max_val_d(x,k,r)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (OUT) :: r
          INTEGER, INTENT (OUT) :: k
        END SUBROUTINE max_val_d
        SUBROUTINE max_val_s(x,k,r)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (OUT) :: r
          INTEGER, INTENT (OUT) :: k
        END SUBROUTINE max_val_s
      END INTERFACE

      INTERFACE amin_val
        SUBROUTINE amin_val_d(x,k,r)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (OUT) :: r
          INTEGER, INTENT (OUT) :: k
        END SUBROUTINE amin_val_d
        SUBROUTINE amin_val_z(x,k,r)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (OUT) :: r
          INTEGER, INTENT (OUT) :: k
        END SUBROUTINE amin_val_z
        SUBROUTINE amin_val_s(x,k,r)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (OUT) :: r
          INTEGER, INTENT (OUT) :: k
        END SUBROUTINE amin_val_s
        SUBROUTINE amin_val_c(x,k,r)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (OUT) :: r
          INTEGER, INTENT (OUT) :: k
        END SUBROUTINE amin_val_c
      END INTERFACE

      INTERFACE amax_val
        SUBROUTINE amax_val_d(x,k,r)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (OUT) :: r
          INTEGER, INTENT (OUT) :: k
        END SUBROUTINE amax_val_d
        SUBROUTINE amax_val_z(x,k,r)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (OUT) :: r
          INTEGER, INTENT (OUT) :: k
        END SUBROUTINE amax_val_z
        SUBROUTINE amax_val_s(x,k,r)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (OUT) :: r
          INTEGER, INTENT (OUT) :: k
        END SUBROUTINE amax_val_s
        SUBROUTINE amax_val_c(x,k,r)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (OUT) :: r
          INTEGER, INTENT (OUT) :: k
        END SUBROUTINE amax_val_c
      END INTERFACE

      INTERFACE sumsq
        SUBROUTINE sumsq_d(x,ssq,scl)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (INOUT) :: ssq, scl
        END SUBROUTINE sumsq_d
        SUBROUTINE sumsq_z(x,ssq,scl)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (INOUT) :: ssq, scl
        END SUBROUTINE sumsq_z
        SUBROUTINE sumsq_s(x,ssq,scl)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (INOUT) :: ssq, scl
        END SUBROUTINE sumsq_s
        SUBROUTINE sumsq_c(x,ssq,scl)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (INOUT) :: ssq, scl
        END SUBROUTINE sumsq_c
      END INTERFACE
    END MODULE blas_dense_red_op