      SUBROUTINE MTNV(ARRAY,NORDER,NSIZE,DET)
C &KCLFT Invert matrix <860314.1909>

C   Last EDIT  <860314.1909>
C **********************************************************************

C+ MTNV  &KCLFT S  Matrix inversion

C  FUNCTIONAL DESCRIPTION:  Inverts a matrix and finds its determinant
C    following Program B-2 in Bevington, DATA REDUCTION AND ERROR
C    ANALYSIS, McGraw-Hill, 1969.

C  CALLING SEQUENCE:  CALL MTNV( ARRAY,NORDER,NSIZE,DET )
C     ARG   I/O/M  TYPE    DESCRIPTION
C    ------  ---   ----    ---------------------------------------------
C    ARRAY : mod   REAL*4  matrix to be inverted
C    NORDER: in    INT     order of the matrix
C    NSIZE : in    INT     size of array in which matrix is stored
C    DET   : out   REAL*4  determinant

C  SUBROUTINES CALLED:

C  REVISION HISTORY:
C    DATE      PROGRAMMER      DESCRIPTION OF CHANGES
C    --------  --------------  ----------------------------------------
C    14Mar86   T.B.H.Kuiper    HEADed

C  OPERATING ENVIRONMENT:
C    Language           : HP 1000 FORTRAN 4X
C    System Dependencies:
C    Hardware Required  :

C  KEYWORDS (MTNV  ): JPL-RAG,MATH,DATA REDUCTION,
C **********************************************************************

C  VARIABLE DICTIONARY
C  -------- ----------
C    AMAX  : maximam element in the matrix
C    I     : loop index
C    IK    : array with column order
C    J     : loop index
C    JK    : array with row order
C    K     : loop index
C    L     : loop index
C    SAVE  : temporary storage while re-ordering
C **********************************************************************

      real*8 ARRAY(NSIZE,NSIZE), AMAX, SAVE, DET
      PARAMETER (MXPARM=20)
      DIMENSION IK(MXPARM), JK(MXPARM)
Cf2py intent(inout) ARRAY
Cf2py intent(in) NORDER
Cf2py intent(in) NSIZE
Cf2py intent(out) DET

      DET = 1.
      DO 100 K=1,NORDER

        AMAX=0.
   21   DO 30 I=K,NORDER
          DO 30 J=K,NORDER
            IF(DABS(AMAX)-DABS(ARRAY(I,J))) 24,24,30
   24         AMAX=ARRAY(I,J)
              IK(K)=I
              JK(K)=J
   30       CONTINUE

        IF(AMAX) 41,32,41
   32     DET=0.
          GO TO 140

   41   I=IK(K)
        IF(I-K) 21,51,43
   43     DO 50 J=1,NORDER
            SAVE=ARRAY(K,J)
            ARRAY(K,J)=ARRAY(I,J)
   50       ARRAY(I,J)=-SAVE
   51   J=JK(K)
        IF(J-K) 21,61,53
   53     DO 60 I=1,NORDER
            SAVE=ARRAY(I,K)
            ARRAY(I,K)=ARRAY(I,J)
   60       ARRAY(I,J)=-SAVE

   61   DO 70 I=1,NORDER
          IF(I-K) 63,70,63
   63       ARRAY(I,K)=-ARRAY(I,K)/AMAX
   70     CONTINUE
        DO 80 I=1,NORDER
          DO 80 J=1,NORDER
            IF(I-K) 74,80,74
   74         IF(J-K) 75,80,75
   75           ARRAY(I,J)=ARRAY(I,J) + ARRAY(I,K)*ARRAY(K,J)
   80       CONTINUE
        DO 90 J=1,NORDER
          IF(J-K) 83,90,83
   83       ARRAY(K,J)=ARRAY(K,J)/AMAX
   90     CONTINUE
          ARRAY(K,K)=1./AMAX
  100   DET=DET*AMAX

      DO 130 L=1,NORDER
        K=NORDER - L +1
        J=IK(K)
        IF(J-K) 111,111,105
  105     DO 110 I=1,NORDER
            SAVE=ARRAY(I,K)
            ARRAY(I,K)=-ARRAY(I,J)
  110       ARRAY(I,J)=SAVE
  111   I=JK(K)
        IF(I-K) 130,130,113
  113     DO 120 J=1,NORDER
            SAVE=ARRAY(K,J)
            ARRAY(K,J)=-ARRAY(I,J)
  120       ARRAY(I,J)=SAVE
  130   CONTINUE
  140 return
      end


!!
!> @brief      Tools for quadrature
!!
!! Subroutine and functions to perform integrals
!!
!! @author     Rodrigo Navarro Perez
!!
module quadrature
use precisions, only: dp
implicit none

private
public :: booles_quadrature
contains

!!
!> @brief      Booles quadrature
!!
!! Given an array containing equidistant evaluations of a function and
!! the distance between evaluation points, uses the Booles rule to
!! calculate the integral of the evaluated function.
!!
!! Given the number of points necessary for the Booles rule, the
!! size of the array has to be a multiple of 4 minus 1
!!
!! @return     Integral of a function
!!
!! @author     Rodrigo Navarro Perez
!!
real(dp) function booles_quadrature(fx, delta_x) result(s)
    implicit none
    real(dp), intent(in), dimension(1:) :: fx !< Array of equidistant evaluations of a function
    real(dp), intent(in) :: delta_x !< distance between evaluation points

    integer :: fx_size, i

    fx_size = size(fx)

    if (mod(fx_size-1,4) /= 0) then
        print *, 'fx array size in booles_quadrature has to be a multiple of 4 plus 1'
        stop
    endif

    s = 0._dp

    do i=1,fx_size-1,4
        s = s + booles_rule(fx(i:i+4), delta_x)
    enddo
end function booles_quadrature

!!
!> @brief      Booles rule
!!
!! Given an array containing 5 equidistant evaluations of a function and
!! the distance between evaluation points, calculates Booles rule using those 5 points.
!!
!! @return     Booles rule for 5 points
!!
!! @author     Rodrigo Navarro Perez
!!
real(dp) function booles_rule(fx, delta_x) result(s)
    implicit none
    real(dp), intent(in), dimension(1:) :: fx !< Array of 5 equidistant evaluations of a function
    real(dp), intent(in) :: delta_x !< distance between evaluation points

    real(dp) :: fx0, fx1, fx2, fx3, fx4

    if( size(fx) /= 5 ) then
        print *, 'fx array size in booles_rule has to be 5'
        stop
    endif

    fx0 = fx(1)
    fx1 = fx(2)
    fx2 = fx(3)
    fx3 = fx(4)
    fx4 = fx(5)

    s = delta_x*2/45._dp*(7*fx4 + 32*fx3 + 12*fx2 + 32*fx1 + 7*fx0)
end function booles_rule

end module quadrature


      SUBROUTINE FRACCART(RA,RB,RC,RX11,RY11,RZ11)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!  converts fractional to cartesian cooridates
!!!!  NB This routine automatically shifts the cartessians to have their origin at
!!!!  the cell centre
!!!!  K.Travis 06/05/12 Univ. of Sheffield
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      USE header_file
      IMPLICIT NONE

      REAL(kind = double) :: RAT,RBT,RCT,RA,RB,RC,RX11,RY11,RZ11

      RAT = RA - 0.5D0
      RBT = RB - 0.5D0
      RCT = RC - 0.5D0
      RX11 = RAT*EFC(1,1) + RBT*EFC(1,2) + RCT*EFC(1,3)
      RY11 = RAT*EFC(2,1) + RBT*EFC(2,2) + RCT*EFC(2,3)
      RZ11 = RAT*EFC(3,1) + RBT*EFC(3,2) + RCT*EFC(3,3)

      END SUBROUTINE


module boss

    implicit none

    ! public boss_kernel

contains

pure function calc_angle(a, b, c) result(angle)

    implicit none

    double precision, intent(in), dimension(3) :: a
    double precision, intent(in), dimension(3) :: b
    double precision, intent(in), dimension(3) :: c

    double precision, dimension(3) :: v1
    double precision, dimension(3) :: v2

    double precision :: cos_angle
    double precision :: angle

    v1 = a - b
    v2 = c - b

    v1 = v1 / norm2(v1)
    v2 = v2 / norm2(v2)

    cos_angle = dot_product(v1,v2)

    ! Clipping
    if (cos_angle > 1.0d0) cos_angle = 1.0d0
    if (cos_angle < -1.0d0) cos_angle = -1.0d0

    angle = acos(cos_angle)

end function calc_angle

pure function calc_cos_angle(a, b, c) result(cos_angle)

    implicit none

    double precision, intent(in), dimension(3) :: a
    double precision, intent(in), dimension(3) :: b
    double precision, intent(in), dimension(3) :: c

    double precision, dimension(3) :: v1
    double precision, dimension(3) :: v2

    double precision :: cos_angle

    v1 = a - b
    v2 = c - b

    v1 = v1 / norm2(v1)
    v2 = v2 / norm2(v2)

    cos_angle = dot_product(v1,v2)

end function calc_cos_angle

function distance_matrix(coords) result(dmat)

    double precision, dimension(:,:), intent(in) :: coords

    double precision, allocatable, dimension(:,:) :: dmat

    integer :: n, i, j

    n = size(coords, dim=1)

    allocate(dmat(n,n))

    do i = 1, n
        do j = i, n

            dmat(i,j) = norm2(coords(i,:) - coords(j,:))
            dmat(j,i) = dmat(i,j)

        enddo
    enddo

end function distance_matrix

subroutine ang_cube(x, angmat)

    double precision, dimension(:,:), intent(in) :: x

    double precision, dimension(:,:,:) :: angmat

    double precision :: theta

    integer :: n, i, j, k

    n = size(x, dim=1)

    angmat = 0.0d0

    do i = 1, n
        do j = 1, n
            if (i == j) cycle

            do k = j+1, n
                if (i == k) cycle

                theta = calc_angle(x(j, :), x(i, :), x(k, :))

                ! write (*,*) i,j,k,theta
                angmat(i,j,k) = theta
                angmat(i,k,j) = theta

            enddo
        enddo
    enddo

end subroutine ang_cube

subroutine initialize_two_body(coords, charges, dmat, distance, scaling, counts, max_id, power)

    implicit none

    double precision, dimension(:,:), intent(in) :: coords
    integer, dimension(:), intent(in) :: charges
    double precision, dimension(:,:), intent(in) :: dmat

    double precision, dimension(:,:), intent(out) :: distance
    double precision, dimension(:,:), intent(out) :: scaling
    integer, dimension(:), intent(out) :: counts

    integer, intent(in) :: max_id
    double precision, intent(in) :: power

    integer :: i, j, n, key
    integer :: qi, qj

    n = size(charges)
    ! max_id = maxval(charges)

    distance = 0.0d0
    scaling  = 0.0d0
    counts   = 0

    do i = 1, n
        do j = i+1, n

            qi = charges(i)
            qj = charges(j)
            key = (min(qi, qj) - 1)*max_id + max(qi, qj)

            ! write (*,*) min(qi, qj), max(qi, qj), key, size(counts), size(distance, dim=1), size(distance, dim=2)

            counts(key) = counts(key) + 1
            ! write (*,*) key, counts(key), dmat(i,j)

            distance(key,counts(key)) = dmat(i,j)
            scaling(key,counts(key)) = dmat(i,j)**(-power)

        enddo
    enddo

    ! write (*,*) counts

    ! stop
end subroutine initialize_two_body

function two_body_kernel(two_body_distance1, two_body_scaling1, two_body_counts1, &
    two_body_distance2, two_body_scaling2, two_body_counts2, width) result(k)

    implicit none

    double precision, dimension(:,:) :: two_body_distance1
    double precision, dimension(:,:) :: two_body_scaling1
    integer, dimension(:) :: two_body_counts1

    double precision, dimension(:,:) :: two_body_distance2
    double precision, dimension(:,:) :: two_body_scaling2
    integer, dimension(:) :: two_body_counts2

    double precision :: width, cut
    double precision :: inv_width
    double precision :: k, mu, scaling, contrib

    double precision :: s11, s22, s12

    integer i, j, a, b

    cut = 4.0d0*width
    k = 0.0d0

    inv_width = -1.0d0 / (4.0d0 * width**2)

    ! j = 0

    do i = 1, size(two_body_counts1)

        if (two_body_counts1(i) < 1) cycle
        if (two_body_counts2(i) < 1) cycle

        do a = 1, two_body_counts1(i)
            do b = 1, two_body_counts2(i)

                mu = (two_body_distance1(i,a) - two_body_distance2(i,b))**2

                if (mu > cut) cycle
                scaling = two_body_scaling1(i,a) * two_body_scaling2(i,b)

                ! contrib = two_body_scaling1(i,a)**2 + two_body_scaling2(i,b)**2 - &
                !                 & 2.0d0 * exp(mu * inv_width) * scaling

                contrib = exp(mu * inv_width) * scaling
                ! s11 = lal

                k = k + contrib

                ! write (*,*), i, k, mu, scaling, contrib
                ! j = j + 1
            end do
        end do
    end do

    ! write (*,*) "TOTAL", j
end function two_body_kernel

subroutine initialize_three_body(coords, charges, dmat, angcube, distance, scaling, counts, max_id )

    implicit none

    double precision, dimension(:,:), intent(in) :: coords
    integer, dimension(:), intent(in) :: charges
    double precision, dimension(:,:), intent(in) :: dmat
    double precision, dimension(:,:,:), intent(in) :: angcube

    double precision, dimension(:,:), intent(out) :: distance
    double precision, dimension(:,:), intent(out) :: scaling
    integer, dimension(:), intent(out) :: counts

    integer :: i, j, n, max_id, key, k
    integer :: qi, qj, qk

    double precision :: factor

    n = size(charges)

    distance = 0.0d0
    scaling  = 0.0d0
    counts   = 0

    do i = 1, n
        do j = 1, n
        if (i == j) cycle
            do k = j+1, n
                if (i == k) cycle

                qi = charges(i)
                qj = charges(j)
                qk = charges(k)
                key = three2key(qi, min(qj, qk), max(qj, qk), max_id)

                ! write (*,*) qi, min(qj, qk), max(qj, qk), key, size(counts), size(distance, dim=1), size(distance, dim=2)

                counts(key) = counts(key) + 1
                ! write (*,*) key, counts(key), angcube(i,j,k)
            !
                distance(key,counts(key)) = angcube(i,j,k)

                factor = (1.0d0 + 3.0d0 * cos(angcube(i,j,k))  * cos(angcube(k,i,j))  &
                       & * cos(angcube(j,k,i))) / (dmat(i,j) * dmat(j,k) * dmat(k,i))**3
                scaling(key,counts(key)) = factor

            enddo
        enddo
    enddo

    ! write (*,*) counts

    ! stop
end subroutine initialize_three_body

subroutine print_occurences(nuclear_charges, occurences)

    implicit none

    integer, dimension(:,:), intent(in) :: nuclear_charges

    integer, dimension(120), intent(out) :: occurences
    integer, dimension(120) :: occurences_local

    integer :: a, i

    integer :: nm
    integer :: na

    integer :: q

    occurences(:) = 0

    na = size(nuclear_charges, dim=1)
    nm = size(nuclear_charges, dim=2)

    ! write (*,*) nm

    do a = 1, nm

        occurences_local = 0
        do i = 1, na

            q = nuclear_charges(i,a)

            if (q < 1) then
                exit
            endif

            occurences_local(q) = occurences_local(q) + 1

        enddo
        do i = 1, size(occurences)
            occurences(i) = max(occurences(i), occurences_local(i))
        enddo

    enddo

    ! do i = 1, size(occurences)

    !     if (occurences(i) > 0) write (*,*) i, occurences(i)

    ! enddo

end subroutine print_occurences

subroutine translate_charges(nuclear_charges, occurences)

    implicit none

    integer, dimension(:,:), intent(inout) :: nuclear_charges
    integer, dimension(120), intent(in) :: occurences

    integer, dimension(120) :: map

    integer :: max_id, i, a

    integer :: nm
    integer :: na

    integer :: q

    na = size(nuclear_charges, dim=1)
    nm = size(nuclear_charges, dim=2)

    map = 0
    max_id = 0
    do i = 1, size(occurences)

        if (occurences(i) > 0) then

            max_id = max_id + 1
            map(i) = max_id
        endif
    enddo

    ! rite (*,*) map

    do a = 1, nm
        do i = 1, na
            q = nuclear_charges(i,a)

            if (q < 1) then
                exit
            endif

            nuclear_charges(i,a) = map(q)

        enddo
    enddo

end subroutine translate_charges

function three2key(a, b, c, max_id) result(key)

    implicit none

    integer, intent(in) :: a, b, c, max_id
    integer :: key

    key = (a-1)*max_id**2 + (b-1)*max_id + c

end function three2key

!function unique_two_body(nuclear_charges) result(unique)

!end function unique_two_body

end module boss

subroutine boss_kernel(X1, X2, nm1, nm2, sigma, d_width, d_power, k)

    use boss, only: distance_matrix, ang_cube, initialize_two_body, two_body_kernel, &
        & initialize_three_body, print_occurences, translate_charges

    implicit none

    double precision, dimension(:,:,:), intent(in) :: X1
    double precision, dimension(:,:,:), intent(in) :: X2

    integer, intent(in) :: nm1, nm2

    double precision, dimension(:,:,:), allocatable :: coordinates1
    double precision, dimension(:,:,:), allocatable :: coordinates2

    integer, dimension(:,:), allocatable :: nuclear_charges1
    integer, dimension(:,:), allocatable :: nuclear_charges2

    double precision, dimension(nm1,nm2), intent(out) :: k

    double precision, dimension(:,:), allocatable :: dmat1
    double precision, dimension(:,:), allocatable :: dmat2

    double precision, allocatable, dimension(:,:,:) :: two_body_distance1
    double precision, allocatable, dimension(:,:,:) :: two_body_scaling1
    integer, allocatable, dimension(:,:) :: two_body_counts1

    double precision, allocatable, dimension(:,:,:) :: two_body_distance2
    double precision, allocatable, dimension(:,:,:) :: two_body_scaling2
    integer, allocatable, dimension(:,:) :: two_body_counts2

    integer :: max_id
    integer :: max_size
    integer :: max_two_body
    integer :: max_three_body

    double precision, parameter :: pi = 4.d0 * atan(1.d0)

    double precision, intent(in) :: d_width
    double precision, intent(in) :: d_power
    double precision, intent(in) :: sigma

    double precision, parameter :: t_width = 0.2d0

    logical, parameter :: three = .false.

    double precision, parameter :: t_weight = 0.0d0

    double precision, dimension(nm1) :: s11
    double precision, dimension(nm2) :: s22

    double precision :: s12
    double precision :: l2

    integer, dimension(:), allocatable :: n1, n2

    integer :: na1, na2

    integer :: a, b, i

    double precision :: v, rho

    double precision, dimension(:,:,:), allocatable :: acube1
    double precision, dimension(:,:,:), allocatable :: acube2

    double precision, allocatable, dimension(:,:,:) :: three_body_distance1
    double precision, allocatable, dimension(:,:,:) :: three_body_scaling1
    integer, allocatable, dimension(:,:) :: three_body_counts1

    double precision, allocatable, dimension(:,:,:) :: three_body_distance2
    double precision, allocatable, dimension(:,:,:) :: three_body_scaling2
    integer, allocatable, dimension(:,:) :: three_body_counts2

    integer, dimension(120) :: max_occurences
    integer, dimension(120) :: occurences1
    integer, dimension(120) :: occurences2

    max_size = max(size(X1, dim=3),size(X2, dim=3))

    allocate(nuclear_charges1(max_size,nm1))
    allocate(nuclear_charges2(max_size,nm2))

    allocate(n1(nm1))
    allocate(n2(nm2))

    n1 = 0
    n2 = 0
    nuclear_charges1 = -1
    nuclear_charges2 = -1

    max_id = 0
    do a = 1, nm1
        do i = 1, max_size
            if (X1(a,1,i) > 0) then
                nuclear_charges1(i,a) = int(X1(a,1,i))
                n1(a) = n1(a) + 1
                max_id = max(max_id, nuclear_charges1(i,a))
            endif
        enddo
    enddo

    do a = 1, nm2
        do i = 1, max_size
            if (X2(a,1,i) > 0) then
                nuclear_charges2(i,a) = int(X2(a,1,i))
                n2(a) = n2(a) + 1
                max_id = max(max_id, nuclear_charges2(i,a))
            endif
        enddo
    enddo

    call print_occurences(nuclear_charges1, occurences1)
    call print_occurences(nuclear_charges2, occurences2)

    max_occurences = 0

    do i = 1, size(max_occurences)
        max_occurences(i) = max(occurences1(i), occurences2(i))

    enddo

    call translate_charges(nuclear_charges1, max_occurences)
    call translate_charges(nuclear_charges2, max_occurences)

    ! write (*,*) max_occurences
    max_id = max(maxval(nuclear_charges1), maxval(nuclear_charges2))
    ! write (*,*) max_id

    ! stop

    max_two_body = max(maxval(n1), maxval(n2))

    max_two_body = max_two_body * (max_two_body - 1)

    allocate(two_body_distance1(max_id**2, max_two_body,nm1))
    allocate(two_body_distance2(max_id**2, max_two_body,nm2))
    allocate(two_body_scaling1(max_id**2, max_two_body,nm1))
    allocate(two_body_scaling2(max_id**2, max_two_body,nm2))
    allocate(two_body_counts1(max_id**2,nm1))
    allocate(two_body_counts2(max_id**2,nm2))

    two_body_distance1 = 0.0d0
    two_body_distance2 = 0.0d0
    two_body_scaling1 = 0.0d0
    two_body_scaling2 = 0.0d0
    two_body_counts1 = 0
    two_body_counts2 = 0

    if (three) then
        max_three_body = max(maxval(n1), maxval(n2))**3

        allocate(three_body_distance1(max_id**3, max_three_body,nm1))
        allocate(three_body_distance2(max_id**3, max_three_body,nm2))
        allocate(three_body_scaling1(max_id**3,  max_three_body,nm1))
        allocate(three_body_scaling2(max_id**3,  max_three_body,nm2))
        allocate(three_body_counts1(max_id**3,nm1))
        allocate(three_body_counts2(max_id**3,nm2))

        three_body_distance1 = 0.0d0
        three_body_distance2 = 0.0d0
        three_body_scaling1 = 0.0d0
        three_body_scaling2 = 0.0d0
        three_body_counts1 = 0
        three_body_counts2 = 0

        allocate(acube1(maxval(n1(:)),maxval(n1(:)),maxval(n1(:))))
        allocate(acube2(maxval(n2(:)),maxval(n2(:)),maxval(n2(:))))

        acube1 = 0.0d0
        acube2 = 0.0d0

    endif

    allocate(dmat1(maxval(n1(:)),maxval(n1(:))))
    allocate(dmat2(maxval(n2(:)),maxval(n2(:))))

    dmat1 = 0.0d0
    dmat2 = 0.0d0

    !$OMP PARALLEL DO PRIVATE(dmat1,acube1)
    do a = 1, nm1

        dmat1(:,:) = distance_matrix(transpose(X1(a,2:4,:n1(a))))

        call initialize_two_body(transpose(X1(a,2:4,:n1(a))), nuclear_charges1(:n1(a),a), dmat1(:n1(a),:n1(a)), &
         & two_body_distance1(:,:,a), two_body_scaling1(:,:,a), two_body_counts1(:,a), max_id, d_power)

        s11(a) =  two_body_kernel( &
            & two_body_distance1(:,:,a), two_body_scaling1(:,:,a), two_body_counts1(:,a), &
            & two_body_distance1(:,:,a), two_body_scaling1(:,:,a), two_body_counts1(:,a), d_width)

        if (three) then
            call  ang_cube(transpose(X1(a,2:4,:n1(a))), acube1)

            call initialize_three_body(transpose(X1(a,2:4,:n1(a))), nuclear_charges1(:n1(a),a), dmat1(:n1(a),:n1(a)), acube1, &
                 & three_body_distance1(:,:,a), three_body_scaling1(:,:,a), three_body_counts1(:,a), max_id)

            s11(a) = s11(a) + t_weight * two_body_kernel( &
                & three_body_distance1(:,:,a), three_body_scaling1(:,:,a), three_body_counts1(:,a), &
                & three_body_distance1(:,:,a), three_body_scaling1(:,:,a), three_body_counts1(:,a), t_width)
        endif

    enddo
    !$OMP END PARALLEL DO

    !$OMP PARALLEL DO private(dmat2, acube2)
    do a = 1, nm2
        dmat2(:,:) = distance_matrix(transpose(X2(a,2:4,:n2(a))))

        call initialize_two_body(transpose(X2(a,2:4,:n2(a))), nuclear_charges2(:n2(a),a), dmat2(:n2(a),:n2(a)), &
            & two_body_distance2(:,:,a), two_body_scaling2(:,:,a), two_body_counts2(:,a), max_id, d_power)

        s22(a) =  two_body_kernel( &
            & two_body_distance2(:,:,a), two_body_scaling2(:,:,a), two_body_counts2(:,a), &
            & two_body_distance2(:,:,a), two_body_scaling2(:,:,a), two_body_counts2(:,a), d_width)

        if (three) then
            call  ang_cube(transpose(X2(a,2:4,:n2(a))), acube2)

            call initialize_three_body(transpose(X2(a,2:4,:n2(a))), nuclear_charges2(:n2(a),a), dmat2(:n2(a),:n2(a)), acube2, &
                & three_body_distance2(:,:,a), three_body_scaling2(:,:,a), three_body_counts2(:,a), max_id)

            s22(a) = s22(a) + t_weight * two_body_kernel( &
                & three_body_distance2(:,:,a), three_body_scaling2(:,:,a), three_body_counts2(:,a), &
                & three_body_distance2(:,:,a), three_body_scaling2(:,:,a), three_body_counts2(:,a), t_width)
        endif

    enddo
    !$OMP END PARALLEL DO

    k = 0.0d0

    !$OMP PARALLEL DO PRIVATE(s12,l2) schedule(dynamic)
    do a = 1, nm1
        do b = 1, nm2

        s12 =  two_body_kernel( &
            & two_body_distance1(:,:,a), two_body_scaling1(:,:,a), two_body_counts1(:,a), &
            & two_body_distance2(:,:,b), two_body_scaling2(:,:,b), two_body_counts2(:,b), d_width)

        if (three) then
            s12 = s12 + t_weight * two_body_kernel( &
                & three_body_distance1(:,:,a), three_body_scaling1(:,:,a), three_body_counts1(:,a), &
                & three_body_distance2(:,:,b), three_body_scaling2(:,:,b), three_body_counts2(:,b), t_width)
        endif

            l2 = s11(a) + s22(b) - 2.0d0 * s12

            k(a,b) = exp( - l2 / (2.0d0 * sigma**2))

            ! Cauchy (10% better than Gaussian)
            ! k(a,b) = 1.0d0 / (1.0d0 + l2/(sigma**2))

            ! Inverse Multiquadratic Kernel (10% better than Gaussian)
            ! k(a,b) = 1.0d0 / sqrt(l2 + sigma)

            ! v = 1/2 (sucks balls)
            ! k(a,b) = exp(-sqrt(l2) /sigma)

            ! v = 3/2 (20% worse than Gaussian)
            ! k(a,b) = (1.0d0 + (sqrt(3.0d0) * sqrt(l2) / sigma)) * exp(-sqrt(3.0d0) * sqrt(l2) /sigma)

            ! v = 5/2 (10% worse than Gaussian)
            ! k(a,b) = (1.0d0 + (sqrt(5.0d0) * sqrt(l2) / sigma) &
            !    & + (5.0d0 * l2 / (3.0d0 * sigma**2))) * exp(-sqrt(5.0d0) * sqrt(l2) /sigma)

        enddo
    enddo
    !$OMP END PARALLEL DO

    deallocate(nuclear_charges1)
    deallocate(nuclear_charges2)
    deallocate(n1)
    deallocate(n2)

    deallocate(two_body_distance1)
    deallocate(two_body_distance2)
    deallocate(two_body_scaling1)
    deallocate(two_body_scaling2)
    deallocate(two_body_counts1)
    deallocate(two_body_counts2)

    deallocate(dmat1)
    deallocate(dmat2)

    if (three) then

        deallocate(three_body_distance1)
        deallocate(three_body_distance2)
        deallocate(three_body_scaling1)
        deallocate(three_body_scaling2)
        deallocate(three_body_counts1)
        deallocate(three_body_counts2)

        deallocate(acube1)
        deallocate(acube2)

    endif

end subroutine boss_kernel


************************************************************************
*
*     Function EXPVAR                               Called by: TAC_LOAD
*
*     Estimate covariance of two EXPON estimators of the form
*     EXPON(SIGMA^2,A,B), assuming that SIGMA^2 is a
*     GAMMA(ALPHA,S2*BETA) random variable (where BETA is a parameter
*     = 2/(N-1) in standard model)
*
*     result is exact aside from machine error
*
*     S2        sample estimate of SIGMA^2
*     ALPHA     parameter of gamma distribution = (N-1)/2 in std.model
*     A1        1st coefficient in front of SIGMA^2
*     B1        1st coefficient in front of SIGMA
*     A2        2nd coefficient in front of SIGMA^2
*     B2        2nd coefficient in front of SIGMA
*
************************************************************************
      DOUBLE PRECISION FUNCTION EXPVAR(S2,ALPHA,A1,B1,A2,B2)
*
*     subroutine args
*
      DOUBLE PRECISION S2,ALPHA,A1,B1,A2,B2
*
*     local vars
*
      INTEGER*4 I,J,N
      DOUBLE PRECISION ARG,A,SIGMA,TOL,TSUM,DELTA
      DOUBLE PRECISION C1(0:1000),C2(0:1000),GAMM(0:1000)
      DATA TOL/1.D-6/
*
*     function declaration
*
      DOUBLE PRECISION DLNGAM
*
*
*
      SIGMA = SQRT(S2)

      ARG = MAX(ABS(A1)*S2+ABS(B1)*SIGMA,ABS(A2)*S2+ABS(B2)*SIGMA)
      A=MAX(ABS(A1),ABS(A2))
      N = MIN(998.D0,
     &        30.D0+ARG*(5.4-0.2*ARG+A
     &        *(8.28-1.11*A+1.98*ARG)+1.33*(MAX(ABS(B1),ABS(B2)))))

 10   EXPVAR = 0.D0
      CALL SQUARE(N,A1,B1,C1)
      CALL SQUARE(N,A2,B2,C2)

      GAMM(0) = 1.D0
      GAMM(1) = EXP(DLNGAM(ALPHA+0.5D0)-DLNGAM(ALPHA))
      DO 30 J=0,N
         GAMM(J+2) = (ALPHA+0.5D0*J)*GAMM(J)
         TSUM = 0.D0
         DO 20 I=0,J
            TSUM = TSUM+C1(I)*C2(J-I)*GAMM(J)/(GAMM(I)*GAMM(J-I))
 20      CONTINUE
         DELTA = SIGMA**J*TSUM
         EXPVAR = EXPVAR+DELTA
 30   CONTINUE
      IF (DELTA.LE.TOL*EXPVAR) RETURN

 40   N = N+10
      IF (N.LT.998) GOTO 10
*
*     Error: failure to converge in 998 terms
*
      CALL ERROR7(12)

      RETURN
      END


real function afgen(table,iltab,x)
! ----------------------------------------------------------------------
!     source             : kees rappoldt, 1/86
!     purpose            : linear interpolation in table table with
!                          length iltab for a given value of the
!                          independent variable x.
! ----------------------------------------------------------------------
      implicit none

      integer i,iltab
      real  table(iltab),slope,x
! ----------------------------------------------------------------------
      if (table(1).ge.x)  goto 40
      do 10 i = 3,iltab-1,2
        if (table(i).ge.x) goto 30
        if (table(i).lt.table(i-2)) goto 20
 10   continue
! --- table fully filled, argument larger then last x in table
      afgen = table(iltab)
      return
! --- table partly filled, argument larger then last x in table
 20   afgen = table(i-1)
      return
! --- argument between first and last x in table, interpolation
 30   slope = (table(i+1)-table(i-1))/(table(i)-table(i-2))
      afgen = table(i-1) + (x-table(i-2))*slope
      return
! --- argument less or equal to first x in table
 40   afgen = table(2)
      return
    end

real function fgrowth(d,wend,wini,tb,tm,te,t,delta)

    !--- A flexible sigmoid function of determinate growth.
    !--- https://doi.org/10.1093/aob/mcg029

    implicit none

    !--- Input parameters
    integer d               ! Derivative type (Integral form [d=0], 1st derivative [d=1]), 1st + CM = 1 [d=2]
    real    wini            ! Min weight at ini time of growth (tb)
    real    wend            ! Max weight at end time of growth (te)
    real    tb              ! Initial time of growth (usually = 0)
    real    tm              ! Time of maximun growth rate
    real    te              ! Time for growth end
    real    t               ! Current time
    real    delta           ! Asymmetry shape factor

    !--- Variables
    real    cm              ! Maximum Growth Rate [dw/dt]

    !--- Outputs
    real    w               ! Current Biomass in time t
    real    dw              ! Current Growth Rate in time t [dw/dt]

    !--- Initialize Variables & Outputs
    cm  = 0.d0
    w   = 0.d0
    dw  = 0.d0

    select case(d)

    case (0)

        !--- Integral Form
        if(t .ge. te)then
            w   = wend
        elseif(t .le. tb)then
            w   = wini
        else
            w   = wini + (wend - wini) * (1.d0 + (te-t)/(te-tm)) * (t/te)**(te/(te-tm))
        endif

        fgrowth = w
        return

    case (1)
        !--- 1st Derivative Form
        if(t .ge. te .or. t .le. tb)then
            !--- No dev out of te-tb range
            dw  = 0.d0
        else
            cm  = (2.d0 * te - tm) / (te * (te-tm)) * (tm / te) ** (tm/(te-tm)) * (wend - wini)
            dw  = cm * (((te-t)/(te-tm)) * ((t-tb)/(tm-tb))**((tm-tb)/(te-tm))) ** delta
        endif

        fgrowth = dw

        return

    case (2)

        !--- 1st Derivative + cm = 1 for relative process rate modeling
        if(t .ge. te .or. t .le. tb)then
            !--- No dev out of te-tb range
            dw  = 0.d0
        else
            cm  = 1.d0
            dw  = cm * (((te-t)/(te-tm)) * ((t-tb)/(tm-tb))**((tm-tb)/(te-tm))) ** delta
        endif

        !--- Set minimum and maximum values
        dw  = dw * (wend - wini) + wini

        fgrowth = dw

        return

    end select

end

real function asy_ws(max_ws, min_ws, t_max_ws, t_mid_ws, t_min_ws, watdmd)
! ----------------------------------------------------------------------
!     source             : Yu. Asymptote curve to model water stress
! ----------------------------------------------------------------------
      implicit none

      real  max_ws, min_ws, t_max_ws, t_mid_ws, t_min_ws
      real  watdmd

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

      if(watdmd .ge. t_min_ws)then

          !--- Optimun water conditions
          asy_ws = min_ws

      else if(watdmd .le. t_max_ws)then

          !--- Extreme drought
          asy_ws = max_ws

      else

          !--- Transient water stress
          asy_ws = max_ws + (min_ws - max_ws) * (1.d0 + (t_min_ws - watdmd) / (t_min_ws - t_mid_ws)) * (((watdmd - t_max_ws)/(t_min_ws - t_max_ws)) ** ((t_min_ws - t_max_ws) / (t_min_ws - t_mid_ws)))

      endif

      return
    end

real function it_struc_pfac(it_struc_tb_ini,            &   ! Input Parameter
                            it_struc_to1,               &   ! Input Parameter
                            it_struc_to2,               &   ! Input Parameter
                            it_struc_tb_end,            &   ! Input Parameter
                            it_struc_pfac_temp_max_red, &   ! Input Parameter
                            it_struc_pfac_wate_max_red, &   ! Input Parameter
                            it_struc_pfac_max,          &   ! Input Parameter
                            it_struc_pfac_min,          &   ! Input Parameter
                            it_struc_pfac_tb,           &   ! Input Parameter
                            it_struc_pfac_tm,           &   ! Input Parameter
                            it_struc_pfac_te,           &   ! Input Parameter
                            it_struc_pfac_delta,        &   ! Input Parameter
                            it_age,                     &   ! Input Variable
                            t,                          &   ! Input Variable
                            swfacf)                         ! Input Variable

    !------------------------------------------------!
    !--- Internode Structural Partitioning Factor ---!
    !------------------------------------------------!

    !--- Required Functions:
    !---    temperature_factor()
    !---    fgrowth()

    !--- MSV, Mar-2019
    !------------------------------------------------!

    implicit none

    !--- Input parameters
    real it_struc_tb_ini
    real it_struc_to1
    real it_struc_to2
    real it_struc_tb_end
    real it_struc_pfac_temp_max_red
    real it_struc_pfac_wate_max_red

    real it_struc_pfac_max
    real it_struc_pfac_min
    real it_struc_pfac_tb
    real it_struc_pfac_tm
    real it_struc_pfac_te
    real it_struc_pfac_delta

    !--- Input Variables
    real t
    real swfacf
    real it_age

    !--- Local variables
    real it_struc_tfac
    real it_struc_wfac
    real it_struc_pfac_red

    !--- Required Functions
    real temperature_factor
    real fgrowth

    !--- Relative reduction of biomass partitioning to structural due to non-optimum temperature condition
    it_struc_tfac   = (1.d0 - temperature_factor(   t,				&
                                                    it_struc_tb_ini,&
                                                    it_struc_to1,   &
                                                    it_struc_to2,   &
                                                    it_struc_tb_end))

    !--- Absolute reduction of biomass partitioning to structural due to non-optimum temperature condition
    it_struc_tfac   = it_struc_tfac * min(it_struc_pfac_temp_max_red, (it_struc_pfac_max - it_struc_pfac_min))

    !--- Relative reduction of biomass partitioning to structural due to non-optimum soil moisture condtition
    it_struc_wfac   = (1.d0 - swfacf) ! Following doi.org/10.1071/CP10182

    !--- Absolute reduction of biomass partitioning to structural due to non-optimum soil moisture condtition
    it_struc_wfac   = it_struc_wfac * min(it_struc_pfac_wate_max_red, (it_struc_pfac_max - it_struc_pfac_min))

    !--- Overall absolute reduction of biomass partitioning to structural tissues due to temperature and soil moisture condition
    it_struc_pfac_red = max(it_struc_tfac, it_struc_wfac)

    !--- Partitioning factor to structural tissues considering temperature and soil moisture conditions
    it_struc_pfac   = fgrowth(2,  (it_struc_pfac_max - it_struc_pfac_red),&
                                    it_struc_pfac_min,                    &
                                    it_struc_pfac_tb,                     &
                                    it_struc_pfac_tm,                     &
                                    it_struc_pfac_te,                     &
                                    it_age,                               &
                                    it_struc_pfac_delta)

    !--- Check Bounds (0-1)
    if(it_struc_pfac .lt. 0.d0)then

        !--- Limit to zero for carbon balance (WRG)
        it_struc_pfac = 0.d0
        write(*,*) "Structural Partitioning Factor Limited to Zero (0.d0 < it_struc_pfac < 1.0d0)."

    else if(it_struc_pfac .gt. 1.d0)then

        !--- Limit to unit for carbon balance (WRG)
        it_struc_pfac = 1.d0
        write(*,*) "Structural Partitioning Factor Limited to Unit (0.d0 < it_struc_pfac < 1.0d0)."

    endif

    return

    end

real function temperature_factor(t,tb_ini,to1,to2,tb_end)

    !--------------------------!
    !--- Temperature Factor ---!
    !--------------------------!

    !--- Compute The Relative Reduction Factor Due to Temperature Based on cardinal temperatures (trapeze shape)

    !--- Input Parameters:
    !---    tb_ini          Minimum temperature for process rate
    !---    to1             Temperature threshold onset of optimun condition
    !---    to2             Temperature threshold end of optimun condition
    !---    tb_end          Maximum temperature for process rate

    !--- MSV, Mar-2019
    !--------------------------!

    implicit none

    !--- Input parameters
    real    tb_ini
    real    to1
    real    to2
    real    tb_end

    !--- Input data
    real    t

    !--- Local Variables
    real    t_fac

    !--- Compute Temperature Factor
    if(t .le. tb_ini .or. t .ge. tb_end)then

        !--- Out of the Temperature limits range (tb_ini,tb_end)
        t_fac   = 0.d0

    elseif(t .ge. to1 .and. t .le. to2)then

        !--- Within optimun Temperature range (to1,to2)
        t_fac   = 1.d0

    elseif(t .gt. tb_ini .and. t .lt. to1)then

        !--- Within Lower Meso-Optimun Temperature range (tb_ini, to1)
        t_fac   = (t - tb_ini) / (to1 - tb_ini)

    else

        !--- Within Upper Meso-Optimun Temperature range (to2, tb_end)
        t_fac   = 1.d0 - (t - to2) / (tb_end - to2)

    endif

    !--- return
    temperature_factor = t_fac
    return

    end

real function tiller_senes(dw,nstk,dnstk,tilleragefac,tillerageprof,atln)

    Implicit none

    integer tl
    integer atln
    real    dw
    real    nstk
    real    dnstk
    real    tilleragefac
    real    tillerageprof(100,2)

    real    dw_ref_till
    real    virt_dw_ref_till
    real    corr_fac_dead
    real    young_till_dw
    real    dead_biomass

    !--- Initalize
    dead_biomass = 0.d0

    if((nstk * tilleragefac) .gt. 0.d0 .and. dw .gt. 0.d0)then

        !--- Convert to g/m2
        dw      = dw * (1.e6/1.e4)

        !--- Dry biomass per reference tiller [g tiller-1]
        dw_ref_till  =   dw / (nstk * tilleragefac)

        !--- Biomass for each tiller according to its age
        virt_dw_ref_till = 0.d0
        do tl = 1, atln
            virt_dw_ref_till =   virt_dw_ref_till + tillerageprof(tl,2) * dw_ref_till
        enddo

        !--- Correction Factor to meet carbon balance
        corr_fac_dead =  dw / virt_dw_ref_till

        !--- Biomass elegible for die [g m-2] (Youngest Tiller)
        young_till_dw = tillerageprof(atln,2) * dw_ref_till * corr_fac_dead

        !--- Dead Biomass [ton ha-1]
        dead_biomass = max(0.d0, young_till_dw * abs(dnstk) * (1.e4 / 1.e6))

        !--- Return DW to original unit (FORTRAN has this "side effect" of altering the function input argument)
        dw  =   dw * (1.e4/1.e6)

    endif
        tiller_senes    =     dead_biomass

    return

    end


c..pentadiagonal
c..routine pentdag solves pentadiagonal systems
      subroutine pentdiag(d,f,u,n)
      implicit none
      double precision d(n,5),f(n),u(n)
      integer n
      call pentdag(d(:,1),d(:,2),d(:,3),d(:,4),d(:,5),f,u,n)
      endsubroutine

      subroutine pentdag(a,b,c,d,e,f,u,n)
      implicit none

c..solves for a vector u of length n in the pentadiagonal linear system
c.. a_i u_(i-2) + b_i u_(i-1) + c_i u_i + d_i u_(i+1) + e_i u_(i+2) = f_i
c..input are the a, b, c, d, e, and f and they are not modified
      integer          n, i
      double precision a(n),b(n),c(n),d(n),e(n),f(n),u(n)
      double precision p(n),q(n),bet,den

c..initialize elimination and backsubstitution arrays
      if (c(1) .eq. 0.0)  stop 'eliminate u2 trivially'
      bet  = 1.0d0/c(1)
      p(1) = -d(1) * bet
      q(1) = -e(1) * bet
      u(1) = f(1)  * bet

      bet = c(2) + b(2)*p(1)
      if (bet .eq. 0.0) stop 'singular 1 in pentdag'
      bet = -1.0d0/bet
      p(2) = (d(2) + b(2)*q(1)) * bet
      q(2) = e(2) * bet
      u(2) = (b(2)*u(1) - f(2)) * bet

c..reduce to upper triangular
      do i=3,n
       bet = b(i) + a(i) * p(i-2)
       den = c(i) + a(i)*q(i-2) + bet*p(i-1)
       if (den .eq. 0.0) stop 'singular 2 in pentdag'
       den = -1.0d0/den
       p(i) = (d(i) + bet*q(i-1)) * den
       q(i) = e(i) * den
       u(i) = (a(i)*u(i-2) + bet*u(i-1) - f(i)) * den
      enddo

c..backsubstitution
      u(n-1) = u(n-1) + p(n-1) * u(n)
      do i=n-2,1,-1
       u(i) = u(i) + p(i) * u(i+1) + q(i) * u(i+2)
      enddo
      return
      endsubroutine


program newtonMethod
    implicit none
    integer :: i, n
    real(8)    :: y(30), x(30), r(30), J(30,4)
    real(8)    :: beta(4), betaOld(4),sol(4), inverz(4,4)
    real(8)    :: eta0, etainf, tau, rr, eta, S
    open(10,file = "podatki2.dat",status = "old")
    do i = 1, 30
        read(10,*) y(i), x(i)
    end do
    close(10)

    !zacetni priblizek
    eta0   = 5.0
    etainf = 6.0
    tau    = 0.005
    rr     = 0.6

    beta = (/eta0,etainf,tau,rr/)
    print*, "beta", beta

    !zacetna vrednost rešitve
    sol(1:4)=(/1.0e0,1.0e0,1.0e0,1.0e0/)

    n = 0
    do while (any(sol>1.0d-6) .and. n < 100)

        !vrednosti funkcij, morajo biti enake 0, tu primerjave izmerjene z izracunano
        do i = 1, 30
            r(i) = y(i) - eta(x(i),beta(1),beta(2),beta(3),beta(4))
        end do
        S = sum(r(:)**2)

        print*,"S",S

        !izracunan Jacobijeve matrike
        do i = 1, 30
            J(i,1) = exp(-(x(i)/beta(3))**beta(4))
            J(i,2) = 1.0 - exp(-(x(i)/beta(3))**beta(4))
            J(i,3) = (beta(4)*(beta(1)-beta(2))*exp(-(x(i)/beta(3))**beta(4))*(x(i)/beta(3))**beta(4))/beta(3)
            J(i,4) = (beta(1)-beta(2))*log(x(i)/beta(3))*exp(-(x(i)/beta(3))**beta(4))*(x(i)/beta(3))**beta(4)
        end do

        betaOld = beta

        call inverse(matmul(transpose(J),J),inverz,4)

        beta = beta - matmul(matmul(inverz,transpose(J)),r)

        print*, "beta", beta
        sol=abs((beta - betaOld)/beta)

        N=N+1
    end do

end program newtonMethod

function eta(x,eta0,etainf,tau,r)
    implicit none
    real(8):: eta,eta0,etainf,tau,r,x

    eta = eta0-(eta0-etainf)*(1.0e0-exp(-((x/tau)**r)))

end function eta

subroutine inverse(a,c,n)
!============================================================
! Inverse matrix
! Method: Based on Doolittle LU factorization for Ax=b
! Alex G. December 2009
!-----------------------------------------------------------
! input ...
! a(n,n) - array of coefficients for matrix A
! n      - dimension
! output ...
! c(n,n) - inverse matrix of A
! comments ...
! the original matrix a(n,n) will be destroyed
! during the calculation
!===========================================================
implicit none
integer, intent(in):: n
real(8) :: a(n,n)
real(8),intent(out):: c(n,n)
real(8):: L(n,n), U(n,n), b(n), d(n), x(n)
real(8):: coeff
integer:: i, j, k

! step 0: initialization for matrices L and U and b
! Fortran 90/95 allows such operations on matrices
L=0.0d0
U=0.0d0
b=0.0d0

! step 1: forward elimination
do k=1, n-1
   do i=k+1,n
      coeff=a(i,k)/a(k,k)
      L(i,k) = coeff
      do j=k+1,n
         a(i,j) = a(i,j)-coeff*a(k,j)
      end do
   end do
end do

! Step 2: prepare L and U matrices
! L matrix is a matrix of the elimination coefficient
! + the diagonal elements are 1.0
do i=1,n
  L(i,i) = 1.0d0
end do
! U matrix is the upper triangular part of A
do j=1,n
  do i=1,j
    U(i,j) = a(i,j)
  end do
end do

! Step 3: compute columns of the inverse matrix C
do k=1,n
  b(k)=1.0
  d(1) = b(1)
! Step 3a: Solve Ld=b using the forward substitution
  do i=2,n
    d(i)=b(i)
    do j=1,i-1
      d(i) = d(i) - L(i,j)*d(j)
    end do
  end do
! Step 3b: Solve Ux=d using the back substitution
  x(n)=d(n)/U(n,n)
  do i = n-1,1,-1
    x(i) = d(i)
    do j=n,i+1,-1
      x(i)=x(i)-U(i,j)*x(j)
    end do
    x(i) = x(i)/u(i,i)
  end do
! Step 3c: fill the solutions x(n) into column k of C
  do i=1,n
    c(i,k) = x(i)
  end do
  b(k)=0.0d0
end do
end subroutine inverse


*> \brief \b CCHKBB
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CCHKBB( NSIZES, MVAL, NVAL, NWDTHS, KK, NTYPES, DOTYPE,
*                          NRHS, ISEED, THRESH, NOUNIT, A, LDA, AB, LDAB,
*                          BD, BE, Q, LDQ, P, LDP, C, LDC, CC, WORK,
*                          LWORK, RWORK, RESULT, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT,
*      $                   NRHS, NSIZES, NTYPES, NWDTHS
*       REAL               THRESH
*       ..
*       .. Array Arguments ..
*       LOGICAL            DOTYPE( * )
*       INTEGER            ISEED( 4 ), KK( * ), MVAL( * ), NVAL( * )
*       REAL               BD( * ), BE( * ), RESULT( * ), RWORK( * )
*       COMPLEX            A( LDA, * ), AB( LDAB, * ), C( LDC, * ),
*      $                   CC( LDC, * ), P( LDP, * ), Q( LDQ, * ),
*      $                   WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CCHKBB tests the reduction of a general complex rectangular band
*> matrix to real bidiagonal form.
*>
*> CGBBRD factors a general band matrix A as  Q B P* , where * means
*> conjugate transpose, B is upper bidiagonal, and Q and P are unitary;
*> CGBBRD can also overwrite a given matrix C with Q* C .
*>
*> For each pair of matrix dimensions (M,N) and each selected matrix
*> type, an M by N matrix A and an M by NRHS matrix C are generated.
*> The problem dimensions are as follows
*>    A:          M x N
*>    Q:          M x M
*>    P:          N x N
*>    B:          min(M,N) x min(M,N)
*>    C:          M x NRHS
*>
*> For each generated matrix, 4 tests are performed:
*>
*> (1)   | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
*>
*> (2)   | I - Q' Q | / ( M ulp )
*>
*> (3)   | I - PT PT' | / ( N ulp )
*>
*> (4)   | Y - Q' C | / ( |Y| max(M,NRHS) ulp ), where Y = Q' C.
*>
*> The "types" are specified by a logical array DOTYPE( 1:NTYPES );
*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
*> Currently, the list of possible types is:
*>
*> The possible matrix types are
*>
*> (1)  The zero matrix.
*> (2)  The identity matrix.
*>
*> (3)  A diagonal matrix with evenly spaced entries
*>      1, ..., ULP  and random signs.
*>      (ULP = (first number larger than 1) - 1 )
*> (4)  A diagonal matrix with geometrically spaced entries
*>      1, ..., ULP  and random signs.
*> (5)  A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
*>      and random signs.
*>
*> (6)  Same as (3), but multiplied by SQRT( overflow threshold )
*> (7)  Same as (3), but multiplied by SQRT( underflow threshold )
*>
*> (8)  A matrix of the form  U D V, where U and V are orthogonal and
*>      D has evenly spaced entries 1, ..., ULP with random signs
*>      on the diagonal.
*>
*> (9)  A matrix of the form  U D V, where U and V are orthogonal and
*>      D has geometrically spaced entries 1, ..., ULP with random
*>      signs on the diagonal.
*>
*> (10) A matrix of the form  U D V, where U and V are orthogonal and
*>      D has "clustered" entries 1, ULP,..., ULP with random
*>      signs on the diagonal.
*>
*> (11) Same as (8), but multiplied by SQRT( overflow threshold )
*> (12) Same as (8), but multiplied by SQRT( underflow threshold )
*>
*> (13) Rectangular matrix with random entries chosen from (-1,1).
*> (14) Same as (13), but multiplied by SQRT( overflow threshold )
*> (15) Same as (13), but multiplied by SQRT( underflow threshold )
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] NSIZES
*> \verbatim
*>          NSIZES is INTEGER
*>          The number of values of M and N contained in the vectors
*>          MVAL and NVAL.  The matrix sizes are used in pairs (M,N).
*>          If NSIZES is zero, CCHKBB does nothing.  NSIZES must be at
*>          least zero.
*> \endverbatim
*>
*> \param[in] MVAL
*> \verbatim
*>          MVAL is INTEGER array, dimension (NSIZES)
*>          The values of the matrix row dimension M.
*> \endverbatim
*>
*> \param[in] NVAL
*> \verbatim
*>          NVAL is INTEGER array, dimension (NSIZES)
*>          The values of the matrix column dimension N.
*> \endverbatim
*>
*> \param[in] NWDTHS
*> \verbatim
*>          NWDTHS is INTEGER
*>          The number of bandwidths to use.  If it is zero,
*>          CCHKBB does nothing.  It must be at least zero.
*> \endverbatim
*>
*> \param[in] KK
*> \verbatim
*>          KK is INTEGER array, dimension (NWDTHS)
*>          An array containing the bandwidths to be used for the band
*>          matrices.  The values must be at least zero.
*> \endverbatim
*>
*> \param[in] NTYPES
*> \verbatim
*>          NTYPES is INTEGER
*>          The number of elements in DOTYPE.   If it is zero, CCHKBB
*>          does nothing.  It must be at least zero.  If it is MAXTYP+1
*>          and NSIZES is 1, then an additional type, MAXTYP+1 is
*>          defined, which is to use whatever matrix is in A.  This
*>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
*>          DOTYPE(MAXTYP+1) is .TRUE. .
*> \endverbatim
*>
*> \param[in] DOTYPE
*> \verbatim
*>          DOTYPE is LOGICAL array, dimension (NTYPES)
*>          If DOTYPE(j) is .TRUE., then for each size in NN a
*>          matrix of that size and of type j will be generated.
*>          If NTYPES is smaller than the maximum number of types
*>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
*>          MAXTYP will not be generated.  If NTYPES is larger
*>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
*>          will be ignored.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of columns in the "right-hand side" matrix C.
*>          If NRHS = 0, then the operations on the right-hand side will
*>          not be tested. NRHS must be at least 0.
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension (4)
*>          On entry ISEED specifies the seed of the random number
*>          generator. The array elements should be between 0 and 4095;
*>          if not they will be reduced mod 4096.  Also, ISEED(4) must
*>          be odd.  The random number generator uses a linear
*>          congruential sequence limited to small integers, and so
*>          should produce machine independent random numbers. The
*>          values of ISEED are changed on exit, and can be used in the
*>          next call to CCHKBB to continue the same random number
*>          sequence.
*> \endverbatim
*>
*> \param[in] THRESH
*> \verbatim
*>          THRESH is REAL
*>          A test will count as "failed" if the "error", computed as
*>          described above, exceeds THRESH.  Note that the error
*>          is scaled to be O(1), so THRESH should be a reasonably
*>          small multiple of 1, e.g., 10 or 100.  In particular,
*>          it should not depend on the precision (single vs. double)
*>          or the size of the matrix.  It must be at least zero.
*> \endverbatim
*>
*> \param[in] NOUNIT
*> \verbatim
*>          NOUNIT is INTEGER
*>          The FORTRAN unit number for printing out error messages
*>          (e.g., if a routine returns IINFO not equal to 0.)
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension
*>                            (LDA, max(NN))
*>          Used to hold the matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A.  It must be at least 1
*>          and at least max( NN ).
*> \endverbatim
*>
*> \param[out] AB
*> \verbatim
*>          AB is REAL array, dimension (LDAB, max(NN))
*>          Used to hold A in band storage format.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*>          LDAB is INTEGER
*>          The leading dimension of AB.  It must be at least 2 (not 1!)
*>          and at least max( KK )+1.
*> \endverbatim
*>
*> \param[out] BD
*> \verbatim
*>          BD is REAL array, dimension (max(NN))
*>          Used to hold the diagonal of the bidiagonal matrix computed
*>          by CGBBRD.
*> \endverbatim
*>
*> \param[out] BE
*> \verbatim
*>          BE is REAL array, dimension (max(NN))
*>          Used to hold the off-diagonal of the bidiagonal matrix
*>          computed by CGBBRD.
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*>          Q is COMPLEX array, dimension (LDQ, max(NN))
*>          Used to hold the unitary matrix Q computed by CGBBRD.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*>          LDQ is INTEGER
*>          The leading dimension of Q.  It must be at least 1
*>          and at least max( NN ).
*> \endverbatim
*>
*> \param[out] P
*> \verbatim
*>          P is COMPLEX array, dimension (LDP, max(NN))
*>          Used to hold the unitary matrix P computed by CGBBRD.
*> \endverbatim
*>
*> \param[in] LDP
*> \verbatim
*>          LDP is INTEGER
*>          The leading dimension of P.  It must be at least 1
*>          and at least max( NN ).
*> \endverbatim
*>
*> \param[out] C
*> \verbatim
*>          C is COMPLEX array, dimension (LDC, max(NN))
*>          Used to hold the matrix C updated by CGBBRD.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*>          LDC is INTEGER
*>          The leading dimension of U.  It must be at least 1
*>          and at least max( NN ).
*> \endverbatim
*>
*> \param[out] CC
*> \verbatim
*>          CC is COMPLEX array, dimension (LDC, max(NN))
*>          Used to hold a copy of the matrix C.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The number of entries in WORK.  This must be at least
*>          max( LDA+1, max(NN)+1 )*max(NN).
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (max(NN))
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is REAL array, dimension (4)
*>          The values computed by the tests described above.
*>          The values are currently limited to 1/ulp, to avoid
*>          overflow.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          If 0, then everything ran OK.
*>
*>-----------------------------------------------------------------------
*>
*>       Some Local Variables and Parameters:
*>       ---- ----- --------- --- ----------
*>       ZERO, ONE       Real 0 and 1.
*>       MAXTYP          The number of types defined.
*>       NTEST           The number of tests performed, or which can
*>                       be performed so far, for the current matrix.
*>       NTESTT          The total number of tests performed so far.
*>       NMAX            Largest value in NN.
*>       NMATS           The number of matrices generated so far.
*>       NERRS           The number of tests which have exceeded THRESH
*>                       so far.
*>       COND, IMODE     Values to be passed to the matrix generators.
*>       ANORM           Norm of A; passed to matrix generators.
*>
*>       OVFL, UNFL      Overflow and underflow thresholds.
*>       ULP, ULPINV     Finest relative precision and its inverse.
*>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
*>               The following four arrays decode JTYPE:
*>       KTYPE(j)        The general type (1-10) for type "j".
*>       KMODE(j)        The MODE value to be passed to the matrix
*>                       generator for type "j".
*>       KMAGN(j)        The order of magnitude ( O(1),
*>                       O(overflow^(1/2) ), O(underflow^(1/2) )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex_eig
*
*  =====================================================================
      SUBROUTINE CCHKBB( NSIZES, MVAL, NVAL, NWDTHS, KK, NTYPES, DOTYPE,
     $                   NRHS, ISEED, THRESH, NOUNIT, A, LDA, AB, LDAB,
     $                   BD, BE, Q, LDQ, P, LDP, C, LDC, CC, WORK,
     $                   LWORK, RWORK, RESULT, INFO )
*
*  -- LAPACK test routine (input) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT,
     $                   NRHS, NSIZES, NTYPES, NWDTHS
      REAL               THRESH
*     ..
*     .. Array Arguments ..
      LOGICAL            DOTYPE( * )
      INTEGER            ISEED( 4 ), KK( * ), MVAL( * ), NVAL( * )
      REAL               BD( * ), BE( * ), RESULT( * ), RWORK( * )
      COMPLEX            A( LDA, * ), AB( LDAB, * ), C( LDC, * ),
     $                   CC( LDC, * ), P( LDP, * ), Q( LDQ, * ),
     $                   WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      INTEGER            MAXTYP
      PARAMETER          ( MAXTYP = 15 )
*     ..
*     .. Local Scalars ..
      LOGICAL            BADMM, BADNN, BADNNB
      INTEGER            I, IINFO, IMODE, ITYPE, J, JCOL, JR, JSIZE,
     $                   JTYPE, JWIDTH, K, KL, KMAX, KU, M, MMAX, MNMAX,
     $                   MNMIN, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
     $                   NTESTT
      REAL               AMNINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, ULP,
     $                   ULPINV, UNFL
*     ..
*     .. Local Arrays ..
      INTEGER            IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
     $                   KMODE( MAXTYP ), KTYPE( MAXTYP )
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           CBDT01, CBDT02, CGBBRD, CLACPY, CLASET, CLATMR,
     $                   CLATMS, CUNT01, SLAHD2, SLASUM, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, REAL, SQRT
*     ..
*     .. Data statements ..
      DATA               KTYPE / 1, 2, 5*4, 5*6, 3*9 /
      DATA               KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3 /
      DATA               KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
     $                   0, 0 /
*     ..
*     .. Executable Statements ..
*
*     Check for errors
*
      NTESTT = 0
      INFO = 0
*
*     Important constants
*
      BADMM = .FALSE.
      BADNN = .FALSE.
      MMAX = 1
      NMAX = 1
      MNMAX = 1
      DO 10 J = 1, NSIZES
         MMAX = MAX( MMAX, MVAL( J ) )
         IF( MVAL( J ).LT.0 )
     $      BADMM = .TRUE.
         NMAX = MAX( NMAX, NVAL( J ) )
         IF( NVAL( J ).LT.0 )
     $      BADNN = .TRUE.
         MNMAX = MAX( MNMAX, MIN( MVAL( J ), NVAL( J ) ) )
   10 CONTINUE
*
      BADNNB = .FALSE.
      KMAX = 0
      DO 20 J = 1, NWDTHS
         KMAX = MAX( KMAX, KK( J ) )
         IF( KK( J ).LT.0 )
     $      BADNNB = .TRUE.
   20 CONTINUE
*
*     Check for errors
*
      IF( NSIZES.LT.0 ) THEN
         INFO = -1
      ELSE IF( BADMM ) THEN
         INFO = -2
      ELSE IF( BADNN ) THEN
         INFO = -3
      ELSE IF( NWDTHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( BADNNB ) THEN
         INFO = -5
      ELSE IF( NTYPES.LT.0 ) THEN
         INFO = -6
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -8
      ELSE IF( LDA.LT.NMAX ) THEN
         INFO = -13
      ELSE IF( LDAB.LT.2*KMAX+1 ) THEN
         INFO = -15
      ELSE IF( LDQ.LT.NMAX ) THEN
         INFO = -19
      ELSE IF( LDP.LT.NMAX ) THEN
         INFO = -21
      ELSE IF( LDC.LT.NMAX ) THEN
         INFO = -23
      ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN
         INFO = -26
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CCHKBB', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 )
     $   RETURN
*
*     More Important constants
*
      UNFL = SLAMCH( 'Safe minimum' )
      OVFL = ONE / UNFL
      ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
      ULPINV = ONE / ULP
      RTUNFL = SQRT( UNFL )
      RTOVFL = SQRT( OVFL )
*
*     Loop over sizes, widths, types
*
      NERRS = 0
      NMATS = 0
*
      DO 160 JSIZE = 1, NSIZES
         M = MVAL( JSIZE )
         N = NVAL( JSIZE )
         MNMIN = MIN( M, N )
         AMNINV = ONE / REAL( MAX( 1, M, N ) )
*
         DO 150 JWIDTH = 1, NWDTHS
            K = KK( JWIDTH )
            IF( K.GE.M .AND. K.GE.N )
     $         GO TO 150
            KL = MAX( 0, MIN( M-1, K ) )
            KU = MAX( 0, MIN( N-1, K ) )
*
            IF( NSIZES.NE.1 ) THEN
               MTYPES = MIN( MAXTYP, NTYPES )
            ELSE
               MTYPES = MIN( MAXTYP+1, NTYPES )
            END IF
*
            DO 140 JTYPE = 1, MTYPES
               IF( .NOT.DOTYPE( JTYPE ) )
     $            GO TO 140
               NMATS = NMATS + 1
               NTEST = 0
*
               DO 30 J = 1, 4
                  IOLDSD( J ) = ISEED( J )
   30          CONTINUE
*
*              Compute "A".
*
*              Control parameters:
*
*                  KMAGN  KMODE        KTYPE
*              =1  O(1)   clustered 1  zero
*              =2  large  clustered 2  identity
*              =3  small  exponential  (none)
*              =4         arithmetic   diagonal, (w/ singular values)
*              =5         random log   (none)
*              =6         random       nonhermitian, w/ singular values
*              =7                      (none)
*              =8                      (none)
*              =9                      random nonhermitian
*
               IF( MTYPES.GT.MAXTYP )
     $            GO TO 90
*
               ITYPE = KTYPE( JTYPE )
               IMODE = KMODE( JTYPE )
*
*              Compute norm
*
               GO TO ( 40, 50, 60 )KMAGN( JTYPE )
*
   40          CONTINUE
               ANORM = ONE
               GO TO 70
*
   50          CONTINUE
               ANORM = ( RTOVFL*ULP )*AMNINV
               GO TO 70
*
   60          CONTINUE
               ANORM = RTUNFL*MAX( M, N )*ULPINV
               GO TO 70
*
   70          CONTINUE
*
               CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA )
               CALL CLASET( 'Full', LDAB, N, CZERO, CZERO, AB, LDAB )
               IINFO = 0
               COND = ULPINV
*
*              Special Matrices -- Identity & Jordan block
*
*                 Zero
*
               IF( ITYPE.EQ.1 ) THEN
                  IINFO = 0
*
               ELSE IF( ITYPE.EQ.2 ) THEN
*
*                 Identity
*
                  DO 80 JCOL = 1, N
                     A( JCOL, JCOL ) = ANORM
   80             CONTINUE
*
               ELSE IF( ITYPE.EQ.4 ) THEN
*
*                 Diagonal Matrix, singular values specified
*
                  CALL CLATMS( M, N, 'S', ISEED, 'N', RWORK, IMODE,
     $                         COND, ANORM, 0, 0, 'N', A, LDA, WORK,
     $                         IINFO )
*
               ELSE IF( ITYPE.EQ.6 ) THEN
*
*                 Nonhermitian, singular values specified
*
                  CALL CLATMS( M, N, 'S', ISEED, 'N', RWORK, IMODE,
     $                         COND, ANORM, KL, KU, 'N', A, LDA, WORK,
     $                         IINFO )
*
               ELSE IF( ITYPE.EQ.9 ) THEN
*
*                 Nonhermitian, random entries
*
                  CALL CLATMR( M, N, 'S', ISEED, 'N', WORK, 6, ONE,
     $                         CONE, 'T', 'N', WORK( N+1 ), 1, ONE,
     $                         WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, KL,
     $                         KU, ZERO, ANORM, 'N', A, LDA, IDUMMA,
     $                         IINFO )
*
               ELSE
*
                  IINFO = 1
               END IF
*
*              Generate Right-Hand Side
*
               CALL CLATMR( M, NRHS, 'S', ISEED, 'N', WORK, 6, ONE,
     $                      CONE, 'T', 'N', WORK( M+1 ), 1, ONE,
     $                      WORK( 2*M+1 ), 1, ONE, 'N', IDUMMA, M, NRHS,
     $                      ZERO, ONE, 'NO', C, LDC, IDUMMA, IINFO )
*
               IF( IINFO.NE.0 ) THEN
                  WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N,
     $               JTYPE, IOLDSD
                  INFO = ABS( IINFO )
                  RETURN
               END IF
*
   90          CONTINUE
*
*              Copy A to band storage.
*
               DO 110 J = 1, N
                  DO 100 I = MAX( 1, J-KU ), MIN( M, J+KL )
                     AB( KU+1+I-J, J ) = A( I, J )
  100             CONTINUE
  110          CONTINUE
*
*              Copy C
*
               CALL CLACPY( 'Full', M, NRHS, C, LDC, CC, LDC )
*
*              Call CGBBRD to compute B, Q and P, and to update C.
*
               CALL CGBBRD( 'B', M, N, NRHS, KL, KU, AB, LDAB, BD, BE,
     $                      Q, LDQ, P, LDP, CC, LDC, WORK, RWORK,
     $                      IINFO )
*
               IF( IINFO.NE.0 ) THEN
                  WRITE( NOUNIT, FMT = 9999 )'CGBBRD', IINFO, N, JTYPE,
     $               IOLDSD
                  INFO = ABS( IINFO )
                  IF( IINFO.LT.0 ) THEN
                     RETURN
                  ELSE
                     RESULT( 1 ) = ULPINV
                     GO TO 120
                  END IF
               END IF
*
*              Test 1:  Check the decomposition A := Q * B * P'
*                   2:  Check the orthogonality of Q
*                   3:  Check the orthogonality of P
*                   4:  Check the computation of Q' * C
*
               CALL CBDT01( M, N, -1, A, LDA, Q, LDQ, BD, BE, P, LDP,
     $                      WORK, RWORK, RESULT( 1 ) )
               CALL CUNT01( 'Columns', M, M, Q, LDQ, WORK, LWORK, RWORK,
     $                      RESULT( 2 ) )
               CALL CUNT01( 'Rows', N, N, P, LDP, WORK, LWORK, RWORK,
     $                      RESULT( 3 ) )
               CALL CBDT02( M, NRHS, C, LDC, CC, LDC, Q, LDQ, WORK,
     $                      RWORK, RESULT( 4 ) )
*
*              End of Loop -- Check for RESULT(j) > THRESH
*
               NTEST = 4
  120          CONTINUE
               NTESTT = NTESTT + NTEST
*
*              Print out tests which fail.
*
               DO 130 JR = 1, NTEST
                  IF( RESULT( JR ).GE.THRESH ) THEN
                     IF( NERRS.EQ.0 )
     $                  CALL SLAHD2( NOUNIT, 'CBB' )
                     NERRS = NERRS + 1
                     WRITE( NOUNIT, FMT = 9998 )M, N, K, IOLDSD, JTYPE,
     $                  JR, RESULT( JR )
                  END IF
  130          CONTINUE
*
  140       CONTINUE
  150    CONTINUE
  160 CONTINUE
*
*     Summary
*
      CALL SLASUM( 'CBB', NOUNIT, NERRS, NTESTT )
      RETURN
*
 9999 FORMAT( ' CCHKBB: ', A, ' returned INFO=', I5, '.', / 9X, 'M=',
     $      I5, ' N=', I5, ' K=', I5, ', JTYPE=', I5, ', ISEED=(',
     $      3( I5, ',' ), I5, ')' )
 9998 FORMAT( ' M =', I4, ' N=', I4, ', K=', I3, ', seed=',
     $      4( I4, ',' ), ' type ', I2, ', test(', I2, ')=', G10.3 )
*
*     End of CCHKBB
*
      END


      program calcSAL

!    note that the documentation for spherepack programs shaec.f, shsec.f
!          along with the example program on page 33 of the spherepack2.0
!          manual helped guide the writing of this program

!     set grid size with parameter statements

      PARAMETER ( NI=4500, NJ=NI/2+1)  !0.08 degrees
      PARAMETER (nnlat=NJ,nnlon=NI)

!     set saved and unsaved work space lengths in terms of nnlat, nnlon

      parameter (nn15=nnlon+15)
!      parameter (llsave=nnlat*(nnlat+1)+3*((nnlat-2)*(nnlat-1)+nn15))
!      parameter (llwork=(nnlat+1)*(nnlon+3*nnlat)+nnlat*(2*nnlat+1))
      parameter (l1use=nnlat,l2=(nnlat+1)/2)
      parameter (llsave=2*nnlat*l2+3*((l1use-2)*(nnlat+nnlat-l1use-1))
     &        /2+nnlon+15)
      parameter (ldwork=nnlat*(nnlon+nnlon))
      parameter (lshaec=llsave)
      parameter (lshsec=llsave)

!     dimension arrays

      real*8 LOADNUMBERS(10000)

      real*4 amp(ni,nj)
      real*4 phase(ni,nj)
      real*4 loadtide(ni,nj)

      REAL*8 TIDEPAD(nnlon,nnlat)
      real*8 tidepad2(nnlat,nnlon)

      real*8 loadtide2(nnlat,nnlon)

      real*8 dwork(ldwork)
      real*8 wshaec(llsave)
      real*8 wshsec(llsave)
      real*8 a(nnlat,nnlat)
      real*8 b(nnlat,nnlat)

      INTEGER ISTART(4), ICOUNT(4)

      character*60,parameter :: infile = "loadnumbers_binary"

!     define pi

      pi=4.0*atan(1.0)

!     read in loadnumbers

      write(6,'(a,a)') 'reading ',trim(infile)
      call flush(6)
      open(10, file=infile, form='unformatted')
      read(10) loadnumbers
      close (10)

!     read in amplitude and phase

      write(6,'(a,a)') 'reading tide_AmPh.A'
      call flush(6)
      INQUIRE( IOLENGTH=MRECL) amp
      open(10, file='tide_AmPh.A', form='unformatted', access="direct", RECL=MRECL)
      read(10, rec=1) amp
      read(10, rec=2) phase
      close (10)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!     calculate loadtide for omegat=0 degrees:
      write(6,'(a)') 'calculate loadtide for omegat=0 degrees:'
      call flush(6)

         do j=1,NJ
           do i=1,NI
              if (amp(i,j) .gt. 1.0d10) then
                tidepad(i,j)=0.0
             else
                tidepad(i,j)=amp(i,j)*cos((pi/180.0)*(0.0-phase(i,j)))
             endif
           enddo
         enddo

!     translate tidepad from geophysical coordinates (which use longitude
!       and latitude, the latter measured from south to north pole) to
!       tidepad2 in mathematical spherical coordinates (which use colatitude
!       and longitude, the former measured from north to south pole)

      do j=1,nnlon
         do i=1,nnlat
            tidepad2(i,j)=tidepad(j,nnlat+1-i)
         enddo
      enddo

!
! initialize spherepack routines
!
      call shaeci(nnlat,nnlon,wshaec,lshaec,dwork,ldwork,ierror)
      if (ierror .ne. 0) print *, 'shaeci ierror = ',ierror
      call shseci(nnlat,nnlon,wshsec,lshsec,dwork,ldwork,ierror)
      if (ierror .ne. 0) print *, 'shseci ierror = ',ierror

!  calculate spherical harmonics

      call shaec(nnlat,nnlon,0,1,tidepad2,nnlat,nnlon,a,b,nnlat,
     &                 nnlat,wshaec,lshaec,dwork,ldwork,ierror)
      if (ierror .ne. 0) print *, 'shaec ierror = ',ierror

!  multiply the harmonics by the load numbers; note start at j=2 since
!        j=1, i = 1 denotes P00; note set a(1,1)=b(1,1)=0 to eliminate
!        possibility of nonzero mean

      a(1,1)=0.0
      b(1,1)=0.0

      do j = 2,nnlat
         do i = 1,j
             a(i,j) = a(i,j)*loadnumbers(j-1)
             b(i,j) = b(i,j)*loadnumbers(j-1)
         enddo
      enddo

!  transform back to physical coordinates

      call shsec(nnlat,nnlon,0,1,loadtide2,nnlat,nnlon,a,b,nnlat,
     &                 nnlat,wshsec,lshsec,dwork,ldwork,ierror)
      if (ierror .ne. 0) print *, 'shsec ierror = ',ierror

!  translate loadtide2 from mathematical spherical coordinates to
!      loadtide in geophysical coordinates.
!  also flip the sign so that this is the SAL *correction* to the tides
!   which is approximately 180 degrees out of phase with the tides.

      do j=1,nnlon
         do i=1,nnlat
            loadtide(j,i)=-loadtide2(nnlat+1-i,j)
         enddo
      enddo

!  sal_ReIm follows the OSU (TPXO) convention for the Imaginary
!   component: phase = atan2(-Im,Re) and amp = sqrt( Re**2 + Im**2 ).

      write(6,'(a)') 'writing Re to sal_ReIm.A'
      call flush(6)
      open( 80, file='sal_ReIm.A', form='unformatted', access="direct", RECL=MRECL)
      write(80, rec=1)loadtide

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!     calculate loadtide for omegat=90 degrees:
      write(6,'(a)') 'calculate loadtide for omegat=90 degrees:'
      call flush(6)

         do j=1,NJ
           do i=1,NI
              if (amp(i,j) .gt. 1.0d10) then
                tidepad(i,j)=0.0
             else
                tidepad(i,j)=amp(i,j)*cos((pi/180.0)*(90.0-phase(i,j)))
             endif
           enddo
         enddo

!     translate tidepad from geophysical coordinates (which use longitude
!       and latitude, the latter measured from south to north pole) to
!       tidepad2 in mathematical spherical coordinates (which use colatitude
!       and longitude, the former measured from north to south pole)

      do j=1,nnlon
         do i=1,nnlat
            tidepad2(i,j)=tidepad(j,nnlat+1-i)
         enddo
      enddo

!
! initialize spherepack routines
!
      call shaeci(nnlat,nnlon,wshaec,lshaec,dwork,ldwork,ierror)
      if (ierror .ne. 0) print *, 'shaeci ierror = ',ierror
      call shseci(nnlat,nnlon,wshsec,lshsec,dwork,ldwork,ierror)
      if (ierror .ne. 0) print *, 'shseci ierror = ',ierror

!  calculate spherical harmonics

      call shaec(nnlat,nnlon,0,1,tidepad2,nnlat,nnlon,a,b,nnlat,
     &                 nnlat,wshaec,lshaec,dwork,ldwork,ierror)
      if (ierror .ne. 0) print *, 'shaec ierror = ',ierror

!  multiply the harmonics by the load numbers; note start at j=2 since
!        j=1, i = 1 denotes P00; note set a(1,1)=b(1,1)=0 to eliminate
!        possibility of nonzero mean

      a(1,1)=0.0
      b(1,1)=0.0

      do j = 2,nnlat
         do i = 1,j
             a(i,j) = a(i,j)*loadnumbers(j-1)
             b(i,j) = b(i,j)*loadnumbers(j-1)
         enddo
      enddo

!  transform back to physical coordinates

      call shsec(nnlat,nnlon,0,1,loadtide2,nnlat,nnlon,a,b,nnlat,
     &                 nnlat,wshsec,lshsec,dwork,ldwork,ierror)
      if (ierror .ne. 0) print *, 'shsec ierror = ',ierror

!  translate loadtide2 from mathematical spherical coordinates to
!      loadtide in geophysical coordinates.
!  sal_ReIm follows the OSU (TPXO) convention for the Imaginary
!   component: phase = atan2(-Im,Re).
!  this implies that the sign of loadtide should be flipped, but we
!  then flip the sign again so that this is the SAL *correction* to the
!  tides which is approximately 180 degrees out of phase with the tides.
!  overall, leave the sign of loadtide2 "as is".

      do j=1,nnlon
         do i=1,nnlat
            loadtide(j,i)=loadtide2(nnlat+1-i,j)
         enddo
      enddo

      write(6,'(a)') 'writing Im to sal_ReIm.A'
      call flush(6)
      write(80, rec=2) loadtide
      close(80)
      endprogram calcSAL


subroutine mg_source(phi, ap, aw, ae, as, an, b, res, nx, ny, dx, dy, source)
use kind_parameters
implicit none

integer:: i, j, nx, ny
real(kind=dp), intent(in), dimension(nx,ny):: phi, ap, b, res, aw, ae, as, an
real(kind=dp), intent(out), dimension(nx,ny):: source
real(kind=dp), dimension(nx), intent(in):: dx
real(kind=dp), dimension(ny), intent(in):: dy

! Calculate the residual r = f - Au, where u is the guessed value
! Input
! u      Matrix for variables
! f      Right Hand Side
! hx     grid spacing in x direction
! hy     grid spacing in y direction
!
! Output
! r      Residual

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012
! Modified: Feb 11, 2013

do j = 2,ny-1

    do i = 2,nx-1

        source(i,j) = (ap(i,j)*phi(i,j) - (aw(i,j)*phi(i-1,j) + ae(i,j)*phi(i+1,j) + as(i,j)*phi(i,j-1) + an(i,j)*phi(i,j+1)) - b(i,j) - res(i,j))

    end do

end do

end subroutine


  MODULE cm1libs

  implicit none

  CONTAINS

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

!
! ---------------------------------------------------------------------
! THIS FUNCTION CALCULATES THE LIQUID SATURATION VAPOR MIXING RATIO AS
! A FUNCTION OF TEMPERATURE AND PRESSURE
!
      REAL FUNCTION RSLF(P,T)

      use input, only : ptype
      use constants
      IMPLICIT NONE
      REAL ESL,X,T,P,C0,C1,C2,C3,C4,C5,C6,C7,C8
      PARAMETER (C0= .611583699E03)
      PARAMETER (C1= .444606896E02)
      PARAMETER (C2= .143177157E01)
      PARAMETER (C3= .264224321E-1)
      PARAMETER (C4= .299291081E-3)
      PARAMETER (C5= .203154182E-5)
      PARAMETER (C6= .702620698E-8)
      PARAMETER (C7= .379534310E-11)
      PARAMETER (C8=-.321582393E-13)

!  Note to self ... this should be changed, somehow, in the future.
!  GHB 060806

    if(ptype.eq.1.or.ptype.eq.2.or.ptype.eq.3.or.ptype.eq.5.or.ptype.eq.6)then

      ! from Bolton (1980, MWR)
      esl=611.2 * EXP( 17.67 * ( T  - 273.15 ) / ( T  - 29.65 ) )
      ! 171023 (fix for very cold temps):
      esl = min( esl , p*0.5 )
      rslf= eps * ESL /(P-ESL)

    elseif(ptype.eq.4)then

      rslf=380.00*exp(17.2693882-4097.8531/(t-35.86))/p

!    elseif(ptype.eq.3)then
!
!      X=MAX(-80.,T-273.16)
!      ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
!      RSLF=eps*ESL/(P-ESL)

    else

      esl=611.2 * EXP( 17.67 * ( T  - 273.15 ) / ( T  - 29.65 ) )
      ! 171023 (fix for very cold temps):
      esl = min( esl , p*0.5 )
      rslf= eps * ESL /(P-ESL)

    endif

      END FUNCTION RSLF

!
! ---------------------------------------------------------------------
! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR MIXING RATIO AS A
! FUNCTION OF TEMPERATURE AND PRESSURE
!
      REAL FUNCTION RSIF(P,T)

      use input, only : ptype
      use constants
      IMPLICIT NONE
      REAL ESI,X,T,P,C0,C1,C2,C3,C4,C5,C6,C7,C8
      PARAMETER (C0= .609868993E03)
      PARAMETER (C1= .499320233E02)
      PARAMETER (C2= .184672631E01)
      PARAMETER (C3= .402737184E-1)
      PARAMETER (C4= .565392987E-3)
      PARAMETER (C5= .521693933E-5)
      PARAMETER (C6= .307839583E-7)
      PARAMETER (C7= .105785160E-9)
      PARAMETER (C8= .161444444E-12)

!  Note to self ... this should be changed, somehow, in the future.
!  GHB 060806

    if(ptype.eq.1.or.ptype.eq.2.or.ptype.eq.3.or.ptype.eq.5.or.ptype.eq.6)then

      ! from Tao et al (1989, MWR)
      esi=611.2 * EXP( 21.8745584 * ( T  - 273.15 ) / ( T  - 7.66 ) )
      ! 171023 (fix for very cold temps):
      esi = min( esi , p*0.5 )
      rsif= eps * ESI /(P-ESI)

    elseif(ptype.eq.4)then

      rsif=380.00*exp(21.87455-5807.4743/(t-7.66))/p

!    elseif(ptype.eq.3)then
!
!      X=MAX(-80.,T-273.16)
!      ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
!      RSIF=eps*ESI/(P-ESI)

    else

      esi=611.2 * EXP( 21.8745584 * ( T  - 273.15 ) / ( T  - 7.66 ) )
      ! 171023 (fix for very cold temps):
      esi = min( esi , p*0.5 )
      rsif= eps * ESI /(P-ESI)

    endif

      END FUNCTION RSIF

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

! REV PROCESSED 213 LINES OF CODE. PROGRAM DONE.
      REAL FUNCTION GAMMA(X)
      implicit none
!D    DOUBLE PRECISION FUNCTION DGAMMA(X)
!----------------------------------------------------------------------
!
! THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A REAL ARGUMENT X.
!   COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCE 1.
!   THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA
!   FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS.  COEFFICIENTS
!   FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED.
!   THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM REFERENCE 2.
!   THE ACCURACY ACHIEVED DEPENDS ON THE ARITHMETIC SYSTEM, THE
!   COMPILER, THE INTRINSIC FUNCTIONS, AND PROPER SELECTION OF THE
!   MACHINE-DEPENDENT CONSTANTS.
!
!
!*******************************************************************
!*******************************************************************
!
! EXPLANATION OF MACHINE-DEPENDENT CONSTANTS
!
! BETA   - RADIX FOR THE FLOATING-POINT REPRESENTATION
! MAXEXP - THE SMALLEST POSITIVE POWER OF BETA THAT OVERFLOWS
! XBIG   - THE LARGEST ARGUMENT FOR WHICH GAMMA(X) IS REPRESENTABLE
!          IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION
!                  GAMMA(XBIG) = BETA**MAXEXP
! XINF   - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER;
!          APPROXIMATELY BETA**MAXEXP
! EPS    - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
!          1.0+EPS .GT. 1.0
! XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
!          1/XMININ IS MACHINE REPRESENTABLE
!
!     APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE:
!
!                            BETA       MAXEXP        XBIG
!
! CRAY-1         (S.P.)        2         8191        966.961
! CYBER 180/855
!   UNDER NOS    (S.P.)        2         1070        177.803
! IEEE (IBM/XT,
!   SUN, ETC.)   (S.P.)        2          128        35.040
! IEEE (IBM/XT,
!   SUN, ETC.)   (D.P.)        2         1024        171.624
! IBM 3033       (D.P.)       16           63        57.574
! VAX D-FORMAT   (D.P.)        2          127        34.844
! VAX G-FORMAT   (D.P.)        2         1023        171.489
!
!                            XINF         EPS        XMININ
!
! CRAY-1         (S.P.)   5.45E+2465   7.11E-15    1.84E-2466
! CYBER 180/855
!   UNDER NOS    (S.P.)   1.26E+322    3.55E-15    3.14E-294
! IEEE (IBM/XT,
!   SUN, ETC.)   (S.P.)   3.40E+38     1.19E-7     1.18E-38
! IEEE (IBM/XT,
!   SUN, ETC.)   (D.P.)   1.79D+308    2.22D-16    2.23D-308
! IBM 3033       (D.P.)   7.23D+75     2.22D-16    1.39D-76
! VAX D-FORMAT   (D.P.)   1.70D+38     1.39D-17    5.88D-39
! VAX G-FORMAT   (D.P.)   8.98D+307    1.11D-16    1.12D-308
!
!*******************************************************************
!*******************************************************************
!
! ERROR RETURNS
!
!  THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR
!     WHEN OVERFLOW WOULD OCCUR.  THE COMPUTATION IS BELIEVED
!     TO BE FREE OF UNDERFLOW AND OVERFLOW.
!
!
!  INTRINSIC FUNCTIONS REQUIRED ARE:
!
!     INT, DBLE, EXP, LOG, REAL, SIN
!
!
! REFERENCES:  AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL
!              FUNCTIONS   W. J. CODY, LECTURE NOTES IN MATHEMATICS,
!              506, NUMERICAL ANALYSIS DUNDEE, 1975, G. A. WATSON
!              (ED.), SPRINGER VERLAG, BERLIN, 1976.
!
!              COMPUTER APPROXIMATIONS, HART, ET. AL., WILEY AND
!              SONS, NEW YORK, 1968.
!
!  LATEST MODIFICATION: OCTOBER 12, 1989
!
!  AUTHORS: W. J. CODY AND L. STOLTZ
!           APPLIED MATHEMATICS DIVISION
!           ARGONNE NATIONAL LABORATORY
!           ARGONNE, IL 60439
!
!----------------------------------------------------------------------
      INTEGER I,N
      LOGICAL PARITY
      REAL               &
!D    DOUBLE PRECISION   &
          C,CONV,EPS,FACT,HALF,ONE,P,PI,Q,RES,SQRTPI,SUM,TWELVE,   &
          TWO,X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
      DIMENSION C(7),P(8),Q(8)
!----------------------------------------------------------------------
!  MATHEMATICAL CONSTANTS
!----------------------------------------------------------------------
      DATA ONE,HALF,TWELVE,TWO,ZERO/1.0E0,0.5E0,12.0E0,2.0E0,0.0E0/,   &
           SQRTPI/0.9189385332046727417803297E0/,                      &
           PI/3.1415926535897932384626434E0/
!D    DATA ONE,HALF,TWELVE,TWO,ZERO/1.0D0,0.5D0,12.0D0,2.0D0,0.0D0/,
!D   1     SQRTPI/0.9189385332046727417803297D0/,
!D   2     PI/3.1415926535897932384626434D0/
!----------------------------------------------------------------------
!  MACHINE DEPENDENT PARAMETERS
!----------------------------------------------------------------------
      DATA XBIG,XMININ,EPS/35.040E0,1.18E-38,1.19E-7/,   &
           XINF/3.4E38/
!D    DATA XBIG,XMININ,EPS/171.624D0,2.23D-308,2.22D-16/,
!D   1     XINF/1.79D308/
!----------------------------------------------------------------------
!  NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX
!     APPROXIMATION OVER (1,2).
!----------------------------------------------------------------------
      DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1,   &
             -3.79804256470945635097577E+2,6.29331155312818442661052E+2,   &
             8.66966202790413211295064E+2,-3.14512729688483675254357E+4,   &
             -3.61444134186911729807069E+4,6.64561438202405440627855E+4/
      DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2,   &
            -1.01515636749021914166146E+3,-3.10777167157231109440444E+3,   &
              2.25381184209801510330112E+4,4.75584627752788110767815E+3,   &
            -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/
!D    DATA P/-1.71618513886549492533811D+0,2.47656508055759199108314D+1,
!D   1       -3.79804256470945635097577D+2,6.29331155312818442661052D+2,
!D   2       8.66966202790413211295064D+2,-3.14512729688483675254357D+4,
!D   3       -3.61444134186911729807069D+4,6.64561438202405440627855D+4/
!D    DATA Q/-3.08402300119738975254353D+1,3.15350626979604161529144D+2,
!D   1      -1.01515636749021914166146D+3,-3.10777167157231109440444D+3,
!D   2        2.25381184209801510330112D+4,4.75584627752788110767815D+3,
!D   3      -1.34659959864969306392456D+5,-1.15132259675553483497211D+5/
!----------------------------------------------------------------------
!  COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF).
!----------------------------------------------------------------------
      DATA C/-1.910444077728E-03,8.4171387781295E-04,                     &
           -5.952379913043012E-04,7.93650793500350248E-04,                &
           -2.777777777777681622553E-03,8.333333333333333331554247E-02,   &
            5.7083835261E-03/
!D    DATA C/-1.910444077728D-03,8.4171387781295D-04,
!D   1     -5.952379913043012D-04,7.93650793500350248D-04,
!D   2     -2.777777777777681622553D-03,8.333333333333333331554247D-02,
!D   3      5.7083835261D-03/
!----------------------------------------------------------------------
!  STATEMENT FUNCTIONS FOR CONVERSION BETWEEN INTEGER AND FLOAT
!----------------------------------------------------------------------
      CONV(I) = REAL(I)
!D    CONV(I) = DBLE(I)
      PARITY=.FALSE.
      FACT=ONE
      N=0
      Y=X
      IF(Y.LE.ZERO)THEN
!----------------------------------------------------------------------
!  ARGUMENT IS NEGATIVE
!----------------------------------------------------------------------
        Y=-X
        Y1=AINT(Y)
        RES=Y-Y1
        IF(RES.NE.ZERO)THEN
          IF(Y1.NE.AINT(Y1*HALF)*TWO)PARITY=.TRUE.
          FACT=-PI/SIN(PI*RES)
          Y=Y+ONE
        ELSE
          RES=XINF
          GOTO 900
        ENDIF
      ENDIF
!----------------------------------------------------------------------
!  ARGUMENT IS POSITIVE
!----------------------------------------------------------------------
      IF(Y.LT.EPS)THEN
!----------------------------------------------------------------------
!  ARGUMENT .LT. EPS
!----------------------------------------------------------------------
        IF(Y.GE.XMININ)THEN
          RES=ONE/Y
        ELSE
          RES=XINF
          GOTO 900
        ENDIF
      ELSEIF(Y.LT.TWELVE)THEN
        Y1=Y
        IF(Y.LT.ONE)THEN
!----------------------------------------------------------------------
!  0.0 .LT. ARGUMENT .LT. 1.0
!----------------------------------------------------------------------
          Z=Y
          Y=Y+ONE
        ELSE
!----------------------------------------------------------------------
!  1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY
!----------------------------------------------------------------------
          N=INT(Y)-1
          Y=Y-CONV(N)
          Z=Y-ONE
        ENDIF
!----------------------------------------------------------------------
!  EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0
!----------------------------------------------------------------------
        XNUM=ZERO
        XDEN=ONE
        DO 260 I=1,8
          XNUM=(XNUM+P(I))*Z
          XDEN=XDEN*Z+Q(I)
  260   CONTINUE
        RES=XNUM/XDEN+ONE
        IF(Y1.LT.Y)THEN
!----------------------------------------------------------------------
!  ADJUST RESULT FOR CASE  0.0 .LT. ARGUMENT .LT. 1.0
!----------------------------------------------------------------------
          RES=RES/Y1
        ELSEIF(Y1.GT.Y)THEN
!----------------------------------------------------------------------
!  ADJUST RESULT FOR CASE  2.0 .LT. ARGUMENT .LT. 12.0
!----------------------------------------------------------------------
          DO 290 I=1,N
            RES=RES*Y
            Y=Y+ONE
  290     CONTINUE
        ENDIF
      ELSE
!----------------------------------------------------------------------
!  EVALUATE FOR ARGUMENT .GE. 12.0,
!----------------------------------------------------------------------
        IF(Y.LE.XBIG)THEN
          YSQ=Y*Y
          SUM=C(7)
          DO 350 I=1,6
            SUM=SUM/YSQ+C(I)
  350     CONTINUE
          SUM=SUM/Y-Y+SQRTPI
          SUM=SUM+(Y-HALF)*LOG(Y)
          RES=EXP(SUM)
        ELSE
          RES=XINF
          GOTO 900
        ENDIF
      ENDIF
!----------------------------------------------------------------------
!  FINAL ADJUSTMENTS AND RETURN
!----------------------------------------------------------------------
      IF(PARITY)RES=-RES
      IF(FACT.NE.ONE)RES=FACT/RES
  900 GAMMA=RES
!D900 DGAMMA = RES
      RETURN
! ---------- LAST LINE OF GAMMA ----------
      END FUNCTION GAMMA

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

  END MODULE cm1libs


PROGRAM mlpmns

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:12

!       ========================================================
!       Purpose: This program computes the associated Legendre
!                functions Pmn(x) and their derivatives Pmn'(x)
!                for a given order using subroutine LPMNS
!       Input :  x --- Argument of Pmn(x)
!                m --- Order of Pmn(x),  m = 0,1,2,...,n
!                n --- Degree of Pmn(x), n = 0,1,2,...,N
!       Output:  PM(n) --- Pmn(x)
!                PD(n) --- Pmn'(x)
!       Examples:
!                m = 1,  N = 5,  x = .5
!                n        Pmn(x)           Pmn'(x)
!               -------------------------------------
!                0    .00000000D+00    .00000000D+00
!                1    .86602540D+00   -.57735027D+00
!                2    .12990381D+01    .17320508D+01
!                3    .32475953D+00    .62786842D+01
!                4   -.13531647D+01    .57735027D+01
!                5   -.19282597D+01   -.43977853D+01

!                m = 2,  N = 6,  x = 2.5
!                n        Pmn(x)           Pmn'(x)
!               -------------------------------------
!                0    .00000000D+00    .00000000D+00
!                1    .00000000D+00    .00000000D+00
!                2    .15750000D+02    .15000000D+02
!                3    .19687500D+03    .26625000D+03
!                4    .16832813D+04    .29812500D+04
!                5    .12230859D+05    .26876719D+05
!                6    .81141416D+05    .21319512D+06
!       =======================================================

IMPLICIT DOUBLE PRECISION (p,x,y)
DIMENSION pm(0:200),pd(0:200)
WRITE(*,*)'Please enter m, N, and x '
!        READ(*,*)M,N,X
m=1
n=5
x=.5
WRITE(*,30)m,n,x
CALL lpmns(m,n,x,pm,pd)
WRITE(*,*)
WRITE(*,*)'  n        Pmn(x)           Pmn''(X)    '
WRITE(*,*)' -------------------------------------'
DO  j=0,n
  WRITE(*,20)j,pm(j),pd(j)
END DO
20      FORMAT(1X,i3,2D17.8)
30      FORMAT(1X,'m =',i2,',  ','n =',i2,',  ','x =',f5.1)
END PROGRAM mlpmns

SUBROUTINE lpmns(m,n,x,pm,pd)

!       ========================================================
!       Purpose: Compute associated Legendre functions Pmn(x)
!                and Pmn'(x) for a given order
!       Input :  x --- Argument of Pmn(x)
!                m --- Order of Pmn(x),  m = 0,1,2,...,n
!                n --- Degree of Pmn(x), n = 0,1,2,...,N
!       Output:  PM(n) --- Pmn(x)
!                PD(n) --- Pmn'(x)
!       ========================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: pm(0:n)
DOUBLE PRECISION, INTENT(OUT)            :: pd(0:n)
IMPLICIT DOUBLE PRECISION (a-h,o-z)

DO  k=0,n
  pm(k)=0.0D0
  pd(k)=0.0D0
END DO
IF (DABS(x) == 1.0D0) THEN
  DO  k=0,n
    IF (m == 0) THEN
      pm(k)=1.0D0
      pd(k)=0.5D0*k*(k+1.0)
      IF (x < 0.0) THEN
        pm(k)=(-1)**k*pm(k)
        pd(k)=(-1)**(k+1)*pd(k)
      END IF
    ELSE IF (m == 1) THEN
      pd(k)=1.0D+300
    ELSE IF (m == 2) THEN
      pd(k)=-0.25D0*(k+2.0)*(k+1.0)*k*(k-1.0)
      IF (x < 0.0) pd(k)=(-1)**(k+1)*pd(k)
    END IF
  END DO
  RETURN
END IF
x0=DABS(1.0D0-x*x)
pm0=1.0D0
pmk=pm0
DO  k=1,m
  pmk=(2.0D0*k-1.0D0)*DSQRT(x0)*pm0
  pm0=pmk
END DO
pm1=(2.0D0*m+1.0D0)*x*pm0
pm(m)=pmk
pm(m+1)=pm1
DO  k=m+2,n
  pm2=((2.0D0*k-1.0D0)*x*pm1-(k+m-1.0D0)*pmk)/(k-m)
  pm(k)=pm2
  pmk=pm1
  pm1=pm2
END DO
pd(0)=((1.0D0-m)*pm(1)-x*pm(0))/(x*x-1.0)
DO  k=1,n
  pd(k)=(k*x*pm(k)-(k+m)*pm(k-1))/(x*x-1.0D0)
END DO
RETURN
END SUBROUTINE lpmns


  ! use D for double precision exponents

  parameter(n_f = 2)
  parameter(L = 4)
  parameter(Lt = 6)
  parameter(cutoff = 100.D0, temporalcutoff = 150.D0)
  parameter(improveN = 2)
  parameter(improveP = 0)
  parameter(improveD = 0)
  parameter(c1S0_phys = -5.615D-5)
  parameter(c3S1_phys = -6.543D-5)

  ! run parameters

  parameter(ntot = 400000)
  parameter(myseed = 123981)
  parameter(ntherm = 1000)
  parameter(nprintevery = 500)
  parameter(measureevery = 2)
  parameter(ncheck = 0)
  parameter(nHMC = 10)
  parameter(eHMC = 0.1D0)
  parameter(startspread = 1.0D0)

  ! constants

  parameter(amnu_phys = 938.92D0)
  parameter(ampi3_phys = 134.98D0)
  parameter(fpi_phys = 92.2D0)
  parameter(gA = 1.29D0)
  parameter(pi = 3.14159265358979324D0)

  ! derived parameters

  parameter(atovera = cutoff/temporalcutoff)
  parameter(amnu = amnu_phys/cutoff)
  parameter(ampi3 = ampi3_phys/cutoff)
  parameter(fpi = fpi_phys/cutoff)
  parameter(c0_phys = (3.D0*c1S0_phys+1.D0*c3S1_phys)/4.D0)
  parameter(cI_phys = (1.D0*c1S0_phys-1.D0*c3S1_phys)/4.D0)
  parameter(c0 = c0_phys*cutoff**2)
  parameter(cI = cI_phys*cutoff**2)
  parameter(h = atovera/(2.D0*amnu))


subroutine gsub(Yout, delta, eps, offset, phase)

    implicit none
    double precision, intent(in) :: delta, eps, offset, phase
    double precision, dimension(4, 2, 2), intent(out) :: Yout
    double precision, dimension(2, 2) :: Reg, Img, Regt, Imgt, sy

    sy  = reshape((/ 0, 1, -1, 0 /), shape(sy))

    Reg     = REALPART(delta * EXP((0d0,1d0) * phase) / (eps + (0d0,1d0) * SQRT(delta**2 - (eps + (0d0,1d0) * offset)**2)) * sy)
    Img     = IMAGPART(delta * EXP((0d0,1d0) * phase) / (eps + (0d0,1d0) * SQRT(delta**2 - (eps + (0d0,1d0) * offset)**2)) * sy)
    Regt    = REALPART(delta * EXP(-(0d0,1d0) * phase) / (eps + (0d0,1d0) * SQRT(delta**2 - (eps + (0d0,1d0) * offset)**2)) * sy)
    Imgt    = IMAGPART(delta * EXP(-(0d0,1d0) * phase) / (eps + (0d0,1d0) * SQRT(delta**2 - (eps + (0d0,1d0) * offset)**2)) * sy)

    Yout(1,:,:) = Reg
    Yout(2,:,:) = Img
    Yout(3,:,:) = Regt
    Yout(4,:,:) = Imgt

end subroutine gsub


! ==============================================================
! Copyright © 2020 Intel Corporation
!
! SPDX-License-Identifier: MIT
! =============================================================
!
! [DESCRIPTION]
! This code finds all primes in the first 40,000,000 integers, the number of
! 4n+1 primes, and the number of 4n-1 primes in the same range.
!
! This source illustrates two OpenMP directives to help speed up
! the code.  First, a dynamic "schedule" clause is used with the OpenMP "for"
! directive. Because the "for" loop's workload increases as its index
! gets bigger, the default "static" scheduling does not work well.
! Instead dynamic scheduling is used to account for the increasing
! workload.  But dynamic scheduling itself has more overhead than
! static scheduling, so a "chunk size" of 10 is used to reduce the
! overhead for dynamic scheduling.  Second, a "reduction" clause is
! used instead of an OpenMP "critical" directive to eliminate lock overhead.
! A "critical" directive would cause excessive lock overhead due to
! the one-thread-at-time update of the shared variables each
! time through the "for" loop.  Instead the reduction clause causes only
! one update of the shared variables once at the end of the loop.
!
! [COMPILE]
! Use the following compiler options to compile both multi- and
! single-threaded versions.
!
! Parallel compilation:
!
!   Windows*: /Qopenmp /fpp
!
!   Linux* and macOS*: -qopenmp -fpp
!
! Serial compilation:
!
!   Use the same command, but omit the -fopenmp (Linux* and macOS*)
!   or /Qopenmp (Windows) option.
!

program ompPrime

#ifdef _OPENMP
   include 'omp_lib.h'  !needed for OMP_GET_NUM_THREADS()
#endif

integer :: start = 1
integer :: end = 40000000
integer :: number_of_primes = 0
integer :: number_of_41primes = 0
integer :: number_of_43primes = 0
integer index, factor, limit, nthr
real rindex, rlimit
logical prime, print_primes

print_primes = .false.
nthr = 1 ! assume just one thread
print *, ' Range to check for Primes:',start,end

#ifdef _OPENMP
!$omp parallel

!$omp single
   nthr = OMP_GET_NUM_THREADS()
   print *, ' We are using',nthr,' thread(s)'
!$omp end single
!

!
!$omp do private(factor, limit, prime) &
   schedule(dynamic,10) &
   reduction(+:number_of_primes,number_of_41primes,number_of_43primes)
#else
   print *, ' We are using',nthr,' thread(s)'
#endif

do index = start, end, 2   !workshared loop

   limit = int(sqrt(real(index)))
   prime = .true.  ! assume number is prime
   factor = 3

   do
      if(prime .and. factor .le. limit) then
         if(mod(index,factor) .eq. 0) then
            prime = .false.
         endif
         factor = factor + 2
      else
         exit  ! we can jump out of non-workshared loop
      endif
   enddo

   if(prime) then
      if(print_primes) then
         print *, index, ' is prime'
      endif

      number_of_primes = number_of_primes + 1

      if(mod(index,4) .eq. 1) then
         number_of_41primes = number_of_41primes + 1
      endif

      if(mod(index,4) .eq. 3) then
         number_of_43primes = number_of_43primes + 1
      endif

   endif   ! if(prime)
enddo
!$omp end do
!$omp end parallel

print *, ' Number of primes found:',number_of_primes
print *, ' Number of 4n+1 primes found:',number_of_41primes
print *, ' Number of 4n-1 primes found:',number_of_43primes
end program ompPrime