 module convolute
 use prec
 use constant
 contains

  subroutine gaussian_smearing(x0, y0, xdata, ydata, npoints, sigma)
    !---------------------------------------------------------------------------
    !
    ! gaussian_smearing: a conventional convolution where the gaussian function
    ! of width sigma is the second factor in the integral.
    ! G(x) = 1/(sqrt(2*pi)*sigma) * exp(- x**2/(2*sigma**2))
    !---------------------------------------------------------------------------

    integer, intent(in) :: npoints
    real(dp), intent(in) :: x0, y0, sigma
    real(dp), intent(out),dimension(npoints) :: xdata, ydata
    real(dp), dimension(npoints) :: tmp
    integer :: i, j

    do i=1,npoints
        tmp(i) =  y0 * invsqrt2pi / sigma * dexp(      &
&                -0.5d0 * ((xdata(i) - x0) / sigma)**2)
    end do

    ydata = tmp

    return
  end subroutine

  subroutine lorentzian_convolute(x0, y0, xdata, ydata, npoints, sigma)
    !---------------------------------------------------------------------------
    !
    ! lorentzian_convolute: a conventional convolution where the lorentzian function
    ! of width sigma is the second factor in the integral.
    ! F(x) = 1/pi * (0.5*sigma/((x-x0)**2+ (0.5*sigma)**2)
    !---------------------------------------------------------------------------

    integer, intent(in) :: npoints
    real(dp), intent(in) :: x0, y0, sigma
    real(dp), intent(out),dimension(npoints) :: xdata, ydata
    real(dp), dimension(npoints):: tmp
    integer :: i, j

    do i=1,npoints
        tmp(i) =  y0 * invpi * (0.5d0*sigma / ((xdata(i) - x0)**2 + &
 &                (0.5d0*sigma)**2))
    end do

    ydata = tmp

    return
  end subroutine

  end module


C	AUTHORS: MIKE MYERS & LUCIA SPAGNUOLO
C	DATE:    MAY 8, 1989

C	Variables:
C		SCORE -> an array of test scores
C		SUM ->   sum of the test scores
C		COUNT -> counter of scores read in
C		I ->     loop counter

	REAL FUNCTION COMPAV(SCORE,COUNT)
            INTEGER SUM,COUNT,I,SCORE(5)

	    SUM = 0
	    DO 30 I = 1,COUNT
		SUM = SUM + SCORE(I)
30	    CONTINUE
	    COMPAV = FLOAT(SUM)/FLOAT(COUNT)
        END

	PROGRAM AVENUM
C
C			MAIN PROGRAM
C
C	AUTHOR:   LOIS BIGBIE
C	DATE:	  MAY 15, 1990
C
C	Variables:
C		MAXNOS -> maximum number of input values
C		NUMS    -> an array of numbers
C		COUNT   -> exact number of input values
C		AVG     -> average returned by COMPAV
C		I       -> loop counter
C

	    INTEGER MAXNOS
	    PARAMETER(MAXNOS=5)
	    INTEGER I, NUMS(MAXNOS), COUNT
	    REAL AVG
	    COUNT = 0
	    DO 80 I = 1,MAXNOS
		READ (5,*,END=100) NUMS(I)
		COUNT = COUNT + 1
80	    CONTINUE
100	    AVG = COMPAV(NUMS, COUNT)
	    WRITE(6,*) 'AVERAGE =',AVG
	END


c     program DRSBLAS2
c>> 1996-06-18 DRSBLAS2 Krogh  Minor format change for C conversion.
c>> 1994-10-19 DRSBLAS2 Krogh  Changes to use M77CON
c>> 1991-11-27 DRSBLAS2 CLL
c>> 1987-12-09 Lawson  Initial Code.
c
c     Demonstrates the use of BLAS subroutines SROTG, SROT, SAXPY,
c     and SCOPY to implement an algorithm for solving a linear
c     least squares problem using sequential accumulation of the
c     data and Givens orthogonal transformations.
c     YTAB() contains rounded values of -2 + 2*X + 3*Exp(-X)
c     -----------------------------------------------------------------
c--S replaces "?": DR?BLAS2, ?ROTG, ?ROT, ?AXPY, ?COPY
c     -----------------------------------------------------------------
      integer MC, MC1, MXY
      parameter ( MC=3, MC1=MC+1, MXY=11 )
      integer IXY, J, NC, NC1, NXY
      real             X, XTAB(MXY), Y, YTAB(MXY), W(MC1)
      real             C, RG(MC1,MC1), S
      real             COEF(MC), DIV, ESTSD, ZERO(1)
c
      data XTAB / 0.0e0,  .1e0,  .2e0,    .3e0,   .4e0,  .5e0,
     *             .6e0,  .7e0,  .8e0,    .9e0,  1.0e0 /
      data YTAB / 1.00e0, .91e0, .86e0,   .82e0,  .81e0, .82e0,
     *             .85e0, .89e0, .95e0,  1.02e0, 1.10e0 /
      data NXY, NC / MXY, MC /
      data ZERO(1) / 0.0e0 /
c     -----------------------------------------------------------------
      NC1 = NC + 1
      call SCOPY(MC1*MC1, ZERO, 0, RG, 1)
      do 20 IXY = 1, NXY
        X = XTAB(IXY)
        Y = YTAB(IXY)
c                                      Build new row of [A:B] in W().
        W(1) = 1.0e0
        W(2) = X
        W(3) = exp(-X)
        W(4) = Y
c                                      Process W() into [R:G].
        do 10 J = 1, NC
          call SROTG(RG(J,J),W(J),C,S)
          call SROT(NC1-J,RG(J,J+1),MC1,W(J+1),1,C,S)
   10   continue
        call SROTG(RG(NC1,NC1),W(NC1),C,S)
   20 continue
c                                      Begin: Solve triangular system.
        call SCOPY(NC,RG(1,NC1),1,COEF,1)
        do 30 J = NC, 1, -1
          DIV = RG(J,J)
          if (DIV .eq. 0.0e0) then
            print '(''ERROR:ZERO DIVISOR AT J ='', I2)', J
            stop
          end if
          COEF(J) = COEF(J) / DIV
          call SAXPY(J-1,-COEF(J),RG(1,J),1,COEF,1)
   30   continue
c                                        End: Solve triangular system.
c
      print'('' Solution: COEF() = '',3f8.3)',(COEF(J),J=1,NC)
      ESTSD = abs(RG(NC1,NC1)) / sqrt(REAL(NXY-NC))
      print'(/'' Estimated Std. Dev. of data errors ='',f9.5)', ESTSD
      stop
      end


program luhn
  implicit none
  integer              :: nargs
  character(len=20)    :: arg
  integer              :: alen, i, dr
  integer, allocatable :: number(:)
  integer, parameter   :: drmap(0:9) = [0, 2, 4, 6, 8, 1, 3, 5, 7, 9]

  ! Get number
  nargs = command_argument_count()
  if (nargs /= 1) then
     stop
  end if
  call get_command_argument(1, arg, alen)
  allocate(number(alen))
  do i=1, alen
     number(alen-i+1) = iachar(arg(i:i)) - iachar('0')
  end do

  ! Calculate number
  dr = 0
  do i=1, alen
     dr = dr + merge(drmap(number(i)), number(i), mod(i,2) == 0)
  end do

  if (mod(dr,10) == 0) then
     write(*,'(a,i0)') arg(1:alen)//' is valid'
  else
     write(*,'(a,i0)') arg(1:alen)//' is not valid'
  end if
end program luhn

! Results:
! 49927398716 is valid
! 49927398717 is not valid
! 1234567812345678 is not valid
! 1234567812345670 is valid


program tri_ppal

use residuotri_interface

implicit none

real, dimension(:), allocatable :: a, a_copia, b, b_copia,r, w,u, res

integer :: n, i, j

print*, 'Introduce o orde do sistema: '
read*, n
print*
print*, 'O orde introducido e: ', n
print*

allocate(a(n), b(2:n), r(n), w(n), u(n), a_copia(n), b_copia(n), res(n))

print*,
print*, 'Introduce a diagonal principal: '
read*, a(1:n)
print*,

print*,
print*, 'Introduce a diagonal inferior: '
read*, b(2:n)
print*,

print*, 'Introduce el segundo miembro: '
read*, r(1:n)
print*,

print*,
print*, 'Diagonal principal: ',a(1:n)
print*, 'Diagonal inferior ', b(2:n)
print*, 'Segundo miembro: ',r(1:n)
print*,

a_copia = a
b_copia = b

a(1) = sqrt(a(1))

do i=2,n
  b(i) = b(i)/a(i-1)
  a(i) = sqrt(a(i)-b(i)*b(i))
end do

print*,
print*, 'Diagonal principal: ',a(1:n)
print*, 'Diagonal inferior ', b(2:n)
print*, 'Segundo miembro: ',r(1:n)
print*,

w(1) = r(1)/a(1)

do i=2,n
print*, r(i)
print*, w(i-1)
print*, a(i)
  w(i)=(r(i)- b(i)*w(i-1))/a(i)
end do

print*, 'Vector w:'
print*, w
print*,

u(n) = w(n)/a(n)

do i=n-1,1,-1
  u(i)= (w(i)-b(i+1)*u(i+1))/a(i)
end do

print*,
print*, 'Vector u (Solucion): '
print*,

print*,
print*, u
print*,

call residuotri(a_copia, b_copia, b_copia, u, r, res)

end program


    MODULE random_nc_f_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

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

      FUNCTION random_nc_f(dfn,dfd,xnonc)
! .. Use Statements ..
        USE random_standard_gamma_mod
        USE random_standard_normal_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Function Return Value ..
        REAL :: random_nc_f
! ..
! .. Scalar Arguments ..
        REAL, INTENT (IN) :: dfd, dfn, xnonc
! ..
! .. Local Scalars ..
        REAL :: xden, xnum
        LOGICAL :: qcond
! ..
! .. Intrinsic Functions ..
        INTRINSIC SQRT
! ..
! .. Executable Statements ..

!**********************************************************************
!     REAL FUNCTION GENNF( DFN, DFD, XNONC )
!           GENerate random deviate from the Noncentral F distribution
!                              Function
!     Generates a random deviate from the  noncentral F (variance ratio)
!     distribution with DFN degrees of freedom in the numerator, and DFD
!     degrees of freedom in the denominator, and noncentrality parameter
!     XNONC.
!                              Arguments
!     DFN --> Numerator degrees of freedom
!             (Must be >= 1.0)
!                              REAL DFN
!      DFD --> Denominator degrees of freedom
!             (Must be positive)
!                              REAL DFD
!     XNONC --> Noncentrality parameter
!               (Must be nonnegative)
!                              REAL XNONC
!                              Method
!     Directly generates ratio of noncentral numerator chisquare variate
!     to central denominator chisquare variate.
!**********************************************************************
!     JJV changed the code to call SGAMMA and SNORM directly
!      REAL random_chisq,random_nc_chisq
!      EXTERNAL random_chisq,random_nc_chisq
!     JJV changed the argument checker to allow DFN = 1.0
!     JJV in the same way as GENNCH was changed.
        qcond = dfn < 1.0 .OR. dfd <= 0.0 .OR. xnonc < 0.0
        IF (qcond) THEN
          WRITE (*,*) 'In GENNF - Either (1) Numerator DF < 1.0 or'
          WRITE (*,*) '(2) Denominator DF <= 0.0 or '
          WRITE (*,*) '(3) Noncentrality parameter < 0.0'
          WRITE (*,*) 'DFN value: ', dfn, 'DFD value: ', dfd, &
            'XNONC value: ', xnonc
          STOP &
            'Degrees of freedom or noncent param out of range in GENNF'
        END IF

!      GENNF = ( GENNCH( DFN, XNONC ) / DFN ) / ( GENCHI( DFD ) / DFD )
!     JJV changed this to call SGAMMA and SNORM directly
!     xnum = random_nc_chisq(dfn,xnonc)/dfn
        IF (dfn<1.000001) THEN
!     JJV case dfn = 1.0 - here I am treating dfn as exactly 1.0
          xnum = (random_standard_normal()+SQRT(xnonc))**2
        ELSE

!     JJV case dfn > 1.0
          xnum = (2.0*random_standard_gamma((dfn- &
            1.0)/2.0)+(random_standard_normal()+SQRT(xnonc))**2)/dfn
        END IF

!     xden = random_chisq(dfd)/dfd
        xden = 2.0*random_standard_gamma(dfd/2.0)/dfd

!     JJV changed constant so that it will not underflow at compile time
!     JJV while not slowing generator by using double precision or logs.
!      IF (.NOT. (xden.LE. (1.0E-38*xnum))) GO TO 40
        IF (xden<=1.0E-37*xnum) THEN
          WRITE (*,*) ' GENNF - generated numbers would cause overflow'
          WRITE (*,*) ' Numerator ', xnum, ' Denominator ', xden
!     JJV next 2 lines changed to maintain truncation of large deviates.
!      WRITE (*,*) ' GENNF returning 1.0E38'
!      random_nc_f = 1.0E38
          WRITE (*,*) ' GENNF returning 1.0E37'
          random_nc_f = 1.0E37
        ELSE

          random_nc_f = xnum/xden
        END IF
        RETURN

      END FUNCTION random_nc_f

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

    END MODULE random_nc_f_mod


!programa que suma de manera recursiva hasta n

program suma_recursiva

  implicit none

  print *, sum_to(10)

contains
  recursive function sum_to(n) result(r)
    implicit none
    integer :: r
    integer, intent(in) :: n

    r = 0

    if (n == 0) then
      return
    end if

    r = n + sum_to(n-1)

  end function sum_to

end program suma_recursiva


module gauss_jordan
  implicit none

contains

  !! Convert to upper triangular form
  pure function upper_triangular(mat) result(A_)
    real, dimension(:, :), intent(in) :: mat
    real, dimension(size(mat, 1), size(mat, 2)) :: A, A_
    integer, dimension(size(mat, 2)) :: r  ! Row permutation/index set
    real :: scaling_factor
    integer :: i, m, n, col, row, row_

    m = size(mat, 2)
    n = size(mat, 1)
    A = mat

    row = 1
    col = 1
    r = (/(i, i=1,m)/)

    do while (row <= m .and. col <= n)
      ! Find row with highest magnitude in the current column
      row_ = maxloc(abs(A(col, r(row:))), dim=1) - 1 + row

      if (A(col, r(row_)) == 0.0) then
        col = col + 1
        cycle
      endif

      ! Swap rows
      r([row, row_]) = r([row_, row])

      ! Normalize row
      scaling_factor = A(col, r(row))
      A(col:, r(row)) = A(col:, r(row)) / scaling_factor

      ! Zero the pivot column for remaining rows
      ! by subtracting off a scaled version of the current row
      forall (i=row+1:m) A(col+1:, r(i)) = A(col+1:, r(i)) &
          - A(col, r(i)) * A(col+1:, r(row))
      A(col, r(row+1:)) = 0.0

      row = row + 1
      col = col + 1
    enddo

    ! Perform reordering
    forall (i=1:m) A_(:, i) = A(:, r(i))
  end function

  !! Convert upper-triangular form to reduced row-echelon form
  pure function substitution(mat) result(A)
    real, dimension(:, :), intent(in) :: mat
    real, dimension(size(mat, 1), size(mat, 2)) :: A
    integer :: i, j, m

    m = size(mat, 2)
    A = mat

    do i = m - 1, 1, -1
      do j = i + 1, m
        A(:, i) = A(:, i) - A(j, i) * A(:, j)
      enddo
    enddo
  end function

  !! Reduced row-echelon form via Gauss-Jordan elimination
  pure function rref(mat) result(A)
    real, dimension(:, :), intent(in) :: mat
    real, dimension(size(mat, 1), size(mat, 2)) :: A

    A = mat
    A = upper_triangular(A)
    A = substitution(A)
  end function

  !! Solve the matrix equation Ax = y using Gauss-Jordan elimination
  !! Arguments:
  !!   A must be a non-singular matrix of size NxN
  !!   y must be a vector of size N
  pure function solve(A, y) result(x)
    real, dimension(:, :), intent(in) :: A
    real, dimension(:), intent(in) :: y
    real, dimension(size(A, 1) + 1, size(A, 2)) :: Ay
    real, dimension(size(y)) :: x

    ! Transpose (for row-memory locality) and augment
    Ay(1:size(A, 1), :) = transpose(A)
    Ay(size(Ay, 1), :) = y

    Ay = rref(Ay)
    x = Ay(size(Ay, 1), :)
  end function

end module gauss_jordan

! TODO size N constant parameters; type/compile-time checking of sizes


subroutine jacobian(Nx,Ny,psi,vis,jac_term)

implicit none
integer, intent(in) :: Nx,Ny
real(8), dimension(Nx,Ny), intent(in)  :: psi,vis
real(8), dimension(Nx,Ny), intent(out) :: jac_term

integer :: i,j

jac_term(:,:) = 0.d0

do i=2,Nx-1
 do j=2,Ny-1

!     Arakawa Jacobian
  jac_term(i,j) = ((psi(i+1,j)-psi(i-1,j))*(vis(i,j+1)-vis(i,j-1)) &
                & -(psi(i,j+1)-psi(i,j-1))*(vis(i+1,j)-vis(i-1,j)) &
                & +psi(i+1,j)*(vis(i+1,j+1)-vis(i+1,j-1)) &
                & -psi(i-1,j)*(vis(i-1,j+1)-vis(i-1,j-1)) &
                & -psi(i,j+1)*(vis(i+1,j+1)-vis(i-1,j+1)) &
                & +psi(i,j-1)*(vis(i+1,j-1)-vis(i-1,j-1)) &
                & +vis(i,j+1)*(psi(i+1,j+1)-psi(i-1,j+1)) &
                & -vis(i,j-1)*(psi(i+1,j-1)-psi(i-1,j-1)) &
                & -vis(i+1,j)*(psi(i+1,j+1)-psi(i+1,j-1)) &
                & +vis(i-1,j)*(psi(i-1,j+1)-psi(i-1,j-1))) &
                & *0.33333333

 end do
end do

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! NOTE: For THIS Jacobian the BOUNDARY VALUES vanish everywhere,
!
! for BOTH free-slip and no-slip boundary conditions!!!!!!!!!!!!!!!!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

! we ignore the interface boundaries here for the moment
! (vis and psi know about the boundaries ofcourse)
! since the boundary values of the jacobian are of no consequence atm
! otherwise we would need to add vis on the boundary as boundary condition!!

end


! demo rotating a 2-D array 90 degrees clockwise
use rotflip, only: rot90, flipud, fliplr

implicit none

integer, parameter :: N=3
integer :: i, iarr(N,N),  Barr(0:2, 0:2)
real :: rarr(N,N)

iarr = reshape( &
  [0, 1, 2, &
   3, 4, 5, &
   6, 7, 8], &
   shape(iarr), order=[2,1])

rarr = iarr

call printarr(iarr,'before rot90')

call printarr(rot90(iarr,0),'rot90(0)')

call printarr(rot90(iarr,1), 'rot90(1)')

call printarr(rot90(iarr,2),'rot90(2)')

call printarr(rot90(iarr,3),'rot90(3)')

call printarr(flipud(iarr), 'flipud()')

call printarr(fliplr(iarr), 'fliplr()')

! -- test non-default bounds
Barr = iarr
print *,lbound(Barr,1)
Barr = rot90(Barr)
print *,lbound(Barr,1)

! -- Fortran polymorphic type
rarr = iarr
rarr = rot90(rarr)

contains

subroutine printarr(arr, msg)

integer, intent(in) :: arr(:,:)
character(*), intent(in), optional :: msg
character(5) :: frmt

write(frmt,'(A1,I1,A3)') '(',size(arr,1),'I1)'

if(present(msg)) print *,msg
do i = 1, size(arr,1)
  print frmt, arr(i,:)
enddo

end subroutine printarr
end program


! Program to test the FORALL construct
program testforall
   implicit none
   integer, dimension (3, 3) :: a
   integer, dimension (3) :: b
   logical, dimension (3, 3) :: m, tr
   integer i
   character(len=9) line

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/));

   tr = .true.

   if (sum(a) .ne. 45) call abort
   write (line, 9000) sum(a)
   if (line .ne. ' 45      ') call abort
   b = sum (a, 1)
   if (b(1) .ne. 6) call abort
   if (b(2) .ne. 15) call abort
   if (b(3) .ne. 24) call abort
   write (line, 9000) sum (a, 1)
   if (line .ne. '  6 15 24') call abort

   m = .true.
   m(1, 1) = .false.
   m(2, 1) = .false.

   if (sum (a, mask=m) .ne. 42) call abort
   if (sum (a, mask=m .and. tr) .ne. 42) call abort

   write(line, 9000) sum (a, mask=m)
   if (line .ne. ' 42      ') call abort

   b = sum (a, 2, m)
   if (b(1) .ne. 11) call abort
   if (b(2) .ne. 13) call abort
   if (b(3) .ne. 18) call abort

   b = sum (a, 2, m .and. tr)
   if (b(1) .ne. 11) call abort
   if (b(2) .ne. 13) call abort
   if (b(3) .ne. 18) call abort
   write (line, 9000) sum (a, 2, m)
   if (line .ne. ' 11 13 18') call abort

9000 format(3I3)
end program


! computes trapezoidal method
program CompTrap
implicit none
double precision x0,xn,h,sum,f,exact,diff,xj
integer n,j
write(*,*)'enter n'
read(*,*) n
x0=0.0d0
xn=2.d0
h=(xn-x0)/dfloat(n)
sum=f(x0)+f(xn)
do j=1,n-1
  xj=x0+dfloat(j)*h
  sum=sum+2.d0*f(xj)
enddo
sum=h/2.d0*sum
exact=dlog(1.5d0)
write(*,*) 'exact=',exact
diff=dabs(sum-exact)
write(*,*) 'Trapezoidal approx=',sum
write(*,*) 'diff=',diff
stop
end program CompTrap

function f(x)
double precision x,f
f=1/(x+4)
return
end function f


program integrals
use procedures
implicit none

real(kind=8) :: a, b, I
real(kind=8), parameter :: pi = 3.141592653589793

   b = (3.0d0*pi)/2.0d0
   a = pi/2.0d0
   call I_Simpsons38(f1, a, b, I)
   write(*,'(A12,F9.5)') 'integral:   ', I

   b = 1.2d0
   a = -1.2d0
   call I_Simpsons38(f2, a, b, I)
   write(*,'(A12,F9.5)') 'integral:   ', I

end program integrals


module fqs_constants

    use fqs_types, only: wp

    implicit none

    private

    public pi, e_, i_

    public FQS_ERROR_H5FILE_NOT_EXIST
    public FQS_ERROR_H5FILE_NDIMS

    real(wp),    parameter :: pi  = 3.1415926535897932384626433832795_wp
    real(wp),    parameter :: e_  = 2.7182818284590452353602874713527_wp
    complex(wp), parameter :: i_  = (0, 1)

    integer,     parameter :: FQS_ERROR_H5FILE_NOT_EXIST = 100
    integer,     parameter :: FQS_ERROR_H5FILE_NDIMS  = 101

end module fqs_constants


recursive subroutine factorial(i,f)
  implicit none
  integer f,i,j
  intent(in) i
  intent(out) f
  if (i.le.0) then
    stop 'argument must be > 0'
  else if (i.eq.1) then
    f=i
  else
    call factorial(i-1,j)
    f=i*j
  end if
end subroutine factorial

program t
  implicit none
  integer::f
  call factorial(5,f)
  print '(i0)',f
end program t


C     THIS COMPUTER PROGRAM, WRITTEN IN FORTRAN, MODELS O2 TRANSPORT FROM
C     AIR TO MITOCHONDRIA, AND THEN COUPLES THIS TO O2 UTLIZATION BY THE
C     MITOCHONDRIA.
C
C     THE PROGRAM ANSWERS THE QUESTION: GIVEN THE TRANPSORT CAPACITY OF
C     THE LUNGS, HEART, BLOOD AND MUSCLES (CHARACTERIZED BY NUMERICAL
C     VALUES FOR THE MAJOR TRANSPORT VARIABLES), HOW MUCH O2 CAN BE
C     SUPPLIED TO THE TISSUES, AND WHAT ARE THE PO2 VALUES AT EACH STEP?
C
C     O2 TRANSPORT IS ACCOMPLISHED BY 4 ORGANS/TISSUES - LUNGS, HEART,
C     BLOOD AND MUSCLES. TRANSPORT THROUGH THIS SYSTEM INVOLVES FOUR
C     SEQUENTIAL PROCESSES OR STEPS -
C
C     1. VENTILATION TO BRING O2 FROM AIR TO THE ALVEOLAR GAS
C
C     VO2  =  k x VA x [PIO2 - PAO2]
C
C     2. DIFFUSION OF O2 FROM ALVEOLAR GAS INTO CAPILLARY BLOOD
C
C     PaO2 - PvO2  =  (PAO2 - PvO2) x exp(-DLO2/(b x Q))
C
C     3. CIRCULATORY TRANSPORT OF O2 FROM LUNGS TO TISSUE MICROVESSELS
C
C     VO2 = Q x [CaO2 - CvO2]
C
C     4. DIFFUSION OF O2 FROM TISSUE MICROVESSELS TO MITOCHONDRIA
C
C     PvO2 - PmitoO2  =  (PaO2 - PmitoO2) x exp(-DMO2/(b x Q))
C
C
C     MODELING IS BASED ON WELL-ESTABLISHED PRINCIPLES OF MASS CONSERVATION
C     FOR O2 AT EVERY STEP, USING CORRESPONDINGLY WELL-ESTABLISHED
C     TRANSPORT EQUATIONS.
C     THERE IS ONE EQUATION FOR EACH OF THE ABOVE 4 STEPS.
C
C     A FIFTH EQUATION BRINGS IN MITOCHONDRIAL METABOLISM. IT EXPRESSES THE
C     RATE OF MITOCHONDRIAL O2 CONSUMPTION AS AN EXPONENTIAL, TWO PARAMETER
C     FUNCTION OF MITOCHONDRIAL PO2. THE TWO PARAMETERS ARE THE P50 AND VO2MAX
C     OF THE EXPONENTIAL RELATIONSHIP
C
C     5.  VO2  =  VO2max x [1  -  exp(-0.693 x PmitoO2 / P50)]
C
C     IN THE ABOVE SYSTEM, THE INDEPENDENT VARIABLES ARE:
C
C     PIO2 (Inspired PO2, mm Hg)
C     VA (alveolar ventilation, L/min)
C     DLO2 (lung diffusing capacity, ml/min/mm Hg)
C     b (slope of the O2-Hb dissociation curve, ml/ml/mm Hg)
C     Q (cardiac output, l/min)
C     DMO2 (muscle diffusing capacity, ml/min/mm Hg)
C     VO2max is maximal mitochondrial VO2 when O2 is in excess, ml/min
C     P50 is the PO2 at which mitochondrial VO2 is half maximal
C
C     IMPLICIT IN THE ABOVE IS KNOWING THE HbO2 DISSOCIATION CURVE IN A
C     QUANTITATIVE SENSE. This means that if we know PO2, we know [O2]
C
C     THE DEPENDENT VARIABLES OR "MODEL OUTPUTS" ARE:
C
C     VO2 (O2 consumed, liters per minute)
C     PAO2 (Alveolar PO2, mm Hg)
C     PaO2 (Arterial PO2, mm Hg). CaO2 is the [O2] at PaO2
C     PvO2 (Venous PO2, mm Hg). CvO2 is the [O2] at PvO2
C     PmitoO2 (Mitochondrial PO2, mm Hg)
C
C     AS SHOULD BE CLEAR, WE HAVE 5 EQUATIONS AND 5 UNKNOWNS. THIS MEANS
C     A UNIQUE SOLUTION CAN BE OBTAINED. THIS PROGRAM FINDS THE SOLUTION FOR
C     DESIRED SET OF INPUT VARIABLES.
C
C     THERE ARE SOME IMPORTANT ASSUMPTIONS/APPROXIMATIONS:
C
C     1. O2 TRANSPORT IS IN A STEADY STATE - ALL INPUT AND OUTPUT VARIABLES
C        ARE CONSTANT IN TIME
C     2. THE LUNGS ARE CURRENTLY ASSUMED TO BE HOMOGENEOUS
C     3. THE TISSUES ARE LIKEWISE ASSUMED TO BE HOMOGENEOUS
C
C     IMPORTANTLY, THIS VERSION OF THE PROGRAM USES THE ACTUAL O2 AND CO2
C     DISSOCIATION CURVES AND MAKES NO LINEAR APPROXIMATION TO EITHER. THIS
C     ALSO MEANS THAT O2-CO2 INTERACTION IS ACCOUNTED FOR. HOWEVER, THIS
C     MAKES THE SOLUTIONS POSSIBLE ONLY VIA TEDIOUS NUMERICAL ANALYSIS.
C     CLOSED FORM, ALGEBRAIC SOLUTIONS ARE INFEASIBLE.
C
C     THE LOGIC IS TO CYCLE THE SYSTEM BETWEEN LUNGS AND TISSUES UNTIL
C     CONVERGENCE AND STABILITY OF OUTCOME VARIBALES IS ESTABLISHED. IN THE
C     LUNGS, STARTING WITH A TRIAL VENOUS AND ALEVOLAR PO2, THE ARTERIAL PO2
C     IS DETERMINED BY CALCULATING THE ENDCAPILLARY VALUE ACCORDING TO THE
C     DIFFUSION EQUATION (EQN 2). THIS OUTPUT ARTERIAL PO2 THEN BECOMES THE
C     INPUT ARTERIAL PO2 FOR TISSUE O2 DIFFUSION ASSUMING A MITOCHONDRIAL
C     PO2 TO START. THIS YIELDS A VENOUS PO2, AND THEN WE CYCLE BACK TO THE
C     LUNG WITH THIS NEW VENOUS PO2 AND SO ON.
C
C     ULTIMATELY, STABILITY IS REACHED AND AT THAT POINT, VO2 WILL BE THE
C     SAME NO MATTER WHICH OF THE 5 EQUATIONS IS USED TO COMPUTE IT.
C
C     THIS VERSION, LUNGTIS3, HAS A BISECTION SEARCH ALGORITHM THAT FINDS
C     THE UNIQUE MITOCHONDRIAL PO2 THAT SATISFIES SIMULTANEOUSLY THE 4-EQN O2
C     TRANSPORT MODEL FROM MOUTH TO MITOCHONDRIA AND THE MITOCHONDRIAL
C     RESPIRATION CURVE (EQN 5).
C
C---------------------------------------------------------------------------
C
C     TECHNICAL NOTE:
C
C     BOTH LUNG AND MUSCLE DIFFUSING CAPACITY ARE CONSTANT LUMPED-PARAMETER
C     VARIABLES IN THIS VERSION BECAUSE THAT IS HOW THEY ARE USUALLY MEASURED.
C     IN REALITY, THEY CONTAIN A TRUE DIFFUSION COMPONENT PLUS AN ELEMENT THAT
C     RECOGNIZES THAT CHEMICAL COMBINATION WITH Hb IS NOT INSTANTANEOUS. IN
C     ADDITION, THE ALGORITHM USES AN ARBITRARY VALUE FOR VOLUME OF BLOOD IN
C     THE LUNG/TISSUE CAPILLARIES (CALLED VC). WHILE VC IS TECHNICALLY NEEDED
C     TO COMPUTE TRANSIT TIME, THE FINAL  RESULT DEPENDS ONLY ON DLO2/Q, OR
C     DMO2/Q, AND IS INDEPENDENT OF CHOICE OF VC.
C     IN OTHER WORDS, CHOOSING A LARGE VC GIVES A LONG TRANSIT TIME FOR
C     A GIVEN BLOOD FLOW RATE, BUT THE TIME COURSE IS PRECISELY SLOWED
C     DOWN IN PROPORTION SO THAT ENDCAPILLARY AND MEAN CAPILLARY DATA
C     ARE UNAFFECTED.
C
      SUBROUTINE deliv()
      COMMON HB,HCRIT,TEMP,APH,BPH,APCO2,BPCO2,P50,O2SOL,VO2,VCO2
C
C     DEFAULT INPUT VARIABLE VALUES ARE PROVIDED TO EASE DATA ENTRY:
C
C     PVO2 & PVCO2 ARE MIXED VENOUS PO2/PCO2 FOR LUNG DIFFUSION COMPUTATION
C
      PVO2=20.0
      PVCO2=75.0
C
C     PALVO2 & PALVCO ARE ALVEOLAR PO2/PCO2 FOR LUNG DIFFUSION COMPUTATION
C
      PALVO2=100.0
      PALVCO=35.0
C
C     VA IS DEFAULT VENTILATION; PB BAROMETRIC PRESSURE; FIO2 INSPIRED O2
C     FRACTION; PIO2 IS CORRESPONDING INSPIRED PO2; FICO2 IS ASSUMED ZERO;
C
      VA=85.0
      PB=760.0
      FIO2=0.2093
      PIO2=FIO2*(PB-50.0)
C
C     FAO2 IS DEFAULT ALVEOLAR O2 FRACTION; DITTO FOR CO2
C     REXP IS THE ASSUMED RESP EXCHANGE RATIO OR RQ (=VCO2/VO2) AT VO2max
C     IT SHOULD BE REDUCED AT LOWER EXERCISE INTENSITIES. IT IS HELD CONSTANT.
C
      FAO2=PALVO2/(PB-50.0)
      FACO2=PALVCO/(PB-50.0)
      REXP=1.15
C
C     NOW FOLLOW IN ORDER :
C
C  O2SOL    O2 PHYSICAL SOLUBILITY IN WATER/BLOOD, ML/DL/MM HG
C  HB       HEMOGLOBIN, GM/100 ML
C  HRCIT    HEMATOCRIT (PER CENT), SET AT 3 * HB
C  TEMP     BODY TEMPERATURE, DEGREES CENTIGRADE
C  P50      O2 HEMOGLOBIN DISSOCIATION CURVE P50, TORR
C  APH      PH OF BLOOD EQUILIBRATED WITH PCO2 OF 30 TORR
C  APCO2    CORRESPONDING PCO2 (30 TORR)
C  BPH      PH OF BLOOD EQUILIBRATED WITH PCO2 OF 60 TORR
C  BPCO2    CORRESPONDING PCO2 (60 TORR)
C  QT       TOTAL TISSUE OR PULMONARY BLOOD FLOW, L/MIN
C  VC       CAPILLARY BLOOD VOLUME, ML
C  DMO2     MEMBRANE DIFFUSING CAPACITY FOR O2, ML/MIN/TORR
C  DT       TIME STEP INTERVAL FOR NUMERICAL INTEGRATION, SECONDS
C
      O2SOL=0.003
      HB=15.0
      HCRIT=3.0*HB
      ITHETA=0
      TEMP=38.0
      P50=26.8
      APH=7.30
      APCO2=30.0
      BPH=7.10
      BPCO2=60.0
      QT=20.0
      VC=5.0*QT
      DLNGO2=60.0
      DMUSO2=80.0
      DT=0.001
C
C     HERE ARE THE CONSTANTS FOR THE STAUB ET AL THETA-O2 RELATIONSHIP:
C SHOULD ONE WANT TO MODEL DIFFUSION INCORPORATING CHEMICAL REACTION RATES
C
C     AS STATED, WE DO NOT DO THIS BECAUSE EXPERIMENTAL DATA ARE FOR TOTAL
C     DLO2 INCORPORATING THIS EFFECT ALREADY
C
C      B1=36.1633
C      B2=-1.5551
C      B3=0.0234
C      B4=-1.15173E-4
C
C     HERE IS THE HALF TIME OF THE CO2 CHEMICAL REACTIONS, SECONDS
C     SAME LOGIC FOR CO2 DIFFUSION AND ITS CHEMICAL REACTIONS IN BLOOD
C
C      THALF=0.15
C
C     THE PROCEDURE BEGINS WITH CHOICES REGARDING OUTPUT OPTIONS:
C
C
  10  CONTINUE
      IPR=1;
C
C     YOU HAVE TO ENTER YOUR CHOSEN NAME FOR THE OUTPUT FILE NOW
C     THE PLOT FILE TABULATES THE POINT BY POINT TIME COURSE OF PO2 AND PCO2
C     CHANGE ALONG THE LUNG AND TISSUE CAPILLARIES. THE USER NAMES THIS FILE
C     AT THIS POINT. THE FORMAT IS 10 COLUMNS, 8 DIGITS EACH
C     EACH HORIZONTAL ROW GIVES RESULTS AT ONE TIME POINT FOR ALL THE
C     VARIABLES. EACH COLUMN THEREFORE TABULATES ONE VARIABLE IN TIME
C     THE TEN VARIABLES, FROM LEFT TO RIGHT IN THE TABLE ARE:
C
C  1   TIME,  SECONDS
C  2   PLASMA PO2,  TORR
C  3   RED CELL PO2,  TORR
C  4   BLOOD O2 CONTEN,  ML/100 ML
C  5   PLASMA PCO2,  TORR
C  6   RED CELL PCO2,  TORR
C  7   BLOOD CO2 CONTENT,  ML/100 ML
C  8   INSTANTANEOUS O2 DIFFUSING CAPACITY,  ML/MIN/TORR
C  9   CORRESPONDING CO2 DIFFUSING CAPACITY,  ML/MIN/TORR
C  10  BLOOD O2 SATURATION,  %
C
      OPEN(UNIT=9,FILE='r2')
      WRITE(9,77)
  77  FORMAT('mm hg: venous o2-co2   alv-tis       arterial')
C
C*************************************************************
C     KEYBOARD ENTRY OF THE TWO MITOCHONDRIAL CURVE PARAMETERS -
C     MAXIMAL VO2 AND P50 OF THE EXPONENTIAL RESPIRATION CURVE
C
      VO2MAX=3000.
      P50MIT=5.
C
C     NOW FOLLOWS THE BISECTION SEARCH FOR THE ACTUAL MITOCHNDIRAL PO2.
C     THIS IS IN FACT SOLVING ONE OF THE 5 MAIN EQUATIONS
C     THE 3000 LOOP ACCOMPLISHES THIS
C
      PTMIN=0.0
      PTMAX=40.0
 3000 PTISO2=(PTMIN+PTMAX)/2.0
C
C     PTISO2 IS THE TRIAL MITOCHONDRIAL PO2, AND BECOMES THE CORRECT VALUE
C     WHEN CONVERGENCE HAS BEEN REACHED
C*************************************************************
      RKMITO=0.693/P50MIT
      REXP=RKMITO*PTISO2
      VO2ACT=VO2MAX*(1.0 - EXP(-REXP))
  90  CONTINUE
      FAO2=PALVO2/(PB-50.0)
      FACO2=PALVCO/(PB-50.0)
      REXP=1.15
      PIO2=(PB-50.0)*FIO2
C********************
      NOUT=9
C********************
      DO 210 JJ=1,NOUT
      FAO2=PALVO2/(PB-50.0)
      FACO2=PALVCO/(PB-50.0)
C     CYCLE BETWEEN THE LUNG AND TISSUE INTEGRATION NOW
C     THIS IS A BOHR INTEGRATION FOR BOTH LUNG AND TISSUES
C     IT IS A SIMPLE ALGORITHM WITHOUT RUNGE-KUTTA,
C     JUST A GRADIENT METHOD WHERE ACCURACY DEPENDS
C     ON SUFFICIENTLY SMALL TIME STEPS
C*******************
      IF(JJ.GT.1) GO TO 170
      NCYC=3
C*******************
 170  CONTINUE
C
C****************************************************************
C
C     THE LOOP BELOW, 190, IS THE MAIN LOOP CYCLING BACK AND FORTH BETWEEN
C     LUNGS AND TISSUES
C
C****************************************************************
C
      WRITE(9,77)
      DO 190 I=1,NCYC
      ILT=0
C     ILT=0 SIGNALS LUNG BOHR INTEGRAL*********************************
C PVO2-venous po2, PVCO2-venous pco2, PALVO2-alveolar po2, PALVCO- alveolar pco2, PO2- arterial po2, PCO2- arterial pco2
      DMO2=DLNGO2
      CALL LT(JJ,I,NCYC,ILT,IPR,IPL,PVO2,PVCO2,PALVO2,PALVCO,PO2,PCO2,
     1QT,DMO2,DT)
      WRITE(9,79)PVO2,PVCO2,PALVO2,PALVCO,PO2,PCO2
  79  FORMAT('L: ',6F8.2)
C      READ(*,*)GARB
      PARTO2=PO2
      PARTCO=PCO2
C      PTISO2=0.0
C***************************
      RR=VCO2/VO2
      FACTOR=1.15/RR
      PTISCO=PVCO2*FACTOR
C****************************************************************
C      WRITE(*,180)I,ILT,VO2,VCO2,PALVO2,PALVCO,PARTO2,PARTCO,PVO2,PVCO2,
C     1PTISO2,PTISCO
C*****************************************************************
C      WRITE(*,79)
C      READ(*,*)GARB
      ILT=1
C
C     ILT=1 SIGNALS TISSUE INTEGRAL************************************
C
C PVO2-venous po2, PVCO2-venous pco2, PALVO2-alveolar po2, PALVCO- alveolar pco2, PO2- arterial po2, PCO2- arterial pco2
      DMO2=DMUSO2
      CALL LT(JJ,I,NCYC,ILT,IPR,IPL,PARTO2,PARTCO,PTISO2,PTISCO,PO2,
     1PCO2,QT,DMO2,DT)
      WRITE(9,80)PO2,PCO2,PTISO2,PTISCO,PARTO2,PARTCO
  80  FORMAT('T: ',6F8.2)
C      WRITE(*,79)
C      READ(*,*)GARB
      PVO2=PO2
      PVCO2=PCO2
C*******************************************************************
C      WRITE(*,180)I,ILT,VO2,VCO2,PALVO2,PALVCO,PARTO2,PARTCO,PVO2,PVCO2,
C     1PTISO2,PTISCO
C*********************************************************************
C      WRITE(*,79)
C      READ(*,*)GARB
 190  CONTINUE
C******************************************************************
C
C     END OF THE MAIN 190 DO LOOP
C
C******************************************************************
      REXP=VCO2/VO2
      FUDGE=1.0 - FIO2*(1.0-REXP)
      VO2EXP=1000.0*VA*(FIO2-FAO2)/FUDGE
      VCO2EX=1000.0*VA*FACO2
      O2TRY=(PB-50.0)*(FIO2 - VO2*FUDGE/(1000.0*VA))
      CO2TRY=(PB-50.0)*VCO2/(1000.0*VA)
C******************************************************************
C      WRITE(*,200)JJ,VO2EXP,VO2,PALVO2,O2TRY,VCO2EX,VCO2,PALVCO,CO2TRY,
C     1REXP
C*********************************************************************
      PALVO2=(O2TRY+PALVO2)/2.0
      PALVCO=(CO2TRY+PALVCO)/2.0
 210  CONTINUE
C******************************************************
C
C     END OF THE MITOCHONDRIAL PO2 BISECTION SEARCH
C
C******************************************************
      CLOSE(9)
      WRITE(*,220)
 220  FORMAT(' WANT TO GO BACK AND DO IT AGAIN ? (YES=1, NO=0)')
      READ(*,*)IMOR
      CLOSE(8)
      CLOSE(3)
 240  CONTINUE
      END
C**********************************************************************
C     THIS ENDS THE PROCEDURE, FOLLOWING ARE ALL THE SUPPORTING SUBROUTINES
C**********************************************************************
C
      SUBROUTINE LT(JJ,ICYC,NCYC,ILT,IPR,IPL,PINO2,PINCO2,ALTSO2,ALTSCO,
     1PO2,PCO2,QT,DMO2,DT)
      DIMENSION TIME(1000),O2PLAS(1000),O2RBC(1000),O2CONC(1000),
     1CO2PLS(1000),CO2RBC(1000),CO2CNT(1000),DIFO2(1000),
     2DIFCO2(1000),O2SAT(1000),YY(1000)
      COMMON HB,HCRIT,TEMP,APH,BPH,APCO2,BPCO2,P50,O2SOL,VO2,VCO2
C     NOW FOLLOWS DATA ENTRY SECTION TOREPLACE DEFAULTS IF DESIRED
C     VARIABLES ARE ENTERED FORMAT FREE (DECIMALS OPTIONAL, COMMAS
C     TO SEPARATE)
C     THE INPUT DATA ARE ALSO PRINTED OUT NOW (IF HARDCOPY DESIRED)
 998  CONTINUE
      VC=5.0*QT
      QMS=QT*1000.0/60.0
C     QMS IS TOTAL BLOOD FLOW, ML/SEC
C      TT=VC*60.0/QT/1000.0
      TT=0.3
C     TT IS TRANSIT TIME (SECONDS) COMPUTED AS CAPILLARY VOLUME/BLOOFLOW
C     ITS VALUE IS ONLY AS CORRECT AS THE ASSUMED VALUE OF VC FROM WHICH
C     IT IS DERIVED.HOWEVER, THE NUMERICAL RESULTS ARE TOTALLY INDEPENDENT
C     OF CHOICE OF VC AND HENCE TT - DEPENDING ON DO2/Q ONLY.
C
      DMO2S=DMO2/60.0
      DMCO2S=20.0*DMO2S
C
C     DMO2S= MEMBRANE O2 DIFF CAP, ML/SEC/TORR
C     DMCO2S=MEMBRANE CO2 DIFF CAP, ML/SEC/TORR, ASSUMED 20 x THAT FOR O2
C     BASED ON DIFFERENCES IN SOLUBILITY AND MOLECULAR WEIGHT
C
C     ALL QUANTITIES ARE NOW IN SECONDS, TORR & ML
C
      CALL BLOOD(PINO2,PINCO2,CINO2,CINCO2,SATRN)
      PO2=PINO2
      PLASPO=PINO2
      PCO2=PINCO2
      PLASPC=PINCO2
      O2C=CINO2
      O2DEL=10.0*QT*O2C
      CO2C=CINCO2
      PBARO2=PO2
      PBARCO=PCO2
      T=0.0
C**********
C     HERE IS THE DIFFUSION LOOP ITSELF (DO 350 IS OUTER LOOP, 340 IS INNER)
C**********
      PRK=0.01/DT
      KPRINT=PRK
      IF(KPRINT.LE.0) KPRINT=1
      K=0
      DSUM=0.0
      DO 350 J=1,1000
      DO 340 I=1,KPRINT
      K=K+1
C     NOW FOLLOWS DO2 COMPUTATION A LA ROUGHTON & FORSTER, 1957
C
C      IF(SATRN.LE.76.0) THETA=2.8
C      IF(SATRN.GT.76.0.AND.SATRN.LT.94.0)
C     1THETA=B1+B2*SATRN+B3*SATRN**2+B4*SATRN**3
C      IF(SATRN.GE.94.0) THETA=24.0-0.24*SATRN
C      THETA=THETA/60.0
C****************
C     THIS LINE REDUCES THETA IN PROPORTION TO HB
C     IF YOU WISH (IE., IF ITHETA IS SET TO 1)
C
C      IF(ITHETA.EQ.1) THETA=THETA*HB/15.0
C****************
C
C     THIS PUTS THETA IN ML/SEC/ML/TORR
C
C      DINV=1.0/DMO2S + 1.0/(VC*THETA)
      IF(K.GT.1) DSUM=DSUM+DMO2
C     NOW FOLLOWS DCO2 COMPUTATION USING HALFTIME
C     OF 0.15 SECONDS AND SAME CONCEPT AS FOR O2:
C     1/D  =  1/DMCO2  +  1/(THETA * VC)
C     THETA IS COMPUTED FROM THE HALFTIME AS FOLLOWS:
C
C      AA=41.58*CO2C*VC
C      BB=THALF*PCO2*100.0
C      AB=AA/BB
C      AB=AB/60.0
C      DINV=1.0/DMCO2S + 1.0/AB
      RK=K
C     THE ABOVE PUTS DO2 AND DCO2 AS PRINTED IN ML/MIN/TORR
C
      TIME(K)=T
      O2PLAS(K)=PLASPO
      O2RBC(K)=PO2
      O2CONC(K)=O2C
      CO2PLS(K)=PLASPC
      CO2RBC(K)=PCO2
      CO2CNT(K)=CO2C
      DIFO2(K)=DMO2
      DIFCO2(K)=DMCO2
      O2SAT(K)=SATRN
      IF(T.GT.0.9999*TT) GO TO 360
C     T IS TOTAL ELAPSED TIME IN THE CAPILLARY; DT THE INTEGRAL ELEMENT
C     OF TIME USED IN THE FORWARD INTEGRATION
      T=T+DT
C     NOW FOLLOWS THE ACTUAL INTEGRATION PROCEDURE
      O2C=O2C+DMO2S*(ALTSO2-PO2)*DT*100.0/VC
      CO2C=CO2C+DMCO2S*(ALTSCO-PCO2)*DT*100.0/VC
      CALL FNDCON(PO2,PCO2,O2C,CO2C,ILT,SATRN)
C     FNDCON IS THE ROUTINE THAT GETS YOU A PO2 FROM AND [O2]
      PLASPO=ALTSO2-(ALTSO2-PO2)
      PLASPC=ALTSCO+(PCO2-ALTSCO)
      PBARO2=(PBARO2*RK+PO2)/(RK+1.0)
      PBARCO=(PBARCO*RK + PCO2)/(RK+1.0)
 340  CONTINUE
 350  CONTINUE
 360  CONTINUE
C     THIS ENDS THE DIFFUSION INTEGRATION LOOP
C     OVERALL OUPUT DATA ARE NOW COMPUTED AND PRINTED
      VO2=ABS(10.0*QT*(CINO2-O2C))
      IF(ILT.EQ.0) O2DEL=O2DEL + VO2
      O2EXT=100.0*VO2/O2DEL
      VCO2=ABS(10.0*QT*(CINCO2-CO2C))
      R=VCO2/VO2
      DIFFPO=ABS(ALTSO2-PO2)
      DIFFPC=ABS(ALTSCO-PCO2)
      IF(ICYC.NE.NCYC) RETURN
      RETURN
      END

      SUBROUTINE BLOOD(PO2,PCO2,O2C,CO2C,SATRN)
C     COMPUTES O2 & CO2 CONTENTS FROM PARTIAL PRESSURES, CALLING THE
C     DISSOCIATION CURVE ROUTINES THAT FOLLOW
      COMMON HB,HCRIT,TEMP,APH,BPH,APCO2,BPCO2,P50,O2SOL
      PH1=PH(PCO2,0.0)
      Y=0.003*HB*(1.0-SATURA(PO2,PCO2,PH1)/100.0)
      PH2=PH(PCO2,Y)
      SATRN=SATURA(PO2,PCO2,PH2)
      O2C=0.0139*HB*SATRN + O2SOL*PO2
      CO2C=CO2CON(PCO2,PH2,SATRN)
      RETURN
      END

      FUNCTION PH(PPCO2,Y)
C     COMPUTES PH FROM BUFFER DATA AND PCO2
      COMMON HB,HCRIT,TEMP,APH,BPH,APCO2,BPCO2,P50,O2SOL
      IF(PPCO2.LT.0.001) PPCO2=0.001
      IF(APH-1.)10,10,20
  10  PH=7.590+Y-.2741*ALOG(PPCO2/20.)
      GO TO 30
  20  PH=BPH+Y+(APH-BPH)*ALOG(PPCO2/BPCO2)/ALOG(APCO2/BPCO2)
  30  RETURN
      END

      FUNCTION CO2CON(PCO2,PHE,SATN)
C     KELMAN'S CO2 DISSOCIATION CURVE
      COMMON HB,HCRIT,TEMP,APH,BPH,APCO2,BPCO2,P50,O2SOL
      P=7.4-PHE
      PK=6.086+.042*P+(38.-TEMP)*(.00472+.00139*P)
      SOL=.0307+.00057*(37.-TEMP)+.00002*(37.-TEMP)*(37.-TEMP)
      DOX=.59+.2913*P-.0844*P*P
      DR=.664+.2275*P-.0938*P*P
      DDD = DOX + (DR - DOX)*(1.-SATN/100.)
      CP=SOL*PCO2*(1.+10.**(PHE-PK))
      CCC = DDD*CP
      CO2CON = (HCRIT*CCC*.01 + (1. - HCRIT*.01)*CP)*2.22
      RETURN
      END

      FUNCTION SATURA(PPO2,PPCO2,PHE)
C     KELMAN'S O2 DISSOCIATION CURVE
      COMMON HB,HCRIT,TEMP,APH,BPH,APCO2,BPCO2,P50,O2SOL
      A1=-8.532229E3
      A2=2.121401E3
      A3=-6.707399E1
      A4=9.359609E5
      A5=-3.134626E4
      A6=2.396167E3
      A7=-6.710441E1
      B=.43429*ALOG(40.)-.43429*ALOG(PPCO2)
      X=PPO2*10.**(.024*(37.-TEMP)+.4*(PHE-7.4)+.06*B)
      X=X*26.8/P50
      IF(X-10.)10,20,20
  10  SAT=0.003683*X+0.000584*X*X
      GO TO 30
  20  SAV2 = X*(X*(X*(X+A3)+A2)+A1)
      SAV3 = X*(X*(X*(X+A7)+A6)+A5)+A4
      SAT = SAV2/SAV3
  30  SATURA=100.*SAT
      RETURN
      END

      SUBROUTINE FNDCON(PO2,PCO2,OXO2,COCON,ILT,SATRN)
C     THIS SUBROUTINE FINDS THE PO2 AND PCO2 THAT CORRESPOND TO A GIVEN PAIR OF
C     CONTENTS. THIS IS ACHIEVED BY A TWO DIMENSIONAL  NEWTON-RAPHSON ITERATIVE
C     PROCEDURE ANALOGOUS TO THAT USED TO MATCH V/Q RATIOS.
C     ACCURACY OF THE MATCH IS FORCED TO WITHIN 0.001 ML/100ML BLOOD
      DIMENSION X(4),Y(4),F(4),G(4),U(4)
      DOUBLE PRECISION U,F,G,DET1,DET2
      COMMON HB,HCRIT,TEMP,APH,BPH,APCO2,BPCO2,P50,O2SOL
      TOL=0.001
      DO 10 KK=1,4
      F(KK)=0.0
      G(KK)=0.0
      U(KK)=0.0
  10  CONTINUE
      ITER=0
      NNN=3
      X(1)=PO2
      Y(1)=PCO2
      X(2)=PO2 + 5.0*(-1.0)**ILT
      Y(2)=PCO2
      X(3)=PO2
      Y(3)=PCO2 - 5.0*(-1.0)**ILT
  20  DO 50 N=1,NNN
      PH1 = PH(Y(N),0.0)
      Y1 = .003*HB*(1. - SATURA(X(N),Y(N),PH1)/100.)
      PH2 = PH(Y(N),Y1)
      SATRN = SATURA(X(N),Y(N),PH2)
      F(N) = .0139*HB*SATRN + O2SOL*X(N) - OXO2
      G(N) = CO2CON(Y(N),PH2,SATRN) - COCON
      IF(ABS(F(N))-TOL)30,30,50
  30  IF(ABS(G(N))-TOL)40,40,50
  40  PO2 = X(N)
      PCO2 = Y(N)
      GO TO 170
  50  CONTINUE
      DO 60 N=1,3
      U(N)=1.
  60  CONTINUE
      CALL DETERM(U,F,G,DET1)
      DO 70 N=1,3
      U(N)=X(N)
  70  CONTINUE
      NFLAG=0
  80  CALL DETERM(U,F,G,DET2)
      IF(NFLAG-1)90,100,100
  90  IF(DET1.EQ.0.0) WRITE(*,180)
      X(4)=DET2/DET1
      GO TO 110
 100  IF(DET1.EQ.0.0) WRITE(*,180)
      Y(4)=DET2/DET1
 110  IF(NFLAG-1)120,140,140
 120  DO 130 N=1,3
      U(N)=Y(N)
 130  CONTINUE
      NFLAG=1
      GO TO 80
 140  DO 150 N=1,2
      J=4-N
      X(J)=X(J-1)
      Y(J)=Y(J-1)
      F(J)=F(J-1)
      G(J)=G(J-1)
 150  CONTINUE
      X(1)=X(4)
      Y(1)=Y(4)
      NNN=1
      ITER=ITER+1
      IF(ITER-30)160,170,170
 160  GO TO 20
 170  CONTINUE
 180  FORMAT(' DET1 IS ZERO IN FNDCON')
      RETURN
      END
      SUBROUTINE DETERM(U,F,G,DET)
C
C     THIS SUBROUTINE IS USED BY FNDCON TO SOLVE THE NUMERCIAL
C     EQUATIONS NECESSARY IN COMPUTING PARTIAL PRESSURES FROM CONTENTS
C
      DIMENSION U(4),F(4),G(4),W(4)
      DOUBLE PRECISION U,F,G,W,D,DET
      DO 10 KK=1,4
  10  W(KK)=0.0
      I=1
      J=2
      K=3
  20  W(I)=U(I)*(F(J)*G(K)-F(K)*G(J))
      IF(I-3)30,60,60
  30  IF(I-1)40,40,50
  40  I=2
      J=3
      K=1
      GO TO 20
  50  I=3
      J=1
      K=2
      GO TO 20
  60  D=0.0
      DO 70 I=1,3
      D=D+W(I)
  70  CONTINUE
      DET=D
      RETURN
      END


program compute_factorial
  implicit none
  integer :: number, i
  write(*,*) "Type a positive integer number:"
  read (*,*) number
  write(*,*) "factorial:", factorial(number)

  contains
  integer function factorial(n)
    integer, intent(in) :: n
    integer :: i
!     factorial = 1
    if (n < 0) error stop 'Only positive integers supported'
    do i = 2, n
      factorial = factorial * i
    enddo
  end function factorial
end program compute_factorial


PROGRAM F045

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER (KIND=8), PARAMETER :: MAX_N     = 1E5

    REAL    (KIND=8), PARAMETER :: TOLERANCE = 1E-5

    REAL    (KIND=8)            :: SQRT_TERM,  TN

    INTEGER :: I

    DO I = 286, MAX_N

        TN = 0.5D0 * I * (I + 1.0D0)

        SQRT_TERM = DSQRT(1.D0 + (24.D0 * TN))

        IF ((SQRT_TERM - REAL(FLOOR(SQRT_TERM, 8), 8)) > TOLERANCE) CYCLE

        IF (MOD(FLOOR(SQRT_TERM, 8) + 1.0D0, 6.0D0) > TOLERANCE) CYCLE

        SQRT_TERM = DSQRT(1.D0 + (8.D0 * TN))

        IF ((SQRT_TERM - REAL(FLOOR(SQRT_TERM, 8), 8)) > TOLERANCE) CYCLE

        IF (MOD(FLOOR(SQRT_TERM, 8) + 1.0D0, 4.0D0) <= TOLERANCE) EXIT

    END DO

    PRINT ('(I0)'), FLOOR(TN, 8)

END PROGRAM F045


Module vec3_utilities_module

  Use, Intrinsic :: iso_fortran_env, Only :  wp => real64

  Implicit None

  Interface Operator( .vec. )
     Module Procedure cross
  End Interface Operator( .vec. )

  Public :: Operator( .vec. )
  Public :: vec3_invert

  Private

Contains

  Pure Function cross( a, b )

    ! perform a vector product

    Real( wp ), Dimension( 1:3 ) :: cross

    Real( wp ), Dimension( 1:3 ), Intent( In ) :: a
    Real( wp ), Dimension( 1:3 ), Intent( In ) :: b

    cross( 1 ) =   ( a( 2 ) * b( 3 ) - a( 3 ) * b( 2 ) )
    cross( 2 ) = - ( a( 1 ) * b( 3 ) - a( 3 ) * b( 1 ) )
    cross( 3 ) =   ( a( 1 ) * b( 2 ) - a( 2 ) * b( 1 ) )

  End Function cross

  Pure Subroutine vec3_invert( A, B )

    Real( wp ), Dimension( 1:3, 1:3 ), Intent( In    ) :: A
    Real( wp ), Dimension( 1:3, 1:3 ), Intent(   Out ) :: B

    Real( wp ) :: V

    V = Dot_product( A( :, 1 ), A( :, 2 ) .vec. A( :, 3 ) )

    B( 1, : ) = A( :, 2 ) .vec. A( :, 3 )
    B( 2, : ) = A( :, 3 ) .vec. A( :, 1 )
    B( 3, : ) = A( :, 1 ) .vec. A( :, 2 )

    B = B / V

  End Subroutine vec3_invert

End Module vec3_utilities_module


      FUNCTION SEVAL(N, U, X, Y, B, C, D)                               ABSH0941
C***********************************************************************ABSH0942
C*****SEVAL EVALUATES THE CUBIC SPLINE FUNCTI0N.                       *ABSH0943
C*****REFERENCES:                                                      *ABSH0944
C*****G.E.FORSYTHE,M.A.MALCOLM,C.B.MOLER, COMPUTER METHODS FOR MATHE-  *ABSH0945
C***** MATICAL COMPUTATIONS, PRENTICE-HALL, 1977, P.76.                *ABSH0946
C*****LAST REVISION: 6/81 R.M.WIELAND AND W.A.HOULBERG ORNL.           *ABSH0947
C*****INPUT PARAMETERS:                                                *ABSH0948
C*****N-NUMBER OF DATA POINTS.                                         *ABSH0949
C*****U-ABSCISSA AT WHICH THE SPLINE IS TO BE EVALUATED.               *ABSH0950
C*****X-ARRAY CONTAINING THE DATA ABCISSAS.                            *ABSH0951
C*****Y-ARRAY CONTAINING THE DATA ORDINATES.                           *ABSH0952
C*****B,C,D-ARRAYS OF SPLINE COEFFICIENTS COMPUTED BY SPLINE.          *ABSH0953
C*****OTHER COMMENTS:                                                  *ABSH0954
C*****SEVAL=Y(I)+B(I)*(U-X(I))+C(I)*(U-X(I))**2+D(I)*(U-X(I))**3       *ABSH0955
C*****WHERE X(I).LT.U.LT.X(I+1), USING HORNER'S RULE.                  *ABSH0956
C*****IF U.LT.X(1) THEN I=1 IS USED.                                   *ABSH0957
C*****IF U.GE.X(N) THEN I=N IS USED.                                   *ABSH0958
C*****IF U IS NOT IN THE SAME INTERVAL AS THE PREVIOUS CALL, THEN A    *ABSH0959
C*****BINARY SEARCH IS PERFORMED TO DETERMINE THE PROPER INTERVAL.     *ABSH0960
C***********************************************************************ABSH0961
      DIMENSION X(N), Y(N), B(N), C(N), D(N)                            ABSH0962
      DATA I /1/                                                        ABSH0963
      IF (I.GE.N) I = 1                                                 ABSH0964
      IF (U.LT.X(I)) GO TO 10                                           ABSH0965
      IF (U.LE.X(I+1)) GO TO 30                                         ABSH0966
C*****BINARY SEARCH.                                                    ABSH0967
   10 I = 1                                                             ABSH0968
      J = N + 1                                                         ABSH0969
   20 K = (I+J)/2                                                       ABSH0970
      IF (U.LT.X(K)) J = K                                              ABSH0971
      IF (U.GE.X(K)) I = K                                              ABSH0972
      IF (J.GT.I+1) GO TO 20                                            ABSH0973
C*****EVALUATE SPLINE.                                                  ABSH0974
   30 DX = U - X(I)                                                     ABSH0975
      SEVAL = Y(I) + DX*(B(I)+DX*(C(I)+DX*D(I)))                        ABSH0976
      RETURN                                                            ABSH0977
      END                                                               ABSH0978


      DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
C**********************************************************************
C
C      Modified Bessel Function K0
C
C**********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION PHO_BESSI0 , X , y
      SAVE

      IF ( X.LT.2.D0 ) THEN
         y = X**2/4.D0
         PHO_BESSK0 = (-LOG(X/2.D0)*PHO_BESSI0(X))
     &                + (-.57721566D0+y*(0.42278420D0+
     &                y*(0.23069756D0+y*(0.3488590D-1+
     &                y*(0.262698D-2+y*(0.10750D-3+y*0.740D-5))))))
      ELSE
         y = 2.D0/X
         PHO_BESSK0 = (EXP(-X)/SQRT(X))
     &                *(1.25331414D0+y*(-0.7832358D-1+y*
     &                (0.2189568D-1+y*(-0.1062446D-1+
     &                y*(0.587872D-2+y*(-0.251540D-2+y*0.53208D-3))))))
      END IF

      END FUNCTION


program test_integer
    use, intrinsic :: iso_fortran_env
    use :: test_check
    implicit none

    call test_numeric_integer()

contains
    subroutine test_numeric_integer()
        use :: numeric_integer
        implicit none

        print *, "numeric integer test start"

        block
            ! int8
            call check(Int8_Max == int(+127_int8, kind=int8), &
                       "int8 maximun test")

            call check(Int8_Min == int(-127_int8 - 1, kind=int8), &
                       "int8 minimum test")

            ! int16
            call check(Int16_Max == int(+32767_int16, kind=int16), &
                       "int16 maximun test")

            call check(Int16_Min == int(-32767_int16 - 1, kind=int16), &
                       "int16 minimum test")

            ! int32
            call check(Int32_Max == int(+2147483647_int32, kind=int32), &
                       "int32 maximun test")

            ! int64
            call check(Int32_Min == int(-2147483647_int32 - 1, kind=int32), &
                       "int32 minimum test")

            call check(Int64_Max == int(+9223372036854775807_int64, kind=int64), &
                       "int64 maximun test")

            call check(Int64_Min == int(-9223372036854775807_int64 - 1, kind=int64), &
                       "int64 minimum test")
        end block

        block
            call check(is_positive(1_int8), "int8 1 is positive test")
            call check(is_positive(Int8_Max), "int8 maximum is positive test")
            call check(is_positive(0_int8), "int8 0 is positive test")
            call check(.not. is_positive(-1_int8), "int8 -1 is not positive test")
            call check(.not. is_positive(Int8_Min), "int8 minimum is not positive test")

            call check(is_positive(1_int16), "int16 1 is positive test")
            call check(is_positive(Int16_Max), "int16 maximum is positive test")
            call check(is_positive(0_int16), "int16 0 is positive test")
            call check(.not. is_positive(-1_int16), "int16 -1 is not positive test")
            call check(.not. is_positive(Int16_Min), "int16 minimum is not positive test")

            call check(is_positive(1_int32), "int32 1 is positive test")
            call check(is_positive(Int32_Max), "int32 maximum is positive test")
            call check(is_positive(0_int32), "int32 0 is positive test")
            call check(.not. is_positive(-1_int32), "int32 -1 is not positive test")
            call check(.not. is_positive(Int32_Min), "int32 minimum is not positive test")

            call check(is_positive(1_int64), "int64 1 is positive test")
            call check(is_positive(Int64_Max), "int64 maximum is positive test")
            call check(is_positive(0_int64), "int64 0 is positive test")
            call check(.not. is_positive(-1_int64), "int64 -1 is not positive test")
            call check(.not. is_positive(Int64_Min), "int64 minimum is not positive test")
        end block

        block
            call check(.not. is_negative(1_int8), "int8 1 is not negative test")
            call check(.not. is_negative(Int8_Max), "int8 maximum is not negative test")
            call check(.not. is_negative(0_int8), "int8 0 is not negative test")
            call check(is_negative(-1_int8), "int8 -1 is negative test")
            call check(is_negative(Int8_Min), "int8 minimum is negative test")

            call check(.not. is_negative(1_int16), "int16 1 is not negative test")
            call check(.not. is_negative(Int16_Max), "int16 maximum is not negative test")
            call check(.not. is_negative(0_int16), "int16 0 is not negative test")
            call check(is_negative(-1_int16), "int16 -1 is negative test")
            call check(is_negative(Int16_Min), "int16 minimum is negative test")

            call check(.not. is_negative(1_int32), "int32 1 is not negative test")
            call check(.not. is_negative(Int32_Max), "int32 maximum is not negative test")
            call check(.not. is_negative(0_int32), "int32 0 is not negative test")
            call check(is_negative(-1_int32), "int32 -1 is negative test")
            call check(is_negative(Int32_Min), "int32 minimum is negative test")

            call check(.not. is_negative(1_int64), "int64 1 is not negative test")
            call check(.not. is_negative(Int64_Max), "int64 maximum is not negative test")
            call check(.not. is_negative(0_int64), "int64 0 is not negative test")
            call check(is_negative(-1_int64), "int64 -1 is negative test")
            call check(is_negative(Int64_Min), "int64 minimum is negative test")

        end block

        block
            call check(to_string(huge(0)) == "2147483647", "to_string() integer test")
            call check(to_string(huge(0)/100, '(i10.10)') == "0021474836", "to_string() integer with format test")
            call check(to_string(-huge(0) - 1) == "-2147483648", "to_string() integer value test")
            call check(to_string(100, 5) == "  100", "to_string() integer digit specification test")
            call check(to_string(100, 2) == "**", "to_string() integer invalid digit specification test")
            call check(to_string(100, digit=5, zerofill=6) == "00100", &
                       "to_string() integer digit specification zero filling out of range test")
            call check(to_string(-100, digit=5, zerofill=4) == " -0100", &
                       "to_string() integer value digit specification zero filling test")
            call check(to_string(-100, digit=5, zerofill=5) == "-00100", &
                       "to_string() integer value digit specification zero filling test")
        end block

        print *, "numeric integer test end"
    end subroutine test_numeric_integer
end program test_integer


subroutine imc_tally()

    use imc_global_mat_data,  only: bee
    use imc_global_mesh_data, only: ncells, dx, temp, fleck, sigma_p, nrgdep
    use imc_global_phys_data, only: c, a
    use imc_global_time_data, only: step, dt

    implicit none

    real(kind=8), dimension(ncells) :: radnrgdens
    real(kind=8), dimension(ncells) :: nrg_inc

    write(*,'(/,A)')    '-------------------------------------------------------------------------------'
    write(*,'(A,I4,A)') 'Tally step (',step,')'
    write(*,'(A)')      '-------------------------------------------------------------------------------'

    ! Start-of-step radiation energy density
    radnrgdens(:) = a * temp(:)**4

    ! Temperature increase
    nrg_inc(:)  = ( &
        nrgdep(:) / dx &
        - fleck(:) * c * dt * sigma_p(:) * radnrgdens(:) &
    )

    temp(:) = temp(:) + nrg_inc(:) / bee

    write(*,'(/,A)') 'Mesh temperature:'
    write(*,'(4(ES16.8))') temp

end subroutine imc_tally


      SUBROUTINE INTEGRAL_TRAPEZOID(IVSIZ, XVEC, YVEC, FROM, TO, RESULT)
        IMPLICIT INTEGER*4 (I-N), DOUBLE PRECISION (A-H, O-Z)
        DIMENSION XVEC(IVSIZ), YVEC(IVSIZ)

        RESULT = 0
        DO 20 I = 1, IVSIZ-1
          X0 = XVEC(I)
          X1 = XVEC(I + 1)

          IF (X0.LT.FROM .OR. X1.GT.TO) GOTO 20

          Y0 = YVEC(I)
          Y1 = YVEC(I + 1)

          RESULT = RESULT + ((X1 - X0) * ((Y0 + Y1) / 2.0))
   20   CONTINUE

C       PRINT *, RESULT
      END SUBROUTINE INTEGRAL_TRAPEZOID

      FUNCTION INTERP(X, N, XV, YV)
        IMPLICIT INTEGER*4 (I-N), DOUBLE PRECISION (A-H, O-Z)
        DOUBLE PRECISION INTERP
        DIMENSION XV(N), YV(N)

        INTERP = 0

        DO 40 I = 1, N

          PROD = 1
          DO 30 J = 1, N
            IF (I.EQ.J) GOTO 30
            PROD = PROD * (X - XV(J)) / (XV(I) - XV(J))
30        CONTINUE

        INTERP = INTERP + YV(I) * PROD

40      CONTINUE

      END FUNCTION


PROGRAM F018

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, DIMENSION(15, 15) :: TRIANGLE =                                   &
    RESHAPE ((/                                                                &
        75,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,            &
        95, 64,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,            &
        17, 47, 82,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,            &
        18, 35, 87, 10,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,            &
        20,  4, 82, 47, 65,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,            &
        19,  1, 23, 75,  3, 34,  0,  0,  0,  0,  0,  0,  0,  0,  0,            &
        88,  2, 77, 73,  7, 63, 67,  0,  0,  0,  0,  0,  0,  0,  0,            &
        99, 65,  4, 28,  6, 16, 70, 92,  0,  0,  0,  0,  0,  0,  0,            &
        41, 41, 26, 56, 83, 40, 80, 70, 33,  0,  0,  0,  0,  0,  0,            &
        41, 48, 72, 33, 47, 32, 37, 16, 94, 29,  0,  0,  0,  0,  0,            &
        53, 71, 44, 65, 25, 43, 91, 52, 97, 51, 14,  0,  0,  0,  0,            &
        70, 11, 33, 28, 77, 73, 17, 78, 39, 68, 17, 57,  0,  0,  0,            &
        91, 71, 52, 38, 17, 14, 91, 43, 58, 50, 27, 29, 48,  0,  0,            &
        63, 66,  4, 68, 89, 53, 67, 30, 73, 16, 69, 87, 40, 31,  0,            &
         4, 62, 98, 27, 23,  9, 70, 98, 73, 93, 38, 53, 60,  4, 23             &
    /), (/ 15, 15 /), ORDER=(/ 2, 1 /))

    INTEGER :: I, J

    DO I = 14, 1, -1

        DO J = 1, I

            IF (TRIANGLE(I+1, J) >= TRIANGLE(I+1, J+1)) THEN
                TRIANGLE(I, J) = TRIANGLE(I, J) + TRIANGLE(I+1, J)
            ELSE
                TRIANGLE(I, J) = TRIANGLE(I, J) + TRIANGLE(I+1, J+1)
            END IF

        END DO

    END DO

    PRINT ('(I0)'), TRIANGLE(1, 1)

END PROGRAM F018


! Created by mus on 29/07/2021.

subroutine shapefunc(N,h,ne,Cij,xg)
    implicit none
    real (kind=8), intent(in)    :: h
    integer, intent(in)          :: N, ne, Cij(N+1,ne)
    real (kind=8), intent(out)   :: xg(ne*N+1)
    integer                      :: i, j
    real (kind=8)                :: xi(N+1), wi(N+1)

    call zwgljd(xi,wi,N+1,0.,0.)

    do i=1,ne
        do j=1,N+1
            xg(Cij(j,i)) = h*(i-1) +  h * ((xi(j) + 1) / 2)
        end do
    end do

end subroutine shapefunc


!******************************************************************************
!*
!*                    FUNCTIONS FOR NUMERICAL INTERPOLATION
!*
!******************************************************************************

  !==========================================================================
  ! 1) AUTHOR: F. Galliano
  !
  ! 2) HISTORY:
  !    - Created 08/2007
  !    - Add interp_lin_sorted on 12/2012
  !    - Correct the starting indices of LOCATE_SORTED: jl=0->1, ju=N+1->N
  !      (02/2014).
  !    - Allow zero values in the log case.
  !
  ! 3) DESCRIPTION: Set of functions performing numerical integration using
  !                 various methods.
  !==========================================================================

MODULE interpolation

  USE utilities, ONLY:
  USE arrays, ONLY:
  USE linear_system, ONLY:
  IMPLICIT NONE
  PRIVATE

  PUBLIC :: interp_poly, interp_spline, interp_lin_sorted, locate_sorted

  INTERFACE interp_poly
    MODULE PROCEDURE interp_poly_v, interp_poly_s
  END INTERFACE interp_poly

  INTERFACE interp_lin_sorted
    MODULE PROCEDURE interp_lin_sorted_v, interp_lin_sorted_s
  END INTERFACE interp_lin_sorted

CONTAINS

  !==========================================================================
  ! index = LOCATE_SORTED(xx[N],x)
  !
  !   Finds the index position of the x value in the xx array, by bisection,
  ! provided that the array has been previously sorted.
  !==========================================================================

  PURE FUNCTION locate_sorted (xx,x)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: xx
    REAL(DP), INTENT(IN) :: x
    INTEGER :: locate_sorted

    INTEGER :: N, jl, jm, ju
    LOGICAL :: ascnd

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

    N = SIZE(xx)
    ascnd = (xx(N) >= xx(1))
    jl = 1
    ju = N
    midpoint: DO
      IF (ju-jl <= 1) EXIT
      jm = (ju+jl)/2
      IF (ascnd .EQV. (x >= xx(jm))) THEN ; jl = jm
                                     ELSE ; ju = jm ; END IF
    END DO midpoint
    output: IF (x == xx(1)) THEN
      locate_sorted = 1
    ELSE IF (x == xx(N)) THEN
      locate_sorted = N-1
    ELSE
      locate_sorted = jl
    END IF output

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

  END FUNCTION locate_sorted

  !==========================================================================
  ! y_new[M] = INTERP_POLY(y_old[N],x_old[N],x_new[M],dy_new[M],DEGREE,XYLOG)
  !
  !   Evaluates the tabulated function (x_old,y_old) into the new array x_new
  ! and returns its values into y_new and error into err_y, using the
  ! Neville's algorithm.
  !==========================================================================

  FUNCTION interp_poly_v (y_old,x_old,x_new,err_new,degree,xlog,ylog)

    USE utilities, ONLY: DP, strike, flEQ
    USE arrays, ONLY: closest
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: y_old, x_old
    REAL(DP), INTENT(IN), DIMENSION(:) :: x_new
    REAL(DP), INTENT(OUT), DIMENSION(SIZE(x_new)), OPTIONAL :: err_new
    INTEGER, INTENT(IN), OPTIONAL :: degree
    LOGICAL, INTENT(IN), OPTIONAL :: xlog, ylog
    REAL(DP), DIMENSION(SIZE(x_new)) :: interp_poly_v

    INTEGER :: i, i_new, m, Npoly, N, Na, jl
    INTEGER, DIMENSION(SIZE(x_new)) :: khi, klo
    REAL(DP), DIMENSION(SIZE(x_old)) :: xa, ya
    REAL(DP), DIMENSION(:), ALLOCATABLE :: C, D, A, dx
    REAL(DP), DIMENSION(SIZE(x_new)) :: x, y_new, dy_new
    LOGICAL :: xlog_flag, ylog_flag

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

    ! Check input
    !------------
    ! Sizes
    N = SIZE(x_new)
    Na = SIZE(x_old)
    IF (SIZE(y_old) /= Na) CALL STRIKE("INTERP_POLY","bad input.")
    IF (PRESENT(err_new)) dy_new = err_new

    ! Degree of the polynomial, default N=3
    IF (PRESENT(degree)) THEN ; Npoly = degree+1 ; ELSE ; Npoly = 3 ; END IF
    IF (Na < Npoly) CALL STRIKE("INTERP_POLY","there is not enough points.")
    ALLOCATE(C(Npoly),D(Npoly),A(Npoly),dx(Npoly))

    ! Type of axes
    IF (PRESENT(xlog)) THEN ; xlog_flag = xlog
                       ELSE ; xlog_flag = .False. ; END IF
    IF (PRESENT(ylog)) THEN ; ylog_flag = ylog
                       ELSE ; ylog_flag = .False. ; END IF
    IF (xlog_flag .AND. (ANY(x_new <= 0.0) .OR. ANY(x_old <= 0.0))) &
      CALL STRIKE("INTERP_POLY","XLOG incompatible with X<=0.")
    IF (ylog_flag .AND. ANY(y_old <= 0.0)) &
      CALL STRIKE("INTERP_POLY","YLOG incompatible with Y<=0.")
    x = MERGE(LOG(x_new),x_new,xlog_flag)
    xa = MERGE(LOG(x_old),x_old,xlog_flag)
    ya = MERGE(LOG(y_old),y_old,ylog_flag)

    ! Interpolation grid
    !-------------------
    ! Locate the adjacent elements and reduce the search zone at each step,
    ! since the x array is sorted.
    DO i=1,N
      jl = MERGE(klo(i-1),1,i > 1)
      klo(i) = MAX(MIN(LOCATE_SORTED(xa(jl:Na),x(i))+jl-1,Na-1),1)
    END DO

    ! Distribute the points as evenly as possible around the value to be
    ! interpolated.
    klo(:) = klo(:) - (Npoly-1)/2
    khi(:) = klo(:) + (Npoly-1)
    ! Shift the values that are out of range, back inside the grid.
    edges: WHERE (klo <= 0)
      khi = khi - klo + 1
      klo = 1
    ELSEWHERE (khi > Na)
      klo = klo - (khi-Na)
      khi = Na
    END WHERE edges

    ! Polynomial interpolation
    !-------------------------
    bigloopx: DO i=1,N

      ! Degree 0
      C = ya(klo(i):khi(i))
      D = ya(klo(i):khi(i))
      dx = xa(klo(i):khi(i)) - x(i)
      i_new = CLOSEST(xa(klo(i):khi(i)),x(i))
      y_new(i) = ya(klo(i)+i_new-1)
      i_new = i_new-1

      ! Build the higher orders
      recursiv: DO m=1,Npoly-1
        A(1:Npoly-m) = dx(1:Npoly-m) - dx(1+m:Npoly)
        IF (ANY(A(1:Npoly-m) == 0._DP)) &
          CALL STRIKE("INTERP_POLY","negative denominator.")
        A(1:Npoly-m) = (C(2:Npoly-m+1)-D(1:Npoly-m)) / A(1:Npoly-m)
        D(1:Npoly-m) = dx(1+m:Npoly) * A(1:Npoly-m)
        C(1:Npoly-m) = dx(1:Npoly-m) * A(1:Npoly-m)
        middle: IF (2*i_new < Npoly-m) THEN
          dy_new(i) = C(i_new+1)
        ELSE
          dy_new(i) = D(i_new)
          i_new = i_new-1
        END IF middle
        y_new(i) = y_new(i) + dy_new(i)
      END DO recursiv

    END DO bigloopx

    ! Final unlogging
    interp_poly_v = MERGE(EXP(y_new),y_new,ylog_flag)
    IF (PRESENT(err_new)) err_new = dy_new
    DEALLOCATE (C,D,A,dx)

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

  END FUNCTION interp_poly_v

  !==========================================================================
  ! Same function when x_new is a scalar.
  !==========================================================================

  FUNCTION interp_poly_s (y_old,x_old,x_new,err_new,degree,xlog,ylog)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: y_old, x_old
    REAL(DP), INTENT(IN) :: x_new
    REAL(DP), INTENT(OUT), OPTIONAL :: err_new
    INTEGER, INTENT(IN), OPTIONAL :: degree
    LOGICAL, INTENT(IN), OPTIONAL :: xlog, ylog
    REAL(DP) :: interp_poly_s

    INTEGER :: Npoly
    REAL(DP), DIMENSION(1) :: polint, err
    LOGICAL :: xlog_flag, ylog_flag

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

    IF (PRESENT(degree)) THEN ; Npoly = degree+1 ; ELSE ; Npoly = 3 ; END IF

    IF (PRESENT(xlog)) THEN ; xlog_flag = xlog
                       ELSE ; xlog_flag = .False. ; END IF
    IF (PRESENT(ylog)) THEN ; ylog_flag = ylog
                       ELSE ; ylog_flag = .False. ; END IF

    polint = INTERP_POLY_V(y_old,x_old,(/x_new/),err,Npoly,xlog_flag,ylog_flag)
    IF (PRESENT(err_new)) err_new = err(1)
    interp_poly_s = polint(1)

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

  END FUNCTION interp_poly_s

  !==========================================================================
  ! y_new[N] = SPLINE(y_old[N],x_old[N],yp1,ypn)
  !
  !   Returns the array that contains the second derivatives of the
  ! interpolating function at the tabulated points x_old.
  !==========================================================================

  FUNCTION spline (x,y,yp1,ypn)

    USE utilities, ONLY: DP, strike
    USE linear_system, ONLY: tridag
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: x, y
    REAL(DP), INTENT(IN) :: yp1, ypn
    REAL(DP), DIMENSION(SIZE(x)) :: spline

    INTEGER :: N
    REAL(DP), DIMENSION(SIZE(x)) :: a, b, c, r

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

    ! Check input
    N = SIZE(x)
    IF (SIZE(y) /= N) CALL STRIKE("SPLINE","bad input.")

    ! Set up the tridiagonal equations
    c(1:n-1) = x(2:n) - x(1:n-1)
    r(1:n-1) = 6.0_DP*((y(2:n)-y(1:n-1)) / c(1:n-1))
    r(2:n-1) = r(2:n-1) - r(1:n-2)
    a(2:n-1) = c(1:n-2)
    b(2:n-1) = 2.0_DP*(c(2:n-1)+a(2:n-1))
    b(1) = 1.0
    b(n) = 1.0
    lowbound: IF (yp1 > 0.99E30_DP) THEN
      r(1) = 0.0
      c(1) = 0.0
    ELSE
      r(1) = (3.0_DP/(x(2)-x(1))) * ((y(2)-y(1))/(x(2)-x(1)) - yp1)
      c(1) = 0.5
    END IF lowbound
    upbound: IF (ypn > 0.99E30_DP) THEN
      r(n) = 0.0
      a(n) = 0.0
    ELSE
      r(n) = (-3.0_DP/(x(n)-x(n-1))) * ((y(n)-y(n-1))/(x(n)-x(n-1)) - ypn)
      a(n) = 0.5
    END IF upbound

    ! Solve the system
    spline(1:N) = TRIDAG(a(2:n),b(1:n),c(1:n-1),r(1:n))

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

  END FUNCTION spline

  !==========================================================================
  ! y_new[M] = INTERP_SPLINE(y_old[N],x_old[N],x_new[M],XLOG=T/F,YLOG=T/F)
  !
  !   Evaluates the tabulated function (x_old,y_old) into the new array x_new
  ! and returns its values into y_new, using cubic spline interpolation.
  ! x_new must be sorted and in ascending order.
  !==========================================================================

  FUNCTION interp_spline (y_old,x_old,x_new,xlog,ylog)

    USE utilities, ONLY: DP, strike, flEQ
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: x_old, y_old
    REAL(DP), DIMENSION(:), INTENT(IN) :: x_new
    LOGICAL, INTENT(IN), OPTIONAL :: xlog, ylog
    REAL(DP), DIMENSION(SIZE(x_new)) :: interp_spline

    INTEGER, DIMENSION(SIZE(x_new)) :: khi, klo
    INTEGER :: Na, N, i, jl
    REAL(DP), DIMENSION(SIZE(x_old)) :: y2a, xa, ya
    REAL(DP), DIMENSION(SIZE(x_new)) :: h, a ,b, x
    LOGICAL :: xlog_flag, ylog_flag

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

    ! Check input
    !------------
    ! Sizes
    N = SIZE(x_new)
    Na = SIZE(x_old)
    IF (SIZE(y_old) /= Na) CALL STRIKE("INTERP_SPLINE","bad input.")

    ! Type of axes
    IF (PRESENT(xlog)) THEN
      xlog_flag = xlog
    ELSE
      xlog_flag = .False.
    END IF
    IF (PRESENT(ylog)) THEN
      ylog_flag = ylog
    ELSE
      ylog_flag = .False.
    END IF
    IF (xlog_flag .AND. (ANY(x_new <= 0.0) .OR. ANY(x_old <= 0.0))) &
      CALL STRIKE("INTERP_SPLINE","XLOG incompatible with X<=0.")
    IF (ylog_flag .AND. ANY(y_old <= 0.0)) &
      CALL STRIKE("INTERP_SPLINE","YLOG incompatible with Y<=0.")
    x = MERGE(LOG(x_new),x_new,xlog_flag)
    xa = MERGE(LOG(x_old),x_old,xlog_flag)
    ya = MERGE(LOG(y_old),y_old,ylog_flag)

    ! Interpolation grid
    !-------------------
    ! Locate the adjacent elements and reduce the search zone at each step,
    ! since the x array is sorted.
    DO i=1,N
      jl = MERGE(klo(i-1),1,i > 1)
      klo(i) = MAX(MIN(LOCATE_SORTED(xa(jl:Na),x(i))+jl-1,Na-1),1)
    END DO
    khi(:) = klo(:)+1

    ! Compute the spline
    !-------------------
    ! Finite difference
    h(:) = xa(khi(:))-xa(klo(:))
    IF (ANY(h == 0.0)) CALL STRIKE("INTERP_SPLINE","bad xa input")

    ! Spline calculation
    y2a(:) = SPLINE(xa,ya,1.E30_DP,1.E30_DP)
    a(:) = (xa(khi(:))-x(:)) / h(:)
    b(:) = (x(:)-xa(klo(:))) / h(:)
    interp_spline(:) = a(:)*ya(klo(:)) + b(:)*ya(khi(:)) &
                    + ( (a(:)**3-a(:))*y2a(klo(:)) &
                        + (b(:)**3-b(:))*y2a(khi(:)) )*h(:)**2 / 6.0_DP

    ! Final unlogging
    IF (ylog_flag) interp_spline(:) = EXP(interp_spline(:))

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

  END FUNCTION interp_spline

  !==========================================================================
  ! y_new[M] = INTERP_LIN_SORTED(y_old[N],x_old[N],x_new[M],XLOG=T/F,YLOG=T/F,
  !                              FORCE=T/F)
  !
  !   Performs fast log or linear interpolation on a previously sorted array.
  ! If log is used, the corresponding array must be positive. No control is
  ! done. FORCE forces to zero the values that are NaN (usually LOG(0)).
  !==========================================================================

  PURE FUNCTION interp_lin_sorted_v (y_old,x_old,x_new,xlog,ylog,force)

    USE utilities, ONLY: DP, isNaN
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: x_old, y_old
    REAL(DP), DIMENSION(:), INTENT(IN) :: x_new
    LOGICAL, INTENT(IN), OPTIONAL :: xlog, ylog, force
    REAL(DP), DIMENSION(SIZE(x_new)) :: interp_lin_sorted_v

    LOGICAL :: xl, yl, forced
    INTEGER :: i, Nnew, Nold
    INTEGER, DIMENSION(SIZE(x_new)) :: ju, jl
    REAL(DP), DIMENSION(SIZE(x_new)) :: x1
    REAL(DP), DIMENSION(SIZE(x_old)) :: x0, y0

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

    ! Preamble
    Nnew = SIZE(x_new)
    Nold = SIZE(x_old)
    xl = .False.
    yl = .False.
    IF (PRESENT(xlog)) xl = xlog
    IF (PRESENT(ylog)) yl = ylog
    x0(:) = MERGE(LOG(x_old),x_old,xl)
    x1(:) = MERGE(LOG(x_new),x_new,xl)
    y0(:) = MERGE(LOG(y_old),y_old,yl)

    ! Find the right points to compute the slope
    FORALL (i=1:Nnew) jl(i) = LOCATE_SORTED(x0,x1(i))
    ju(:) = jl(:) + 1

    ! Interpolate
    interp_lin_sorted_v(:) = (y0(ju(:))-y0(jl(:)))/(x0(ju(:))-x0(jl(:))) &
                             * (x1(:)-x0(jl(:))) + y0(jl(:))

    ! Finalize
    interp_lin_sorted_v(:) = MERGE( EXP(interp_lin_sorted_v(:)), &
                                    interp_lin_sorted_v(:), yl )

    ! Deal with the potential zero/negative values if FORCE
    forced = .False.
    IF (PRESENT(force)) forced = force
    IF (forced .AND. xl) THEN
      WHERE (ISNAN(interp_lin_sorted_v(:))) interp_lin_sorted_v(:) = 0._DP
    END IF

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

  END FUNCTION interp_lin_sorted_v

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

  PURE FUNCTION interp_lin_sorted_s (y_old,x_old,x_new,xlog,ylog,force)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: x_old, y_old
    REAL(DP), INTENT(IN) :: x_new
    LOGICAL, INTENT(IN), OPTIONAL :: xlog, ylog, force
    REAL(DP) :: interp_lin_sorted_s
    LOGICAL :: xl, yl, forced

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

    xl = .False.
    yl = .False.
    forced = .False.
    IF (PRESENT(xlog)) xl = xlog
    IF (PRESENT(ylog)) yl = ylog
    IF (PRESENT(force)) forced = force
    interp_lin_sorted_s = MINVAL(INTERP_LIN_SORTED_V(y_old,x_old,[x_new],xl,yl, &
                                                     forced))

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

  END FUNCTION interp_lin_sorted_s

END MODULE interpolation


!Find the midpoint of (2,4) & (4,-10)
program Midpoint
    implicit none

    !Variable Declaration
    real :: a,b,c,d

    !Reading Date
    WRITE(*,*)"Enter the coordinate of A?"
    READ(*,*) a,b

    WRITE(*,*)"Enter the coordinate of B?"
    READ(*,*) c,d

    !Printing using Format
    print'("The midpoint of A and B is (",f5.2,",",f5.2,")")',(a+c)/2,(b+d)/2.0

end program Midpoint


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
C
C  1. TASK         INTERPOLATION OF A FUNCTION DEFINED POINT BY POINT
C  *********       THE X COORDINATES ARE USER SPECIFIED.
C                  THE INTERPOLATION PROCESS CAN BE EITHER CONSTANT,LINEAR
c                  OR EVEN dOUBLE QUADRATIC WITH EXTRAPOLATION USING THE
c                  POLYNOM HIGHEST ORDER
C                  thE DOUBLE QUADRATIC INTERPOLATION IS A 3RD ORDER METHOD
c                  BY WHICH 2 PARABOLS ENCOMPASSING EACH 3 AND 4 sAMPLING POINTS
c                  ARE DEFINED.
c                  THE SOLUTION IS A LINEAR COMBINATION OF THE CONCERNED
c                  PARABOLS VALUES DEPENDING ON THE DEFINITION OF THE ACTUAL
c                  SAMPLING POINT INTERVAL
C
C
C  2.INPUT     CALL ONEDINT(XE,YE,NE,XA,YA,NA,IART,IEXP,IER)
C  ***********                XE = ABSCISSE VECTOR OF THE SAMPLING POINTS
C                             YE = ORDINATE VECTOR OF THE SAMPLING POINTS
C                             NE = LENGHT OF THE SAMPLING POINT VECTOR
C                             XA = ASCISSE VECTOR OF THE INTERPOLATION POINT(INPUT)
C                             YA = ORDINATE VECTOR OF THE INTERPOLATION POINT(OUTPUT)
C                             NA = LENGTH OF THE INTERPOLATION VECTOR                         c                             IART = tYPE OF INTERPOLATION
C                                    =0: CONSTANT
C                                    =1: LINEAR
C                                    =2: DOUBLE QUADRATIC
C                             IEXP = TYPE OF EXTRAPOLATION
C                                    IEXP = 10*IEX1 + IEXN
C                                    IEX1 EXTRAPOLATIONS BEYOND THE
C                                         1. SAMPLING POINT IN THE VECTOR
C                                    IEXN EXTRAPOLATION BEYOND THE
C                                         LAST SAMPLING POINT IN THE VECTOR
C                                    SELECTION OF THE EXTRAPOLATION TYPE AS
C                                    FOR IART.
C                             IER  = ERROR CODE
C                                    = 0: NORMAL PROCEEDING
C                                    =-1:PROBLEM IN TH EGIVEN VALUES
C                                         PROGRAMM STOPS.
C
C  3.RESTRICTION    ABSCISSE VECTOR XE MUST BE STRICTLY MONOTONIC INCREASING SORTED
C  ***************  AUTOMATIC CONTROL INSIDE TEH SUBROUTINE:
C                   NE = 0: ERROR INTERRUPTION
C                   NE = 1: ONLY CONSTANT INTER- EXTRAPOLATION
C                   NE = 2: MAXIMAL LINEAR INTER- EXTRAPOLATION
C                   NE = 3: MAXIMAL QUADRATIC INTER- EXTRAPOLATIO
C                   THE PARAMETER FOR THE TYPE OF EXTRAPOLATION
c                   MUST NOT BE GREATER THAN THE ONE FOR TH EINTERPOLATION TYPE
C                   OTHERWISE THE  VALUE IS AUTOMATICALLY ADAPTATED
C
      SUBROUTINE ONEDINT(XE,YE,NE,XA,YA,NA,IART,IEXP,IER)
      implicit none
      INTEGER NE,NA,NA1,NE1,IG,IER,IA,IART,IE2,I,IEXP,IE1,L
      REAL*8 XE(NE),YE(NE),XA(NA),YA(NA),ZW1,ZW2,XO,YO,RAB,XD,YD,
     &  XZ,YZ,XU,YU,EQ,EQD,X
C
C INTERPOLATION FUNCTION
C ------------------------
      EQ(X) = YU + YU * (X-XU) / XU +
     1        ((YZ-YU)/(XZ-XU) - YU/XU) * (X-XU) * X / XZ
      EQD(X) = YZ * X / XZ +
     1        (YD / XD - YZ / XZ) * X * (X - XZ) / (XD - XZ)
C
C INPUT/DATA TEST,INTERPOLATION DIVERGENCE,EXTRAPOLATION LIMIT
C----------------------------------------------------------------
      NA1 = NA - 1
      IF (NA .LE. 0) GO TO 900
      NE1 = NE - 1
      IF (NE1.lt.0) then
         go to 900
      elseif(ne1.eq.0) then
         go to 22
      else
         go to 18
      endif
   18 DO 20 L = 1,NE1
   20 IF ((XE(L+1)-XE(L)) .LE. 0) GO TO 900
   22 IE1 = IEXP / 10
      IE2 = IEXP - 10*IE1
      IA = IART
      IF (NE1 .LT. IA)   IA = NE1
      IF (IA .LT. IE1)   IE1 = IA
      IF (IA .LT. IE2)   IE2 = IA
C
C SUCCESSIVE PROCESSING THE INTERPOLATION EXIGENCES
C-------------------------------------------------------
C
C     ZUR ERHOEHUNG DER NUMERISCHEN GENAUIGKEIT WIRD EINE
C     TRANSLATION VON (XO,YO) IN (0,0) DURCHGEFUEHRT. DIES
C     BEWIRKT AUSSERDEM  EINE BESCHLEUNIGUNG DES VERFAHRENS.
C
      DO 100 I = 1,NA
      DO 24 L = 1,NE
      IF (XA(I) .LT. XE(L)) GO TO 30
   24 CONTINUE
      L = NE
      IF ((IE2 - 1).lt.0) then
         go to 50
      elseif((ie2-1).eq.0) then
         go to 35
      else
         go to 70
      endif
   30 IF (L .GT. 1) GO TO 40
      IF ((IE1 - 1).lt.0) then
         go to 50
      elseif((ie1-1).eq.0) then
         go to 25
      else
         go to 70
      endif
   40 IF ((IA-1).lt.0) then
         go to 45
      elseif((ia-1).eq.0) then
         go to 60
      else
         go to 70
      endif
C
C CONSTANT INTERPOLATION
C -----------------------
   45 L = L - 1
   50 YA(I) = YE(L)
      GO TO 100
C
C LINEAR EXTRAPOLATION
C ------------------------------
   25 IF (IA .EQ. 1) GO TO 60
      XO = XE(2)
      XU = XE(1) - XO
      YO = YE(2)
      YU = YE(1) - YO
      XZ = XE(3) - XO
      YZ = YE(3) - YO
      GO TO 38
   35 IF (IA .EQ. 1) GO TO 60
      XO = XE(NE1)
      XZ = XE(NE1-1) - XO
      XU = XE(NE) - XO
      YO = YE(NE1)
      YZ = YE(NE1-1) - YO
      YU = YE(NE) - YO
C
C LINEAR EXTRAPOLATION WITH QUADRATIC INTERPOLATION
C -----------------------------------------------------
   38 RAB = YU / XU + XU * ((YZ-YU) / (XZ-XU) - YU/XU) / XZ
      YA(I) = YU + YO + (XA(I) -XU-XO)*RAB
      GO TO 100
C
C LINEAR INTERPOLATION
C ---------------------
  60  IG = L - 1
      IF (IG .LT. 1) IG = 1
      YA(I) = YE(IG) + (XA(I)-XE(IG))*(YE(IG+1)-YE(IG))
     1        / (XE(IG+1)-XE(IG))
      GO TO 100
   70 IF (L .GT. 2) GO TO 80
      XO = XE(2)
      XU = XE(1) - XO
      YO = YE(2)
      YU = YE(1) - YO
      XZ = XE(3) - XO
      YZ = YE(3) - YO
      GO TO 85
   80 IF (L .LT. NE) GO TO 90
      XO = XE(NE1)
      XU = XE(NE1-1) - XO
      XZ = XE(NE) - XO
      YO = YE(NE1)
      YU = YE(NE1-1) - YO
      YZ = YE(NE) - YO
   85 YA(I) = EQ(XA(I)-XO) + YO
      GO TO 100
C
C DOUBLE QUADRATIC INTERPOLATION
C ----------------------------------
   90 XO = XE(L-1)
      XU = XE(L-2) - XO
      XZ = XE(L) - XO
      XD = XE(L+1) - XO
      YO = YE(L-1)
      YU = YE(L-2) - YO
      YZ = YE(L) - YO
      YD = YE(L+1) - YO
      ZW1 = EQ(XA(I)-XO)
      ZW2 = EQD(XA(I)-XO)
      YA(I) = ZW1 + (ZW2 - ZW1) * (XA(I) - XO)/XZ + YO
  100 CONTINUE
C
C RETURN BY NORMAL PROCEEDING
C -------------------------------
      IER = 0
      RETURN
C
C ERROR RETURN
C ------------
  900 IER = -1
      RETURN
      END


MODULE pk_EisensteinHu
implicit none
private
public EisensteinHu
contains

SUBROUTINE EisensteinHu(ak,omegamh2,fb,T)
! REF: Eisenstein and Hu, ApJ, 496, 605 (1998), Eq.(29)-(31)
  IMPLICIT none
  DOUBLE PRECISION, intent(IN) :: ak,omegamh2,fb ! 1/Mpc; omega_mh^2; omega_b/omega_m
  DOUBLE PRECISION, intent(OUT):: T
  DOUBLE PRECISION :: alpha,sound,shape,aq
  alpha= 1d0 &
       -0.328d0*dlog(431d0*omegamh2)*fb &
       +0.38d0*dlog(22.3d0*omegamh2)*fb**2d0
  sound= 44.5d0*dlog(9.83d0/omegamh2)  &
       /dsqrt(1d0+10d0*(fb*omegamh2)**(3d0/4d0))
  shape= omegamh2 &
       *(alpha+(1d0-alpha)/(1d0+(0.43d0*ak*sound)**4d0))
  aq= ak*(2.725d0/2.7d0)**2d0/shape
  T= dlog(2d0*dexp(1d0)+1.8d0*aq) &
       /(dlog(2d0*dexp(1d0)+1.8d0*aq) &
       +(14.2d0+731d0/(1d0+62.5d0*aq))*aq*aq)
  return
END SUBROUTINE EisensteinHu
end module pk_EisensteinHu


Program Quadratic_Equation_of_One_Variable_Simple   !一段简单的解一元二次方程的代码，没有考虑非一元二次方程的情况。
implicit none
    real(8):: delta , x1 , x2 , a , b , c

    read*, a!=0 , b , c
    delta = b**2 - 4*a*c
    if (delta > 0) then
        x1 = (-b + sqrt(delta))/2.* a
        x2 = (-b - sqrt(delta))/2.* a
        write(*,100) 'r1=' , x1 , 'r2=' , x2
     else if (delta == 0 ) then
        x1 = -b / 2.*a
        write(*,100) 'r1=' , x1 , 'r2=' , x1
100 format('' , A3 , F7.2 , / , A3 , F7.2)        !一种格式化输出
    else
        write(*,200)'No real roots!'
200 format('' , A14)
    end if
end