MODULE DG_WAVE

USE MPI
USE BASIS
USE PARAM, ONLY: N, C, T_TOTAL, NT
USE USER_DEFINED

IMPLICIT NONE

DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:, :) :: DER_TRANSPOSE   ! THE TRANSPOSE OF THE FIRST DERIVATIVE MATRIX
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SOLUTION   ! SOLUTION AT GL POINTSJ
DOUBLE PRECISION :: DELTA_T

CONTAINS

SUBROUTINE DG_WAVE_PROCEDURE
! ----------------------------------------------------------------------
! SOLVE A SCALER ADVACTION PROBLEM
! INTEGRATE THE SYSTEM FROM INITIAL TO FINAL TIME
! USE GAUSS-LENGENDRE POINTS
! MODIFIED ALORITHM 51
!-----------------------------------------------------------------------

    IMPLICIT NONE

    INTEGER :: K

    DOUBLE PRECISION :: TN = 0.0D0 ! CURRENT TIME
    DOUBLE PRECISION :: ERROR(0:N)
    DOUBLE PRECISION :: EXACT(0:N)

    !-------------------------------------------------------------------
    ! ALLOCATE
    ALLOCATE(SOLUTION(0:N))
    SOLUTION=0.0D0
    !-------------------------------------------------------------------

    !-------------------------------------------------------------------
    ! COMPUTE GAUSS-LEGENDRE POINTS AND WEIGHTS
    ! COMPUTE THE FIRST ORDER PLOYMOIAL DERIVATIVE MATRIX
    ! COMPUTE THE LAGANDRE POLYNOMIAL AT THE TWO ENDS OF THE BOUNDARIES
    CALL CONSTRUCT_DG
    !-------------------------------------------------------------------

    !-------------------------------------------------------------------
    ! USER DEFINED INITIAL CONDITION
    CALL INITIAL_CONDITION(N, SOLUTION)
    !-------------------------------------------------------------------

!    PRINT *, SOLUTION

    !-------------------------------------------------------------------
    ! CONFIRM THE TIME STEP
    CALL DECIDE_TIME_STEP(N)
!    DELTA_T = 1.5E-4
    !-------------------------------------------------------------------

    !-------------------------------------------------------------------
!    DO K=0, NT-1
    DO K=0,0

        CALL DG_STEP_BY_RK3(TN, N)
        TN = (K+1)*DELTA_T
    ENDDO
    !-------------------------------------------------------------------

    ! ------------------------------------------------------------------
    ! GET ERROR
    CALL GET_ERROR(N, ERROR, EXACT, TN)
    !-------------------------------------------------------------------

!    PRINT *, MAXVAL(DABS(ERROR))

    !-------------------------------------------------------------------
    ! WRITE SOLUTION TO FILE
!    OPEN(UNIT=6, FILE="advaction_solution.txt")
!    DO K=0, N
!        WRITE(6, 30) K, GL_POINT(K), SOLUTION(K), EXACT(K), ERROR(K)
!30 FORMAT(I2, 2X, F10.5, 2X, E20.10, 2X, E20.10, 2X, E20.10)

!    ENDDO
!    CLOSE(UNIT=6)
    !-------------------------------------------------------------------

    ! WRITE DATA TO FILE------------------------------------------------
    CALL WRITE_DATA(N, EXACT, TN)   ! FILE = "advaction_solution.dat"
    !-------------------------------------------------------------------

    ! GET ERROR MAX-----------------------------------------------------
!    OPEN(UNIT = 6, FILE="max_error.dat", ACCESS="APPEND")
!    WRITE(6, 70) N, MAXVAL(DABS(ERROR))
!70 FORMAT(I3, 2X, E20.10)
!    CLOSE(UNIT = 6)
    !-------------------------------------------------------------------

END SUBROUTINE DG_WAVE_PROCEDURE

SUBROUTINE CONSTRUCT_DG
!-----------------------------------------------------------------------
! CONSTRUCTOR FOR THE DISCONTINUOUS GALERKIN CLASS
! ALGORITHM 59
!-----------------------------------------------------------------------

    IMPLICIT NONE

    INTEGER :: I, J

    !-------------------------------------------------------------------
    ALLOCATE(LAGRANGE_LEFT(0: N), LAGRANGE_RIGHT(0: N))
    ALLOCATE(DER_TRANSPOSE(0: N, 0: N))

    LAGRANGE_LEFT = 0.0D0
    LAGRANGE_RIGHT = 0.0D0
    DER_TRANSPOSE = 0.0D0
    !-------------------------------------------------------------------

    ! GL POINTS AND WEIGHTS---------------------------------------------
    CALL GL(N)
    !-------------------------------------------------------------------

    ! FIRST DERIVATIVE MATRIX-------------------------------------------
    CALL mth_Order_Polynomial_Derivative_Matrix(N,1, GL_POINT)    ! USE GL POINTS,
    !--------------------------------------------------------------------

    ! LAGRANGE POLY AT POINT -1.0 AND +1.0 -----------------------------
    CALL LAGRANGE_INTERPOLATING_POLYNOMIAL(N, -1.0D0, GL_POINT, BARY, LAGRANGE_LEFT)
    CALL LAGRANGE_INTERPOLATING_POLYNOMIAL(N, 1.0D0, GL_POINT, BARY, LAGRANGE_RIGHT)
    !-------------------------------------------------------------------

!    PRINT *, LAGRANGE_LEFT

    ! COMPUTE DERIVATIVE TRANSPOSE--------------------------------------
    DO J=0, N
        DO I=0, N
            DER_TRANSPOSE(I, J) = - DER(J, I)*GL_W(J)/GL_W(I)
        ENDDO

    ENDDO
    !-------------------------------------------------------------------

END SUBROUTINE CONSTRUCT_DG

SUBROUTINE DG_DERIVATIVE(N, SOLUTION_LEFT, SOLUTION_RIGHT, SOLUTION_DER)
!-----------------------------------------------------------------------
! FIRST SPATIAL DERIVATIVE VIA THE GALERKIN APPROXIMATION
! ALGORITHM 60
!-----------------------------------------------------------------------

    IMPLICIT NONE

    INTEGER :: N    ! POLY ORDER
    INTEGER :: J

    DOUBLE PRECISION :: SOLUTION_LEFT   ! SOLUTION ON THE LEFT BOUNDARY
    DOUBLE PRECISION :: SOLUTION_RIGHT   ! SOLUTION ON THE RIGHT BOUNDARY
    DOUBLE PRECISION :: SOLUTION_DER(0:N)

    CALL MATRIX_VECTOR_DERIVATIVE(N, DER_TRANSPOSE, SOLUTION, SOLUTION_DER)

    DO J=0, N
        SOLUTION_DER(J) = SOLUTION_DER(J)+&
                        (SOLUTION_RIGHT*LAGRANGE_RIGHT(J) - &
                        SOLUTION_LEFT*LAGRANGE_LEFT(J))/GL_W(J)
    ENDDO

END SUBROUTINE DG_DERIVATIVE

SUBROUTINE EVALUATE_BOUNDARY(N, T, C, SOLUTION_LEFT, SOLUTION_RIGHT)
!!----------------------------------------------------------------------
!! TIME DERIVATIVE FOR DG
!! ALGORITHM 61 (PART 1)
!! INPUT : T: TIME; C: WAVE SPEED
!!----------------------------------------------------------------------

    IMPLICIT NONE

    INTEGER:: N ! POLY ORDER

    DOUBLE PRECISION :: T   ! TIME
    DOUBLE PRECISION :: C   ! WAVE SPEED
    DOUBLE PRECISION :: SOLUTION_LEFT, SOLUTION_RIGHT   ! APPROXIMATE SOLUTION ON THE LEFT AND RIGHT END OF THE BOUNDARY

!    PRINT *, SOLUTION

    ! GET SOLUTION ON THE LEFT AND RIGHT BOUNDARY-----------------------
    IF(C > 0) THEN
        SOLUTION_LEFT = BOUNDARY_SOLUTION(T)
        CALL INTERPOLATE_TO_BOUNDARY(N, SOLUTION, LAGRANGE_RIGHT, SOLUTION_RIGHT)
    ELSE
        SOLUTION_RIGHT = BOUNDARY_SOLUTION(T)
        CALL INTERPOLATE_TO_BOUNDARY(N, SOLUTION, LAGRANGE_LEFT, SOLUTION_LEFT)
    ENDIF
    !-------------------------------------------------------------------

!    PRINT *, LAGRANGE_RIGHT

!    PRINT *, SOLUTION_RIGHT

!    PRINT *, SOLUTION

END SUBROUTINE EVALUATE_BOUNDARY

SUBROUTINE DG_TIME_DERIVATIVE(N, SOLUTION_LEFT, SOLUTION_RIGHT, C, &
                                SOLUTION_TIME_DER)
!-----------------------------------------------------------------------
! TIME DERIVATIVE
! ALORITHM 61 (PART 2)
!-----------------------------------------------------------------------
    IMPLICIT NONE

    INTEGER :: N

    DOUBLE PRECISION :: SOLUTION_LEFT, SOLUTION_RIGHT
    DOUBLE PRECISION :: SOLUTION_TIME_DER(0:N)
    DOUBLE PRECISION :: C   ! WAVE SPEED
    DOUBLE PRECISION :: SOLUTION_DER(0:N)

    CALL DG_DERIVATIVE(N, SOLUTION_LEFT, SOLUTION_RIGHT, SOLUTION_DER)

    SOLUTION_TIME_DER = -C * SOLUTION_DER

END SUBROUTINE DG_TIME_DERIVATIVE

SUBROUTINE INTERPOLATE_TO_BOUNDARY(N, SOLUTION1, LAGRANGE1, INTERPOLATE_VALUE)
!!----------------------------------------------------------------------
!! TO COMPUTE THE SOLUTION AT THE OTHER BOUNDARY
!! ALORITHM 61 (PART 3)
!!----------------------------------------------------------------------
    IMPLICIT NONE

    INTEGER :: N    ! POLY ORDER
    INTEGER :: J

    DOUBLE PRECISION :: INTERPOLATE_VALUE
    DOUBLE PRECISION, DIMENSION(0:N) :: SOLUTION1
    DOUBLE PRECISION, DIMENSION(0:N) :: LAGRANGE1

    INTERPOLATE_VALUE = 0.0D0

    DO J=0, N
        INTERPOLATE_VALUE = INTERPOLATE_VALUE + LAGRANGE1(J)*SOLUTION1(J)

    ENDDO

END SUBROUTINE INTERPOLATE_TO_BOUNDARY

SUBROUTINE DG_STEP_BY_RK3(TN, N)
! ----------------------------------------------------------------------
! THRID ORDER RUNGE-KUTTA INTEGRATION
! INPUT: TN: CURRENT TIME; TIME_DER: DG TIME DERIVATIVE
! ALGORITHM 62
!-----------------------------------------------------------------------

    IMPLICIT NONE

    INTEGER :: N
    INTEGER :: I, J

    DOUBLE PRECISION :: TN  ! CURRENT TIME
    DOUBLE PRECISION :: T
    DOUBLE PRECISION :: SOLUTION_TIME_DER(0:N)   ! DG TIME DERIVATIVE AT CURRENT TIME
    DOUBLE PRECISION :: G(0:N)  ! INTERMEDIATE ARRAY
    DOUBLE PRECISION :: AM(3), BM(3), GM(3) ! COEFFICIENT
    DOUBLE PRECISION :: SOLUTION_LEFT, SOLUTION_RIGHT

    AM = (/0.0D0, (-5.0D0/9.0D0), (-153D0/128.0D0)/)
    BM = (/0.0D0, (1.0D0/3.0D0), (3.0D0/4.0D0)/)
    GM = (/(1.0D0/3.0D0), (15.0D0/16.0D0), (8.0D0/15.0D0)/)

    SOLUTION_TIME_DER = 0.0D0

    DO I=1,3
        T=TN+BM(I)*DELTA_T
!        PRINT *, T

        CALL EVALUATE_BOUNDARY(N, T, C, SOLUTION_LEFT, SOLUTION_RIGHT)
        CALL DG_TIME_DERIVATIVE(N, SOLUTION_LEFT, SOLUTION_RIGHT, C, SOLUTION_TIME_DER)

!        PRINT *, SOLUTION_LEFT

        DO J=0,N
            G(J) = AM(I)*G(J) + SOLUTION_TIME_DER(J)
            SOLUTION(J) = SOLUTION(J) + GM(I)*DELTA_T*G(J)
        ENDDO
    ENDDO

END SUBROUTINE DG_STEP_BY_RK3

SUBROUTINE DECIDE_TIME_STEP(N)

    USE PARAM, ONLY: NT, T_TOTAL

    IMPLICIT NONE

    INTEGER :: N    ! POLY ORDER

    DOUBLE PRECISION :: DEL_T_MAX   ! MAXIMUM DELTA_T FOR STABILITY

    !-------------------------------------------------------------------
    IF(N < 32) THEN
        DEL_T_MAX=DBLE(2.5D0/N)

    ELSE
        DEL_T_MAX=DBLE(38.0D0*2.51D0/(N)**2)
    ENDIF
    !-------------------------------------------------------------------

    !-------------------------------------------------------------------
    DELTA_T = DBLE(T_TOTAL/NT)
    !-------------------------------------------------------------------

    !-------------------------------------------------------------------
    IF(DEL_T_MAX < DELTA_T) THEN

        PRINT *, "TIME STEP NUMBER TN IS TOO SMALL."
        PRINT *, "TN >= ", INT(T_TOTAL/DEL_T_MAX)

        STOP

    ENDIF
    !-------------------------------------------------------------------

END SUBROUTINE DECIDE_TIME_STEP

SUBROUTINE GET_ERROR(N, ERROR, EXACT, T)

    IMPLICIT NONE

    INTEGER :: N
    INTEGER :: I

    DOUBLE PRECISION :: EXACT(0: N)
    DOUBLE PRECISION :: ERROR(0: N)
    DOUBLE PRECISION :: T   ! TIME T

    ERROR = 0.0D0

    CALL EXACT_SOLUTION(T, GL_POINT, N, EXACT)

    DO I=0, N
        ERROR(I) = EXACT(I) - SOLUTION(I)

    ENDDO

END SUBROUTINE GET_ERROR

SUBROUTINE WRITE_DATA(N, EXACT, TN)

    INTEGER :: N
    INTEGER :: K

    DOUBLE PRECISION :: EXACT(0:N)  ! EXACT SOLUTION
    DOUBLE PRECISION :: TN

    OPEN(UNIT=7, FILE="advaction_solution.dat")
    WRITE(7, FMT='(''VARIABLES = "X", "SOLUTION", "EXACT"'')')
    WRITE(7, 60) 'ZONE DATAPACKING=BLOCK, T= ', '"', TN, '"', 'I=',N+1
60 FORMAT(A27, A1, F5.2, A1, 2X, A2, I3)

    ! WRITE SOLUTION----------------------------------------------------
    DO K=0, N
        WRITE(7, 40, ADVANCE='NO') GL_POINT(K)
    ENDDO
40 FORMAT(F10.5)

    DO K=0, N
        WRITE(7, 50, ADVANCE='NO') SOLUTION(K)
    ENDDO
50 FORMAT(E20.10)

    DO K=0, N
        WRITE(7, 50, ADVANCE='NO') EXACT(K)
    ENDDO
    !-------------------------------------------------------------------

    CLOSE(UNIT=7)

END SUBROUTINE WRITE_DATA

END MODULE DG_WAVE


! performance_arrays.f90 --
!
!     Example belonging to "Modern Fortran in Practice" by Arjen Markus
!
!     This work is licensed under the Creative Commons Attribution 3.0 Unported License.
!     To view a copy of this license, visit http://creativecommons.org/licenses/by/3.0/
!     or send a letter to:
!     Creative Commons, 444 Castro Street, Suite 900, Mountain View, California, 94041, USA.
!
!     Simple program to determine the performance differences between
!     using array-valued functions and ordinary do-loops
!
program performance_arrays
    implicit none

    real, dimension(:), allocatable :: data
    real                            :: threshold, mean1, mean2, difference
    real                            :: meansum
    integer                         :: i, j, nodata, norepeat
    integer                         :: time1, time2, time3
    integer, dimension(6)           :: time_pack
    integer, dimension(6)           :: time_do

    threshold  = 0.1
    nodata     = 1
    norepeat   = 1000
    do i = 1,6
        nodata = nodata * 10
        allocate( data(1:nodata) )

        call random_number( data )

        difference = 0.0
        meansum    = 0.0
        call system_clock( time1 )
        do j = 1,norepeat
            call mean_pack( pack( data, data > threshold ), mean1 )
            meansum = meansum + mean1
        enddo

        call system_clock( time2 )
        do j = 1,norepeat
            call mean_do_loop( data, threshold, mean2 )
            meansum = meansum + mean2
        enddo
        call system_clock( time3 )

        time_pack(i) = time_pack(i) + (time2-time1)
        time_do(i)   = time_do(i)   + (time3-time2)

        difference   = difference + abs(mean1-mean2)

        deallocate( data )
    enddo

    write( *, '(i10,2i10)' ) ( 10**i, time_do(i), time_pack(i), i = 1,6 )
    write( *, '(a,e12.4)' )    'Mean difference: ', difference / 600.0
contains
subroutine mean_pack( data, mean )
    real, dimension(:) :: data

    real               :: mean

    mean = sum(data)/max(1,size(data))

end subroutine mean_pack

subroutine mean_do_loop( data, threshold, mean )
    real, dimension(:) :: data
    real               :: threshold
    real               :: mean

    integer            :: i
    integer            :: count

    mean  = 0.0
    count = 0
    do i = 1,size(data)
        if ( data(i) > threshold ) then
            mean  = mean  + data(i)
            count = count + 1
        endif
    enddo

    mean = mean / max(1,count)

end subroutine mean_do_loop
end program


program blas_probabilities
    use, intrinsic :: iso_fortran_env, only : DP => REAL64, error_unit
    use :: init_mod, only : initialize, create_matrix
    implicit none
    integer :: matrix_size, nr_iters, i
    real(kind=DP), dimension(:, :), allocatable :: prob_matrix, final_matrix, &
                                                   tmp_matrix
    real(kind=DP) :: max_val

    call initialize(matrix_size, nr_iters)
    prob_matrix = create_matrix(matrix_size)
    final_matrix = create_matrix(matrix_size)
    tmp_matrix = create_matrix(matrix_size)

    call random_number(prob_matrix)
    call normalize(prob_matrix)
    call dcopy(size(prob_matrix), prob_matrix, 1, final_matrix, 1)

    do i = 2, nr_iters, 2
        call dgemm('n', 'n', &
                   matrix_size, matrix_size, matrix_size, &
                   1.0_DP, final_matrix, matrix_size, &
                   prob_matrix, matrix_size, 0.0_DP, &
                   tmp_matrix, matrix_size)
        call dgemm('n', 'n', &
                   matrix_size, matrix_size, matrix_size, &
                   1.0_DP, tmp_matrix, matrix_size, &
                   prob_matrix, matrix_size, 0.0_DP, &
                   final_matrix, matrix_size)
    end do
    if (mod(nr_iters, 2) /= 0) then
        call dgemm('n', 'n', &
                   matrix_size, matrix_size, matrix_size, &
                   1.0_DP, final_matrix, matrix_size, &
                   prob_matrix, matrix_size, 0.0_DP, &
                   tmp_matrix, matrix_size)
        call dcopy(size(prob_matrix), tmp_matrix, 1, final_matrix, 1)
    end if

    max_val = 0.0_DP
    do i = 1, size(final_matrix, 1)
        if (final_matrix(i, i) > max_val) max_val = final_matrix(i, i)
    end do

    if (matrix_size <= 10) call print_matrix(final_matrix)

    deallocate (prob_matrix, final_matrix, tmp_matrix)

    print '(A, e25.15)', 'maximum value = ', max_val

contains

    subroutine print_matrix(matrix)
        implicit none
        real(kind=DP), dimension(:, :), intent(in) :: matrix
        integer :: row

        do row = 1, size(matrix, 1)
            print '(*(F12.7))', matrix(row, :)
        end do
    end subroutine print_matrix

    subroutine normalize(matrix)
        implicit none
        real(kind=DP), dimension(:, :), intent(inout) :: matrix
        real(kind=DP), dimension(:), allocatable :: norm
        integer :: row, istat, rows, cols

        rows = size(matrix, 1)
        cols = size(matrix, 2)
        allocate (norm(rows), stat=istat)
        if (istat /= 0) then
            write (unit=error_unit, fmt='(A)') 'error: can not allocate norm'
            stop 8
        end if
        norm = sum(matrix, dim=2)
        do row = 1, rows
            call dscal(cols, 1.0_DP/norm(row), matrix(row, :), 1)
        end do

        deallocate (norm)
    end subroutine normalize

end program blas_probabilities


      include 'ttb/ttb_library.f'

      SUBROUTINE UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,
     1 RPL,DDSDDT,DRPLDE,DRPLDT,
     2 STRAN,DSTRAN,TIME,DTIME,TEMP,DTEMP,PREDEF,DPRED,CMNAME,
     3 NDI,NSHR,NTENS,NSTATV,PROPS,NPROPS,COORDS,DROT,PNEWDT,
     4 CELENT,DFGRD0,DFGRD1,NOEL,NPT,LAYER,KSPT,JSTEP,KINC)

      ! ABAQUS UMAT:    Nearly-Incompressible Neo-Hookean Material
      !                 Example for usage of Tensor Toolbox
      ! capability:     3D analysis, axisymmetric?
      ! Formulation:    Total Lagrange with push forward for Abaqus
      ! Andreas Dutzler, 2018-07-22, Graz University of Technology

      use Tensor
      implicit none

      INCLUDE 'ABA_PARAM.INC'

      CHARACTER*80 CMNAME
      DIMENSION STRESS(NTENS),STATEV(NSTATV),
     1 DDSDDE(NTENS,NTENS),DDSDDT(NTENS),DRPLDE(NTENS),
     2 STRAN(NTENS),DSTRAN(NTENS),TIME(2),PREDEF(1),DPRED(1),
     3 PROPS(NPROPS),COORDS(3),DROT(3,3),DFGRD0(3,3),DFGRD1(3,3),
     4 JSTEP(4)

      type(Tensor2) :: F1
      real(kind=8)  :: J,kappa,C10

      type(Tensor2s) :: C1,invC1,S1,Eye
      type(Tensor4s) :: C4

      ! material parameters
      C10 = 0.5
      kappa = 500.0

      Eye = identity2(Eye)
      F1 = dfgrd1(1:3,1:3)
      J = det(F1)

      ! right cauchy-green deformation tensor and it's inverse
      C1 = transpose(F1)*F1
      invC1 = inv(C1) ! faster method: invC1 = inv(C1,J**2)

      ! pk2 stress
      S1 = 2.*C10*J**(-2./3.)*dev(C1)*invC1 + kappa*(J-1)*J*invC1

      ! push forward to cauchy stress used in abaqus
      S1 = piola(F1,S1)/J

      ! material elasticity tensor
      C4 = 2.*C10 * J**(-2./3.) * 2./3. *
     *  ( tr(C1) * (invC1.cdya.invC1)
     *    - (Eye.dya.invC1) - (invC1.dya.Eye)
     *    + tr(C1)/3. * (invC1.dya.invC1) )
     *  + (kappa*(J-1)*J+kappa*J**2) * (invC1.dya.invC1)
     *  - 2.*kappa*(J-1)*J* (invC1.cdya.invC1)

      ! push forward to jaumann tangent of cauchy stress for abaqus
      C4 = piola(F1,C4)/detF1 + (S1.cdya.Eye)+(Eye.cdya.S1)

      ! output as array
      s(1:ntens)         = asabqarray( voigt(S1), ntens )
      d(1:ntens,1:ntens) = asabqarray( voigt(C4), ntens, ntens )

      return
      end


module NSGRAV
! Description:
!    Contains procedures for the calculation of perturbations due to the non-
!    sphericity of the main body. INITIALIZE_NSGRAV reads main body data from a
!    data file, and initializes coefficient matrices.
!    The calculation of the perturbing potential, perturbing acceleration, and
!    the time derivative of the potential in the body-fixed frame (the latter is
!    needed in regularized formulations) takes place in PINES_NSG.
!    NORMFACT gives the normalization factor for the gravitational coefficients.
!
! Author:
!    Davide Amato
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! Revisions:
!    180806: Overhaul and implementation of Pines method.
!    181204: Use GMST (IERS 2006 conventions) rather than ERA. Consider Earth
!            Rotation Rate derived from IERS 2006 conventions.
!
! ==============================================================================

! MODULES
use KINDS,      only: dk
use SETTINGS,   only: gdeg,gord
use IO,         only: id_earth
use PHYS_CONST, only: qk,GE,RE,flatt,omegaE,secsPerDay,secsPerSidDay,twopi,&
&ERR_constant
implicit none

! VARIABLES
! Spherical harmonics (unnormalized)
integer               ::  maxDeg, maxOrd
real(dk),allocatable  ::  Cnm(:,:),Snm(:,:)

! Pines algorithm arrays
real(dk),allocatable  ::  Anm(:,:),Dnm(:,:),Enm(:,:),Fnm(:,:),Gnm(:,:)
real(dk),allocatable  ::  Rm(:),Im(:),Pn(:)
real(dk),allocatable  ::  Aux1(:),Aux2(:),Aux3(:),Aux4(:,:)

contains

subroutine INITIALIZE_NSGRAV(earthFile)
! Description:
!    Reads Earth gravity data from a text file. Initializes the gravitational
!    parameter, equatorial radius, flattening, rotational velocity, spherical
!    harmonics coefficients, and auxiliary matrices for Pines' algorithm. The
!    latter computes the Earth potential in Cartesian coordinates, avoiding
!    singularities due to the spherical harmonics.
!    Part of this subroutine is due to Hodei Urrutxua (Universidad Rey Juan
!    Carlos, Madrid, Spain) and Claudio Bombardelli (Universidad Politécnica de
!    Madrid, Madrid, Spain).
!
! Author:
!    Davide Amato
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! Revisions:
!    180806: Subroutine created from part of READ_PHYS().
!
! ==============================================================================

! Arguments
character(len=*),intent(in)  ::  earthFile

! Locals
character(len=72)  ::  dummy
real(dk)           ::  invFlatt
integer            ::  i,j,l,m,n

! ==============================================================================

open(unit=id_earth,file=trim(earthFile),status='old',action='read')
read(id_earth,'(a)') (dummy, i=1,4)
read(id_earth,'(a37,i3)') dummy, maxDeg
read(id_earth,'(a37,i3)') dummy, maxOrd
read(id_earth,'(a36,e22.15)') dummy, GE
read(id_earth,'(a36,e22.15)') dummy, RE
read(id_earth,'(a36,e22.15)') dummy, invFlatt
read(id_earth,'(a36,e22.15)') dummy, omegaE

flatt    = 1._dk/invFlatt

! Read and de-normalize spherical harmonics coefficients and auxiliary matrices
! for Pines' algorithm.
! Initialize
l = 1; m = 0;
allocate(Cnm(1:maxDeg,0:maxDeg)); Cnm = 0._dk
allocate(Snm(1:maxDeg,0:maxDeg)); Snm = 0._dk
allocate(Anm(0:maxDeg+2, 0:maxDeg+2))
allocate(Dnm(1:maxDeg,   0:maxDeg))
allocate(Gnm(1:maxDeg,   0:maxDeg))
allocate(Enm(1:maxDeg,   1:maxDeg))
allocate(Fnm(1:maxDeg,   1:maxDeg))
allocate(Rm(0:maxDeg)    )
allocate(Im(0:maxDeg)    )
allocate(Pn(0:maxDeg + 1))
allocate(Aux1(1:maxDeg+1))
allocate(Aux2(1:maxDeg+1))
allocate(Aux3(1:maxDeg+1))
allocate(Aux4(1:maxDeg+1, 0:maxDeg+1))

read(id_earth,'(a)') (dummy, i=1,2)
do i=1,maxDeg
  do j=0,minval([i,maxOrd])
    read(id_earth,'(2(1x,i2),2(1x,e24.17))') l,m,Cnm(i,j),Snm(i,j)
    Cnm(i,j) = Cnm(i,j)/NORMFACT(i,j)
    Snm(i,j) = Snm(i,j)/NORMFACT(i,j)
  end do
end do

close(id_earth)

! Fill coefficient arrays for Pines algorithm
Anm(:,:) = 0._dk
Dnm(:,:) = 0._dk
Gnm(:,:) = 0._dk
Enm(:,:) = 0._dk
Fnm(:,:) = 0._dk
Anm(0,0) = 1._dk
Anm(1,1) = 1._dk
do n = 1,maxDeg + 1
  Aux1(n) = 2._dk*n + 1._dk
  Aux2(n) = Aux1(n) / (n+1._dk)
  Aux3(n) = n / (n+1._dk)
  do m = 0, n-1
    Aux4(n,m) = (n+m+1._dk)
  end do
end do

! Earth Rotation Rate (revolutions per tropical day)
secsPerSidDay = twopi/omegaE
ERR_constant = secsPerDay/secsPerSidDay

end subroutine INITIALIZE_NSGRAV

function NORMFACT(l,m)
! Description:
!    Normalization factor for the spherical harmonics coefficients and
!    associated Legendre functions:
!
!    sqrt( (l + m)! / ( (2 - delta_{0,m}) * (2n  + 1) * (n - m)! ) )
!
! Reference:
!    [1] Montenbruck, O., Gill, E., "Satellite Orbits", p. 58, Springer, 2000.
!
! Author:
!    Davide Amato
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! ==============================================================================

! Arguments and function definition
integer,intent(in)  ::  l,m
real(qk)            ::  NORMFACT
! Locals
real(qk)            ::  lr,mr
real(qk)            ::  kron
real(qk)            ::  numer,denom

! ==============================================================================
lr = real(l,qk)
mr = real(m,qk)

numer = gamma(lr + mr + 1._qk)

if (m == 0) then
	kron = 1._qk
else
	kron = 0._qk
end if

denom = (2._qk - kron) * (2._qk*lr + 1._qk) * gamma(lr - mr + 1._qk)

NORMFACT = sqrt(numer/denom)

end function NORMFACT

subroutine PINES_NSG(GM,RE,rIn,tau,FIn,pot,dPot)
! Description:
!    Compute the perturbing acceleration, perturbing potential (optional), and
!    time derivative of the perturbing potential in the body-fixed frame
!    (optional), given the position vector wrt the non-spherical body, its
!    gravitational parameter and its potential coefficients.
!    Uses the method described in the Reference to perform the calculation in
!    Cartesian coordinates, thereby avoiding associated Legendre functions and
!    polynomials. The formulation is non-singular everywhere for r > RE, where
!    RE is the radius of the non-spherical body.
!
!    Adapted from code developed by Hodei Urrutxua (Universidad Rey Juan Carlos,
!    Madrid, Spain) and Claudio Bombardelli (Universidad Politécnica de Madrid,
!    Madrid, Spain).
!
! Author:
!    Davide Amato
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! Reference:
!    S. Pines, "Uniform Representation of the Gravitational Potential and its
!    derivatives," AIAA J. 11 (11), pp. 1508-1511, 1973.
!
! Revisions:
!    180806: First working version of subroutine.
!    181204: Use GMST (IERS 2006 conventions) rather than ERA. Consider Earth
!            Rotation Rate derived from IERS 2006 conventions.
!
! ==============================================================================

! Use associations
use AUXILIARIES, only: MJD0, TU, T2MJD
use PHYS_CONST,  only: delta_JD_MJD
use PHYS_CONST,  only: ERR_IAU06, UTC2TT

! Arguments
real(dk),intent(in)   ::  GM             ! Gravitational parameter
real(dk),intent(in)   ::  RE             ! Equatorial radius
real(dk),intent(in)   ::  rIn(1:3)       ! Position in the inertial frame
real(dk),intent(in)   ::  tau            ! Physical time
real(dk),intent(out),optional  ::  FIn(1:3)  ! Perturbing acceleration in the inertial frame
real(dk),intent(out),optional  ::  pot   ! Perturbing potential
real(dk),intent(out),optional  ::  dPot  ! Time derivative of the potential in body-fixed frame
! Locals
real(dk)  ::  rNorm,rNormSq  ! Norm of position vector and square
real(dk)  ::  s,t,u  ! Direction cosines in the body-fixed frame
real(dk)  ::  rho    ! = equatorial radius / r
real(dk)  ::  F(1:3),a1,a2,a3,a4  ! Acceleration and its components
integer   ::  n,m    ! Harmonic indices
logical   ::  skip_EFG
! GMST-related quantities
real(dk)  ::  MJD_UTC, MJD_TT      ! UTC and TT dates
real(dk)  ::  GMST,cosGMST,sinGMST ! GMST and its trig functions
real(dk)  ::  ERR, ERR_nd          ! Earth Rotation Rate [rad/s, -]

! SOFA routines
real(dk) :: iau_GMST06

! ==============================================================================

rNormSq = dot_product(rIn,rIn)
rNorm = sqrt(rNormSq)

! ==============================================================================
! 01. Transform from inertial to body-fixed frame
! ==============================================================================

u = rIn(3)/rNorm

! Greenwich Mean Sidereal Time (IAU 2006 conventions)
MJD_UTC = T2MJD(tau)
MJD_TT  = UTC2TT(MJD_UTC)

GMST = iau_GMST06 ( delta_JD_MJD, MJD_UTC, delta_JD_MJD, MJD_TT )
cosGMST = cos(GMST); sinGMST = sin(GMST)

! Rotate equatorial components of rIn to get direction cosines in the body-fixed frame
s = (rIn(1) * cosGMST + rIn(2) * sinGMST)/rNorm
t = (rIn(2) * cosGMST - rIn(1) * sinGMST)/rNorm

rho = RE/rNorm

! ==============================================================================
! 02. Fill in coefficient matrices and auxiliary vectors
! ==============================================================================

! Fill A Matrix
Anm(0,0) = 1._dk
Anm(1,1) = 1._dk
Anm(1,0) = u
do n = 1, gdeg + 1
  Anm(n+1,n+1) = Aux1(n) * Anm(n,n) ! Fill the diagonal
  Anm(n+1,0) = Aux2(n) * u * Anm(n,0) - Aux3(n) * Anm(n-1,0) ! Fill the 1st column
  Anm(n+1,n) = u * Anm(n+1,n+1)    ! Fill the subdiagonal

end do
do n = 2, gdeg + 1 ! Fill remaining elements
  do m = 0, n - 2
    Anm(n+1,m+1) = Aux4(n,m) * Anm(n,m) + u * Anm(n,m+1)
  end do

end do

! Fill R, I, and P vectors
Rm(0) = 1._dk
Im(0) = 0._dk
Pn(0) = GM / rNorm
Pn(1) = rho * Pn(0)
do n = 1, gdeg
  Rm(n)   = s  * Rm(n-1) - t * Im(n-1)
  Im(n)   = s  * Im(n-1) + t * Rm(n-1)
  Pn(n+1) = rho * Pn(n)

end do

! Fill D, E, and F matrices
skip_EFG = present(pot) .and. .not.(present(FIn)) .and. .not.(present(dPot))
do m = 1, gord
  do n = m, gdeg
    Dnm(n,m) = Cnm(n,m)*Rm(m)   + Snm(n,m)*Im(m)
    if (.not.(skip_EFG)) then
      Enm(n,m) = Cnm(n,m)*Rm(m-1) + Snm(n,m)*Im(m-1)
      Fnm(n,m) = Snm(n,m)*Rm(m-1) - Cnm(n,m)*Im(m-1)

    end if
  end do

end do
do n = 1, gdeg
  Dnm(n,0) = Cnm(n,0)*Rm(0)  !+ S(n,0)*I(0) = 0
end do

! ==============================================================================
! 03. Perturbing potential
! ==============================================================================

if (present(pot)) then
  pot = 0._dk
  do m = 1, gord
    do n = m, gdeg
      pot = pot + Pn(n) * Anm(n,m) * Dnm(n,m)

    end do

  end do
  do n = 1, gdeg
  pot = pot + Pn(n) * Anm(n,0) * Dnm(n,0)

  end do
  pot = -pot  ! Change the sign to get the potential
end if

! ==============================================================================
! 04. Perturbing acceleration
! ==============================================================================

if (present(FIn)) then
  a1 = 0._dk; a2 = 0._dk; a3 = 0._dk; a4 = 0._dk
  do m = 1, gord
    do n = m, gdeg
      a1 = a1 + Pn(n+1) * Anm(n,m) * m * Enm(n,m)
      a2 = a2 + Pn(n+1) * Anm(n,m) * m * Fnm(n,m)
      a3 = a3 + Pn(n+1) * Anm(n,m+1)   * Dnm(n,m)
      a4 = a4 - Pn(n+1) * Anm(n+1,m+1) * Dnm(n,m)
    end do
  end do
  do n = 1, gdeg
    a3 = a3 + Pn(n+1) * Anm(n,1)     * Dnm(n,0)
    a4 = a4 - Pn(n+1) * Anm(n+1,1)   * Dnm(n,0)

  end do
  F = [a1, a2, a3] + [s, t, u] * a4
  F = F / RE

  ! Transform to inertial frame
  FIn(1) = F(1)*cosGMST - F(2)*sinGMST
  FIn(2) = F(1)*sinGMST + F(2)*cosGMST
  FIn(3) = F(3)

end if

! ==============================================================================
! 05. Time derivative of potential in body-fixed frame
! ==============================================================================

if(present(dPot)) then
  dPot = 0._dk
  ERR = ERR_IAU06(0._dk, MJD_TT)
  ERR_nd = ERR / TU
  do m = 1, gord
    do n = m, gdeg
      Gnm(n,m) = m * ( t * Enm(n,m) - s * Fnm(n,m) )
      Gnm(n,m) = ERR_nd * Gnm(n,m)
      dPot = dPot + Pn(n) * Anm(n,m) * Gnm(n,m)

    end do

  end do
  dPot = -dPot
end if

end subroutine PINES_NSG

end module NSGRAV


subroutine GetSubsWaveLength(SubsWaveLength)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************

use comdi, only: izone_top,z_plot
use comai, only: neq
use combi, only: cord
implicit none
real*8 :: SubsWaveLength,x_min,x_max,x_shift,x_scale,Integral, &
   a_max,DeltaChi,AvgSubs,MaxSubs,MinSubs
real*8, allocatable :: Chi(:),Subsid(:),a(:)
integer :: I,NumNodes,Counter,n,MaxCoeffNum
integer, parameter :: NumCoeffs = 100
real*8, parameter :: pi = 3.14159

! top boundary is indicated by the neq entries of izone_top:
! izone_top(I) = 3 indicates that node I is on the top boundary;
! izone_top(I) = 0 indicates that node I is not on the top
! boundary

! cord(I,1) = x coordinates, cord(I,2) = y coordinatess,
! cord(I,3) = z coordinates

! final heights are in the array z_plot, which also has neq
! entries

! shift and rescale the x coords so that they lie between
! 0 and 1; convert resulting wavelength back to meters
! afterward

! find x_min, x_max, and # of nodes above the subsidence zone
x_min =  1.e30
x_max = -1.e30
NumNodes = 0
do I=1,neq
   if (izone_top(I)==3) then
      if (cord(I,1)<x_min) then
         x_min = cord(I,1)
      end if
      if (cord(I,1)>x_max) then
         x_max = cord(I,1)
      end if
      NumNodes = NumNodes + 1
   end if
end do
x_shift = -x_min
x_scale = (x_max - x_min)

allocate(Chi(NumNodes))
allocate(Subsid(NumNodes))
Counter = 1
AvgSubs = 0.0
MaxSubs = -1.e30
MinSubs =  1.e30
do I=1,neq
   if (izone_top(I)==3) then
      Chi(Counter) = (cord(I,1) + x_shift)/x_scale
      Subsid(Counter) = z_plot(I)
      if (Subsid(Counter)>MaxSubs) then
         MaxSubs = Subsid(Counter)
      end if
      if (Subsid(Counter)<MinSubs) then
         MinSubs = Subsid(Counter)
      end if
      !write(*,*) Counter,'XCoord: ',cord(I,1),'Chi: ',Chi(Counter)
      !write(*,*) Counter,'subsid: ',Subsid(Counter)
      Counter = Counter + 1
   end if
end do
AvgSubs = (MaxSubs + MinSubs)/2.0
! vertically shift the subsidence to center on AvgSubs
do I=1,Counter-1
   Subsid(I) = Subsid(I) - AvgSubs
end do

! calculate the fourier series coefficients a_n, find max | a_n |
a_max = 0.0
allocate(a(NumCoeffs))
do n=1,NumCoeffs
   Integral = 0.0
   do I=1,Counter-2
      DeltaChi = Chi(I+1)-Chi(I)
      Integral = Integral + sin(n*pi*Chi(I))*Subsid(I)*DeltaChi
   end do
   a(n) = 2.0*Integral
   !write(*,*) n,'| a |: ',dabs(a(n))
   if (dabs(a(n))>a_max) then
      a_max = dabs(a(n))
      MaxCoeffNum = n
   end if
end do
!write(*,*) 'max coeff number: ',MaxCoeffNum
!write(*,*) 'max coeff: ',a(MaxCoeffNum)
SubsWaveLength = 2.0*x_scale/MaxCoeffNum
end


	SUBROUTINE PRNLNR  ( np, dlon, iret )
C************************************************************************
C* PRNLNR                                                               *
C*									*
C* This function converts a longitude in radians into radians which	*
C* fall within the range PI to -PI.					*
C*									*
C* PRNLNR ( NP, DLON, IRET )						*
C*									*
C* Input parameters:							*
C*	NP		INTEGER		Number of longitudes		*
C*									*
C* Input and output parameters:						*
C*	DLON (*)	REAL		Longitude in radians		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					 0 = normal			*
C**									*
C* Log:									*
C* G. Chatters/RDS	11/80 						*
C* C. Millburn		 6/84	Rewritten for GEMPAK3			*
C* M. desJardins/GSFC	 8/87	Corrected sign of pi in check for <	*
C* M. desJardins/GSFC	 1/88	Fixed missing data			*
C* K. Brill/EMC		 3/96	Add loop				*
C* M. Linda/GSC		 9/97	Changed a key word in the prologue	*
C* T. Piper/GSC		 3/99	Corrected prolog			*
C************************************************************************
	INCLUDE 	'GEMPRM.PRM'
C*
	REAL		dlon (*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C*
	DO i = 1, np
C
C*	Check for missing data.
C
	    IF  ( .not. ERMISS ( dlon (i) ) )  THEN
                dln   = dlon (i) - IFIX ( dlon (i) / TWOPI ) * TWOPI
		IF ( dln .lt. -PI ) dln = dln + TWOPI
		IF ( dln .gt.  PI ) dln = dln - TWOPI
		dlon (i) = dln
	    END IF
	END DO
C*
	RETURN
	END


!-----subroutine---------------------------------------------g.guidati--
!
subroutine SPL_EX1 (xa, ya, y2a, n, x, y, dydx, khi, klo)
!
!-----------------------------------------------------------------------
!
!     franco guidati    IAG
!                       Uni Stuttgart
!
!     modified Pat Moriarty 10/23/03
!     scope             execute spline interpolation
!                       (natural splines)
!
!.......................................................................
!               declarations
!.......................................................................

USE TIPrecision

IMPLICIT                        NONE

   ! Local variables.

INTEGER(4)                   :: klo
INTEGER(4)                   :: khi
INTEGER(4)                   :: n

REAL(DbKi)                   :: a
REAL(DbKi)                   :: b
REAL(DbKi)                   :: dydx
REAL(DbKi)                   :: h
REAL(DbKi)                   :: x
REAL(DbKi)                   :: y
REAL(DbKi)                   :: xa(n)
REAL(DbKi)                   :: ya(n)
REAL(DbKi)                   :: y2a(n)

!.......................................................................
!               execute spline interpolation
!.......................................................................

      h = xa(khi)-xa(klo)
      if (h.eq.0.) then
          write(*,*)'ERROR:TINoise:SPL_E0A: bad xa input in splint'
          STOP 1
      endif
      a = (xa(khi)-x)/h
      b = (x-xa(klo))/h
      y = a*ya(klo)+b*ya(khi)+((a*a*a-a)*y2a(klo)+(b*b*b-b)*y2a(khi))*(h*h)/6.0d0
!      write(*,*) '---',real(h),real(y),real(a),real(b)
      dydx = (-ya(klo)+ya(khi))/h+((-3.0d0*a*a+1.0d0)*y2a(klo)+(+3.0d0*b*b-1.0d0)*y2a(khi))*h/6.0d0

!.......................................................................
!               end of subroutine
!.......................................................................
      return
!***********************************************************************
      end


      PROGRAM xlaguer
C     driver for routine laguer
      INTEGER M,MP1,NTRY
      REAL EPS
      PARAMETER(M=4,MP1=M+1,NTRY=21,EPS=1.0E-6)
      INTEGER i,iflag,its,j,n
      COMPLEX a(MP1),y(NTRY),x
      DATA a/(0.0,2.0),(0.0,0.0),(-1.0,-2.0),(0.0,0.0),(1.0,0.0)/
      write(*,'(/1x,a)') 'Roots of polynomial x^4-(1+2i)*x^2+2i'
      write(*,'(/1x,t16,a4,t29,a7,t39,a5/)') 'Real','Complex','#iter'
      n=0
      do 12 i=1,NTRY
        x=cmplx((i-11.0)/10.0,(i-11.0)/10.0)
        call laguer(a,M,x,its)
        if (n.eq.0) then
          n=1
          y(1)=x
          write(*,'(1x,i5,2f15.6,i5)') n,x,its
        else
          iflag=0
          do 11 j=1,n
            if (abs(x-y(j)).le.EPS*abs(x)) iflag=1
11        continue
          if (iflag.eq.0) then
            n=n+1
            y(n)=x
            write(*,'(1x,i5,2f15.6,i5)') n,x,its
          endif
        endif
12    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xlaguer.for


!!
!> @brief      fundamental constants
!!
!! List of fundamental physical and mathematical constants. Unlike most other modules, all
!! parameters are public.
!!
!! When possible, constants contain more digits than double precision, so that
!! they are rounded correctly. Single letter constants contain underscore so
!! that they do not clash with user variables ("e" and "i" are frequently used as
!! loop variables)
!!
!! @author     Rodrigo Navarro Perez
!!
module constants
use precisions, only: dp
implicit none

public

real(dp), parameter :: pi = 3.1415926535897932384626433832795_dp !<  \f$\pi\f$
real(dp), parameter :: e_ = 2.7182818284590452353602874713527_dp !< base of the natural log, \f$ e \f$
real(dp), parameter :: euler_mascheroni = 0.577216_dp!< Euler Mascheroni constant, typically denoted by \f$ \gamma \f$ ! 0.5772156649015328606065120900824_dp
complex(dp), parameter :: i_ = (0, 1) !< \f$ i = \sqrt{-1} \f$

! Values from National Institute of Standards and Technology (NIST CODATA)
! https://www.nist.gov/pml/fundamental-physical-constants
! Retrieved on April 8th 2021
real(dp), parameter :: hbar_c    = 197.3269804_dp!< \f$\hbar c\f$ in units of MeV fm
real(dp), parameter :: proton_mass  = 938.27208816_dp!< proton mass in units of MeV
real(dp), parameter :: neutron_mass = 939.56542052_dp!< neutron mass in units of MeV
real(dp), parameter :: electron_mass = 0.51099895000_dp!< electron mass in units of MeV
real(dp), parameter :: mu_proton = 2.79284734463_dp!< proton magnetic moment in units of the nuclear magneton \f$ \mu_n \f$
real(dp), parameter :: mu_neutron = -1.91304273_dp!< neutron magnetic moment in units of the nuclear magneton \f$ \mu_n \f$
real(dp), parameter :: alpha = 1/137.035999084_dp!< fine structure constant, dimensionless.

! Values from Particle Data Group (PDG)
! http://pdg.lbl.gov/
! P.A. Zyla et al. (Particle Data Group), Prog. Theor. Exp. Phys. 2020, 083C01 (2020)
real(dp), parameter :: pion_c_mass =  139.57039_dp!< charged pion_mass in units of MeV
real(dp), parameter :: pion_0_mass =  134.9768_dp!< neutral pion_mass in units of MeV
real(dp), parameter :: pion_mass = (2*pion_c_mass + pion_0_mass)/3  !< average pion mass in units of MeV

! Historic, charge independent, recommended value.
real(dp), parameter :: f_pi_n_2 = 0.075_dp !< pion nucleon coupling constant \f$ f^2 \f$. Dimensionless

! ! Original AV18 values
! real(dp), parameter :: hbar_c    = 197.327053_dp!< \f$\hbar c\f$ in units of MeV fm
! real(dp), parameter :: proton_mass  = 938.27231_dp!< proton mass in units of MeV
! real(dp), parameter :: neutron_mass = 939.56563_dp!< neutron mass in units of MeV
! real(dp), parameter :: electron_mass = 0.510999_dp!< electron mass in units of MeV
! real(dp), parameter :: mu_proton = 2.7928474_dp!< proton magnetic moment in units of the nuclear magneton \f$ \mu_n \f$
! real(dp), parameter :: mu_neutron = -1.9130427_dp!< neutron magnetic moment in units of the nuclear magneton \f$ \mu_n \f$
! real(dp), parameter :: alpha = 1/137.035989_dp!< fine structure constant, dimensionless.
! real(dp), parameter :: pion_c_mass =  139.5675_dp!< charged pion_mass in units of MeV
! real(dp), parameter :: pion_0_mass =  134.9739_dp!< neutral pion_mass in units of MeV
! real(dp), parameter :: pion_mass = 138.0363_dp!< average pion mass in units of MeV
! real(dp), parameter :: f_pi_n_2 = 0.075_dp !< pion nucleon coupling constant \f$ f^2 \f$. Dimensionless

end module


      FUNCTION rtflsp(func,x1,x2,xacc)
      INTEGER MAXIT
      REAL rtflsp,x1,x2,xacc,func
      EXTERNAL func
      PARAMETER (MAXIT=30)
      INTEGER j
      REAL del,dx,f,fh,fl,swap,xh,xl
      fl=func(x1)
      fh=func(x2)
      if(fl*fh.gt.0.) pause 'root must be bracketed in rtflsp'
      if(fl.lt.0.)then
        xl=x1
        xh=x2
      else
        xl=x2
        xh=x1
        swap=fl
        fl=fh
        fh=swap
      endif
      dx=xh-xl
      do 11 j=1,MAXIT
        rtflsp=xl+dx*fl/(fl-fh)
        f=func(rtflsp)
        if(f.lt.0.) then
          del=xl-rtflsp
          xl=rtflsp
          fl=f
        else
          del=xh-rtflsp
          xh=rtflsp
          fh=f
        endif
        dx=xh-xl
        if(abs(del).lt.xacc.or.f.eq.0.)return
11    continue
      pause 'rtflsp exceed maximum iterations'
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/rtflsp.for


program mapsl
    !  Based on: Justin E. Kerwin December, 2000
    !------------------------------------------------------------------------------

    !	Declare the variables----------------------------------------------------
    implicit none
    character(len=1) yesno
    character(len=20) :: buffer
    character(len=20) :: params
    real, parameter :: pi=3.1415927e00, rad=1.7453293e-02
    real :: x,y,theta,rsq,u,v,r,xc,yc,alpha_deg,alpha,rc,beta,rcsq,g,gamma, &
        lambda,tau_deg,xi,eta,x_circle,y_circle,fl2,u_foil,v_foil, &
        theta1,theta2,dtheta,rmax,dr,cp,xle,xte,chord,cl
    real, allocatable, dimension(:) :: xi_foil,cp_foil,eta_foil
    complex :: z,zp1,zm1,zeta,w_circle,dzeta_dz,w_foil
    integer :: n,m,ntheta,nradial

    !input the variables defining foil geometry and angle of attack ----------
    write(*,'(a)') ' enter xc,yc,trailing edge angle ' ! position of center of circle--------
    read(*,*) xc,yc,tau_deg ! note: xc must be <= 0 ------------
    lambda=2.0-tau_deg/180.0 ! the exponent in the k-t mapping function -
    fl2=4.0*lambda**2 ! pre-comute a mapping function constant----
    rcsq=(1.0-xc)**2+yc**2 ! radius of circle passing through (1,0) ---

    rc=sqrt(rcsq)
    beta=atan(yc/(1.0-xc))

    alpha_deg=0
    theta1=0
    theta2=360
    dtheta=1
    ntheta=nint((theta2+theta1)/dtheta)+1 ! number of radial grid lines
    !	alocate the arrays and open output files --------------------------------
    allocate(xi_foil(ntheta),eta_foil(ntheta),cp_foil(ntheta)) ! arrays for foil cp -----

    buffer=leading_zero(xc)
    params='_'//trim(buffer)
    buffer=leading_zero(yc)
    params=trim(params)//'_'//trim(buffer)
    write(buffer,'(I0)')int(tau_deg)
    params=trim(params)//'_'//trim(buffer)
!     write(buffer,'(I0)')int(alpha_deg)
!     params=trim(params)//'_'//trim(buffer)

!     open(2,file='cp-karman-trefftz'//trim(params)//'.dat',status='unknown',form='formatted')
    open(3,file='geom-karman-trefftz'//trim(params)//'.dat',status='unknown',form='formatted')

    !-----generate velocity and presure field -------------------------------------
    m=1
    r=rc+real(m-1)*dr
    rsq=r**2
    ! grid radial coordinate in the z (circle) plane--
    do n=1,ntheta
        theta=rad*(theta1-real(n-1)*dtheta) ! grid angular coordinate--
        x=xc+r*cos(theta) ! convert to cartesian-----
        y=yc+r*sin(theta)
        !-----------compute the velocity field around the circle-----------------------
        u=cos(alpha)-rcsq*cos(2.0*theta-alpha)/rsq-g*sin(theta)/r
        v=sin(alpha)-rcsq*sin(2.0*theta-alpha)/rsq+g*cos(theta)/r

        !-----------express the field point position and velocity in complex form------
        z=cmplx(x,y) ! form complex number (x+iy)-------
        w_circle=cmplx(u,-v)
        ! complex velocity in z plane------
        !-----------use the karman-trefftz transformation to map points to zeta plane--
        zp1=(z+1.0)**lambda
        zm1=(z-1.0)**lambda
        zeta=lambda*(zp1+zm1)/(zp1-zm1)
        xi=real(zeta) ! transformed x coordinate---------
        eta=aimag(zeta) ! transformed y coordinate --------
        !-----------compute the derivative of the mapping function; transform velocities
        dzeta_dz=fl2*((z-1.0)**(lambda-1.0)*(z+1.0)**(lambda-1.0))/ (zp1-zm1)**2

        if(abs(dzeta_dz)>0.0001) then
            w_foil=w_circle/dzeta_dz ! complex velocity in foil plane------

        else
            w_foil=0.0
        end if
        u_foil=real(w_foil)
        v_foil=-aimag(w_foil)

        ! avoids divide by zero at trailing edge

        !-----------compute the presure coefficient, cp, and output to plotting file---

        cp=abs(w_foil)**2-1.0

        if(m==1) then
            ! save presure on foil surface for later use--
            xi_foil(n)=xi
            eta_foil(n)=eta
            cp_foil(n)=cp
        end if
    end do
    !-----scale the chordwise coordinate to (0,1) and output foil pressure dist.---
    xle=10.0
    xte=-10.0
    do n=1,ntheta
        xle=min(xle,xi_foil(n))
        xte=max(xte,xi_foil(n))
    end do
    ! Coordinate scalling
    chord=xte-xle
    do n=1,ntheta
        xi_foil(n)=(xi_foil(n)-xle)/chord
        eta_foil(n)=eta_foil(n)/chord
    end do
!     write(2,'(2f10.5)') (xi_foil(n),cp_foil(n),n=1,ntheta)
!     close(2)

    write(3,'(2f10.5)') (xi_foil(n),eta_foil(n),n=1,ntheta)
    close(3)

contains

    function leading_zero(x) result(buffer)
        real :: x
        character(len=20) :: buffer
        integer :: ix
        if (x.lt.0) then
            ix = ceiling(x)
        else
            ix = floor(x)
        endif
        if (x.lt.0) then
            write(buffer,1) abs(ix), abs(x)-floor(abs(x))
            1   format('-',i0,f0.1)
        else
            write(buffer,2) floor(x), abs(x)-floor(abs(x))
            2   format(i0,f0.1)
        endif

    end function

end program mapsl


!..
!..file contains fermi-dirac integral routines:
!..
!..function zfermim12 does a rational function fit for the order -1/2 integral
!..function zfermi12 does a rational function fit for the order 1/2 integral
!..function zfermi1 does a rational function fit for the order 1 integral
!..function zfermi32 does a rational function fit for the order 3/2 integral
!..function zfermi2 does a rational function fit for the order 2 integral
!..function zfermi52 does a rational function fit for the order 5/2 integral
!..function zfermi3 does a rational function fit for the order 3 integral
!..
!..function ifermim12 is a rational function fit for the inverse of order -1/2
!..function ifermi12 is a rational function fit for the inverse of order 1/2
!..function ifermi32 is a rational function fit for the inverse of order 3/2
!..function ifermi52 is a rational function fit for the inverse of order 5/2

module fermi

contains

      double precision function zfermim12(x)
!      include 'implno.dek'
!..
!..this routine applies a rational function expansion to get the fermi-dirac
!..integral of order -1/2 evaluated at x. maximum error is 1.23d-12.
!..reference: antia apjs 84,101 1993
!..
!..declare
      integer          i,m1,k1,m2,k2
      double precision x,an,a1(12),b1(12),a2(12),b2(12),rn,den,xx

!..load the coefficients of the expansion
      data  an,m1,k1,m2,k2 /-0.5d0, 7, 7, 11, 11/
      data  (a1(i),i=1,8)/ 1.71446374704454d7,    3.88148302324068d7, &
                           3.16743385304962d7,    1.14587609192151d7, &
                           1.83696370756153d6,    1.14980998186874d5, &
                           1.98276889924768d3,    1.0d0/
      data  (b1(i),i=1,8)/ 9.67282587452899d6,    2.87386436731785d7, &
                           3.26070130734158d7,    1.77657027846367d7, &
                           4.81648022267831d6,    6.13709569333207d5, &
                           3.13595854332114d4,    4.35061725080755d2/
      data (a2(i),i=1,12)/-4.46620341924942d-15, -1.58654991146236d-12, &
                          -4.44467627042232d-10, -6.84738791621745d-8, &
                          -6.64932238528105d-6,  -3.69976170193942d-4, &
                          -1.12295393687006d-2,  -1.60926102124442d-1, &
                          -8.52408612877447d-1,  -7.45519953763928d-1, &
                           2.98435207466372d0,    1.0d0/
      data (b2(i),i=1,12)/-2.23310170962369d-15, -7.94193282071464d-13, &
                          -2.22564376956228d-10, -3.43299431079845d-8, &
                          -3.33919612678907d-6,  -1.86432212187088d-4, &
                          -5.69764436880529d-3,  -8.34904593067194d-2, &
                          -4.78770844009440d-1,  -4.99759250374148d-1, &
                           1.86795964993052d0,    4.16485970495288d-1/

      if (x .lt. 2.0d0) then
       xx = exp(x)
       rn = xx + a1(m1)
       do i=m1-1,1,-1
        rn = rn*xx + a1(i)
       enddo
       den = b1(k1+1)
       do i=k1,1,-1
        den = den*xx + b1(i)
       enddo
       zfermim12 = xx * rn/den
!..
      else
       xx = 1.0d0/(x*x)
       rn = xx + a2(m2)
       do i=m2-1,1,-1
        rn = rn*xx + a2(i)
       enddo
       den = b2(k2+1)
       do i=k2,1,-1
        den = den*xx + b2(i)
       enddo
       zfermim12 = sqrt(x)*rn/den
      end if
      return
      end

      double precision function zfermi12(x)
!      include 'implno.dek'
!..
!..this routine applies a rational function expansion to get the fermi-dirac
!..integral of order 1/2 evaluated at x. maximum error is 5.47d-13.
!..reference: antia apjs 84,101 1993
!..
!..declare
      integer          i,m1,k1,m2,k2
      double precision x,an,a1(12),b1(12),a2(12),b2(12),rn,den,xx

!..load the coefficients of the expansion
      data  an,m1,k1,m2,k2 /0.5d0, 7, 7, 10, 11/
      data  (a1(i),i=1,8)/5.75834152995465d6,   1.30964880355883d7, &
                          1.07608632249013d7,   3.93536421893014d6, &
                          6.42493233715640d5,   4.16031909245777d4, &
                          7.77238678539648d2,   1.0d0/
      data  (b1(i),i=1,8)/6.49759261942269d6,   1.70750501625775d7, &
                          1.69288134856160d7,   7.95192647756086d6, &
                          1.83167424554505d6,   1.95155948326832d5, &
                          8.17922106644547d3,   9.02129136642157d1/
      data (a2(i),i=1,11)/4.85378381173415d-14, 1.64429113030738d-11, &
                          3.76794942277806d-9,  4.69233883900644d-7, &
                          3.40679845803144d-5,  1.32212995937796d-3, &
                          2.60768398973913d-2,  2.48653216266227d-1, &
                          1.08037861921488d0,   1.91247528779676d0, &
                          1.0d0/
      data (b2(i),i=1,12)/7.28067571760518d-14, 2.45745452167585d-11, &
                          5.62152894375277d-9,  6.96888634549649d-7, &
                          5.02360015186394d-5,  1.92040136756592d-3, &
                          3.66887808002874d-2,  3.24095226486468d-1, &
                          1.16434871200131d0,   1.34981244060549d0, &
                          2.01311836975930d-1, -2.14562434782759d-2/

      if (x .lt. 2.0d0) then
       xx = exp(x)
       rn = xx + a1(m1)
       do i=m1-1,1,-1
        rn = rn*xx + a1(i)
       enddo
       den = b1(k1+1)
       do i=k1,1,-1
        den = den*xx + b1(i)
       enddo
       zfermi12 = xx * rn/den

      else
       xx = 1.0d0/(x*x)
       rn = xx + a2(m2)
       do i=m2-1,1,-1
        rn = rn*xx + a2(i)
       enddo
       den = b2(k2+1)
       do i=k2,1,-1
        den = den*xx + b2(i)
       enddo
       zfermi12 = x*sqrt(x)*rn/den
      end if
      return
      end

      double precision function zfermi1(x)
!      include 'implno.dek'
!..
!..this routine applies a rational function expansion to get the fermi-dirac
!..integral of order 1 evaluated at x. maximum error is 1.0e-8.
!..reference: antia  priv comm. 11sep94
!..
!..declare
      integer          i,m1,k1,m2,k2
      double precision x,an,a1(12),b1(12),a2(12),b2(12),rn,den,xx

!..load the coefficients of the expansion
      data  an,m1,k1,m2,k2 /1.0, 7, 4, 9, 5/
      data  (a1(i),i=1,8)/-7.606458638543d7,  -1.143519707857d8, &
                          -5.167289383236d7,  -7.304766495775d6, &
                          -1.630563622280d5,   3.145920924780d3, &
                          -7.156354090495d1,   1.0d0/
      data  (b1(i),i=1,5)/-7.606458639561d7,  -1.333681162517d8, &
                          -7.656332234147d7,  -1.638081306504d7, &
                          -1.044683266663d6/
      data (a2(i),i=1,10)/-3.493105157219d-7, -5.628286279892d-5, &
                          -5.188757767899d-3, -2.097205947730d-1, &
                          -3.353243201574d0,  -1.682094530855d1, &
                          -2.042542575231d1,   3.551366939795d0, &
                          -2.400826804233d0,   1.0d0/
      data  (b2(i),i=1,6)/-6.986210315105d-7, -1.102673536040d-4, &
                          -1.001475250797d-2, -3.864923270059d-1, &
                          -5.435619477378d0,  -1.563274262745d1/

      if (x .lt. 2.0d0) then
       xx = exp(x)
       rn = xx + a1(m1)
       do i=m1-1,1,-1
        rn = rn*xx + a1(i)
       enddo
       den = b1(k1+1)
       do i=k1,1,-1
        den = den*xx + b1(i)
       enddo
       zfermi1 = xx * rn/den

      else
       xx = 1.0d0/(x*x)
       rn = xx + a2(m2)
       do i=m2-1,1,-1
        rn = rn*xx + a2(i)
       enddo
       den = b2(k2+1)
       do i=k2,1,-1
        den = den*xx + b2(i)
       enddo
       zfermi1 = x*x*rn/den
      end if
      return
      end

      double precision function zfermi32(x)
!      include 'implno.dek'
!..
!..this routine applies a rational function expansion to get the fermi-dirac
!..integral of order 3/2 evaluated at x. maximum error is 5.07d-13.
!..reference: antia apjs 84,101 1993
!..
!..declare
      integer          i,m1,k1,m2,k2
      double precision x,an,a1(12),b1(12),a2(12),b2(12),rn,den,xx

!..load the coefficients of the expansion
      data  an,m1,k1,m2,k2 /1.5d0, 6, 7, 9, 10/
      data  (a1(i),i=1,7)/4.32326386604283d4,   8.55472308218786d4, &
                          5.95275291210962d4,   1.77294861572005d4, &
                          2.21876607796460d3,   9.90562948053193d1, &
                          1.0d0/
      data  (b1(i),i=1,8)/3.25218725353467d4,   7.01022511904373d4, &
                          5.50859144223638d4,   1.95942074576400d4, &
                          3.20803912586318d3,   2.20853967067789d2, &
                          5.05580641737527d0,   1.99507945223266d-2/
      data (a2(i),i=1,10)/2.80452693148553d-13, 8.60096863656367d-11, &
                          1.62974620742993d-8,  1.63598843752050d-6, &
                          9.12915407846722d-5,  2.62988766922117d-3, &
                          3.85682997219346d-2,  2.78383256609605d-1, &
                          9.02250179334496d-1,  1.0d0/
      data (b2(i),i=1,11)/7.01131732871184d-13, 2.10699282897576d-10, &
                          3.94452010378723d-8,  3.84703231868724d-6, &
                          2.04569943213216d-4,  5.31999109566385d-3, &
                          6.39899717779153d-2,  3.14236143831882d-1, &
                          4.70252591891375d-1, -2.15540156936373d-2, &
                          2.34829436438087d-3/

      if (x .lt. 2.0d0) then
       xx = exp(x)
       rn = xx + a1(m1)
       do i=m1-1,1,-1
        rn = rn*xx + a1(i)
       enddo
       den = b1(k1+1)
       do i=k1,1,-1
        den = den*xx + b1(i)
       enddo
       zfermi32 = xx * rn/den

      else
       xx = 1.0d0/(x*x)
       rn = xx + a2(m2)
       do i=m2-1,1,-1
        rn = rn*xx + a2(i)
       enddo
       den = b2(k2+1)
       do i=k2,1,-1
        den = den*xx + b2(i)
       enddo
       zfermi32 = x*x*sqrt(x)*rn/den
      end if
      return
      end

      double precision function zfermi2(x)
!      include 'implno.dek'
!..
!..this routine applies a rational function expansion to get the fermi-dirac
!..integral of order 2 evaluated at x. maximum error is 1.0e-8.
!..reference: antia  priv comm. 11sep94
!..
!..declare
      integer          i,m1,k1,m2,k2
      double precision x,an,a1(12),b1(12),a2(12),b2(12),rn,den,xx

!..load the coefficients of the expansion
      data  an,m1,k1,m2,k2 /2.0, 7, 4, 5, 9/
      data  (a1(i),i=1,8)/-1.434885992395d8,  -2.001711155617d8, &
                          -8.507067153428d7,  -1.175118281976d7, &
                          -3.145120854293d5,   4.275771034579d3, &
                          -8.069902926891d1,   1.0d0/
      data  (b1(i),i=1,5)/-7.174429962316d7,  -1.090535948744d8, &
                          -5.350984486022d7,  -9.646265123816d6, &
                          -5.113415562845d5/
      data  (a2(i),i=1,6)/ 6.919705180051d-8,  1.134026972699d-5, &
                           7.967092675369d-4,  2.432500578301d-2, &
                           2.784751844942d-1,  1.0d0/
      data (b2(i),i=1,10)/ 2.075911553728d-7,  3.197196691324d-5, &
                           2.074576609543d-3,  5.250009686722d-2, &
                           3.171705130118d-1, -1.147237720706d-1, &
                           6.638430718056d-2, -1.356814647640d-2, &
                          -3.648576227388d-2,  3.621098757460d-2/

      if (x .lt. 2.0d0) then
       xx = exp(x)
       rn = xx + a1(m1)
       do i=m1-1,1,-1
        rn = rn*xx + a1(i)
       enddo
       den = b1(k1+1)
       do i=k1,1,-1
        den = den*xx + b1(i)
       enddo
       zfermi2 = xx * rn/den

      else
       xx = 1.0d0/(x*x)
       rn = xx + a2(m2)
       do i=m2-1,1,-1
        rn = rn*xx + a2(i)
       enddo
       den = b2(k2+1)
       do i=k2,1,-1
        den = den*xx + b2(i)
       enddo
       zfermi2 = x*x*x*rn/den
      end if
      return
      end

      double precision function zfermi52(x)
!      include 'implno.dek'
!..
!..this routine applies a rational function expansion to get the fermi-dirac
!..integral of order 5/2 evaluated at x. maximum error is 2.47d-13.
!..reference: antia apjs 84,101 1993
!..
!..declare
      integer          i,m1,k1,m2,k2
      double precision x,an,a1(12),b1(12),a2(12),b2(12),rn,den,xx

!..load the coefficients of the expansion
      data  an,m1,k1,m2,k2 /2.5d0, 6, 7, 10, 9/
      data  (a1(i),i=1,7)/6.61606300631656d4,   1.20132462801652d5, &
                          7.67255995316812d4,   2.10427138842443d4, &
                          2.44325236813275d3,   1.02589947781696d2, &
                          1.0d0/
      data  (b1(i),i=1,8)/1.99078071053871d4,   3.79076097261066d4, &
                          2.60117136841197d4,   7.97584657659364d3, &
                          1.10886130159658d3,   6.35483623268093d1, &
                          1.16951072617142d0,   3.31482978240026d-3/
      data (a2(i),i=1,11)/8.42667076131315d-12, 2.31618876821567d-9, &
                          3.54323824923987d-7,  2.77981736000034d-5, &
                          1.14008027400645d-3,  2.32779790773633d-2, &
                          2.39564845938301d-1,  1.24415366126179d0, &
                          3.18831203950106d0,   3.42040216997894d0, &
                          1.0d0/
      data (b2(i),i=1,10)/2.94933476646033d-11, 7.68215783076936d-9, &
                          1.12919616415947d-6,  8.09451165406274d-5, &
                          2.81111224925648d-3,  3.99937801931919d-2, &
                          2.27132567866839d-1,  5.31886045222680d-1, &
                          3.70866321410385d-1,  2.27326643192516d-2/

      if (x .lt. 2.0d0) then
       xx = exp(x)
       rn = xx + a1(m1)
       do i=m1-1,1,-1
        rn = rn*xx + a1(i)
       enddo
       den = b1(k1+1)
       do i=k1,1,-1
        den = den*xx + b1(i)
       enddo
       zfermi52 = xx * rn/den

      else
       xx = 1.0d0/(x*x)
       rn = xx + a2(m2)
       do i=m2-1,1,-1
        rn = rn*xx + a2(i)
       enddo
       den = b2(k2+1)
       do i=k2,1,-1
        den = den*xx + b2(i)
       enddo
       zfermi52 = x*x*x*sqrt(x)*rn/den
      end if
      return
      end

      double precision function zfermi3(x)
!      include 'implno.dek'
!..
!..this routine applies a rational function expansion to get the fermi-dirac
!..integral of order 3 evaluated at x. maximum error is 1.0e-8.
!..reference: antia  priv comm. 11sep94
!..
!..declare
      integer          i,m1,k1,m2,k2
      double precision x,an,a1(12),b1(12),a2(12),b2(12),rn,den,xx

!..load the coefficients of the expansion
      data  an,m1,k1,m2,k2 /3.0, 4, 6, 7, 7/
      data  (a1(i),i=1,5)/ 6.317036716422d2,    7.514163924637d2, &
                           2.711961035750d2,    3.274540902317d1, &
                           1.0d0/
      data  (b1(i),i=1,7)/ 1.052839452797d2,    1.318163114785d2, &
                           5.213807524405d1,    7.500064111991d0, &
                           3.383020205492d-1,   2.342176749453d-3, &
                          -8.445226098359d-6/
      data  (a2(i),i=1,8)/ 1.360999428425d-8,   1.651419468084d-6, &
                           1.021455604288d-4,   3.041270709839d-3, &
                           4.584298418374d-2,   3.440523212512d-1, &
                           1.077505444383d0,    1.0d0/
      data  (b2(i),i=1,8)/ 5.443997714076d-8,   5.531075760054d-6, &
                           2.969285281294d-4,   6.052488134435d-3, &
                           5.041144894964d-2,   1.048282487684d-1, &
                           1.280969214096d-2,  -2.851555446444d-3/

      if (x .lt. 2.0d0) then
       xx = exp(x)
       rn = xx + a1(m1)
       do i=m1-1,1,-1
        rn = rn*xx + a1(i)
       enddo
       den = b1(k1+1)
       do i=k1,1,-1
        den = den*xx + b1(i)
       enddo
       zfermi3 = xx * rn/den

      else
       xx = 1.0d0/(x*x)
       rn = xx + a2(m2)
       do i=m2-1,1,-1
        rn = rn*xx + a2(i)
       enddo
       den = b2(k2+1)
       do i=k2,1,-1
        den = den*xx + b2(i)
       enddo
       zfermi3 = x*x*x*x*rn/den
      end if
      return
      end

      double precision function ifermim12(f)
!      include 'implno.dek'
!..
!..this routine applies a rational function expansion to get the inverse
!..fermi-dirac integral of order -1/2 when it is equal to f.
!..maximum error is 3.03d-9.   reference: antia apjs 84,101 1993
!..
!..declare
      integer          i,m1,k1,m2,k2
      double precision f,an,a1(12),b1(12),a2(12),b2(12),rn,den,ff

!..load the coefficients of the expansion
      data  an,m1,k1,m2,k2 /-0.5d0, 5, 6, 6, 6/
      data  (a1(i),i=1,6)/-1.570044577033d4,   1.001958278442d4, &
                          -2.805343454951d3,   4.121170498099d2, &
                          -3.174780572961d1,   1.0d0/
      data  (b1(i),i=1,7)/-2.782831558471d4,   2.886114034012d4, &
                          -1.274243093149d4,   3.063252215963d3, &
                          -4.225615045074d2,   3.168918168284d1, &
                          -1.008561571363d0/
      data  (a2(i),i=1,7)/ 2.206779160034d-8,  -1.437701234283d-6, &
                           6.103116850636d-5,  -1.169411057416d-3, &
                           1.814141021608d-2,  -9.588603457639d-2, &
                           1.0d0/
      data  (b2(i),i=1,7)/ 8.827116613576d-8,  -5.750804196059d-6, &
                           2.429627688357d-4,  -4.601959491394d-3, &
                           6.932122275919d-2,  -3.217372489776d-1, &
                           3.124344749296d0/

      if (f .lt. 4.0d0) then
       rn = f + a1(m1)
       do i=m1-1,1,-1
        rn = rn*f + a1(i)
       enddo
       den = b1(k1+1)
       do i=k1,1,-1
        den = den*f + b1(i)
       enddo
       ifermim12 = log(f * rn/den)

      else
       ff = 1.0d0/f**(1.0d0/(1.0d0 + an))
       rn = ff + a2(m2)
       do i=m2-1,1,-1
        rn = rn*ff + a2(i)
       enddo
       den = b2(k2+1)
       do i=k2,1,-1
        den = den*ff + b2(i)
       enddo
       ifermim12 = rn/(den*ff)
      end if
      return
      end

      double precision function ifermi12(f)
!      include 'implno.dek'
!..
!..this routine applies a rational function expansion to get the inverse
!..fermi-dirac integral of order 1/2 when it is equal to f.
!..maximum error is 4.19d-9.   reference: antia apjs 84,101 1993
!..
!..declare
      integer          i,m1,k1,m2,k2
      double precision f,an,a1(12),b1(12),a2(12),b2(12),rn,den,ff

!..load the coefficients of the expansion
      data  an,m1,k1,m2,k2 /0.5d0, 4, 3, 6, 5/
      data  (a1(i),i=1,5)/ 1.999266880833d4,   5.702479099336d3, &
                           6.610132843877d2,   3.818838129486d1, &
                           1.0d0/
      data  (b1(i),i=1,4)/ 1.771804140488d4,  -2.014785161019d3, &
                           9.130355392717d1,  -1.670718177489d0/
      data  (a2(i),i=1,7)/-1.277060388085d-2,  7.187946804945d-2, &
                          -4.262314235106d-1,  4.997559426872d-1, &
                          -1.285579118012d0,  -3.930805454272d-1, &
                           1.0d0/
      data  (b2(i),i=1,6)/-9.745794806288d-3,  5.485432756838d-2, &
                          -3.299466243260d-1,  4.077841975923d-1, &
                          -1.145531476975d0,  -6.067091689181d-2/

      if (f .lt. 4.0d0) then
       rn = f + a1(m1)
       do i=m1-1,1,-1
        rn = rn*f + a1(i)
       enddo
       den = b1(k1+1)
       do i=k1,1,-1
        den = den*f + b1(i)
       enddo
       ifermi12 = log(f * rn/den)

      else
       ff = 1.0d0/f**(1.0d0/(1.0d0 + an))
       rn = ff + a2(m2)
       do i=m2-1,1,-1
        rn = rn*ff + a2(i)
       enddo
       den = b2(k2+1)
       do i=k2,1,-1
        den = den*ff + b2(i)
       enddo
       ifermi12 = rn/(den*ff)
      end if
      return
      end

      double precision function ifermi32(f)
!      include 'implno.dek'
!..
!..this routine applies a rational function expansion to get the inverse
!..fermi-dirac integral of order 3/2 when it is equal to f.
!..maximum error is 2.26d-9.   reference: antia apjs 84,101 1993
!..
!..declare
      integer          i,m1,k1,m2,k2
      double precision f,an,a1(12),b1(12),a2(12),b2(12),rn,den,ff

!..load the coefficients of the expansion
      data  an,m1,k1,m2,k2 /1.5d0, 3, 4, 6, 5/
      data  (a1(i),i=1,4)/ 1.715627994191d2,   1.125926232897d2, &
                           2.056296753055d1,   1.0d0/
      data  (b1(i),i=1,5)/ 2.280653583157d2,   1.193456203021d2, &
                           1.167743113540d1,  -3.226808804038d-1, &
                           3.519268762788d-3/
      data  (a2(i),i=1,7)/-6.321828169799d-3, -2.183147266896d-2, &
                          -1.057562799320d-1, -4.657944387545d-1, &
                          -5.951932864088d-1,  3.684471177100d-1, &
                           1.0d0/
      data  (b2(i),i=1,6)/-4.381942605018d-3, -1.513236504100d-2, &
                          -7.850001283886d-2, -3.407561772612d-1, &
                          -5.074812565486d-1, -1.387107009074d-1/

      if (f .lt. 4.0d0) then
       rn = f + a1(m1)
       do i=m1-1,1,-1
        rn = rn*f + a1(i)
       enddo
       den = b1(k1+1)
       do i=k1,1,-1
        den = den*f + b1(i)
       enddo
       ifermi32 = log(f * rn/den)

      else
       ff = 1.0d0/f**(1.0d0/(1.0d0 + an))
       rn = ff + a2(m2)
       do i=m2-1,1,-1
        rn = rn*ff + a2(i)
       enddo
       den = b2(k2+1)
       do i=k2,1,-1
        den = den*ff + b2(i)
       enddo
       ifermi32 = rn/(den*ff)
      end if
      return
      end

      double precision function ifermi52(f)
!      include 'implno.dek'
!..
!..this routine applies a rational function expansion to get the inverse
!..fermi-dirac integral of order 5/2 when it is equal to f.
!..maximum error is 6.17d-9.   reference: antia apjs 84,101 1993
!..
!..declare
      integer          i,m1,k1,m2,k2
      double precision f,an,a1(12),b1(12),a2(12),b2(12),rn,den,ff

!..load the coefficients of the expansion
      data  an,m1,k1,m2,k2 /2.5d0, 2, 3, 6, 6/
      data  (a1(i),i=1,3)/ 2.138969250409d2,   3.539903493971d1, &
                           1.0d0/
      data  (b1(i),i=1,4)/ 7.108545512710d2,   9.873746988121d1, &
                           1.067755522895d0,  -1.182798726503d-2/
      data  (a2(i),i=1,7)/-3.312041011227d-2,  1.315763372315d-1, &
                          -4.820942898296d-1,  5.099038074944d-1, &
                           5.495613498630d-1, -1.498867562255d0, &
                           1.0d0/
      data  (b2(i),i=1,7)/-2.315515517515d-2,  9.198776585252d-2, &
                          -3.835879295548d-1,  5.415026856351d-1, &
                          -3.847241692193d-1,  3.739781456585d-2, &
                          -3.008504449098d-2/

      if (f .lt. 4.0d0) then
       rn = f + a1(m1)
       do i=m1-1,1,-1
        rn = rn*f + a1(i)
       enddo
       den = b1(k1+1)
       do i=k1,1,-1
        den = den*f + b1(i)
       enddo
       ifermi52 = log(f * rn/den)

      else
       ff = 1.0d0/f**(1.0d0/(1.0d0 + an))
       rn = ff + a2(m2)
       do i=m2-1,1,-1
        rn = rn*ff + a2(i)
       enddo
       den = b2(k2+1)
       do i=k2,1,-1
        den = den*ff + b2(i)
       enddo
       ifermi52 = rn/(den*ff)
      end if
      return
      end
end module fermi


subroutine compute_flux (lo, hi, domlo, domhi, phi, philo, phihi, &
                         fluxx, fxlo, fxhi, fluxy, fylo, fyhi,f, flo,fhi, &
                         dx,n) bind(C, name="compute_flux")

  !  Compute the flux for the nth rhs term

  use amrex_fort_module, only : amrex_real
  implicit none

  integer lo(2), hi(2), domlo(2), domhi(2)
  integer philo(2), phihi(2), fxlo(2), fxhi(2), fylo(2), fyhi(2),flo(2), fhi(2)
  real(amrex_real), intent(in)    :: phi  (philo(1):phihi(1),philo(2):phihi(2))
  real(amrex_real), intent(inout) :: fluxx( fxlo(1): fxhi(1), fxlo(2): fxhi(2))
  real(amrex_real), intent(inout) :: fluxy( fylo(1): fyhi(1), fylo(2): fyhi(2))
  real(amrex_real), intent(inout) :: f   (flo(1):fhi(1),flo(2):fhi(2))
  real(amrex_real), intent(in)    :: dx(2)
  integer, intent(in) :: n

  ! local variables
  integer i,j

  select case(n)
     case (0)  !  Explicit term (here it is advection)
        ! x-fluxes
        do j = lo(2), hi(2)
           do i = lo(1), hi(1)+1
              fluxx(i,j) = ( phi(i,j) + phi(i-1,j) ) / 2.0d0
              fluxx(i,j) = (-phi(i+1,j)+ 7.0d0*( phi(i,j) + phi(i-1,j) )-phi(i-2,j)) / 12.0d0
           end do
        end do

        ! y-fluxes
        do j = lo(2), hi(2)+1
           do i = lo(1), hi(1)
              fluxy(i,j) =(-phi(i,j+1)+7.0d0*( phi(i,j) + phi(i,j-1) )-phi(i,j-2)) / 12.0d0
           end do
        end do

        !  Function value is divergence of flux
        do j = lo(2), hi(2)
           do i = lo(1), hi(1)
              f(i,j) =  (fluxx(i+1,j  ) - fluxx(i,j))/dx(1) &
                   + (fluxy(i  ,j+1) - fluxy(i,j))/dx(2)
              f(i,j)=0.0d0
           end do

        end do
     case (1)  !  First implicit piece (here it is diffusion)
        ! x-fluxes
        do j = lo(2), hi(2)
           do i = lo(1), hi(1)+1
              fluxx(i,j) = ( phi(i,j) - phi(i-1,j) ) / dx(1)
!              fluxx(i,j) = ( -phi(i+1,j)  +15.0d0*(phi(i,j) - phi(i-1,j)) + phi(i-2,j) ) /(12.0d0*dx(1))
           end do
        end do

        ! y-fluxes
        do j = lo(2), hi(2)+1
           do i = lo(1), hi(1)
              fluxy(i,j) = ( phi(i,j) - phi(i,j-1) ) / dx(2)
!              fluxy(i,j) = ( -phi(i,j+1)  +15.0d0*(phi(i,j) - phi(i,j-1)) + phi(i,j-2) ) /(12.0d0*dx(2))
           end do
        end do

        !  Function value is divergence of flux
        do j = lo(2), hi(2)
           do i = lo(1), hi(1)
              f(i,j) =  (fluxx(i+1,j  ) - fluxx(i,j))/dx(1) &
                   + (fluxy(i  ,j+1) - fluxy(i,j))/dx(2)
              f(i,j)=f(i,j)*0.1d0
           end do
        end do
     case default
        print *, 'bad case in advance_2d'
     end select

end subroutine compute_flux


module slf_histo

    use iso_fortran_env, only: r64 => real64
    implicit none

contains

    subroutine histo(x,min,max,h,loc)
        real(r64), intent(in) :: x(:)
        real(r64), intent(in) :: min,max
        real(r64), intent(out) :: h(:)
        real(r64), intent(out), optional :: loc(:)
        real(r64) :: bin
        integer :: n,nb,i,k
        n = size(x)
        nb = size(h)
        bin = (max-min)/nb
        h = 0
        do i=1,n
            k = floor((x(i) - min) / bin) + 1
            if (k .ge. 1 .and. k .le. nb)  h(k) = h(k) + 1d0 / n
        end do
        if (present(loc)) then
            do i=1,nb
                loc(i) = (i-0.5) * bin + min
            end do
        end if
    end subroutine

    subroutine histo2d(x,y,xlim,ylim,h,locx,locy)
        real(r64), intent(in) :: x(:), y(:)
        real(r64), intent(in) :: xlim(2), ylim(2)
        real(r64), intent(out) :: h(:,:)
        real(r64), intent(out), optional :: locx(:,:), locy(:,:)
        real(r64) :: xbin, ybin
        integer :: n,nx,ny,i,j,k
        n = size(x)
        nx = size(h,1)
        ny = size(h,2)
        xbin = (xlim(2)-xlim(1))/nx
        ybin = (ylim(2)-ylim(1))/ny
        h = 0
        do i=1,n
            j = floor((x(i) - xlim(1)) / xbin) + 1
            k = floor((y(i) - ylim(1)) / ybin) + 1
            if (j .ge. 1 .and. j .le. nx        &
                .and. k .ge. 1 .and. k .le. ny)  h(j,k) = h(j,k) + 1d0 / n
        end do
        if (present(locx)) then
            do i=1,nx
                do j=1,ny
                    locx(i,j) = (i-0.5) * xbin + xlim(1)
                end do
            end do
        end if
        if (present(locy)) then
            do i=1,nx
                do j=1,ny
                    locy(i,j) = (j-0.5) * ybin + ylim(1)
                end do
            end do
        end if
    end subroutine

end module


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

subroutine fcho_solve(A,y,x)

    implicit none

    double precision, dimension(:,:), intent(in) :: A
    double precision, dimension(:), intent(in) :: y
    double precision, dimension(:), intent(inout) :: x

    integer :: info, na

    na = size(A, dim=1)

    call dpotrf("U", na, A, na, info)
    if (info > 0) then
        write (*,*) "WARNING: Cholesky decomposition DPOTRF() exited with error code:", info
    endif

    x(:na) = y(:na)

    call dpotrs("U", na, 1, A, na, x, na, info)
    if (info > 0) then
        write (*,*) "WARNING: Cholesky solve DPOTRS() exited with error code:", info
    endif

end subroutine fcho_solve

subroutine fcho_invert(A)

    implicit none

    double precision, dimension(:,:), intent(inout) :: A
    integer :: info, na

    na = size(A, dim=1)

    call dpotrf("L", na, A , na, info)
    if (info > 0) then
        write (*,*) "WARNING: Cholesky decomposition DPOTRF() exited with error code:", info
    endif

    call dpotri("L", na, A , na, info )
    if (info > 0) then
        write (*,*) "WARNING: Cholesky inversion DPOTRI() exited with error code:", info
    endif

end subroutine fcho_invert

subroutine fbkf_invert(A)

    implicit none

    double precision, dimension(:,:), intent(inout) :: A
    integer :: info, na, nb

    integer, dimension(size(A,1)) :: ipiv   ! pivot indices
    integer :: ilaenv

    integer :: lwork

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

    na = size(A, dim=1)

    nb = ilaenv( 1, 'DSYTRF', "L", na, -1, -1, -1 )

    lwork = na*nb

    allocate(work(lwork))

    ! call dpotrf("L", na, A , na, info)
    call dsytrf("L", na, A, na, ipiv, work, lwork, info)
    if (info > 0) then
        write (*,*) "WARNING: Bunch-Kaufman factorization DSYTRI() exited with error code:", info
    endif

    ! call dpotri("L", na, A , na, info )
    call dsytri( "L", na, a, na, ipiv, work, info )
    if (info > 0) then
        write (*,*) "WARNING: BKF inversion DPOTRI() exited with error code:", info
    endif

    deallocate(work)

end subroutine fbkf_invert

subroutine fbkf_solve(A,y,x)

    implicit none

    double precision, dimension(:,:), intent(in) :: A
    double precision, dimension(:), intent(in) :: y
    double precision, dimension(:), intent(inout) :: x

    double precision, allocatable, dimension(:) :: work
    integer :: ilaenv

    integer, dimension(size(A,1)) :: ipiv   ! pivot indices
    integer :: info, na, nb, lwork

    na = size(A, dim=1)

    nb = ilaenv( 1, 'DSYTRF', "L", na, -1, -1, -1 )

    lwork = na*nb
    allocate(work(lwork))

    call dsytrf("L", na, A, na, ipiv, work, lwork, info)
    if (info > 0) then
        write (*,*) "WARNING: Bunch-Kaufman factorization DSYTRI() exited with error code:", info
    endif

    x(:na) = y(:na)

    call dsytrs("L", na, 1, A, na, ipiv, x, na, info )

    if (info > 0) then
        write (*,*) "WARNING: Bunch-Kaufman solver DSYTRS() exited with error code:", info
    endif

    deallocate(work)
end subroutine fbkf_solve


PROGRAM heat_2d
IMPLICIT NONE
REAL, PARAMETER :: COOL = 20., HOT = 100., DEFAULT = 50.
REAL, PARAMETER :: LIMIT = 1.0E-32
INTEGER, PARAMETER :: MAX_ROWS = 100, MAX_COLS = 100
REAL, DIMENSION(MAX_ROWS,MAX_COLS) :: plate
REAL :: prev, new
INTEGER :: i, j, steps, same
LOGICAL :: done

! Initialize values
plate = DEFAULT
plate(1,1:MAX_COLS) = COOL
plate(MAX_ROWS,1:MAX_COLS) = COOL
plate(1:MAX_ROWS,1) = COOL
plate(1:MAX_ROWS,MAX_COLS) = COOL
plate(3,8) = HOT
WRITE(*, *) "INITIAL TEMPS (C):"
!WRITE(*, '(10F11.3)') ((plate(i, j), j = 1, MAX_COLS), i = 1, MAX_ROWS)

done = .false.
steps = 0
DO
  IF (done) THEN
    EXIT
  END IF
  same = 0
  DO i = 2, MAX_ROWS - 1
    IF (done) THEN
      EXIT
    END IF
    DO j = 2, MAX_COLS - 1
      IF (i .eq. 3 .and. j .eq. 8) THEN
        CYCLE
      ELSE
        prev = plate(i, j)
        new = 0.25 * (plate(i+1, j) + plate(i-1, j) + plate(i, j+1) + plate(i, j-1))
        plate(i, j) = new
        !WRITE(*, *) prev, new, i, j
        IF (ABS(new - prev) .le. LIMIT) THEN
          same = same + 1
          !WRITE(*, *) prev, new, i, j
          !done = .true.
        !  EXIT
        END IF
      END  IF
    END DO
  END DO
  steps = steps + 1
  IF (same .ge. (MAX_ROWS - 2) * (MAX_COLS - 2) - 1) THEN
    done = .true.
  END IF
END DO

WRITE(*, '(I6,1X,A)') steps, "STEPS. FINAL TEMPS (C):"
!WRITE(*, '(10F11.3)') ((plate(i, j), j = 1, MAX_COLS), i = 1, MAX_ROWS)

END PROGRAM heat_2d


double precision function inner_product(u, v)

! Calculates the inner product of cell-centered vectors u and v, using
! interior cells only.

    !$ use omp_lib
    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn) :: u, v

    integer :: ix, iy, ieqn

    inner_product = 0.d0
    do ieqn = 1, meqn
        !$omp parallel do reduction(+ : inner_product) private(ix, iy)
        do iy = 1, my
            do ix = 1, mx
                inner_product = inner_product + u(ix, iy, ieqn) * v(ix, iy, ieqn) * dx * dy
            end do
        end do
    end do

end function inner_product


PROGRAM main

  USE mo_kind,     ONLY: dp, i4
  USE mo_utils,    ONLY: ne
  USE mo_cfortran, ONLY: fctest ! sums between two elements in first dimension (multiply with constant)
  use mo_ansi_colors, only: color, c_red, c_green

  IMPLICIT NONE

  INTEGER(i4), PARAMETER :: d1 = 5
  INTEGER(i4), PARAMETER :: d2 = 4
  INTEGER(i4), PARAMETER :: n1 = 2
  INTEGER(i4), PARAMETER :: n2 = 3

  REAL(dp), DIMENSION(d1,d2) :: A

  REAL(dp), parameter :: c=2.0

  INTEGER(i4) :: i, j
  CHARACTER(LEN=30) :: form1
  logical :: isgood

  isgood = .true.

  forall(i=1:d1, j=1:d2) A(i,j) = real(i**j,dp)

  write(form1,"(A,I3,A)") "(", d1, "f5.0)"
  do j=1, d2
     write(*,form1) A(:,j)
  end do

  ! Beware C-indexes start with 0
  ! Also C is colunm-major so that one wants to transpose A, perhaps
  write(*,'(A,2f6.1)') 'sum(A(2+1:3+1,1)*2 = (3+4)*2 = 14: ', fctest(A, n1, n2, c), sum(A(n1+1:n2+1,1)*c)
  write(*,'(A,2f6.1)') 'sum(A(1,2+1:3+1)*2 = (1+1)*2 =  4: ', fctest(transpose(A), n1, n2, c), sum(A(1,n1+1:n2+1)*c)

  if (ne(fctest(A, n1, n2, c), 14.0_dp)) isgood = .false.

  if (isgood) then
     write(*,*) 'cfortran ', color('o.k.', c_green)
  else
     write(*,*) 'cfortran ', color('failed!', c_red)
  endif

END PROGRAM main