!>------------------------------------------------
!! Perform a basic quantile mapping from one variable to another
!!
!! Develop or apply quantile mapping.
!!
!!  @author
!!  Ethan Gutmann (gutmann@ucar.edu)
!!
!!------------------------------------------------
module quantile_mapping
    use sort_mod, only : sort
    use data_structures

    implicit none
    private
    public :: develop_qm
    public :: apply_qm
    public :: reverse_qm

    integer, parameter :: DEFAULT_QM_SEGMENTS = 100
    integer, parameter :: EXTREME_WINDOW      = 5
    real,    parameter :: SMALL_VALUE         = 1e-10

contains

    subroutine develop_qm(input_data, data_to_match, qm, n_segments)
        implicit none
        real, intent(in), dimension(:) :: input_data, data_to_match
        integer, intent(in), optional :: n_segments
        type(qm_correction_type), intent(out) :: qm

        integer :: ni, nm, nseg
        integer :: i, top, bottom
        real    :: input_i, input_step, match_i, match_step ! these are real to handle more bins than elements
        real    :: denominator
        real, dimension(:), allocatable :: input_data_sorted, data_to_match_sorted

        if ( present(n_segments) ) then
            nseg = n_segments
        else
            nseg = DEFAULT_QM_SEGMENTS
        end if

        ! setup the sorted input data to process
        ni = size(input_data)
        allocate(input_data_sorted(ni))
        call sort(input_data, input_data_sorted)

        ! setup the sorted matching data to process
        nm = size(data_to_match)
        allocate(data_to_match_sorted(nm))
        call sort(data_to_match, data_to_match_sorted)

        if (nseg<5) then
            ! write(*,*), "Quantile mapping with < 5 segments not recommended, using 5 segments. "
            nseg=5
        endif
        if ((nseg-1) > min(ni,nm)) then
            nseg = min(ni,nm)+1
            ! write(*,*) " WARNING: reducing number of QM segments:",nseg
        endif
        input_step = ni/real(nseg-1)
        match_step = nm/real(nseg-1)

        input_i = 1
        match_i = 1

        if (allocated(qm%start_idx)) then
            deallocate(qm%start_idx,qm%end_idx,qm%slope,qm%offset)
        endif
        allocate(qm%start_idx(nseg))
        allocate(qm%end_idx(nseg))
        allocate(qm%slope(nseg))
        allocate(qm%offset(nseg))

        ! first handle the bottom of the QM segment
        bottom = 1
        top = max(1, min(EXTREME_WINDOW, int(input_step/4)))
        qm%start_idx(1) = sum(input_data_sorted( bottom:top )) / (top - bottom + 1)

        bottom = top
        top = 1 + input_step
        qm%end_idx(1)   = sum(input_data_sorted( bottom:top )) / (top - bottom + 1)

        bottom = 1
        top = max(1, min(EXTREME_WINDOW, int(match_step/4)) )
        qm%offset(1)    = sum(data_to_match_sorted( bottom:top )) / (top - bottom + 1)
        denominator     = qm%end_idx(1) - qm%start_idx(1)
        if (denominator < SMALL_VALUE) then
            qm%slope(1) = 0
            qm%offset(2) = qm%offset(1)
        else
            bottom = top
            top = 1 + match_step
            qm%offset(2) = sum(data_to_match_sorted( bottom:top ))/ (top - bottom + 1)
            qm%slope(1)  = ( qm%offset(2) - qm%offset(1)) &
                           / denominator
        endif

        input_i = input_step
        match_i = match_step
        do i=2,nseg-1
            qm%start_idx(i) = qm%end_idx(i-1)
            bottom          = max(int(input_i),1)
            top             = int(input_i + input_step)
            qm%end_idx(i)   = sum(input_data_sorted( bottom:top )) / (top - bottom + 1)

            denominator     = qm%end_idx(i) - qm%start_idx(i)
            if (denominator < SMALL_VALUE) then
                qm%offset(i+1) = qm%offset(i)
                qm%slope(i)    = 0
            else
                bottom          = max(int(match_i),1)
                top             = int(match_i + match_step)
                qm%offset(i+1)  = sum(data_to_match_sorted( bottom:top ))/ (top - bottom + 1)

                qm%slope(i) = (qm%offset(i+1) - qm%offset(i)) &
                             / denominator
            endif

            input_i = input_i + input_step
            match_i = match_i + match_step

        end do

        ! For the last segment, just fit to an average over the top 2-5 values so we can get a more extreme fit
        ! that isn't dependant just on the absolute highest value.
        i = nseg
        qm%start_idx(i) = qm%end_idx(i-1)
        bottom          = min(max(int(input_i - input_step/4), ni - EXTREME_WINDOW), ni-1)
        top             = ni

        qm%end_idx(i)   = sum(input_data_sorted( bottom:top )) / (top - bottom + 1)

        bottom          = min(max(int(match_i - match_step/4), nm - EXTREME_WINDOW), nm-1)
        top             = nm
        input_i         = sum(data_to_match_sorted( bottom:top ))/ (top - bottom + 1)
        denominator     = max(SMALL_VALUE, qm%end_idx(i) - qm%start_idx(i))
        qm%slope(i)     = (input_i - qm%offset(i)) &
                         / denominator
        qm%end_idx(i)   = input_data_sorted( ni )

    end subroutine develop_qm

    ! reverse the quantile map for a given input value
    function qm_value_reverse(input, qm) result(output)
        implicit none
        real, intent(in) :: input
        type(qm_correction_type), intent(in) :: qm

        real :: output
        integer :: i, n, step
        logical :: found

        found=.False.
        n = size(qm%start_idx)
        i = n/2
        step = n/4+1

        ! search for the first point in offset with start > input
        ! Uses a log(n) binary search because we "know" the qm data are sorted.
        do while (.not.found)
            i = max(1,min(n,i))
            if (qm%offset(i) > input) then
                if (qm%offset(max(1,i-1)) <= input) then
                    found=.True.
                else if (i==1) then
                    found=.True.
                else
                    i = i-step
                    step = ceiling(step/2.0)
                endif
            else if (i==n) then
                found=.True.
            else
                i = i+step
                step = ceiling(step/2.0)
            endif
        end do
        if (i>1) then
            if (qm%offset(i) > input) then
                i=i-1
            endif

        endif

        if (i==n) then
            output = qm%end_idx(i)
        elseif (qm%slope(i) /= 0) then
            output = (input - qm%offset(i)) / qm%slope(i) + qm%start_idx(i)
        else
            output = qm%start_idx(i)
        endif

    end function qm_value_reverse

    ! apply a quantile mapping scheme to a given input value
    function qm_value(input, qm) result(output)
        implicit none
        real, intent(in) :: input
        type(qm_correction_type), intent(in) :: qm

        real :: output
        integer :: i, n, step
        logical :: found

        found=.False.
        n = size(qm%start_idx)
        i = n/2
        step = n/4+1

        ! search for the first point in start_idx with start > input
        ! Uses a log(n) binary search because we "know" the qm data are sorted.
        do while (.not.found)
            i = max(1,min(n,i))
            if (qm%start_idx(i) > input) then
                if (qm%start_idx(max(1,i-1)) <= input) then
                    found=.True.
                else if (i==1) then
                    found=.True.
                else
                    i = i-step
                    step = ceiling(step/2.0)
                endif
            else if (i==n) then
                found=.True.
            else
                i = i+step
                step = ceiling(step/2.0)
            endif
        end do
        if (i>1) then
            if (qm%start_idx(i) > input) then
                i=i-1
            endif
        endif

        output = qm%offset(i) + qm%slope(i) * (input - qm%start_idx(i))

    end function qm_value

    !>----------------------------------------------
    !! Apply a previously developed quantile mapping to input and store the results in output
    !!
    !!----------------------------------------------
    subroutine apply_qm(input, output, qm)
        implicit none
        real, intent(in),  dimension(:) :: input
        real, intent(out), dimension(:) :: output
        type(qm_correction_type), intent(in) :: qm

        integer :: i, n

        n = size(input)
        !$omp parallel default(shared) &
        !$omp firstprivate(i,n)
        !$omp do
        do i = 1, n
            output(i) = qm_value(input(i), qm)
        end do
        !$omp end do
        !$omp end parallel

    end subroutine apply_qm

    !>----------------------------------------------
    !! Reverse a previously applied quantile mapping
    !!
    !!----------------------------------------------
    subroutine reverse_qm(input, qm)
        implicit none
        real, intent(inout),  dimension(:) :: input
        type(qm_correction_type), intent(in) :: qm

        integer :: i, n

        n = size(input)
        !$omp parallel default(shared) &
        !$omp firstprivate(i,n)
        !$omp do
        do i = 1, n
            input(i) = qm_value_reverse(input(i), qm)
        end do
        !$omp end do
        !$omp end parallel

    end subroutine reverse_qm

end module quantile_mapping


!     bar pressure and derivative
subroutine r_sbpress(dxmj,ddxmj,xmj)
  use r_common
  use solid_variables, only: nsd_solid

  implicit none

  real(8) :: xmj(3),dxmj(3,2*nsd_solid)
  real(8) :: ddxmj(3,2*nsd_solid,2*nsd_solid)

  integer :: i,j

  bpre=-rk*(xmj(3)-1.0d0)
  do i=1,2*nsd_solid
     dbpre(i)=-rk*dxmj(3,i)
     do j=1,2*nsd_solid
        ddbpre(i,j)=-rk*ddxmj(3,i,j)
     enddo
  enddo

  return
end subroutine r_sbpress


MODULE m_kkintgr

   !------------------------------------------------------------------------------
   !
   ! MODULE: m_kkintgr
   !
   !> @author
   !> Henning Janßen
   !
   ! DESCRIPTION:
   !>  Performs the Kramer-Kronig-Transformation to obtain the Green's function
   !>  in the complex plane from the imaginary part calculated on the real axis
   !
   ! TODO: Look at FFT for Transformation
   !       How to do changing imaginary parts
   !------------------------------------------------------------------------------
   USE m_constants
   USE m_juDFT

   IMPLICIT NONE

   INTEGER, PARAMETER :: method_maclaurin = 1
   INTEGER, PARAMETER :: method_deriv     = 2
   INTEGER, PARAMETER :: method_direct    = 3
   INTEGER, PARAMETER :: method_fft       = 4

   CHARACTER(len=10), PARAMETER :: smooth_method = 'lorentzian' !(lorentzian or gaussian)

   CONTAINS

   SUBROUTINE kkintgr(im,eMesh,ez,l_conjg,g,method)

      !calculates the Kramer Kronig Transformation on the same contour where the imaginary part was calculated
      !Re(G(E+i * delta)) = -1/pi * int_bot^top dE' P(1/(E-E')) * Im(G(E'+i*delta))

      !The dominant source of error for this routine is a insufficiently dense energy mesh on the real axis
      !TODO: Some way to estimate the error (maybe search for the sharpest peak and estimate from width)
      USE m_smooth
      USE m_lorentzian_smooth

      REAL,          INTENT(IN)     :: im(:)       !Imaginary part of the green's function on the real axis
      REAL,          INTENT(IN)     :: eMesh(:)    !Energy grid on the real axis
      COMPLEX,       INTENT(IN)     :: ez(:)       !Complex energy contour
      LOGICAL,       INTENT(IN)     :: l_conjg     !Switch determines wether we calculate g on the complex conjugate of the contour ez
      COMPLEX,       INTENT(INOUT)  :: g(:)        !Green's function on the complex plane
      INTEGER,       INTENT(IN)     :: method      !Integer associated with the method to be used (definitions above)

      INTEGER  :: iz,izp,n1,n2,ne,nz
      INTEGER  :: ismooth,nsmooth
      REAL     :: eb,del
      REAL     :: re_n1,re_n2,im_n1,im_n2
      INTEGER, ALLOCATABLE :: smoothInd(:)
      REAL, ALLOCATABLE    :: sigma(:)
      REAL, ALLOCATABLE    :: smoothed(:,:)

      nz  = SIZE(ez)
      ne  = SIZE(eMesh)
      eb  = eMesh(1)
      del = eMesh(2) - eMesh(1)

      ALLOCATE(smoothInd(nz),source=0)
      ALLOCATE(sigma(nz),source=0.0)

      IF(method.NE.method_direct) THEN
         CALL timestart("kkintgr: smoothing")
         !Smooth the imaginary part beforehand
         !Determine how many unique values there are for the imaginary part
         nsmooth = 0
         outer: DO iz = 1, nz
            DO izp = 1, iz-1
               IF(ABS(AIMAG(ez(izp))-AIMAG(ez(iz))).LT.1e-12) THEN
                  smoothInd(iz) = smoothInd(izp)
                  CYCLE outer
               ENDIF
            ENDDO
            nsmooth = nsmooth + 1
            smoothInd(iz) = nsmooth
            sigma(nsmooth) = AIMAG(ez(iz))
         ENDDO outer
         ALLOCATE(smoothed(ne,nsmooth), source=0.0)
         !$OMP parallel do default(none) &
         !$OMP shared(nsmooth,smoothed,sigma,ne,eMesh,im) &
         !$OMP private(ismooth)
         DO ismooth = 1, nsmooth
            smoothed(:,ismooth) = im(:ne)
            IF(ABS(sigma(ismooth)).LT.1e-12) CYCLE
            SELECT CASE (TRIM(ADJUSTL(smooth_method)))
            CASE('lorentzian')
               CALL lorentzian_smooth(eMesh,smoothed(:,ismooth),sigma(ismooth),ne)
            CASE('gaussian')
               CALL smooth(eMesh,smoothed(:,ismooth),sigma(ismooth),ne)
            CASE DEFAULT
               CALL juDFT_error("No valid smooth_method set",&
                                hint="This is a bug in FLEUR, please report",&
                                calledby="kkintgr")
            END SELECT
         ENDDO
         !$OMP end parallel do
         CALL timestop("kkintgr: smoothing")
      ENDIF

      CALL timestart("kkintgr: integration")
      !$OMP parallel do default(none) &
      !$OMP shared(nz,ne,method,del,eb,l_conjg) &
      !$OMP shared(g,ez,eMesh,im,smoothed,smoothInd) &
      !$OMP private(iz,n1,n2,re_n1,re_n2,im_n1,im_n2)
      DO iz = 1, nz
         SELECT CASE(method)

         CASE(method_direct)
            g(iz) = kk_direct(im,eMesh,MERGE(conjg(ez(iz)),ez(iz),l_conjg))
         CASE(method_maclaurin, method_deriv)
            !Use the previously smoothed version and interpolate after
            !Next point to the left
            n1 = INT((REAL(ez(iz))-eb)/del) +1
            !next point to the right
            n2 = n1 + 1
            !Here we perform the Kramers-kronig-Integration
            re_n2 = kk_num(smoothed(:,smoothInd(iz)),ne,n2,method)
            re_n1 = kk_num(smoothed(:,smoothInd(iz)),ne,n1,method)
            !Interpolate to the energy ez(iz)
            !Real Part
            g(iz) = (re_n2-re_n1)/del * (REAL(ez(iz))-(n1-1)*del-eb) + re_n1

            !Imaginary Part (0 outside of the energy range)
            IF(n1.LE.ne.AND.n1.GE.1) THEN
               im_n1 = smoothed(n1,smoothInd(iz))
            ELSE
               im_n1 = 0.0
            ENDIF
            IF(n2.LE.ne.AND.n2.GE.1) THEN
               im_n2 = smoothed(n2,smoothInd(iz))
            ELSE
               im_n2 = 0.0
            ENDIF

            g(iz) = g(iz) + ImagUnit *( (im_n2-im_n1)/del * (REAL(ez(iz))-(n1-1)*del-eb) + im_n1 )

            IF(l_conjg) g(iz) = conjg(g(iz))

         CASE(method_fft)
            CALL juDFT_error("Not implemented yet", calledby="kkintgr")
         CASE DEFAULT
            CALL juDFT_error("Not a valid integration method", calledby="kkintgr")
         END SELECT
      ENDDO
      !$OMP end parallel do
      CALL timestop("kkintgr: integration")

   END SUBROUTINE kkintgr

   PURE COMPLEX FUNCTION kk_direct(im,eMesh,z)

      USE m_trapz

      REAL,    INTENT(IN) :: im(:)
      REAL,    INTENT(IN) :: eMesh(:)
      COMPLEX, INTENT(IN) :: z

      COMPLEX :: integrand(SIZE(eMesh))

      integrand = 1.0/(z-eMesh) * im
      kk_direct = -1/pi_const *trapz(integrand,eMesh(2)-eMesh(1),SIZE(eMesh))
   END FUNCTION kk_direct

   PURE REAL FUNCTION kk_num(im,ne,ire,method)

      REAL,    INTENT(IN)  :: im(:) !Imaginary part
      INTEGER, INTENT(IN)  :: ne     !Dimension of the energy grid
      INTEGER, INTENT(IN)  :: ire    !Position where to calculate the real part
      INTEGER, INTENT(IN)  :: method !Method to be used
      INTEGER i,j
      REAL    y,im_ire

      kk_num = 0.0
      IF(ire.LE.ne.AND.ire.GE.1) THEN
         im_ire = im(ire)
      ELSE
         im_ire = 0.0
      ENDIF

      SELECT CASE(method)

      CASE (method_maclaurin)
         !Calculate the real part on the same energy points as the imaginary part
         !regardless of the contour
         !If i is odd skip the odd points and the other way around and use the trapezian method
         DO i = MERGE(1,2,MOD(ire,2)==0), ne, 2
            y = - 1/pi_const * 2.0 * im(i)/REAL(ire-i)
            IF(i.EQ.1 .OR. i.EQ.2 .OR.&
               i.EQ.ne .OR. i.EQ.ne-1) y = y/2.0
            kk_num = kk_num + y
         ENDDO

      CASE (method_deriv)
         !Remove the singularity and treat it analytically
         DO j = 1, ne
            IF(j-ire.NE.0) THEN
               y = -1/pi_const * (im(j)-im_ire)/REAL(ire-j)
            ELSE
               IF(ire.EQ.1) THEN
                  y = -1/pi_const * (im(2)-im(1))
               ELSE IF(ire.EQ.ne) THEN
                  y = -1/pi_const * (im(ne)-im(ne-1))
               ELSE IF((ire.LT.ne).AND.(ire.GT.1)) THEN
                  y = -1/pi_const * (im(ire+1)-im(ire-1))/2.0
               ENDIF
            ENDIF
            IF(j.EQ.1 .OR. j.EQ.ne) y = y/2.0
            kk_num = kk_num + y
         ENDDO
      CASE default
      END SELECT

   END FUNCTION kk_num

END MODULE m_kkintgr


C/*   22 JULY 80   ...GMY...    INITIAL RELEASE */
c     Sept. 1992   ...WPL... Ported for UNIX Conversion
c
      SUBROUTINE MOMATI(OAL,OAS,SSL,SSS,SCALE,FL,SCLO,SCLA,ANGN,RANGE,
     &A,RS)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 A(3,3),RS(3)
c
C THIS ROUTINE COMPUTES THE PLANET TO CAMERA ROTATION MATRIX (A) AND THE
C VECTOR FROM PLANET CENTER TO SPACECRAFT (RS), EXPRESSED IN THE PLANET
C SYSTEM. A VECTOR V IN THE PLANET SYSTEM IS THEN RELATED TO THE SAME
C VECTOR VP IN THE CAMERA SYSTEM by
c
C          VP = A*V + RS   ,   Note  A is a 3x3  Matrix
c
C REQUIRED NAVIGATION INFORMATION ...
C  OAL,OAS=LINE,SAMPLE LOCATION OF OPTIC AXIS
C  SSL,SSS=LINE,SAMPLE LOCATION OF PLANET CENTER
C  SCLA=PLANETOCENTRIC LATITUDE OF S/C (DEG)
C  SCLO=WEST LONGITUDE OF S/C
C  ANGN=NORTH ANGLE AT OPTIC AXIS INTERCEPT POINT
C  RANGE=RANGE FROM S/C TO PLANET CENTER
C  SCALE=SCALE IN PIXELS/MM
C  FL=FOCAL LENGTH IN MM
C
      PI = 3.141592653589D0
      RAD = PI/180.D0
      CLA = DCOS(SCLA*RAD)
      SLA = DSIN(SCLA*RAD)
      CLON = DCOS(SCLO*RAD)
      SLON = DSIN(SCLO*RAD)
C
C          THIS SECTION COMPUTES ROTATIONS A AND B
C          FIRST COMPUT RS VECTOR IN CAMERA SYSTEM
c
      X = SSS - OAS
      Y = SSL - OAL
      Z = FL*SCALE
      D = DSQRT(X*X+Y*Y+Z*Z)
c
C          CHECK FOR SPECIAL CASES
c
      ICASE = 0
c
C          INITIALLY, NA=0, A=90, B=0 (CASE 1)
c
      CNA = 1.D0
      SNA = 0.D0
      CRA = 0.D0
      SRA = 1.D0
      IF(SCLA.LT.0.D0) SRA=-1.D0
      CRB = 1.D0
      SRB = 0.D0
      D1 = DSQRT(X*X+Y*Y)
      IF(DABS(SCLA).NE.90.D0) GOTO 3
      IF(D1.EQ.0.D0) GOTO 5
C
C          CASE 2  SCLA=90, (OAL,OAS).NE.(SSL,SSS)
c
      ICASE = 2
      CLON = -CLON
      SLON = -SLON
      CNA = Y/D1
      SNA = -X/D1
      IF(SCLA.GT.0.) GOTO 10
      CNA = -CNA
      SNA = -SNA
      GOTO 10
C
C
3     IF(ANGN.NE.-999.) GOTO 6
      IF(D1.EQ.0.D0) GOTO 5
c
C          CASE 3  SPIN AXIS PARALLEL TO OPTIC AXIS
c
      CNA = Y/D1
      SNA = -X/D1
      IF(SCLA.LT.0.) GOTO 4
      CNA = -CNA
      SNA = -SNA
4     CLA = DABS((-X*SNA+Y*CNA)/D)
      SLA = Z/D
      IF(SCLA.LT.0.) SLA=-SLA
      GOTO 15
C
C          CASE 1  SCLA=90, (OAL,OAS)=(SSL,SSS)
5     CLA = 0.D0
      SLA = -1.D0
      IF(SCLA.LT.0.) GOTO 15
      SLA = 1.D0
      CLON = -CLON
      SLON = -SLON
      GOTO 15
C
C          NORMAL CASE
c
6     CNA = DCOS(ANGN*RAD)
      SNA = DSIN(ANGN*RAD)
C          ROTATE ABOUT Z-AXIS SO THAT NORTH IS UP IN IMAGE
10    CX = (X*CNA + Y*SNA)/D
      CY = (-X*SNA+ Y*CNA)/D
      CZ = Z/D
c
C          ROTATE ABOUT X-AXIS SO THAT -Y AXIS IS PARALLEL TO SPIN AXIS.
c
      D = CY*CY + CZ*CZ
      G = D - SLA*SLA
      IF(G.LT.0.) G=0.
      G = DSQRT(G)
      CRA = (CY*SLA+CZ*G)/D
      SRA = (CZ*SLA-CY*G)/D
      IF(ICASE.NE.0) GOTO 15
      CZ = CZ*CRA - CY*SRA
      D = DSQRT(CX*CX+CZ*CZ)
      CRB = CZ/D
      SRB = CX/D
C
C          THIS SECTION COMPUTES RESULTANT ROTATION MATRIX
C          A MATRIX IS INITIALLY NORTH ANGLE ROTATION ABOUT Z-AXIS
c
C     changed by Roatsch, March 2000, was
c15    CALL ZIA(A,18)
15    Continue
      A(1,3) = 0.d0
      A(2,3) = 0.d0
      A(3,1) = 0.d0
      A(3,2) = 0.d0

c     continues original code
      A(1,1) = CNA
      A(2,1) = SNA
      A(1,2) = -SNA
      A(2,2) = CNA
      A(3,3) = 1.D0
c
C          ROTATE ABOUT X-AXIS SO THAT -Y AXIS IS PARALLEL TO SPIN AXIS.
C          A = M1*A
      DO 20 I=1,3
      A2 = CRA*A(I,2) + SRA*A(I,3)
      A(I,3) = -SRA*A(I,2) + CRA*A(I,3)
20    A(I,2) = A2

c
C          ROTATE ABOUT Y-AXIS SO THAT PLANET CENTER LIES IN Y-Z PLANE.
C          A = M2*A
c
      DO 30 I=1,3
      A1 = CRB*A(I,1) - SRB*A(I,3)
      A(I,3) = SRB*A(I,1) + CRB*A(I,3)
30    A(I,1) = A1
C          INTERCHANGE COORDINATES SO THAT
C              XP = -Z, YP=X, ZP=-Y
      DO 40 I=1,3
      A1 = A(I,1)
      A2 = A(I,2)
      A(I,1) = -A(I,3)
      A(I,2) = A1
40    A(I,3) = -A2
c
C          ROTATE ABOUT Z-AXIS SO THAT X-AXIS POINTS TO LON 0, LAT 0.
C          A = M3*A
c
      DO 50 I=1,3
      A1 = CLON*A(I,1) + SLON*A(I,2)
      A(I,2) = -SLON*A(I,1) + CLON*A(I,2)
50    A(I,1) = A1
C
C          COMPUTE VECTOR FROM PLANET CENTER TO S/C, IN PLANET SYSTEM.
c
      RS(1) = RANGE*CLA*CLON
      RS(2) = -RANGE*CLA*SLON
      RS(3) = RANGE*SLA
c
      RETURN
      END


      double precision function svan(s,t,p0,sigma)
c
c  modified rcm
c ******************************************************
c specific volume anomaly (steric anomaly) based on 1980 equation
c of state for seawater and 1978 practical salinity scale.
c references
c millero, et al (1980) deep-sea res.,27a,255-264
c millero and poisson 1981,deep-sea res.,28a pp 625-629.
c both above references are also found in unesco report 38 (1981)
c units:
c       pressure        p0       decibars
c       temperature     t        deg celsius (ipts-68)
c       salinity        s        (ipss-78)
c       spec. vol. ana. svan     m**3/kg *1.0e-8
c       density ana.    sigma    kg/m**3
c ******************************************************************
c check value: svan=981.3021 e-8 m**3/kg.  for s = 40 (ipss-78) ,
c t = 40 deg c, p0= 10000 decibars.
c check value: sigma = 59.82037  kg/m**3 for s = 40 (ipss-78) ,
c t = 40 deg c, p0= 10000 decibars.
c *******************************************************
c
      implicit double precision (a-h,o-z)
      double precision k,k0,kw,k35
c      real p,t,s,sig,sr,r1,r2,r3,r4
c      real a,b,c,d,e,a1,b1,aw,bw,k,k0,kw,k35
c      real svan,p0,sigma,r3500,dr350,v350p,sva,dk,gam,pk,dr35p
c      real dvan
c equiv
      equivalence (e,d,b1),(bw,b,r3),(c,a1,r2)
      equivalence (aw,a,r1),(kw,k0,k)
c ********************
c data
      data r3500,r4/1028.1063,4.8314d-4/
      data dr350/28.106331/
c   r4 is refered to as  c  in millero and poisson 1981
c convert pressure to bars and take square root salinity.
      p=p0/10.
      sr = sqrt(abs(s))
c *********************************************************
c pure water density at atmospheric pressure
c   bigg p.h.,(1967) br. j. applied physics 8 pp 521-537.
c
      r1 = ((((6.536332d-9*t-1.120083d-6)*t+1.001685d-4)*t
     x-9.095290d-3)*t+6.793952d-2)*t-28.263737
c seawater density atm press.
c  coefficients involving salinity
c  r2 = a   in notation of millero and poisson 1981
      r2 = (((5.3875d-9*t-8.2467d-7)*t+7.6438d-5)*t-4.0899d-3)*t
     x+8.24493d-1
c  r3 = b  in notation of millero and poisson 1981
      r3 = (-1.6546d-6*t+1.0227d-4)*t-5.72466d-3
c  international one-atmosphere equation of state of seawater
      sig = (r4*s + r3*sr + r2)*s + r1
c specific volume at atmospheric pressure
      v350p = 1.0/r3500
      sva = -sig*v350p/(r3500+sig)
      sigma=sig+dr350
c  scale specific vol. anamoly to normally reported units
      svan=sva*1.0d+8
      if(p.eq.0.0) return
c ******************************************************************
c ******  new high pressure equation of state for seawater ********
c ******************************************************************
c        millero, et al , 1980 dsr 27a, pp 255-264
c               constant notation follows article
c********************************************************
c compute compression terms
      e = (9.1697d-10*t+2.0816d-8)*t-9.9348d-7
      bw = (5.2787d-8*t-6.12293d-6)*t+3.47718d-5
      b = bw + e*s
c
      d = 1.91075d-4
      c = (-1.6078d-6*t-1.0981d-5)*t+2.2838d-3
      aw = ((-5.77905d-7*t+1.16092d-4)*t+1.43713d-3)*t
     x-0.1194975
      a = (d*sr + c)*s + aw
c
      b1 = (-5.3009d-4*t+1.6483d-2)*t+7.944d-2
      a1 = ((-6.1670d-5*t+1.09987d-2)*t-0.603459)*t+54.6746
      kw = (((-5.155288d-5*t+1.360477d-2)*t-2.327105)*t
     x+148.4206)*t-1930.06
      k0 = (b1*sr + a1)*s + kw
c evaluate pressure polynomial
c ***********************************************
c   k equals the secant bulk modulus of seawater
c   dk=k(s,t,p)-k(35,0,p)
c  k35=k(35,0,p)
c ***********************************************
      dk = (b*p + a)*p + k0
      k35  = (5.03217d-5*p+3.359406)*p+21582.27
      gam=p/k35
      pk = 1.0 - gam
      sva = sva*pk + (v350p+sva)*p*dk/(k35*(k35+dk))
c  scale specific vol. anamoly to normally reported units
      svan=sva*1.0d+8
      v350p = v350p*pk
c  ****************************************************
c compute density anamoly with respect to 1000.0 kg/m**3
c  1) dr350: density anamoly at 35 (ipss-78), 0 deg. c and 0 decibars
c  2) dr35p: density anamoly 35 (ipss-78), 0 deg. c ,  pres. variation
c  3) dvan : density anamoly variations involving specfic vol. anamoly
c ********************************************************************
c check value: sigma = 59.82037  kg/m**3 for s = 40 (ipss-78),
c t = 40 deg c, p0= 10000 decibars.
c *******************************************************
      dr35p=gam/v350p
      dvan=sva/(v350p*(v350p+sva))
      sigma=dr350+dr35p-dvan
      return
      end


      SUBROUTINE build_matrices_legendre(n, a, b, a_inv, b_inv)
      USE stel_kinds
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: n
      REAL(rprec), INTENT(OUT), DIMENSION(0:n,0:n) :: a, b,
     1  a_inv, b_inv
      INTEGER :: idx, i, j
      REAL(rprec) :: factorial
      REAL(rprec), DIMENSION(13), PARAMETER :: norm_legEND =
     1    ( / 1, 1, 3, 5, 35, 63, 231, 429, 6435,
     2        12155, 46189, 88179, 676039 / )
      REAL(rprec), DIMENSION(13), PARAMETER ::  norm_inv_legEND =
     1    ( / 1, 1, 2, 2, 8, 8, 16, 16, 128,
     2        128, 256, 256, 1024 / )
      REAL(rprec), DIMENSION(13*13), PARAMETER :: b_legEND =
     1  ( / 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     2  0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     3  1, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     4  0, 3, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     5  7, 0, 20, 0, 8, 0, 0, 0, 0, 0, 0, 0, 0,
     6  0, 27, 0, 28, 0, 8, 0, 0, 0, 0, 0, 0, 0,
     7  33, 0, 110, 0, 72, 0, 16, 0, 0, 0, 0, 0, 0,
     8  0, 143, 0, 182, 0, 88, 0, 16, 0, 0, 0, 0, 0,
     9  715, 0, 2600, 0, 2160, 0, 832, 0, 128, 0, 0, 0, 0,
     A  0, 3315, 0, 4760, 0, 2992, 0, 960, 0, 128, 0, 0, 0,
     B  4199, 0, 16150, 0, 15504, 0, 7904, 0, 2176, 0,
     C  256, 0, 0,
     D  0, 20349, 0, 31654, 0, 23408, 0, 10080, 0, 2432,
     E  0, 256, 0,
     F  52003, 0, 208012, 0, 220248, 0, 133952, 0, 50048,
     G  0, 10752, 0, 1024 / )
      REAL(rprec), DIMENSION(13*13), PARAMETER :: b_legend_inv =
     1  ( / 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     2  0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     3  -1, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     4  0, -3, 0, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     5  3, 0, -30, 0, 35, 0, 0, 0, 0, 0, 0, 0, 0,
     6  0, 15, 0, -70, 0, 63, 0, 0, 0, 0, 0, 0, 0,
     7  -5, 0, 105, 0, -315, 0, 231, 0, 0, 0, 0, 0, 0,
     8  0, -35, 0, 315, 0, -693, 0, 429, 0, 0, 0, 0, 0,
     9  35, 0, -1260, 0, 6930, 0, -12012, 0, 6435, 0, 0,
     A  0, 0,
     B  0, 315, 0, -4620, 0, 18018, 0, -25740, 0, 12155,
     C  0, 0, 0,
     D  -63, 0, 3465, 0, -30030, 0, 90090, 0, -109395, 0,
     E  46189, 0, 0,
     F  0, -693, 0, 15015, 0, -90090, 0, 218790, 0, -230945,
     G  0, 88179, 0,
     H  231, 0, -18018, 0, 225225, 0, -1021020, 0, 2078505,
     I  0, -1939938, 0, 676039 / )

!--------------------------------------------------------------------------------------------------
!      P_n(y):: LEGENDRE polynomial in [-1,1]. Matrix coefficients from
!      "Handbook of Mathematical Functions", Abramowitz and Stegun, 1973, p.795.
!      If higher degree polyn. needed, THEN data set must be extended.
!
!      DESCRIPTION OF MATRICES:
!
!      A, A_inv: convert Legendre Pol. to and from y-powers in [-1,1]
!
!              norm_legend(m)*y**m = sum_n=0^m (b_legend{mn} L_n)
!              norm_legend_inv(m)*L_m = sum_n=0^N (b_legend_inv{mn} y**n)
!
!           ==>   A_{mn} = b_legend_{mn}/norm_legend(m)                IF  m<=n  or  0. otherwise
!           ==>   A_inv_{mn} = b_legend_inv_{mn}/norm_inv_legend(m)    IF  m<=n  or  0. otherwise
!
!      B, B_inv: convert y-powers in [-1,1] to and from x-powers in [0,1]
!
!             x = (y + 1)/2;   x**m =  sum_n=0^m  2**(-m) m!/(n!(m-n)!)  y**n
!             y = 2*x - 1;     y**m =  sum_n=0^m  2**n (-1)**(m-n) m!/(n!(m-n)!)  x**n
!
!           ==>   B_{mn} =  2**(-m) m!/(n!(m-n)!)                     IF  m<=n  or  0. otherwise
!           ==>   B_inv_{mn} =  2**n (-1)**(m-n) m!/(n!(m-n)!)        IF  m<=n  or  0. otherwise
!
!
!      NOTICE that:   A_inv = (A)**(-1);  B_inv = (B)**(-1)
!--------------------------------------------------------------------------------------------------

      IF (n > 12) STOP 'N(Legendre) CANNOT be larger than 12!!!'

      a = 0
      a_inv = 0
      b = 0
      b_inv = 0

       DO i = 0, n
         idx = 13*i
         DO j = 0, i
           a(i,j) = b_legend(idx+j+1)/norm_legend(i+1)
           a_inv(i,j) = b_legend_inv(idx+j+1)/norm_inv_legend(i+1)
           b(i,j) = 2._dp**(-i) * factorial(i)/
     1       (factorial(j)*factorial(i-j))
           b_inv(i,j) = 2._dp**j*(-1._dp)**(i-j)* factorial(i)/
     1       (factorial(j)*factorial(i-j))
         END DO
       END DO

      END SUBROUTINE build_matrices_legendre


      SUBROUTINE INTEGRATE( TIN, TOUT )

      USE KPP_ROOT_global

! TIN - Start Time
      KPP_REAL TIN
! TOUT - End Time
      KPP_REAL TOUT

      INTEGER    INFO(5)

      EXTERNAL FUNC_CHEM, JAC_CHEM

      INFO(1) = Autonomous

      call ROS2(NVAR,TIN,TOUT,STEPMIN,STEPMAX,   &
            STEPMIN,VAR,ATOL,RTOL, &
            Info,FUNC_CHEM,JAC_CHEM)

      END SUBROUTINE INTEGRATE

      SUBROUTINE ROS2(N,T,Tnext,Hmin,Hmax,Hstart,  &
            y,AbsTol,RelTol,      &
            Info,FUNC_CHEM,JAC_CHEM)

      USE KPP_ROOT_params
      USE KPP_ROOT_Jacobian_sparsity
      IMPLICIT NONE

!  INPUT ARGUMENTS:
!     y = Vector of (NVAR) concentrations, contains the
!     initial values on input
!     [T, Tnext] = the integration interval
!     Hmin, Hmax = lower and upper bounds for the selected step-size.
!      Note that for Step = Hmin the current computed
!      solution is unconditionally accepted by the error
!      control mechanism.
!     AbsTol, RelTol = (NVAR) dimensional vectors of
!      componentwise absolute and relative tolerances.
!     FUNC_CHEM = name of routine of derivatives. KPP syntax.
!      See the header below.
!     JAC_CHEM = name of routine that computes the Jacobian, in
!      sparse format. KPP syntax. See the header below.
!     Info(1) = 1  for  autonomous   system
!         = 0  for nonautonomous system
!     Info(2) = 1  for third order embedded formula
!         = 0  for first order embedded formula
!
!   Note: Stage 3 used to build strongly A-stable order 3 formula for error control
!        Embed3 = (Info(2).EQ.1)
!     if Embed3 = .true. then the third order embedded formula is used
!         .false. then a first order embedded  formula is used
!
!
!  OUTPUT ARGUMENTS:
!     y = the values of concentrations at Tend.
!     T = equals Tend on output.
!     Info(2) = # of FUNC_CHEM calls.
!     Info(3) = # of JAC_CHEM calls.
!     Info(4) = # of accepted steps.
!     Info(5) = # of rejected steps.

      KPP_REAL K1(NVAR), K2(NVAR), K3(NVAR)
      KPP_REAL F1(NVAR), JAC(LU_NONZERO)
      KPP_REAL DFDT(NVAR)
      KPP_REAL Hmin,Hmax,Hnew,Hstart,ghinv,uround
      KPP_REAL y(NVAR), ynew(NVAR)
      KPP_REAL AbsTol(NVAR), RelTol(NVAR)
      KPP_REAL T, Tnext, H, Hold, Tplus
      KPP_REAL ERR, factor, facmax
      KPP_REAL tau, beta, elo, dround, a21, c31, c32
      KPP_REAL gamma3, d1, d2, d3, gam
      INTEGER    n,nfcn,njac,Naccept,Nreject,i,j,ier
      INTEGER    Info(5)
      LOGICAL    IsReject, Autonomous, Embed3
      EXTERNAL    FUNC_CHEM, JAC_CHEM

      KPP_REAL gamma, m1, m2, alpha, beta1, beta2, delta, w, e

!     Initialization of counters, etc.
      Autonomous = Info(1) .EQ. 1
      Embed3  = Info(2) .EQ. 1
      uround  = 1.d-15
      dround  = dsqrt(uround)
      H = DMAX1(1.d-8, Hmin)
      Tplus = T
      IsReject = .false.
      Naccept  = 0
      Nreject  = 0
      Nfcn     = 0
      Njac     = 0

!     Method Parameters
      gamma = 1.d0 + 1.d0/sqrt(2.d0)
      a21   = - 1.d0/gamma
      m1 = -3.d0/(2.d0*gamma)
      m2 = -1.d0/(2.d0*gamma)
      c31 = -1.0D0/gamma**2*(1.0D0-7.0D0*gamma+9.0D0*gamma**2) &
      /(-1.0D0+2.0D0*gamma)
      c32 = -1.0D0/gamma**2*(1.0D0-6.0D0*gamma+6.0D0*gamma**2) &
       /(-1.0D0+2.0D0*gamma)/2
      gamma3 = 0.5D0 - 2*gamma
      d1 = ((-9.0D0*gamma+8.0D0*gamma**2+2.0D0)/gamma**2/      &
       (-1.0D0+2*gamma))/6.0D0
      d2 = ((-1.0D0+3.0D0*gamma)/gamma**2/(-1.0D0+2.0D0*gamma))/6.0D0
      d3 = -1.0D0/(3.0D0*gamma)

! === Starting the time loop ===
 10    CONTINUE
      Tplus = T + H
      if ( Tplus .gt. Tnext ) then
         H = Tnext - T
         Tplus = Tnext
      end if

      call JAC_CHEM(NVAR, T, y, JAC)

      Njac = Njac+1
      ghinv = -1.0d0/(gamma*H)
      DO j=1,NVAR
         JAC(LU_DIAG(j)) = JAC(LU_DIAG(j)) + ghinv
      END DO
      CALL KppDecomp (JAC, ier)

      if (ier.ne.0) then
        if ( H.gt.Hmin) then
          H = 5.0d-1*H
          go to 10
        else
          print *,'IER <> 0, H=',H
          stop
        end if
      end if

      call FUNC_CHEM(NVAR, T, y, F1)

! ====== NONAUTONOMOUS CASE ===============
   IF (.not. Autonomous) THEN
     tau = dsign(dround*dmax1( 1.0d-6, dabs(T) ), T)
     call FUNC_CHEM(NVAR, T+tau, y, K2)
     nfcn=nfcn+1
     DO j = 1,NVAR
       DFDT(j) = ( K2(j)-F1(j) )/tau
     END DO
   END IF ! .NOT.Autonomous

! ----- STAGE 1 -----
   DO j = 1,NVAR
      K1(j) =  F1(j)
   END DO
   IF (.NOT.Autonomous) THEN
     delta = gamma*H
     DO j = 1,NVAR
       K1(j) = K1(j) + delta*DFDT(j)
     END DO
   END IF ! .NOT.Autonomous
   call KppSolve (JAC, K1)

! ----- STAGE 2  -----
   DO j = 1,NVAR
     ynew(j) = y(j) + a21*K1(j)
   END DO
   call FUNC_CHEM(NVAR, T+H, ynew, F1)
   nfcn=nfcn+1
   beta = 2.d0/(gamma*H)
   DO j = 1,NVAR
     K2(j) = F1(j) + beta*K1(j)
   END DO
   IF (.NOT. Autonomous) THEN
     delta = -gamma*H
     DO j = 1,NVAR
       K2(j) = K2(j) + delta*DFDT(j)
     END DO
   END IF ! .NOT.Autonomous
   call KppSolve (JAC, K2)

! ----- STAGE 3  -----
   IF (Embed3) THEN
   beta1 = -c31/H
   beta2 = -c32/H
   delta = gamma3*H
   DO j = 1,NVAR
     K3(j) = F1(j) + beta1*K1(j) + beta2*K2(j)
   END DO
   IF (.NOT.Autonomous) THEN
     DO j = 1,NVAR
       K3(j) = K3(j) + delta*DFDT(j)
     END DO
   END IF ! .NOT.Autonomous
   CALL KppSolve (JAC, K3)
    END IF ! Embed3

! ---- The Solution ---
   DO j = 1,NVAR
     ynew(j) = y(j) + m1*K1(j) + m2*K2(j)
   END DO

! ====== Error estimation ========

    ERR=0.d0
    DO i=1,NVAR
       w = AbsTol(i) + RelTol(i)*DMAX1(DABS(y(i)),DABS(ynew(i)))
    IF ( Embed3 ) THEN
     e = d1*K1(i) + d2*K2(i) + d3*K3(i)
    ELSE
         e = 1.d0/(2.d0*gamma)*(K1(i)+K2(i))
    END IF  ! Embed3
       ERR = ERR + ( e/w )**2
    END DO
    ERR = DMAX1( uround, DSQRT( ERR/NVAR ) )

! ======= Choose the stepsize ===============================

    IF ( Embed3 ) THEN
        elo = 3.0D0 ! estimator local order
    ELSE
        elo = 2.0D0
    END IF
    factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0))
    Hnew   = DMIN1(Hmax,DMAX1(Hmin, H/factor))

! ======= Rejected/Accepted Step ============================

    IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN
      IsReject = .true.
      H = DMIN1(H/10,Hnew)
      Nreject  = Nreject+1
    ELSE
      DO i=1,NVAR
         y(i)  = ynew(i)
      END DO
      T = Tplus
      IF (.NOT. IsReject) THEN
          H = Hnew   ! Do not increase stepsize if previous step was rejected
      END IF
      IsReject = .false.
      Naccept = Naccept+1
    END IF

! ======= End of the time loop ===============================
      IF ( T .lt. Tnext ) GO TO 10

! ======= Output Information =================================
      Info(2) = Nfcn
      Info(3) = Njac
      Info(4) = Naccept
      Info(5) = Nreject

      END SUBROUTINE Ros2

      SUBROUTINE FUNC_CHEM(N, T, Y, P)
      USE KPP_ROOT_global
      INTEGER N
      KPP_REAL   T, Told
      KPP_REAL   Y(NVAR), P(NVAR)
      Told = TIME
      TIME = T
      CALL Update_SUN()
      CALL Update_RCONST()
      CALL Fun( Y, FIX, RCONST, P )
      TIME = Told
      END SUBROUTINE FUNC_CHEM

      SUBROUTINE JAC_CHEM(N, T, Y, J)
      USE KPP_ROOT_global
      INTEGER N
      KPP_REAL   Told, T
      KPP_REAL   Y(NVAR), J(LU_NONZERO)
      Told = TIME
      TIME = T
      CALL Update_SUN()
      CALL Update_RCONST()
      CALL Jac_SP( Y, FIX, RCONST, J )
      TIME = Told
      END SUBROUTINE JAC_CHEM


      SUBROUTINE ROM1 (N,SUM,NX)
C
C     ROM1 INTEGRATES THE 6 SOMMERFELD INTEGRALS FROM A TO B IN LAMBDA.
C     THE METHOD OF VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION IS USED.
C
      COMPLEX A,B,SUM,G1,G2,G3,G4,G5,T00,T01,T10,T02,T11,T20
      COMMON /CNTOUR/ A,B
      DIMENSION SUM(6), G1(6), G2(6), G3(6), G4(6), G5(6), T01(6), T10(6
     1), T20(6)
      DATA NM,NTS,RX/131072,4,1.E-4/
      LSTEP=0
      Z=0.
      ZE=1.
      S=1.
      EP=S/(1.E4*NM)
      ZEND=ZE-EP
      DO 1 I=1,N
1     SUM(I)=(0.,0.)
      NS=NX
      NT=0
      CALL SAOA (Z,G1)
2     DZ=S/NS
      IF (Z+DZ.LE.ZE) GO TO 3
      DZ=ZE-Z
      IF (DZ.LE.EP) GO TO 17
3     DZOT=DZ*.5
      CALL SAOA (Z+DZOT,G3)
      CALL SAOA (Z+DZ,G5)
4     NOGO=0
      DO 5 I=1,N
      T00=(G1(I)+G5(I))*DZOT
      T01(I)=(T00+DZ*G3(I))*.5
      T10(I)=(4.*T01(I)-T00)/3.
C     TEST CONVERGENCE OF 3 POINT ROMBERG RESULT
      CALL TEST (REAL(T01(I)),REAL(T10(I)),TR,AIMAG(T01(I)),AIMAG(T10
     1(I)),TI,0.)
      IF (TR.GT.RX.OR.TI.GT.RX) NOGO=1
5     CONTINUE
      IF (NOGO.NE.0) GO TO 7
      DO 6 I=1,N
6     SUM(I)=SUM(I)+T10(I)
      NT=NT+2
      GO TO 11
7     CALL SAOA (Z+DZ*.25,G2)
      CALL SAOA (Z+DZ*.75,G4)
      NOGO=0
      DO 8 I=1,N
      T02=(T01(I)+DZOT*(G2(I)+G4(I)))*.5
      T11=(4.*T02-T01(I))/3.
      T20(I)=(16.*T11-T10(I))/15.
C     TEST CONVERGENCE OF 5 POINT ROMBERG RESULT
      CALL TEST (REAL(T11),REAL(T20(I)),TR,AIMAG(T11),AIMAG(T20(I)),TI
     1,0.)
      IF (TR.GT.RX.OR.TI.GT.RX) NOGO=1
8     CONTINUE
      IF (NOGO.NE.0) GO TO 13
9     DO 10 I=1,N
10    SUM(I)=SUM(I)+T20(I)
      NT=NT+1
11    Z=Z+DZ
      IF (Z.GT.ZEND) GO TO 17
      DO 12 I=1,N
12    G1(I)=G5(I)
      IF (NT.LT.NTS.OR.NS.LE.NX) GO TO 2
      NS=NS/2
      NT=1
      GO TO 2
13    NT=0
      IF (NS.LT.NM) GO TO 15
      IF (LSTEP.EQ.1) GO TO 9
      LSTEP=1
      CALL LAMBDA (Z,T00,T11)
      PRINT 18, T00
      PRINT 19, Z,DZ,A,B
      DO 14 I=1,N
14    PRINT 19, G1(I),G2(I),G3(I),G4(I),G5(I)
      GO TO 9
15    NS=NS*2
      DZ=S/NS
      DZOT=DZ*.5
      DO 16 I=1,N
      G5(I)=G3(I)
16    G3(I)=G2(I)
      GO TO 4
17    CONTINUE
      RETURN
C
18    FORMAT (38H ROM1 -- STEP SIZE LIMITED AT LAMBDA =,2E12.5)
19    FORMAT (10E12.5)
      END


      subroutine impsample(model_flag)
!***********************************************************************
! Copyright 2006 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Assign weights for importance sampling based on position in
!D1 CDF curve.
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 Initial implementation: 27-Oct-06, Programmer: S. Kelkar
!D2
!D2 $Log:   /pvcs.config/fehm90/src/impsample.f_a  $
!D2
!***********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.3.6 Streamline particle-tracking module
!D3
!***********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!***********************************************************************
c Oct 25, 06 s kelkar
c Assuming retardation factors using the following importance
c sampling scheme - equally divide the range of the retardation factor
c into num_part intervals, and then assign the weight to the n-th
c particle as weight(n)=CDF(n)-CDF(n-1) that will be needed for
c calculating breakthrough curves

      use comdti
      use comai
      use comsptr
      use comsk

      implicit none

      integer i, j, np, model_flag, num_part_1
      integer :: impseed = 41293150
      real*8 ret_min,ret_max,ret,dret,cdf0,cdf1,sum_weight
      real*8 ret_log,dret_log,ret0,ret1

      save impseed
      real   ran_sp, randum

      real*8 , allocatable :: temp_weight(:)
      real*8 , allocatable :: temp_rcoll(:)

      integer , allocatable :: index (:)
      allocate(index(num_part+1))
      allocate(temp_rcoll(num_part))
      allocate(temp_weight(num_part))

      ret_min= r_min(1)
      ret_max= r_max(1)
      if(ret_max-ret_min.eq.0)then
         ret_weight = 1./num_part
         rcoll_div = ret_max
      else

c in order to honor the max and min of R, the first and last
c points are forced to these values, but this makes the two
c end intervals half the length of the remaining intervals.
c np-1 equal divisions in the log space. use midpoints of
c these intervals to calculate delta(CDF), except for the end
c points

         if(num_part.gt.1) then
c dret_log is half the division size in log space
            dret_log=0.5*(dlog10(ret_max/ret_min))/(num_part-1)
c calculate the first point
            ret=ret_min
            ret_log=dlog10(ret)
            temp_rcoll(1) = ret
            call calculate_cdf(model_flag,1,1,ret,cdf0)
            ret_log=ret_log+dret_log
            ret=10.**(ret_log)
            call calculate_cdf(model_flag,1,1,ret,cdf1)
            temp_weight(1)=cdf1-cdf0
            cdf0=cdf1

            do np=2,num_part-1
               ret_log=ret_log+dret_log
               temp_rcoll(np) =10.**(ret_log)
c use the next mid-point for probability
               ret_log=ret_log+dret_log
               ret=10.**(ret_log)
               call calculate_cdf(model_flag,1,1,ret,cdf1)
               temp_weight(np)=cdf1-cdf0
               cdf0=cdf1
            enddo
c calculate the last point
            ret_log=ret_log+dret_log
            ret=10.**(ret_log)
            temp_rcoll(num_part) =ret
            call calculate_cdf(model_flag,1,1,ret,cdf1)
            temp_weight(num_part)=cdf1-cdf0

         else
c cant sample less than 2 points, output an error message
            write(iptty,*)'# of smaples in impsample table le 1. stop'
            write(ierr,*)'# of smaples in impsample table le 1. stop'
            stop
         endif

c randomize the assignment of the indices 1 thru num_part
         do i=1,num_part
            index(i)=i
         enddo
         index(num_part+1)=num_part
         num_part_1=num_part
         do i=1,num_part
            randum = ran_sp(impseed)
            np=1+int(randum*num_part_1)
            ret_weight(i,1)= temp_weight(index(np))
            rcoll_div(i,1)= temp_rcoll(index(np))
            num_part_1=num_part_1-1
            do j = np,num_part_1
               index(j) = index(j+1)
            enddo
         enddo
      endif

c make sure weights are normalized to total number of particles
      sum_weight=0
      do np=1,num_part
         sum_weight=sum_weight+ret_weight(np,1)
      enddo
      if(sum_weight.le.0.) then
         write(ierr,*)'error in R_importance_sample. stop.'
         if (iptty .ne. 0)
     &        write(iptty,*)'error in R_importance_sample. stop.'
         stop
      endif
      sum_weight = sum_weight/num_part
      do np=1,num_part
         ret_weight(np,1)=ret_weight(np,1)/sum_weight
      enddo

      deallocate(index)
      deallocate(temp_weight)
      deallocate(temp_rcoll)

      return

      end subroutine impsample
c...........................................................


module mod_initsolver
  use iso_c_binding, only: C_PTR
  use decomp_2d    , only: xsize,ysize
  use mod_fft      , only: fftini
  use mod_param    , only: pi
  use mod_types
  implicit none
  private
  public initsolver
  contains
  subroutine initsolver(ng,lo_z,hi_z,dli,dzci,dzfi,cbc,bc,lambdaxy,c_or_f,a,b,c,arrplan,normfft, &
                        rhsbx,rhsby,rhsbz)
    !
    ! initializes the Poisson/Helmholtz solver
    !
    implicit none
    integer , intent(in), dimension(3) :: ng,lo_z,hi_z
    real(rp), intent(in), dimension(3 ) :: dli
    real(rp), intent(in), dimension(0:) :: dzci,dzfi
    character(len=1), intent(in), dimension(0:1,3) :: cbc
    real(rp)        , intent(in), dimension(0:1,3) :: bc
    real(rp), intent(out), dimension(lo_z(1):,lo_z(2):) :: lambdaxy
    character(len=1), intent(in), dimension(3) :: c_or_f
    real(rp), intent(out), dimension(:) :: a,b,c
    type(C_PTR), intent(out), dimension(2,2) :: arrplan
    real(rp), intent(out), dimension(:,:,0:) :: rhsbx
    real(rp), intent(out), dimension(:,:,0:) :: rhsby
    real(rp), intent(out), dimension(:,:,0:) :: rhsbz
    real(rp), intent(out) :: normfft
    real(rp), dimension(3)        :: dl
    real(rp), dimension(0:ng(3)+1) :: dzc,dzf
    integer :: i,j
    real(rp), dimension(ng(1))      :: lambdax
    real(rp), dimension(ng(2))      :: lambday
    !
    ! generating eigenvalues consistent with the BCs
    !
    call eigenvalues(ng(1),cbc(:,1),c_or_f(1),lambdax)
    lambdax(:) = lambdax(:)*dli(1)**2
    call eigenvalues(ng(2),cbc(:,2),c_or_f(2),lambday)
    lambday(:) = lambday(:)*dli(2)**2
    !
    ! add eigenvalues
    !
    do j=lo_z(2),hi_z(2)
      do i=lo_z(1),hi_z(1)
        lambdaxy(i,j) = lambdax(i)+lambday(j)
      end do
    end do
    !
    ! compute coefficients for tridiagonal solver
    !
    call tridmatrix(cbc(:,3),ng(3),dli(3),dzci,dzfi,c_or_f(3),a,b,c)
    !
    ! compute values to be added to the right hand side
    !
    dl(:)  = dli( :)**(-1)
    dzc(:) = dzci(:)**(-1)
    dzf(:) = dzfi(:)**(-1)
    call bc_rhs(cbc(:,1),bc(:,1),[dl(1) ,dl(1)      ],[dl(1) ,dl(1)    ],c_or_f(1),rhsbx)
    call bc_rhs(cbc(:,2),bc(:,2),[dl(2) ,dl(2)      ],[dl(2) ,dl(2)    ],c_or_f(2),rhsby)
    if(     c_or_f(3) == 'c') then
      call bc_rhs(cbc(:,3),bc(:,3),[dzc(0),dzc(ng(3)  )],[dzf(1),dzf(ng(3))],c_or_f(3),rhsbz)
    else if(c_or_f(3) == 'f') then
      call bc_rhs(cbc(:,3),bc(:,3),[dzc(1),dzc(ng(3)-1)],[dzf(1),dzf(ng(3))],c_or_f(3),rhsbz)
    end if
    !
    ! prepare ffts
    !
    call fftini(xsize,ysize,cbc(:,1:2),c_or_f(1:2),arrplan,normfft)
  end subroutine initsolver
  !
  subroutine eigenvalues(n,bc,c_or_f,lambda)
    implicit none
    integer , intent(in ) :: n
    character(len=1), intent(in), dimension(0:1) :: bc
    character(len=1), intent(in) :: c_or_f ! c -> cell-centered; f -> face-centered
    real(rp), intent(out), dimension(n) :: lambda
    integer :: l
    select case(bc(0)//bc(1))
    case('PP')
      do l=1,n
        lambda(l  )   = -4.*sin((1.*(l-1))*pi/(1.*n))**2
      end do
    case('NN')
      if(     c_or_f == 'c') then
        do l=1,n
          lambda(l)   = -4.*sin((1.*(l-1))*pi/(2.*n))**2
        end do
      else if(c_or_f == 'f') then
        do l=1,n
          lambda(l)   = -4.*sin((1.*(l-1))*pi/(2.*(n-1+1)))**2
        end do
      end if
    case('DD')
      if(     c_or_f == 'c') then
        do l=1,n
          lambda(l)   = -4.*sin((1.*(l-0))*pi/(2.*n))**2
        end do
      else if(c_or_f == 'f') then
        do l=1,n-1 ! point at n is a boundary and is excluded here
          lambda(l)   = -4.*sin((1.*(l-0))*pi/(2.*(n+1-1)))**2
        end do
      end if
    case('ND','DN')
      do l=1,n
        lambda(l)   = -4.*sin((1.*(2*l-1))*pi/(4.*n))**2
      end do
    end select
  end subroutine eigenvalues
  !
  subroutine tridmatrix(bc,n,dzi,dzci,dzfi,c_or_f,a,b,c)
    implicit none
    character(len=1), intent(in), dimension(0:1) :: bc
    integer , intent(in) :: n
    real(rp), intent(in) :: dzi
    real(rp), intent(in), dimension(0:) :: dzci,dzfi
    character(len=1), intent(in) :: c_or_f ! c -> cell-centered; f-face-centered
    real(rp), intent(out), dimension(n) :: a,b,c
    integer :: k
    integer :: ibound
    real(rp), dimension(0:1) :: factor
    select case(c_or_f)
    case('c')
      do k=1,n
        a(k) = dzfi(k)*dzci(k-1)
        c(k) = dzfi(k)*dzci(k)
      end do
    case('f')
      do k = 1,n
        a(k) = dzfi(k)*dzci(k)
        c(k) = dzfi(k+1)*dzci(k)
      end do
    end select
    b(:) = -(a(:)+c(:))
    do ibound = 0,1
      select case(bc(ibound))
      case('P')
        factor(ibound) = 0.
      case('D')
        factor(ibound) = -1.
      case('N')
        factor(ibound) = 1.
      end select
    end do
    select case(c_or_f)
    case('c')
      b(1) = b(1) + factor(0)*a(1)
      b(n) = b(n) + factor(1)*c(n)
    case('f')
      if(bc(0) == 'N') b(1) = b(1) + factor(0)*a(1)
      if(bc(1) == 'N') b(n) = b(n) + factor(1)*c(n)
    end select
    a(:) = a(:)
    b(:) = b(:)
    c(:) = c(:)
  end subroutine tridmatrix
  !
  subroutine bc_rhs(cbc,bc,dlc,dlf,c_or_f,rhs)
    implicit none
    character(len=1), intent(in), dimension(0:1) :: cbc
    real(rp), intent(in), dimension(0:1) :: bc
    real(rp), intent(in), dimension(0:1) :: dlc,dlf
    real(rp), intent(out), dimension(:,:,0:) :: rhs
    character(len=1), intent(in) :: c_or_f ! c -> cell-centered; f -> face-centered
    real(rp), dimension(0:1) :: factor
    real(rp) :: sgn
    integer :: ibound
    !
    select case(c_or_f)
    case('c')
      do ibound = 0,1
        select case(cbc(ibound))
        case('P')
          factor(ibound) = 0.
        case('D')
          factor(ibound) = -2.*bc(ibound)
        case('N')
          if(ibound == 0) sgn =  1.
          if(ibound == 1) sgn = -1.
          factor(ibound) = sgn*dlc(ibound)*bc(ibound)
        end select
      end do
    case('f')
      do ibound = 0,1
        select case(cbc(ibound))
        case('P')
          factor(ibound) = 0.
        case('D')
          factor(ibound) = -bc(ibound)
        case('N')
          if(ibound == 0) sgn =  1.
          if(ibound == 1) sgn = -1.
          factor(ibound) = sgn*dlf(ibound)*bc(ibound)
        end select
      end do
    end select
    do concurrent(ibound=0:1)
      rhs(:,:,ibound) = factor(ibound)/dlc(ibound)/dlf(ibound)
      rhs(:,:,ibound) = factor(ibound)/dlc(ibound)/dlf(ibound)
    end do
  end subroutine bc_rhs
end module mod_initsolver


!***********************************/
!	Name:Roe平均を計算するプログラム
!	Alias:GetRoeAverage
!	Description:隣接する2つのセルから保存変数を受け取ってRoe平均を計算する
!	Type:RoeAverage
!	Input:Geometory,RoeAverage
!	Output:RoeAverage
!	Note:内部関数としてRoeの荷重平均を求める関数が入っている
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2017.12.27
!	Other:1次元と2次元に対応 !12/26 UGetRoeAverageの引数からUGを削除
!***********************************/
subroutine UGetRoeAverage(RA,P4O)
    use StructVar_Mod
    use ConstantVar_Mod, Gamma => SpecificOfHeatRatio
    implicit none

    type(RoeAverage), intent(inout) :: RA
    type(PrivateVar4OMP), intent(inout) :: P4O

        if(RA%SideQuantity(1,1) < 0.0d0)  then
            write(6,*) P4O%Cell1,P4O%Cell2
            write(6,*) RA%SideQuantity(1,1),RA%SideQuantity(1,2)
        end if

    P4O%GRA%SqrtDensity(:) = dsqrt(RA%SideQuantity(1,:))
    P4O%GRA%InverseDensitySum = 1.0d0 / (P4O%GRA%SqrtDensity(1) + P4O%GRA%SqrtDensity(2))

    !保存量からのRoe平均生成
        !1:音速,2~:速度,最後:エンタルピ

            P4O%GRA%Velocity(1,:) = RA%SideQuantity(2,:)/RA%SideQuantity(1,:)
            P4O%GRA%Velocity(2,:) = RA%SideQuantity(3,:)/RA%SideQuantity(1,:)
            P4O%GRA%Velocity(3,:) = RA%SideQuantity(4,:)/RA%SideQuantity(1,:)
            P4O%GRA%Enthalpy(:) = Gamma*RA%SideQuantity(5,:)/ RA%SideQuantity(1,:) &
                &   - Gmin1*0.5d0*(P4O%GRA%Velocity(1,:)**2 + P4O%GRA%Velocity(2,:)**2 + P4O%GRA%Velocity(3,:)**2)

            RA%RoeAverage(2) = RoeLoadAverage(P4O%GRA%Velocity(1,1),P4O%GRA%Velocity(1,2))
            RA%RoeAverage(3) = RoeLoadAverage(P4O%GRA%Velocity(2,1),P4O%GRA%Velocity(2,2))
            RA%RoeAverage(4) = RoeLoadAverage(P4O%GRA%Velocity(3,1),P4O%GRA%Velocity(3,2))
            RA%RoeAverage(5) = RoeLoadAverage(P4O%GRA%Enthalpy(1),P4O%GRA%Enthalpy(2))

            if(Gmin1*RA%RoeAverage(5)-0.5d0*(sum(RA%RoeAverage(2:4)**2)) < 0) then
                write(6,*) "UGetRoeAverage Line42"
                write(6,*) "RightSide"
                write(6,*) "Vel",P4O%GRA%Velocity(1,1), P4O%GRA%Velocity(2,1),P4O%GRA%Velocity(3,1)
                write(6,*) "Ent",P4O%GRA%Enthalpy(1)
                write(6,*) "SqD",P4O%GRA%SqrtDensity(1)
                write(6,*) "LeftSide"
                write(6,*) "Vel",P4O%GRA%Velocity(1,2), P4O%GRA%Velocity(2,2),P4O%GRA%Velocity(3,2)
                write(6,*) "Ent",P4O%GRA%Enthalpy(2)
                write(6,*) "SqD",P4O%GRA%SqrtDensity(2)
                write(6,*) "RoeAverage"
                write(6,*) "DRL",RA%SideQuantity(1,1),RA%SideQuantity(1,2)
                write(6,*) "a^2",Gmin1*RA%RoeAverage(5)-0.5d0*(sum(RA%RoeAverage(2:4)**2))
                write(6,*) "Rh",RA%RoeAverage(5)
                write(6,*) "RVx",RA%RoeAverage(2)
                write(6,*) "RVy",RA%RoeAverage(3)
                write(6,*) "RVz",RA%RoeAverage(4)
                RetryFlag = 1
             end if

                RA%RoeAverage(1) = dsqrt(Gmin1*RA%RoeAverage(5)-0.5d0*(sum(RA%RoeAverage(2:4)**2)))

    return
contains
    function RoeLoadAverage(QuantityL,QuantityR) result(Average)
    implicit none
    double precision,intent(in) :: QuantityL,QuantityR
    double precision :: Average

    Average =  (P4O%GRA%SqrtDensity(1)*QuantityL + P4O%GRA%SqrtDensity(2)*QuantityR)*P4O%GRA%InverseDensitySum

    return
    end function RoeLoadAverage

end subroutine UGetRoeAverage


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE PEKDES (SP,NCHAN,ICH1,ICH2,IACF,IACL,SPMAX,IMAX,
     1     RMEAN,IMED,IMODE,SIGI,IFWHM,SKEW1,SKEW2,IRC)
      IMPLICIT NONE
C
C Purpose: To calculate the parameters which describe a peak which
C          will be found between channels ICH1 and ICH2 in array SP
C
      REAL SP(1),SPMAX,RMEAN,SIGI,SKEW1,SKEW2
      INTEGER NCHAN,IACF,IACL,IMAX,IMED,IMODE,IFWHM,IRC
C
C SP     : array containing data
C NCHAN  : size of array SP
C IACF   : first active channel (SP()>0.0)
C IACL   : last active channel
C SPMAX  : highest value found in SP()
C IMAX   : channel where SPMAX was found
C RMEAN  : mean
C IMED   : median
C IMODE  : mode
C SIGI   : standard deviation " sigma "
C IFWHM  : FWHM expressed as number of channels
C SKEW1  : Third Moment / Sigma**3
C SKEW2  : ( mean - median ) / sigma
C IRC    : Return code 0 - if successful
C                      1 - if half maximum CANNOT be found
C
C Calls   1: MINMAX
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL    SPMIN,SPMAX2,SUMSP,SUMPR,SUMSP2,SECM,THIRDM,DELTAI
      INTEGER IMIN,IL,I2,ICH1,ICH2,I1,I
C
C SPMIN  : Minimum value of spectrum
C SPMAX2 : Spectrum maximum/2
C SUMSP  : Integral of spectrum
C SUMPR  :
C SUMSP2 :
C SECM   : Second moment
C THIRDM : Third moment
C IMIN   : Minimum value in spectrum
C IL     :
C I2     :
C
C
C-----------------------------------------------------------------------
      IRC=0
C
C========find active channels,max, and min.
C
      IACF=0
      IACL=0
      CALL MINMAX (SP,NCHAN,ICH1,ICH2,IMIN,IMAX,SPMIN,SPMAX)
      DO 5 I=ICH1,ICH2
         IF (SP(I).NE.0.0.AND.IACF.EQ.0) IACF=I
5     CONTINUE
      DO 6 I=ICH2,ICH1,-1
         IF (SP(I).NE.0.0.AND.IACL.EQ.0) IACL=I
6     CONTINUE
      IL=IACL-IMAX
      SPMAX2=SPMAX/2.0
C
C========TEST FOR VALIDITY
C
      DO 10 I=1,IL
         IF (SP(IMAX+I).LE.SPMAX2) GOTO 20
10    CONTINUE
      GOTO 998
C
C========VALID
C
20    I2=IMAX+I
      IL=IMAX-IACF
      DO 30 I=1,IL
         IF (SP(IMAX-I).LE.SPMAX2) GOTO 40
30    CONTINUE
      GOTO 998
C
C========ALL VALID
C
   40 I1=IMAX-I
      IFWHM=I2-I1
      SUMSP=0.0
      SUMPR=0.0
C
      DO 50 I=IACF,IACL
         SUMSP=SUMSP+SP(I)
         SUMPR=SUMPR+I*SP(I)
50    CONTINUE
C
      RMEAN=SUMPR/SUMSP
      SUMSP2=SUMSP/2.0
      SUMSP=0.0
      DO 60 I=IACF,IACL
         SUMSP=SUMSP+SP(I)
         IF (SUMSP.GE.SUMSP2) GOTO 70
60    CONTINUE
C
70    IMED=I
      IMODE=IMAX
      SECM=0.0
      THIRDM=0.0
C
      DO 80 I=IACF,IACL
         DELTAI=I-RMEAN
         SECM=SECM+DELTAI*DELTAI*SP(I)
         THIRDM=THIRDM+DELTAI*DELTAI*DELTAI*SP(I)
80    CONTINUE
C
      SECM=SECM/(SUMSP2*2.0)
      THIRDM=THIRDM/(SUMSP2*2.0)
      SECM=ABS(SECM)
      SIGI=SQRT(SECM)
      SKEW1=THIRDM/(SIGI*SIGI*SIGI)
      SKEW2=(RMEAN-IMODE)/SIGI
      RETURN
C
998   IRC=1
      RETURN
      END


c      program main
c      implicit none
c      double precision mt,mw,tw,topwidth
c      include 'constants.f'
c      include 'qcdcouple.f'
c
c      ason2pi=0.119d0/2d0/pi
c
c      mw=82d0
c      mt=180d0
c      tw=topwidth(mt,mw)
c
c      write(6,*) 'twidth/born ',tw
c
c      end

      double precision function topwidth(mt,mw)
      implicit none
C     alpha_s correction to top width
C     Formula taken from
C %\cite{Kuhn:1996ug}
c \bibitem{Kuhn:1996ug}
c J.~H.~Kuhn,
c %``Theory of top quark production and decay,''
c arXiv:hep-ph/9707321.
c %%CITATION = HEP-PH 9707321;%%
      double precision y,f0,f1,mt,mw,omy,ddilog
      include 'constants.f'
      include 'qcdcouple.f'

      y=(mw/mt)**2
      omy=1d0-y
      F0=2d0*omy**2*(1d0+2d0*y)
      F1=F0*(pisq+2d0*(ddilog(y)-ddilog(omy)))
     . +4d0*y*(1d0-y*(1d0+2d0*y))*log(y)
     . +2d0*omy**2*(5d0+4d0*y)*log(omy)
     . -omy*(5d0+y*(9d0-6d0*y))

c      F1=F0*(2d0/3d0*pisq-2.5d0-3d0*y+4.5d0*y**2
c     . -3d0*y**2*dlog(y))
c      write(6,*) F1/F0

      topwidth=1d0-cf*ason2pi*F1/F0

c      write(6,*) 'dQCD ',-cf/2d0*F1/F0
      return
      end

c      double precision function virtbit(mt,mw)
c      implicit none
C     alpha_s correction to top width, virtual+dipole integration only
c      double precision y,f0,d1,mt,mw,omy,ddilog
c      include 'constants.f'
c      include 'qcdcouple.f'

c      y=(mw/mt)**2
c      omy=1d0-y
c      F0=2d0*omy**2*(1d0+2d0*y)

c      d1=-F0*(pisq+2d0*(ddilog(y)-ddilog(omy)))
c     .  +log(omy)*(-10d0+12d0*y+6d0*y**2-8d0*y**3)
c     .  +y*log(y)*(-6d0-5d0*y+14d0*y**2)
c     .  +5d0/2d0+y-13d0/2d0*y**2+3d0*y**3

c      virtbit=1d0+cf*ason2pi*d1/F0
c      return
c      end

c      double precision function realbit(mt,mw)
c      implicit none
C     alpha_s correction to top width
C     Formula taken from
c      double precision mt,mw,rsq,omrsq,wlog,rlog,ddilog,ct,Kfun
c      include 'constants.f'
c      include 'qcdcouple.f'
c      include 'epinv.f'
c      include 'epinv2.f'

c      rsq=(mw/mt)**2
c      omrsq=1d0-rsq
c      wlog=log(omrsq)
c      rlog=log(rsq)

c      ct=epinv2*epinv
c     . +epinv*(2.5d0-2d0*wlog)
c     . +25d0/4d0+0.5d0*(1d0/omrsq**2-8d0/omrsq+7d0)*rlog
c     . +0.5d0/omrsq+2d0*ddilog(omrsq)-5d0*pisqo6
c     . -5d0*wlog+2d0*wlog**2

c      Kfun=1d0/rsq*wlog

c      ct=ct-epinv*epinv2
c     . -epinv*(2.5d0-2d0*wlog)
c     . -0.5d0*(11d0)-pisqo6-2d0*ddilog(rsq)
c     .  +3d0*wlog-2d0*wlog**2-Kfun
c
c
c      realbit=1d0+cf*ason2pi*ct
c
c      return
c      end


!file: glasso.f90
subroutine glasso(Omega, Sigma, & !output
                  Sigma_pre, lambda, & !inputs :: data and parameter
                  ths, max_iter, & !inputs, optional :: opt. parameters
                  ths_lasso, max_iter_lasso, & !inputs, optional :: opt. param for lasso
                  dim_Sigma) !inputs :: dimensions
    implicit none

    !inputs :: dimensions
    integer, intent(in) :: dim_Sigma

    !inputs :: data and parameter
    real(8), dimension(dim_Sigma, dim_Sigma), intent(in) :: Sigma_pre, lambda

    !inputs :: opt. parameters
    integer, intent(in) :: max_iter
    real(8), intent(in) :: ths
    integer :: max_iter_lasso
    real(8) :: ths_lasso

!f2py integer optional, intent(in) :: max_iter = 100
!f2py real(8) optional, intent(in) :: ths = 0.001
!f2py integer optional, intent(in) :: max_iter_lasso = -1
!f2py real(8) optional, intent(in) :: ths_lasso = -1

    !in/outputs
    real(8), dimension(dim_Sigma, dim_Sigma) :: Omega, Sigma

!f2py intent(inplace) Omega
!f2py intent(inplace) Sigma

    ! local variables
    integer :: i, p, q, dim_dep
    real(8), dimension(dim_Sigma, dim_Sigma) :: Sigma_last

    if (max_iter_lasso < 0) then
        max_iter_lasso = max_iter
    end if
    if (ths_lasso < 0) then
        ths_lasso = ths
    end if

    do i = 1, max_iter
        Sigma_last = Sigma

        do p = 1, dim_Sigma
            dim_dep = &
                count((lambda(p,:) >= 0) .and. ((/(q,q=1,dim_Sigma)/) /= p))

            call glasso_p(Omega, Sigma, Sigma_pre, lambda, &
                          ths_lasso, max_iter_lasso, &
                          p, dim_Sigma, dim_dep)
        end do

        if (maxval(abs(Sigma - Sigma_last)) < ths) then
            exit
        end if
    end do
end subroutine glasso


program unary_plus_minus
  i = -10
  i = -3 + 4
  i = 3 - 4
  i = -3 + (-4)
  i = (-3) + (-4)
  i = 4 + (-3)
  i = 4 - (-3)
  i = -3 * 4
  i = -3 * (-4)
  i = (-3) * (+4)
  i = 3 + (-j)
  i = -j + (-3) * (-4)
  i = -(3 - 4)
  i = +(3 - 4)
  i = -3**2 ! = -9
  i = (-3) ** 2 ! = 9
  i = 4 ** (-2)
  i = 10 / (-2) + (-3) * 4
  i = 10 / (-2) + (-3) * 4 ** (-5)
end


           program demo_reshape
           implicit none
           integer :: i
           integer, dimension(4) :: x=[(i,i=10,40,10)]
             ! X is originally a vector with four elements
             write(*,*) shape(x)                     ! prints "4"
             write(*,*) shape(reshape(x, [2, 2]))    ! prints "2 2"
           end program demo_reshape


subroutine interp_1d(xvals,yvals,nvals,x,y,r_missing_data,idebug)

real xvals(nvals)
real yvals(nvals)
real x,y

if(idebug .eq. 1)then
    write(13,*)' x,nvals,xvals ',x,nvals,xvals
endif

y = r_missing_data

do i = 1,nvals-1
    if(xvals(i) .ge. x .and. xvals(i+1) .le. x)then
        frac = (x-xvals(i)) / (xvals(i+1)-xvals(i))
        y = yvals(i) * (1.-frac) + yvals(i+1)*frac
    endif
enddo

return
end


!==============================================================================!
  subroutine Inertia(grid, sub)
!------------------------------------------------------------------------------!
!                                                                      !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use all_mod
  use gen_mod
  use div_mod
  use Grid_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
  integer         :: sub   ! subdomain
!-----------------------------------[Locals]-----------------------------------!
  integer :: i, n_cells_sub
  real    :: xm, ym, zm
  real    :: i_matrix(3,3), d(3), v(3,3), d_max(3)
!==============================================================================!

  xm = 0.0
  ym = 0.0
  zm = 0.0
  n_cells_sub=0
  do i=1,grid % n_cells
    if(proces(i)==sub) then
      xm = xm + grid % xc(i)
      ym = ym + grid % yc(i)
      zm = zm + grid % zc(i)
      n_cells_sub=n_cells_sub+1
    end if
  end do
  xm = xm / n_cells_sub
  ym = ym / n_cells_sub
  zm = zm / n_cells_sub

  write(*,*) '# Center of mass for subdomain ', sub, ' is: ', xm, ym, zm

  i_matrix = 0.
  do i=1,grid % n_cells
    if(proces(i)==sub) then
      i_matrix(1,1) = i_matrix(1,1) + (grid % yc(i)-ym)**2  &
                                    + (grid % zc(i)-zm)**2
      i_matrix(2,2) = i_matrix(2,2) + (grid % xc(i)-xm)**2  &
                                    + (grid % zc(i)-zm)**2
      i_matrix(3,3) = i_matrix(3,3) + (grid % xc(i)-xm)**2  &
                                    + (grid % yc(i)-ym)**2

      i_matrix(1,2) = i_matrix(1,2) - (grid % xc(i)-xm) * (grid % yc(i)-ym)
      i_matrix(1,3) = i_matrix(1,3) - (grid % xc(i)-xm) * (grid % zc(i)-zm)
      i_matrix(2,3) = i_matrix(2,3) - (grid % yc(i)-ym) * (grid % zc(i)-zm)
    end if
  end do
  i_matrix(2,1) = i_matrix(1,2)
  i_matrix(3,1) = i_matrix(1,3)
  i_matrix(3,2) = i_matrix(2,3)

  call Compute_Eigenvalues(i_matrix, 3, 3, d, v, i)

  write(*,*) 'd=',d(1), d(2), d(3)

  write(*,*) 'v=', (v(1,i), i=1,3)
  write(*,*) '  ', (v(2,i), i=1,3)
  write(*,*) '  ', (v(3,i), i=1,3)

  if(min(d(1),d(2),d(3)) == d(1)) then
    d_max(1) = v(1,1)
    d_max(2) = v(2,1)
    d_max(3) = v(3,1)
  else if(min(d(1),d(2),d(3)) == d(2)) then
    d_max(1) = v(1,2)
    d_max(2) = v(2,2)
    d_max(3) = v(3,2)
  else if(min(d(1),d(2),d(3)) == d(3)) then
    d_max(1) = v(1,3)
    d_max(2) = v(2,3)
    d_max(3) = v(3,3)
  end if

  write(*,*) '# Sorting the cells'
  do i = 1, grid % n_cells
    iin(i) = i
    criter(i) = grid % xc(i) * d_max(1) +  &
                grid % yc(i) * d_max(2) +  &
                grid % zc(i) * d_max(3)
  end do
  call Sort_Real_By_Index(criter(1), iin(1), grid % n_cells, 2)

  end subroutine


subroutine acf_routine
use CLUSTER
use ENFORCE

implicit none

integer :: i, m, n
real :: zero

do m=1,npas
	vel_act_est(m) = 0.d0
end do

do m = 1,npas-1
 do n = 1, npas-m
  do i = 1, natom
    vel_act_est(m) = vel_act_est(m) + v_acf(n+m,i,1)*v_acf(n,i,1) + v_acf(n+m,i,2)*v_acf(n,i,2) + v_acf(n+m,i,3)*v_acf(n,i,3)
  end do
 end do
end do

do m=1,npas-1
  vel_act_est(m) = vel_act_est(m)*(npas-m)/(npas)
end do

zero = vel_act_est(1)
do m=1, npas-1
  vel_act_est(m) = vel_act_est(m)/zero
end do

do m=1,npas-1
write(56,*) m,vel_act_est(m)
end do
close(unit=56)

end subroutine

!


module mod_monolis_solver_GropCG
  use mod_monolis_prm
  use mod_monolis_com
  use mod_monolis_mat
  use mod_monolis_precond
  use mod_monolis_matvec
  use mod_monolis_linalg
  use mod_monolis_linalg_util
  use mod_monolis_converge

  implicit none

contains

  subroutine monolis_solver_GropCG(monoPRM, monoCOM, monoMAT)
    implicit none
    type(monolis_prm) :: monoPRM
    type(monolis_com) :: monoCOM
    type(monolis_mat) :: monoMAT
    integer(kind=kint) :: N, NP, NDOF, NNDOF
    integer(kind=kint) :: i, iter, iter_RR
    !integer(kind=kint) :: reqs1(1), reqs2(1)
    !integer(kind=kint) :: statuses(monolis_status_size,1)
    real(kind=kdouble) :: R2, B2
    real(kind=kdouble) :: alpha, beta, delta, gamma, gamma1
    !real(kind=kdouble) :: buf1(1), buf2(2)
    real(kind=kdouble), allocatable :: R(:), U(:), V(:), Q(:), P(:), S(:)
    real(kind=kdouble), pointer :: B(:), X(:)
    logical :: is_converge

    N     = monoMAT%N
    NP    = monoMAT%NP
    NDOF  = monoMAT%NDOF
    NNDOF = N*NDOF
    X => monoMAT%X
    B => monoMAT%B
    iter_RR = 50

    if(monoPRM%is_init_x) X = 0.0d0

    allocate(R(NDOF*NP)); R = 0.0d0
    allocate(U(NDOF*NP)); U = 0.0d0
    allocate(V(NDOF*NP)); V = 0.0d0
    allocate(Q(NDOF*NP)); Q = 0.0d0
    allocate(P(NDOF*NP)); P = 0.0d0
    allocate(S(NDOF*NP)); S = 0.0d0

    call monolis_set_converge(monoPRM, monoCOM, monoMAT, B, B2, is_converge, monoPRM%tdotp, monoPRM%tcomm_dotp)
    if(is_converge) return
    call monolis_residual(monoCOM, monoMAT, X, B, R, monoPRM%tspmv, monoPRM%tcomm_spmv)
    call monolis_precond_apply(monoPRM, monoCOM, monoMAT, R, U)

    call monolis_vec_copy_R(N, NDOF, U, P)

    call monolis_matvec(monoCOM, monoMAT, P, S, monoPRM%tspmv, monoPRM%tcomm_spmv)
    call monolis_inner_product_R(monoCOM, N, NDOF, R, U, gamma, monoPRM%tdotp, monoPRM%tcomm_dotp)

    do iter = 1, monoPRM%maxiter
      call monolis_inner_product_R(monoCOM, N, NDOF, P, S, delta, monoPRM%tdotp, monoPRM%tcomm_dotp)
      call monolis_precond_apply(monoPRM, monoCOM, monoMAT, S, Q)

      alpha = gamma/delta

      do i = 1, NNDOF
        X(i) = X(i) + alpha*P(i)
        R(i) = R(i) - alpha*S(i)
        U(i) = U(i) - alpha*Q(i)
      enddo

      call monolis_inner_product_R(monoCOM, N, NDOF, R, U, gamma1, monoPRM%tdotp, monoPRM%tcomm_dotp)
      call monolis_inner_product_R(monoCOM, N, NDOF, R, R, R2, monoPRM%tdotp, monoPRM%tcomm_dotp)

      call monolis_matvec(monoCOM, monoMAT, U, V, monoPRM%tspmv, monoPRM%tcomm_spmv)

      beta  = gamma1/gamma
      gamma = gamma1

      do i = 1, NNDOF
        P(i) = U(i) + beta * P(i)
        S(i) = V(i) + beta * S(i)
      enddo

      call monolis_check_converge_2(monoPRM, monoCOM, monoMAT, R2, B2, iter, is_converge)
      if(is_converge) exit
    enddo

    call monolis_update_R(monoCOM, NDOF, X, monoPRM%tcomm_spmv)

    deallocate(R)
    deallocate(U)
    deallocate(V)
    deallocate(Q)
    deallocate(P)
    deallocate(S)
  end subroutine monolis_solver_GropCG

end module mod_monolis_solver_GropCG


program watch
    implicit none
    integer, parameter :: rows = 3, cols = 4
    integer :: i, j
    integer, dimension(rows, cols) :: values
    character(len=32) :: fmt_str

    do j = 1, cols
        do i  = 1, rows
          values(i, j) = (i - 1)*cols + j
        end do
    end do

    write (fmt_str, '(A, I0, A)') '(', cols, 'I4)'
    do i = 1, rows
        print fmt_str, values(i, :)
    end do

end program watch


c=======================================================================
c
c     Fichier d'utilitaires
c
c     sous-programmes divers
c
c        DAYRAT  : Computes a kind of daily 'rate'
c                  from the yearly interest rate of risk-free asset
c        FREERA  : computing the risk-free rate
c        WZERO   : put zero at the values of a vector less than eps
c                  and increase the greatest element with residual
c        GESTERR : gestion of errors
c        GREPS   : computing groups in a sorted vector for a sensibility
c        POLYN   : computing a polynome (Horner algorithm)
c        INDMTI  : index of symmetric matrix in triangular inf. matrix
c
c=======================================================================
c
c     subroutine DAYRAT
c
c     Computes a kind of daily 'rate' from the yearly interest rate of
c     risk-free asset
c
c=======================================================================
c
c     INPUT :
c            taux   : yearly interest rate of risk-free asset     double
c            nbjour : effective number of days in a year        interger
c
c     OUTPUT :
c            taujou : daily rate                                  double
c            info   : = 0 successful exit                        integer
c
c-----------------------------------------------------------------------
c
      subroutine DAYRAT ( taux, nbjour, taujou, info )
c
      implicit none
c
      integer nbjour, info
      double precision taux, taujou
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
      taujou = 0.0
c
      if ( nbjour.le.0 ) then
         info = -2
         return
      endif

      taujou = taux / nbjour
c
      return
      end
c
c=======================================================================
c
c     subroutine FREERA
c
c     Computing the risk-free rate
c
c=======================================================================
c
c     INPUT :
c            nasset : size of the portfolio                      integer
c                     with risk-free asset as first component
c            wasset : portfolio weights vector(nasset)            double
c                     with risk-free to compute
c
c     OUTPUT :
c            wasset : portfolio weights vector(nasset)            double
c                     with risk-free asset as first component
c
c-----------------------------------------------------------------------
c
      subroutine FREERA ( nasset, wasset )
c
      implicit none
c
      integer nasset
      double precision wasset(*)
c
      integer i
      double precision som
c
c-----------------------------------------------------------------------
c
      som =  0.
      do i=2,nasset
         som = som + wasset(i)
      end do
      wasset(1) = 1. - som
c
      return
      end
c
c=======================================================================
c
c     subroutine WZERO
c
c     Put zero at the values of a vector less than eps
c     and increase the greatest element with residual
c
c=======================================================================
c
c     INPUT :
c            nvect  : size of the vector                         integer
c            vect   : vector(nvect)                               double
c            eps    : if vect(i) < eps, vect(i) = 0.              double
c
c     OUTPUT :
c            vect   : modified vector(nvect)                      double
c
c-----------------------------------------------------------------------
c
      subroutine WZERO ( nvect, vect, eps )
c
      implicit none
c
      integer nvect
      double precision vect(*), eps
c
      integer i, imax
      double precision res, vmax
c
c-----------------------------------------------------------------------
c
      res =  0.
      vmax = vect(1)
      imax = 1
      do i=1,nvect
         if (vect(i).lt.eps) then
            res = res + vect(i)
            vect(i) = 0.
         else
            if (vect(i).gt.vmax) then
               vmax = vect(i)
               imax = i
            end if
         end if
      end do
      vect(imax) = vmax + res
c
      return
      end
c
c=======================================================================
c
c     subroutine GESTERR
c
c     Gestion of errors
c
c=======================================================================
c
c     INPUT :
c            cinfo  : information on path of errors          charcter*80
c            cpath  : addition of path                       charcter*10
c
c     OUTPUT :
c            cinfo  : information on path of errors          charcter*80
c-----------------------------------------------------------------------
c
      subroutine GESTERR ( cinfo, cpath )
c
      implicit none
c
      character*80 cinfo
      character*20 cpath
c
      integer i, imin
c
c-----------------------------------------------------------------------
c
      i = 1
      do while ( cinfo(i:i).ne.' ')
         i = i+1
      end do
      imin = min(i+20,80)
      if (i.le.80) cinfo(i:imin)=cpath
c
      return
      end
c
c========================================================================
c
c     subroutine POLYN
c
c     Computing a polynome (Horner algorithm)
c
c=======================================================================
c
c     INPUT :
c            n      : size of the polynome                       integer
c            param  : parameters of the polynome  vector(n+1)     double
c                     in the order a(0),a(1),........,a(n-1),a(n)
c            x      : value of x                                  double
c
c     OUTPUT :
c            value  :                                             double
c                   a(n)*x**(n) + a(n-1)*x**(n-1) +...+ a(1)*x + a(0)
c
c-----------------------------------------------------------------------
c
      subroutine POLYN ( n, param, x, value )
c
      implicit none
c
      integer n
      double precision x, value
      double precision param(*)
c
      integer i
c
c-----------------------------------------------------------------------
c
      value = param(n+1)
      do i=n,1,-1
         value = value*x + param(i)
      end do
c
      return
      end
c
c=======================================================================
c
c     subroutine INDMTI
c
c     index of symmetric matrix in triangular inferior matrix
c
c=======================================================================
c
c     INPUT :
c            nmat   : size of matrix                             integer
c            ks     : index in symmetric matrix                  integer
c
c     OUTPUT :
c            i      : index(row) in triangular inferior matrix   integer
c            j      : index(column) in triangular inf. matrix    integer
c
c-----------------------------------------------------------------------
c
      subroutine INDMTI ( nmat, ks, i, j )
c
      implicit none
c
      integer nmat, ks, i, j
c
      integer k
c
c-----------------------------------------------------------------------
c
      k = 1
      do i=1,nmat
         do j=1,i
            if (ks.eq.k) return
            k = k + 1
         end do
      end do
c
      return
      end


       SUBROUTINE W3FT03(FL,HI,STI,STJ,MAXI,MAXJ,ITYPE)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FT03         A POINT INTERPOLATER
C   AUTHOR: HOWCROFT, J.     ORG: W342       DATE: 79-02-15
C
C ABSTRACT: DO EITHER BILINEAR OR BIQUADRATIC INTERPOLATION FOR A
C   POINT WITHIN A TWO-DIMENSIONAL DATA ARRAY.
C
C PROGRAM HISTORY LOG:
C   79-02-15  J.HOWCROFT
C   89-01-25  R.E.JONES  CHANGE TO MICROSOFT FORTRAN 4.10
C   90-06-12  R.E.JONES  CHANGE TO SUN FORTRAN 1.3
C   91-03-30  R.E.JONES  CONVERT TO SiliconGraphics FORTRAN
C   93-03-29  R.E.JONES  ADD SAVE STATEMENT
C   96-07-01  R.E.JONES  COMPILE ON CRAY
C
C USAGE:  CALL W3FT03(FL,HI,STI,STJ,MAXI,MAXJ,KQUAD)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     FL     ARG LIST  REAL*4 TWO-DIMENSIONAL CARTESIAN ARRAY OF DATA
C     MAXI   ARG LIST  INTEGER*4 I-DIMENSION OF FL
C     MAXJ   ARG LIST  INTEGER*4 J-DIMENSION OF FL
C     STI    ARG LIST  REAL*4 I-COORDINATE TO WHICH A VALUE IS TO BE
C                      INTERPOLATED
C     STJ    ARG LIST  REAL*4 J-COORDINATE TO WHICH A VALUE IS TO BE
C                      INTERPOLATED
C     KQUAD  ARG LIST  INTEGER*4 INTERPOLATION METHOD:
C                      IF = 2, BIQUADRATIC INTERPOLATION IS DONE,
C                      IF = ANY OTHER VALUE, DO BILINEAR.
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     HI     ARG LIST  REAL*4 INTERPOLATED OUTPUT VALUE
C
C   REMARKS: NO ERROR CHECKS ARE MADE. IT IS LEFT FOR THE USER TO
C     DETERMINE THAT THE POINT FOR WHICH INTERPOLATION IS DESIRED
C     LIES WITHIN THE GRID.
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY C916/256, CRAY J916/2048
C
C$$$
C
       REAL            FL(MAXI,MAXJ)
       REAL            E (4)
C
       SAVE
C
       I  = STI
       J  = STJ
       DI = I
       DJ = J
       DI = STI - DI
       DJ = STJ - DJ
C
       HI = 0.
C                      TEST FOR POINT OFF GRID.
       IF (I.LT.1 .OR. I.GT.MAXI) GO TO 300
       IF (J.LT.1 .OR. J.GT.MAXJ) GO TO 300
       IF (ITYPE .NE. 2) GO TO 100
C                      DO BILINEAR IF POINT IS BETWEEN ULTIMATE AND
C                      PENULTIMATE ROWS, WHERE BIQUAD NOT POSSIBLE.
       IF (I.LT.2 .OR. I.GT.(MAXI-1)) GO TO 100
       IF (J.LT.2 .OR. J.GT.(MAXJ-1)) GO TO 100
       GO TO 200
C
C        BILINEAR.
  100  CONTINUE
         HI = FL(I  ,J  )*(1.-DI)*(1.-DJ)  + FL(I+1,J  )*DI*(1.-DJ)
     &      + FL(I  ,J+1)*(1.-DI)*DJ       + FL(I+1,J+1)*DI*DJ
         GO TO 300
C
  200  CONTINUE
C        BIQUADRATIC.
       DI2 = DI*(DI-1.)*.25
       DJ2 = DJ*(DJ-1.)*.25
       J1  = J - 1
       DO 250  K=1,4
         E(K) = FL(I  ,J1)*(1.-DI-DI2) + FL(I+1,J1)*(DI-DI2)
     &        + (FL(I-1,J1) + FL(I+2,J1))*DI2
         J1 = J1 + 1
  250  CONTINUE
       HI = E(2)*(1.-DJ-DJ2) + E(3)*(DJ-DJ2) + (E(1) + E(4))*DJ2
C
  300  CONTINUE
       RETURN
       END


! { dg-do compile }
!
! PR fortran/36355
! Check MATMUL argument types:
!
!           numeric   logical   other
! numeric      1         2        3
! logical      2         1        3
! other        3         3        3
!
! where
!   1    ok
!   2    argument type mismatch
!   3    invalid argument types
!

  INTEGER :: a(2,2)
  LOGICAL :: b(2,2)
  CHARACTER :: c

  a = MATMUL(a, a)            ! ok
  a = MATMUL(a, b)            ! { dg-error "must match" }
  a = MATMUL(a, c)            ! { dg-error "must be numeric or LOGICAL" }

  b = MATMUL(b, a)            ! { dg-error "must match" }
  b = MATMUL(b, b)            ! ok
  b = MATMUL(b, c)            ! { dg-error "must be numeric or LOGICAL" }

  c = MATMUL(c, a)            ! { dg-error "must be numeric or LOGICAL" }
  c = MATMUL(c, b)            ! { dg-error "must be numeric or LOGICAL" }
  c = MATMUL(c, c)            ! { dg-error "must be numeric or LOGICAL" }
END