! Subroutine to use the BPM equations for turbine acoustics

! cubic spline interpolation setup (for Tip Vortex Noise)
subroutine splineint(n,x,y,xval,yval)
    implicit none

    integer, parameter :: dp = kind(0.d0)

    ! in
    integer, intent(in) :: n
    real(dp), dimension(n), intent(in) :: x,y
    real(dp), intent(in) :: xval

    ! out
    real(dp), intent(out) :: yval

    ! local
    integer :: i
    real(dp) :: x1,x2,x3,y1,y2,y3

    ! assuming the values of x are in accending order
    do i = 1,n
      if (xval < x(i)) then
        if (i == 2) then
          x1 = x(1)
          x2 = x(2)
          x3 = x(3)
          y1 = y(1)
          y2 = y(2)
          y3 = y(3)
          call cubspline(x1,x2,x3,y1,y2,y3,xval,yval)
        else if (i == n) then
          x1 = x(n-2)
          x2 = x(n-1)
          x3 = x(n)
          y1 = y(n-2)
          y2 = y(n-1)
          y3 = y(n)
          call cubspline(x1,x2,x3,y1,y2,y3,xval,yval)
        else
          if (xval <= (x(i)+x(i-1))/2.0_dp) then
            x1 = x(i-2)
            x2 = x(i-1)
            x3 = x(i)
            y1 = y(i-2)
            y2 = y(i-1)
            y3 = y(i)
            call cubspline(x1,x2,x3,y1,y2,y3,xval,yval)
          else
            x1 = x(i-1)
            x2 = x(i)
            x3 = x(i+1)
            y1 = y(i-1)
            y2 = y(i)
            y3 = y(i+1)
            call cubspline(x1,x2,x3,y1,y2,y3,xval,yval)
          end if
        end if
        exit
      else if (xval == x(i)) then
        yval = y(i)
        exit
      end if

    end do

end subroutine splineint

subroutine cubspline(x1,x2,x3,y1,y2,y3,xval,yval)
    implicit none

    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: x1,x2,x3,y1,y2,y3,xval

    ! out
    real(dp), intent(out) :: yval

    ! local
    real(dp) :: a11,a12,a13,a21,a22,a23,a31,a32,a33,b1,b2,b3
    real(dp) :: bot,xtop,ytop,ztop,k1,k2,k3,a,b,t

    a11 = 2.0_dp/(x2-x1)
    a12 = 1.0_dp/(x2-x1)
    a13 = 0.0_dp
    a21 = 1.0_dp/(x2-x1)
    a22 = 2.0_dp*((1.0_dp/(x2-x1))+(1.0_dp/(x3-x2)))
    a23 = 1.0_dp/(x3-x2)
    a31 = 0.0_dp
    a32 = 1.0_dp/(x3-x2)
    a33 = 2.0_dp/(x3-x2)
    b1 = 3.0_dp*(y2-y1)/(x2-x1)**2
    b2 = 3.0_dp*(((y2-y1)/(x2-x1)**2)+((y3-y2)/(x3-x2)**2))
    b3 = 3.0_dp*(y3-y2)/(x3-x2)**2

    bot = a11*a22*a33+a12*a23*a31+a13*a21*a32-a13*a22*a31-a12*a21*a33-a11*a23*a32
    if (xval < x2) then
      xtop = b1*a22*a33+a12*a23*b3+a13*b2*a32-a13*a22*b3-a12*b2*a33-b1*a23*a32
      ytop = a11*b2*a33+b1*a23*a31+a13*a21*b3-a13*b2*a31-b1*a21*a33-a11*a23*b3

      k1 = xtop/bot
      k2 = ytop/bot

      a = k1*(x2-x1)-(y2-y1)
      b = -k2*(x2-x1)+(y2-y1)
      t = (xval-x1)/(x2-x1)

      yval = (1.0_dp-t)*y1+t*y2+t*(1.0_dp-t)*(a*(1.0_dp-t)+b*t)
    else
      ytop = a11*b2*a33+b1*a23*a31+a13*a21*b3-a13*b2*a31-b1*a21*a33-a11*a23*b3
      ztop = a11*a22*b3+a12*b2*a31+b1*a21*a32-b1*a22*a31-a12*a21*b3-a11*b2*a32

      k2 = ytop/bot
      k3 = ztop/bot

      a = k2*(x3-x2)-(y3-y2)
      b = -k3*(x3-x2)+(y3-y2)
      t = (xval-x2)/(x3-x2)

      yval = (1.0_dp-t)*y2+t*y3+t*(1.0_dp-t)*(a*(1.0_dp-t)+b*t)
    end if

end subroutine cubspline

! Function to compute directivity angles and distance
! Based on work by Luis Vargas (Wind Turbine Noise Prediction)
subroutine direct(n,xt,yt,zt,c,c1,d,Hub,beta,r,theta_e,phi_e)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  integer, intent(in) :: n
  real(dp), intent(in) :: xt,yt,zt,Hub,beta
  real(dp), dimension(n), intent(in) :: c,c1,d
  ! out
  real(dp), dimension(n), intent(out) :: r,theta_e,phi_e
  ! local
  integer :: i,sign
  real(dp) :: pi,xo,yo,zo,xs,zs,xe_d,ze_d,theta,xe,ze,phi_er
  real(dp), dimension(n) :: c2
  intrinsic sin
  intrinsic cos
  intrinsic atan2
  intrinsic sqrt
  intrinsic abs
  ! constants
  pi = 3.1415926535897932_dp

  ! distance from pitch-axis to trailing edge
  c2(1:n) = c(1:n)-c1(1:n)

  ! Calculating observer location from hub
  xo = xt ! lateral direction
  yo = yt ! downstream direction
  zo = zt-Hub ! height direction

  do i=1,n
    ! Calculating trailing edge position from hub
    xs = sin(beta)*d(i)-cos(beta)*c2(i)
    zs = cos(beta)*d(i)+sin(beta)*c2(i)

    ! Calculating observer position from trailing edge
    xe_d = xo-xs
    ze_d = zo-zs

    ! Rotating observer position with repsect to beta
    theta = pi-beta
    xe = cos(theta)*xe_d+sin(theta)*ze_d
    ze = -sin(theta)*xe_d+cos(theta)*ze_d

    ! Calculating observer distance and directivity angles
    r(i) = sqrt(yo**2+xe**2+ze**2)
    theta_e(i) = atan2(sqrt(yo**2+ze**2),xe)
    phi_e(i) = atan2(yo,ze)

    ! Quadratic smoothing when phi_e is close to 0 or 180 degrees
    if (abs(phi_e(i)) < 5.0_dp*pi/180.0_dp) then
      if (phi_e(i) >= 0.0_dp) then
        sign = 1
      else
        sign = -1
      end if
      phi_er = abs(phi_e(i))*180.0_dp/pi
      phi_er = 0.1_dp*phi_er**2+2.5_dp
      phi_e(i) = sign*phi_er*pi/180.0_dp
    else if (abs(phi_e(i)) > 175.0_dp*pi/180.0_dp) then
      if (phi_e(i) >= 0.0_dp) then
        sign = 1
      else
        sign = -1
      end if
      phi_er = abs(phi_e(i))*180.0_dp/pi
      phi_er = -0.1_dp*(phi_er-180.0_dp)**2+177.5_dp
      phi_e(i) = sign*phi_er*pi/180.0_dp
    end if

  end do

end subroutine direct

! Directivity function for high-frequency noise
! not for high-angle separation; becomes inaccurate for theta_e approaching 180 deg
subroutine Dhfunc(theta_e,phi_e,M,Dh)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  real(dp), intent(in) :: theta_e,phi_e,M
  ! out
  real(dp), intent(out) :: Dh
  ! local
  real(dp) :: conv,Mc
  intrinsic sin
  intrinsic cos

  conv = 0.8_dp ! convection factor for speed
  Mc = M*conv

  Dh = (2.0_dp*(sin(theta_e/2.0_dp))**2*(sin(phi_e))**2)/((1.0_dp&
  +M*cos(theta_e))*(1.0_dp+(M-Mc)*cos(theta_e))**2)

end subroutine Dhfunc

! Directivity function for low-frequency noise
subroutine Dlfunc(theta_e,phi_e,M,Dl)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  real(dp), intent(in) :: theta_e,phi_e,M
  ! out
  real(dp), intent(out) :: Dl
  intrinsic sin
  intrinsic cos

  Dl = ((sin(theta_e))**2*(sin(phi_e))**2)/(1.0_dp+M*cos(theta_e))**4

end subroutine Dlfunc

! Spectral Function A
subroutine Afunc(ain,Re,Aspec)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  real(dp), intent(in) :: ain,Re
  ! out
  real(dp), intent(out) :: Aspec
  ! local
  real(dp) :: a,Amin,Amax,a0,Amin0,Amax0,AR0
  intrinsic log10
  intrinsic abs
  intrinsic sqrt

  a = abs(log10(ain))

  ! Calculating Amin
  if(a < 0.204_dp) then
    Amin = sqrt(67.552_dp-886.788_dp*a**2)-8.219_dp
  else if (a >= 0.204_dp .and. a <= 0.244_dp) then
    Amin = -32.665_dp*a+3.981_dp
  else
    Amin = -142.795_dp*a**3+103.656_dp*a**2-57.757_dp*a+6.006_dp
  end if

  ! Calculating Amax
  if (a < 0.13_dp) then
    Amax = sqrt(67.552_dp-886.788_dp*a**2)-8.219_dp
  else if(a >= 0.13_dp .and. a <= 0.321_dp) then
    Amax = -15.901_dp*a+1.098_dp
  else
    Amax = -4.669_dp*a**3+3.491_dp*a**2-16.699_dp*a+1.149_dp
  end if

  ! Calculating a0
  if (Re < 9.52e4_dp) then
    a0 = 0.57_dp
  else if (Re >= 9.52e4_dp .and. Re <= 8.57e5_dp) then
    a0 = -9.57e-13_dp*(Re-8.57e5_dp)**2+1.13_dp
  else
    a0 = 1.13_dp
  end if

  ! Calculating Amin(a0)
  if (a0 < 0.204_dp) then
    Amin0 = sqrt(67.552_dp-886.788_dp*a0**2)-8.219_dp
  else if (a0 >= 0.204 .and. a0 <= 0.244) then
    Amin0 = -32.665_dp*a0+3.981_dp
  else
    Amin0 = -142.795_dp*a0**3+103.656_dp*a0**2-57.757_dp*a0+6.006_dp
  end if

  ! Calculating Amax(a0)
  if (a0 < 0.13_dp) then
    Amax0 = sqrt(67.552_dp-886.788_dp*a0**2)-8.219_dp
  else if (a0 >= 0.13_dp .and. a0 <= 0.321_dp) then
    Amax0 = -15.901_dp*a0+1.098_dp
  else
    Amax0 = -4.669_dp*a0**3+3.491_dp*a0**2-16.699_dp*a0+1.149_dp
  end if

  AR0 = (-20.0_dp-Amin0)/(Amax0-Amin0)

  Aspec = Amin+AR0*(Amax-Amin)

end subroutine Afunc

! Spectral Function B
subroutine Bfunc(bin,Re,Bspec)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  real(dp), intent(in) :: bin,Re
  ! out
  real(dp), intent(out) :: Bspec
  ! local
  real(dp) :: b,Bmin,Bmax,b0,Bmin0,Bmax0,BR0
  intrinsic log10
  intrinsic abs
  intrinsic sqrt

  b = abs(log10(bin))

  ! Calculating Bmin
  if (b < 0.13_dp) then
    Bmin = sqrt(16.888_dp-886.788_dp*b**2)-4.109_dp
  else if (b >= 0.13_dp .and. b <= 0.145_dp) then
    Bmin = -83.607_dp*b+8.138_dp
  else
    Bmin = -817.810_dp*b**3+355.210_dp*b**2-135.024_dp*b+10.619_dp
  end if

  ! Calculating Bmax
  if (b < 0.10_dp) then
    Bmax = sqrt(16.888_dp-886.788_dp*b**2)-4.109_dp
  else if (b >= 0.10_dp .and. b <= 0.187_dp) then
    Bmax = -31.330_dp*b+1.854_dp
  else
    Bmax = -80.541_dp*b**3+44.174_dp*b**2-39.381_dp*b+2.344_dp
  end if

  ! Calculating b0
  if (Re < 9.52e4_dp) then
    b0 = 0.30_dp
  else if (Re >= 9.52e4_dp .and. Re <= 8.57e5_dp) then
    b0 = -4.48e-13_dp*(Re-8.57e5_dp)**2+0.56_dp
  else
    b0 = 0.56_dp
  end if

  ! Calculating Bmin(b0)
  if (b0 < 0.13_dp) then
    Bmin0 = sqrt(16.888_dp-886.788_dp*b0**2)-4.109_dp
  else if (b0 >= 0.13_dp .and. b0 <= 0.145_dp) then
    Bmin0 = -83.607_dp*b0+8.138_dp
  else
    Bmin0 = -817.810_dp*b0**3+355.210_dp*b0**2-135.024_dp*b0+10.619_dp
  end if

  ! Calculating Bmax(b0)
  if (b0 < 0.10_dp) then
    Bmax0 = sqrt(16.888_dp-886.788_dp*b0**2)-4.109_dp
  else if (b0 >= 0.10_dp .and. b0 <= 0.187_dp) then
    Bmax0 = -31.330_dp*b0+1.854_dp
  else
    Bmax0 = -80.541_dp*b0**3+44.174_dp*b0**2-39.381_dp*b0+2.344_dp
  end if

  BR0 = (-20.0_dp-Bmin0)/(Bmax0-Bmin0)

  Bspec =  Bmin+BR0*(Bmax-Bmin)

end subroutine Bfunc

subroutine G1func(e,G1)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  real(dp), intent(in) :: e
  ! out
  real(dp), intent(out) :: G1
  ! local
  intrinsic log10
  intrinsic sqrt

  if (e <= 0.5974_dp) then
    G1 = 39.8_dp*log10(e)-11.12_dp
  else if (e <= 0.8545_dp .and. e > 0.5974_dp) then
    G1 = 98.409_dp*log10(e)+2.0_dp
  else if (e <= 1.17_dp .and. e > 0.8545_dp) then
    G1 = sqrt(2.484_dp-506.25_dp*(log10(e))**2)-5.076_dp
  else if (e <= 1.674_dp .and. e > 1.17_dp) then
    G1 = -98.409_dp*log10(e)+2.0_dp
  else
    G1 = -39.8_dp*log10(e)-11.12_dp
  end if

end subroutine G1func

subroutine G2func(d,G2)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  real(dp), intent(in) :: d
  ! out
  real(dp), intent(out) :: G2
  ! local
  intrinsic log10

  if (d <= 0.3237_dp) then
    G2 = 77.852_dp*log10(d)+15.328_dp
  else if (d <= 0.5689_dp .and. d > 0.3237_dp) then
    G2 = 65.188_dp*log10(d)+9.125_dp
  else if (d <= 1.7579_dp .and. d > 0.5689_dp) then
    G2 = -114.052_dp*(log10(d))**2
  else if (d <= 3.0889_dp .and. d > 1.7579_dp) then
    G2 = -65.188_dp*log10(d)+9.125_dp
  else
    G2 = -77.852_dp*log10(d)+15.328_dp
  end if

end subroutine G2func

subroutine G3func(alpha,G3)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  real(dp), intent(in) :: alpha
  ! out
  real(dp), intent(out) :: G3

  G3 = 171.04_dp-3.03_dp*alpha

end subroutine G3func

subroutine G4func(hdav,psi,G4)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  real(dp), intent(in) :: hdav,psi
  ! out
  real(dp), intent(out) :: G4
  ! local
  intrinsic log10

  if (hdav <= 5.0_dp) then
    G4 = 17.5_dp*log10(hdav)+157.5_dp-1.114_dp*psi
  else
    G4 = 169.7_dp-1.114_dp*psi
  end if

end subroutine G4func

subroutine G5func(hdav,psi,StSt_peak,G5)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  real(dp), intent(in) :: hdav,psi,StSt_peak
  ! out
  real(dp), intent(out) :: G5
  ! local
  real(dp) :: eta,mu,m,eta_0,k,G14,hdav_prime,mu0,m0,eta_00,k0,G0
  intrinsic log10
  intrinsic sqrt

  ! finding G5 at phi = 14 deg
  eta = log10(StSt_peak)

  if (hdav < 0.25_dp) then
    mu = 0.1221_dp
  else if (hdav < 0.62_dp .and. hdav >= 0.25_dp) then
    mu = -0.2175_dp*hdav+0.1755_dp
  else if (hdav < 1.15_dp .and. hdav >= 0.62_dp) then
    mu = -0.0308_dp*hdav+0.0596_dp
  else
    mu = 0.0242_dp
  end if

  if(hdav <= 0.02_dp) then
    m = 0.0_dp
  else if (hdav <= 0.5_dp .and. hdav > 0.02_dp) then
    m = 68.724_dp*(hdav)-1.35_dp
  else if (hdav <= 0.62_dp .and. hdav > 0.5_dp) then
    m = 308.475_dp*hdav-121.23_dp
  else if (hdav <= 1.15_dp .and. hdav > 0.62_dp) then
    m = 224.811_dp*hdav-69.35_dp
  else if (hdav <= 1.2 .and. hdav > 1.15) then
    m = 1583.28_dp*hdav-1631.59_dp
  else
    m = 268.344_dp
  end if

  eta_0 = -sqrt((m**2*mu**4)/(6.25_dp+m**2*mu**2))
  k = 2.5_dp*sqrt(1.0_dp-(eta_0/mu)**2)-2.5_dp-m*eta_0

  if (eta < eta_0) then
    G14 = m*eta+k
  else if (eta < 0.0_dp .and. eta >= eta_0) then
    G14 = 2.5_dp*sqrt(1.0_dp-(eta/mu)**2)-2.5_dp
  else if (eta < 0.03616_dp .and. eta >= 0.0_dp) then
    G14 = sqrt(1.5625_dp-1194.99_dp*eta**2)-1.25_dp
  else
    G14 = -155.543_dp*eta+4.375_dp
  end if

  ! finding G5 at psi = 0 deg
  hdav_prime = 6.724_dp*hdav**2-4.019_dp*hdav+1.107_dp

  if (hdav_prime < 0.25_dp) then
    mu0 = 0.1221_dp
  else if (hdav_prime < 0.62_dp .and. hdav_prime >= 0.25_dp) then
    mu0 = -0.2175_dp*hdav_prime+0.1755_dp
  else if (hdav_prime < 1.15_dp .and. hdav_prime >= 0.62_dp) then
    mu0 = -0.0308_dp*hdav_prime+0.0596_dp
  else
    mu0 = 0.0242_dp
  end if

  if (hdav_prime <= 0.02_dp) then
    m0 = 0.0_dp
  else if (hdav_prime <= 0.5_dp .and. hdav_prime > 0.02_dp) then
    m0 = 68.724_dp*hdav_prime-1.35_dp
  else if (hdav_prime <= 0.62_dp .and. hdav_prime > 0.5_dp) then
    m0 = 308.475_dp*hdav_prime-121.23_dp
  else if (hdav_prime <= 1.15_dp .and. hdav_prime > 0.62_dp) then
    m0 = 224.811_dp*hdav_prime-69.35_dp
  else if (hdav_prime <= 1.2_dp .and. hdav_prime > 1.15_dp) then
    m0 = 1583.28_dp*hdav_prime-1631.59_dp
  else
    m0 = 268.344_dp
  end if

  eta_00 = -sqrt((m0**2*mu0**4)/(6.25_dp+m0**2*mu0**2))
  k0 = 2.5_dp*sqrt(1.0_dp-(eta_00/mu0)**2)-2.5_dp-m0*eta_00

  if (eta < eta_00) then
    G0 = m0*eta+k0
  else if (eta < 0.0_dp .and. eta >= eta_00) then
    G0 = 2.5_dp*sqrt(1.0_dp-(eta/mu0)**2)-2.5_dp
  else if (eta < 0.03616_dp .and. eta >= 0.0_dp) then
    G0 = sqrt(1.5625_dp-1194.99_dp*eta**2)-1.25_dp
  else
    G0 = -155.543_dp*eta+4.375_dp
  end if

  G5 = G0+0.0714_dp*psi*(G14-G0)

end subroutine G5func

! Turbulent Boundary Layer Trailing Edge Noise
subroutine TBLTEfunc(f,V,L,c,r,theta_e,phi_e,alpha,nu,c0,trip,TBLTE)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  real(dp), intent(in) :: f,V,L,c,r,theta_e,phi_e,alpha,nu,c0
  logical, intent(in) :: trip
  ! out
  real(dp), intent(out) :: TBLTE
  ! local
  real(dp) :: M,Re,d0,d0_d,ds_d,dpr,dp_d,Dh,Dl,Stp,Sts,St1,St2,St_bar,St_peak
  real(dp) :: apre,asuc,bang,gamma,gamma0,beta,beta0,K1,K2,Re_dp,DeltaK1
  real(dp) :: Ap,As,B,SPLp,SPLs,SPLa,A,rc
  intrinsic log10
  intrinsic sqrt
  intrinsic abs
  intrinsic max
  ! constants
  M = V/c0
  Re = (V*c)/nu

  if (trip .eqv. .false.) then
    ! UNTRIPPED boundary layer at 0 deg- thickness, displacement thickness
    d0 = c*(10.0_dp**(1.6569_dp-0.9045_dp*log10(Re)+0.0596_dp*(log10(Re))**2))
    d0_d = c*(10.0_dp**(3.0187_dp-1.5397_dp*log10(Re)+0.1059_dp*(log10(Re))**2))
  else
    ! TRIPPED boundary layer at 0 deg- thickness, displacement thickness
    d0 = c*(10.0_dp**(1.892_dp-0.9045_dp*log10(Re)+0.0596_dp*(log10(Re))**2))
    if (Re <= 0.3e6_dp) then
      d0_d = c*0.0601_dp*Re**(-0.114_dp)
    else
      d0_d = c*(10.0_dp**(3.411_dp-1.5397_dp*log10(Re)+0.1059_dp*(log10(Re))**2))
    end if
  end if

  ! boundary layer on pressure side- thickness, displacement thickness
  dpr = d0*(10.0_dp**(-0.04175_dp*alpha+0.00106_dp*alpha**2))
  dp_d = d0_d*(10.0_dp**(-0.0432_dp*alpha+0.00113_dp*alpha**2))

  if (trip .eqv. .false.) then
    ! UNTRIPPED boundary layer on suction side- displacement thickness
    if (alpha <= 7.5_dp .and. alpha >= 0.0_dp) then
      ds_d = d0_d*10.0_dp**(0.0679_dp*alpha)
    else if (alpha <= 12.5_dp .and. alpha > 7.5_dp) then
      ds_d = d0_d*0.0162_dp*10.0_dp**(0.3066_dp*alpha)
    !else if (alpha <= 25.0_dp .and. alpha > 12.5_dp) then
    else
      ds_d = d0_d*52.42_dp*10.0_dp**(0.0258_dp*alpha)
    end if
  else
    ! TRIPPED boundary layer on suction side- displacement thickness
    if (alpha <= 5.0_dp .and. alpha >= 0.0_dp) then
      ds_d = d0_d*10.0_dp**(0.0679_dp*alpha)
    else if (alpha <= 12.5_dp .and. alpha > 5.0_dp) then
      ds_d = d0_d*0.381_dp*10.0_dp**(0.1516_dp*alpha)
    !else if (alpha <= 25.0_dp .and. alpha > 12.5_dp) then
    else
      ds_d = d0_d*14.296_dp*10.0_dp**(0.0258_dp*alpha)
    end if
  end if

  call Dhfunc(theta_e,phi_e,M,Dh)
  call Dlfunc(theta_e,phi_e,M,Dl)

  Stp = (f*dp_d)/V
  Sts = (f*ds_d)/V

  St1 = 0.02_dp*M**(-0.6_dp)

  if (alpha < 1.33_dp) then
    St2 = St1*1.0_dp
  else if (alpha <= 12.5_dp .and. alpha >= 1.33_dp) then
    St2 = St1*10.0_dp**(0.0054_dp*(alpha-1.33_dp)**2)
  else
    St2 = St1*4.72_dp
  end if

  St_bar = (St1+St2)/2.0_dp

  St_peak = max(St1,St2,St_bar)

  apre = Stp/St1
  asuc = Sts/St1
  bang = Sts/St2

  gamma = 27.094_dp*M+3.31_dp
  gamma0 = 23.43_dp*M+4.651_dp
  beta = 72.65_dp*M+10.74_dp
  beta0 = -34.19_dp*M-13.82_dp

  if (Re < 2.47e5_dp) then
    K1 = -4.31_dp*log10(Re)+156.3_dp
  else if (Re >= 2.47e5_dp .and. Re <= 8.0e5_dp) then
    K1 = -9.0_dp*log10(Re)+181.6_dp
  else
    K1 = 128.5_dp
  end if

  if (alpha < (gamma0-gamma)) then
    K2 = K1-1000.0_dp
  else if (alpha >= (gamma0-gamma) .and. alpha <= (gamma0+gamma)) then
    K2 = K1+sqrt(beta**2-(beta/gamma)**2*(alpha-gamma0)**2)+beta0
  else
    K2 = K1-12.0_dp
  end if

  Re_dp = (V*dp_d)/nu

  if (Re_dp <= 5000.0_dp) then
    DeltaK1 = alpha*(1.43_dp*log10(Re_dp)-5.29_dp)
  else
    DeltaK1 = 0.0_dp
  end if

  ! Keeping observer distance from getting too close to the turbine
  if (r < 1e-8_dp) then
    rc = 1e-8_dp
  else
    rc = r
  end if

  if(alpha > 12.5_dp .or. alpha > gamma0) then
    ! Turbulent Boundary Layer Separation Stall Noise (TBLSS); this is were the airfoil is stalling and stall noise dominates
    ! SPLp = -infinity; 10**(SPLp/10) = 0
    ! SPLs = -infinity; 10**(SPLs/10) = 0

    call Afunc(bang,3.0_dp*Re,A)

    SPLa = 10.0_dp*log10((ds_d*M**5*L*Dl)/rc**2)+A+K2

    TBLTE = 10.0_dp*log10(10.0_dp**(SPLa/10.0_dp))

  else
    call Afunc(apre,Re,Ap)
    call Afunc(asuc,Re,As)
    call Bfunc(bang,Re,B)

    SPLp = 10.0_dp*log10((dp_d*M**5*L*Dh)/rc**2)+Ap+(K1-3.0_dp)+DeltaK1
    SPLs = 10.0_dp*log10((ds_d*M**5*L*Dh)/rc**2)+As+(K1-3.0_dp)
    SPLa = 10.0_dp*log10((ds_d*M**5*L*Dh)/rc**2)+B+K2

    TBLTE =  10.0_dp*log10(10.0_dp**(SPLp/10.0_dp)+10.0_dp**(SPLs/10.0_dp)&
    +10.0_dp**(SPLa/10.0_dp))

  end if

end subroutine TBLTEfunc

! Turbulent Boundary Layer Tip Vortex Noise
subroutine TBLTVfunc(f,V,c,r,theta_e,phi_e,atip,c0,tipflat,AR,TBLTV)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  real(dp), intent(in) :: f,V,c,r,theta_e,phi_e,atip,c0,AR
  logical, intent(in) :: tipflat
  ! out
  real(dp), intent(out) :: TBLTV
  ! local
  real(dp) :: M,Mmax,Dh,atip_d,atipcorr,l,St,rc
  real(dp), dimension(6) :: AR_data,atipcorr_data
  intrinsic log10
  ! constants
  M = V/c0
  Mmax = M*(1.0_dp+0.036*atip)

  call Dhfunc(theta_e,phi_e,M,Dh)

  ! Tip vortex noise correction based on data from "Airfoil Tip Vortex Formation Noise"
  AR_data = (/2.0_dp,2.67_dp,4.0_dp,6.0_dp,12.0_dp,24.0_dp/)
  atipcorr_data = (/0.54_dp,0.62_dp,0.71_dp,0.79_dp,0.89_dp,0.95_dp/)

  if ((AR >= 2.0_dp) .and. (AR <= 24.0_dp)) then
    call splineint(6,AR_data,atipcorr_data,AR,atipcorr)
  else if (AR .gt. 24.0_dp) then
    atipcorr = 1.0_dp
  else
    atipcorr = 0.5_dp
  end if

  atip_d = atip*atipcorr

  if (tipflat .eqv. .false.) then
    ! rounded tip
    l = 0.008_dp*c*atip_d
  else
    ! flat tip
    if (atip_d <= 2.0_dp .and. atip_d >= 0.0_dp) then
      l = c*(0.0230_dp+0.0169_dp*atip_d)
    else
      l = c*(0.0378_dp+0.0095_dp*atip_d)
    end if
  end if

  St = (f*l)/(V*(1.0_dp+0.036_dp*atip_d))

  ! Keeping observer distance from getting too close to the turbine
  if (r < 1e-8_dp) then
    rc = 1e-8_dp
  else
    rc = r
  end if

  TBLTV =  10.0_dp*log10((M**2*Mmax**3*l**2*Dh)/rc**2)&
  -30.5_dp*(log10(St)+0.3_dp)**2+126.0_dp

end subroutine TBLTVfunc

! Laminar Boundary Layer Vortex Shedding
subroutine LBLVSfunc(f,V,L,c,r,theta_e,phi_e,alpha,nu,c0,trip,LBLVS)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  real(dp), intent(in) :: f,V,L,c,r,theta_e,phi_e,alpha,nu,c0
  logical, intent(in) :: trip
  ! out
  real(dp), intent(out) :: LBLVS
  ! local
  real(dp) :: M,Re,d0,dpr,St,Dh,St1,St_peak,e,G1,Re0,d,G2,G3,rc
  intrinsic log10
  ! constants
  M = V/c0
  Re = (V*c)/nu

  if (trip .eqv. .false.) then
    ! UNTRIPPED boundary layer at 0 deg- thickness
    d0 = c*(10.0_dp**(1.6569_dp-0.9045_dp*log10(Re)+0.0596_dp*(log10(Re))**2))
  else
    ! TRIPPED boundary layer at 0 deg- thickness
    d0 = c*(10.0_dp**(1.892_dp-0.9045_dp*log10(Re)+0.0596_dp*(log10(Re))**2))
  end if
  ! boundary layer on pressure side- thickness
  dpr = d0*(10.0_dp**(-0.04175_dp*alpha+0.00106_dp*alpha**2))

  St = (f*dpr)/V

  call Dhfunc(theta_e,phi_e,M,Dh)

  if (Re <= 1.3e5_dp) then
    St1 = 0.18_dp
  else if (Re <= 4.0e5_dp .and. Re > 1.3e5_dp) then
    St1 = 0.001756_dp*Re**0.3931_dp
  else
    St1 = 0.28_dp
  end if

  St_peak = St1*10.0_dp**(-0.04_dp*alpha)

  e = St/St_peak

  call G1func(e,G1)

  if (alpha <= 3.0_dp) then
    Re0 = 10.0_dp**(0.215_dp*alpha+4.978_dp)
  else
    Re0 = 10.0_dp**(0.12_dp*alpha+5.263_dp)
  end if

  d = Re/Re0

  call G2func(d,G2)
  call G3func(alpha,G3)

  ! Keeping observer distance from getting too close to the turbine
  if (r < 1e-8_dp) then
    rc = 1e-8_dp
  else
    rc = r
  end if

  LBLVS = 10.0_dp*log10((dpr*M**5*L*Dh)/rc**2)+G1+G2+G3

end subroutine LBLVSfunc

! Trailing Edge Bluntness Vortex Shedding Noise
subroutine TEBVSfunc(f,V,L,c,h,r,theta_e,phi_e,alpha,nu,c0,psi,trip,TEBVS)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  real(dp), intent(in) :: f,V,L,c,h,r,theta_e,phi_e,alpha,nu,c0,psi
  logical, intent(in) :: trip
  ! out
  real(dp), intent(out) :: TEBVS
  ! local
  real(dp) :: M,Re,d0,d0_d,dpr,dp_d,ds_d,Dh,St,dav,hdav
  real(dp) :: St_peak,StSt_peak,G4,G5,rc
  intrinsic log10
  ! constants
  M = V/c0
  Re = (V*c)/nu

  if (trip .eqv. .false.) then
    ! UNTRIPPED boundary layer at 0 deg- thickness, displacement thickness
    d0 = c*(10.0_dp**(1.6569_dp-0.9045_dp*log10(Re)+0.0596_dp*(log10(Re))**2))
    d0_d = c*(10.0_dp**(3.0187_dp-1.5397_dp*log10(Re)+0.1059_dp*(log10(Re))**2))
  else
    ! TRIPPED boundary layer at 0 deg- thickness, displacement thickness
    d0 = c*(10.0_dp**(1.892_dp-0.9045_dp*log10(Re)+0.0596_dp*(log10(Re))**2))
    if (Re <= 0.3e6_dp) then
      d0_d = c*0.0601_dp*Re**(-0.114_dp)
    else
      d0_d = c*(10.0_dp**(3.411_dp-1.5397_dp*log10(Re)+0.1059_dp*(log10(Re))**2))
    end if
  end if

  ! boundary layer on pressure side- thickness, displacement thickness
  dpr = d0*(10.0_dp**(-0.04175_dp*alpha+0.00106_dp*alpha**2))
  dp_d = d0_d*(10.0_dp**(-0.0432_dp*alpha+0.00113_dp*alpha**2))

  if (trip .eqv. .false.) then
    ! UNTRIPPED boundary layer on suction side- displacement thickness
    if (alpha <= 7.5_dp .and. alpha >= 0.0_dp) then
      ds_d = d0_d*10.0_dp**(0.0679_dp*alpha)
    else if (alpha <= 12.5_dp .and. alpha > 7.5_dp) then
      ds_d = d0_d*0.0162_dp*10.0_dp**(0.3066_dp*alpha)
    !else if (alpha <= 25_dp .and. alpha > 12.5_dp) then
    else
      ds_d = d0_d* 52.42_dp* 10.0_dp**(0.0258_dp*alpha)
    end if
  else
    ! TRIPPED boundary layer on suction side- displacement thickness
    if (alpha <= 5.0_dp .and. alpha >= 0.0_dp) then
      ds_d = d0_d*10.0_dp**(0.0679_dp*alpha)
    else if (alpha <= 12.5_dp .and. alpha > 5.0_dp) then
      ds_d = d0_d*0.381_dp*10.0_dp**(0.1516_dp*alpha)
    !else if (alpha <= 25.0_dp .and. alpha > 12.5_dp) then
    else
      ds_d = d0_d*14.296_dp*10.0_dp**(0.0258_dp*alpha)
    end if
  end if

  call Dhfunc(theta_e,phi_e,M,Dh)
  St = (f*h)/V
  dav = (dp_d+ds_d)/2.0_dp

  hdav = h/dav

  if (hdav >= 0.2_dp) then
    St_peak = (0.212_dp-0.0045_dp*psi)/(1.0_dp+0.235_dp*(1.0_dp/hdav)&
    -0.0132_dp*(1.0_dp/hdav)**2)
  else
    St_peak = 0.1_dp*(hdav)+0.095_dp-0.00243_dp*psi
  end if

  StSt_peak = St/St_peak

  call G4func(hdav,psi,G4)
  call G5func(hdav,psi,StSt_peak,G5)

  ! Keeping observer distance from getting too close to the turbine
  if (r < 1e-8_dp) then
    rc = 1e-8_dp
  else
    rc = r
  end if

  TEBVS = 10.0_dp*log10((h*M**(5.5_dp)*L*Dh)/rc**2)+G4+G5

end subroutine TEBVSfunc

! Computing the overall sound pressure level (OASPL) of a turbine defined below (in dB)
subroutine OASPL(n,ox,oy,oz,windvel,rpm,B,Hub,rad,c,c1,alpha,nu,c0,psi,AR,SPLoa)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  integer, intent(in) :: n,B
  real(dp), intent(in) :: ox,oy,oz,rpm,windvel,Hub,nu,c0,psi,AR
  real(dp), dimension(n), intent(in) :: rad
  real(dp), dimension(n-1), intent(in) :: c,c1,alpha
  ! out
  real(dp), intent(out) :: SPLoa
  ! local
  integer :: nf,bf,i,j,k,bi,di
  real(dp) :: pi,omega,atip,B_int,TBLTE,TBLTV,LBLVS,TEBVS
  real(dp), dimension(n-1) :: L,d,V,h,r,theta_e,phi_e
  real(dp), dimension((n-1)*B) :: TE_t,BLVS_t,BVS_t
  real(dp), dimension(B) :: TV_t
  real(dp), dimension(27) :: f,TE,TV,BLVS,BVS,SPLf,AdB
  real(dp), dimension(3) :: beta,SPLoa_d
  logical :: trip,tipflat
  intrinsic sqrt
  intrinsic sum
  intrinsic log10
  ! constants
  pi = 3.1415926535897932_dp
  nf = 27
  bf = 3

  ! Using untripped or tripped boundary layer specficiation
  trip = .false. ! untripped
  ! trip = .true. ! tripped

  ! Tip specfication
  tipflat = .false. ! round
  ! tipflat = .true. ! flat

  ! Parameters of the wind turbine
  omega = (rpm*2.0_dp*pi)/60.0_dp  ! angular velocity (rad/sec)

  do i = 1,n-1
    L(i) = rad(i+1)-rad(i) ! length of each radial section (m)
    d(i) = rad(i) ! radial section to be used in directivity calculations (m)
    V(i) = sqrt((omega*rad(i))**2+windvel**2) ! wind speed over the blade (m/s)
  end do

  h(1:n-1) = 0.01_dp*c(1:n-1)  ! trailing edge thickness; 1% of chord length (m)
  atip = alpha(n-1)  ! angle of attack of the tip region (deg)

  ! Blade rotation increments to rotate around (45 deg from Vargas paper)
  ! beta = (/0.0_dp,0.25_dp*pi,0.5_dp*pi,0.75_dp*pi,pi,1.25_dp*pi,1.5_dp*pi,1.75_dp*pi/) ! 8 increments
  beta = (/0.0_dp,2.0_dp*pi/9.0_dp,4.0_dp*pi/9.0_dp/) ! 3 increments (equivalent of 9 for 3 blades)
  ! beta = (/0.0_dp,pi/) ! 2 increments
  ! beta = (/0.0_dp/) ! 1 increment (top blade facing straight up)

  B_int = 2.0_dp*pi/B ! Intervals between blades (from the first blade at 0 deg)

  ! One-third octave band frequencies (Hz)
  f = (/100.0_dp,125.0_dp,160.0_dp,200.0_dp,250.0_dp,315.0_dp,400.0_dp,500.0_dp,&
  630.0_dp,800.0_dp,1000.0_dp,1250.0_dp,1600.0_dp,2000.0_dp,2500.0_dp,3150.0_dp,&
  4000.0_dp,5000.0_dp,6300.0_dp,8000.0_dp,10000.0_dp,12500.0_dp,16000.0_dp,&
  20000.0_dp,25000.0_dp,31500.0_dp,40000.0_dp/)

  ! A-weighting curve (dBA) for sound perception correction
  AdB = (/-19.145_dp,-16.190_dp,-13.244_dp,-10.847_dp,-8.675_dp,-6.644_dp,&
  -4.774_dp,-3.248_dp,-1.908_dp,-0.795_dp,0.0_dp,0.576_dp,0.993_dp,1.202_dp,&
  1.271_dp,1.202_dp,0.964_dp,0.556_dp,-0.114_dp,-1.144_dp,-2.488_dp,-4.250_dp,&
  -6.701_dp,-9.341_dp,-12.322_dp,-15.694_dp,-19.402_dp/)

  do di=1,bf ! for each rotation increment
    do j=1,nf ! for each frequency
      do bi=1,B ! for each blade
        ! Calcuating observer distances and directivty angles for the given blade orientation
        call direct(n-1,ox,oy,oz,c,c1,d,Hub,beta(di)+(bi-1)*B_int,r,theta_e,phi_e)

        call TBLTVfunc(f(j),V(n-1),c(n-1),r(n-1),theta_e(n-1),phi_e(n-1),atip,c0,&
        tipflat,AR,TBLTV)
        TV_t(bi) = TBLTV
        do k=1,n-1
          ! Calculating sound pressure level (dB) for each noise source at each radial position
          call TBLTEfunc(f(j),V(k),L(k),c(k),r(k),theta_e(k),phi_e(k),alpha(k),&
          nu,c0,trip,TBLTE)
          if (trip .eqv. .false.) then
            call LBLVSfunc(f(j),V(k),L(k),c(k),r(k),theta_e(k),phi_e(k),alpha(k),&
            nu,c0,trip,LBLVS)
          else
            LBLVS = 0.0_dp
          end if
          call TEBVSfunc(f(j),V(k),L(k),c(k),h(k),r(k),theta_e(k),phi_e(k),&
          alpha(k),nu,c0,psi,trip,TEBVS)

          ! Assigning noise to blade segment
          TE_t(k+(n-1)*(bi-1)) = TBLTE
          BLVS_t(k+(n-1)*(bi-1)) = LBLVS
          BVS_t(k+(n-1)*(bi-1)) = TEBVS
        end do
      end do

      ! Adding sound pressure levels (dB)
      TE(j) = 10.0_dp*log10(sum(10.0_dp**(TE_t/10.0_dp)))
      TV(j) = 10.0_dp*log10(sum(10.0_dp**(TV_t/10.0_dp)))
      BLVS(j) = 10.0_dp*log10(sum(10.0_dp**(BLVS_t/10.0_dp)))
      BVS(j) = 10.0_dp*log10(sum(10.0_dp**(BVS_t/10.0_dp)))

      ! Combining noise sources into overall SPL
      SPLf(j) = 10.0_dp*log10(10.0_dp**(TE(j)/10.0_dp)+10.0_dp**(TV(j)/&
      10.0_dp)+10.0_dp**(BLVS(j)/10.0_dp)+10.0_dp**(BVS(j)/10.0_dp))
    end do

    ! Correcting with A-weighting
    SPLf(1:nf) = SPLf(1:nf)+AdB(1:nf)

    ! Adding SPLs for each rotation increment
    SPLoa_d(di) = 10.0_dp*log10(sum(10.0_dp**(SPLf/10.0_dp)))

    ! Protecting total calcuation from negative SPL values
    if (SPLoa_d(di) < 0.0_dp) then
      SPLoa_d(di) = 0.0_dp
    end if
  end do

  ! Performing root mean square calculation of SPLs at rotation increments for final value
  SPLoa = sqrt(sum(SPLoa_d**2)/bf)

end subroutine OASPL

! Placing a turbine in a specified location and finding the OASPL of the turbine with reference to an observer
subroutine turbinepos(nturb,nseg,nobs,x,y,obs,winddir,windvel,rpm,B,Hub,&
  rad,c,c1,alpha,nu,c0,psi,AR,noise_corr,SPL_obs)
  implicit none
  integer, parameter :: dp = kind(0.d0)
  ! in
  integer, intent(in) :: nturb,nseg,nobs,B
  real(dp), intent(in) :: winddir,Hub,nu,c0,psi,AR,noise_corr
  real(dp), dimension(nturb), intent(in) :: x,y,rpm,windvel
  real(dp), dimension(nobs), intent(in) :: obs
  real(dp), dimension(nseg), intent(in) :: rad
  real(dp), dimension(nseg-1), intent(in) :: c,c1,alpha
  ! out
  real(dp), intent(out) :: SPL_obs
  ! local
  integer :: i
  real(dp) :: pi,windrad,ox,oy,oz,rxy,ang
  real(dp), dimension(nturb) :: tSPL
  intrinsic sqrt
  intrinsic sin
  intrinsic cos
  intrinsic atan2
  intrinsic abs
  intrinsic sum
  ! constants
  pi = 3.1415926535897932_dp

  windrad = (winddir+180.0_dp)*pi/180.0_dp

  do i = 1,nturb ! for each turbine
    ! Centering the turbine at (0,0) with repect to the observer location
    ox = obs(1)-x(i)
    oy = obs(2)-y(i)
    oz = obs(3)

    ! Adjusting the coordinates to turbine reference frame (wind moving in y-direction)
    rxy = sqrt(ox**2+oy**2)
    ang = atan2(oy,ox)+windrad

    ox = rxy*cos(ang)
    oy = rxy*sin(ang)

    ! Calculating the overall SPL of each of the turbines at the observer location
    call OASPL(nseg,ox,oy,oz,windvel(i),rpm(i),B,Hub,rad,c,c1,alpha,nu,c0,psi,AR,tSPL(i))
  end do

  ! Combining the SPLs from each turbine and correcting the value based on the wind farm
  SPL_obs = (10.0_dp*log10(sum(10.0_dp**(tSPL/10.0_dp))))*noise_corr

end subroutine turbinepos

! To build for Python interface:
! f2py -c  --opt=-O2 -m _bpmacoustic BPM_Acoustic_Model.f90
! python C:\Python27\Scripts\f2py.py -c --opt=-O2 --compiler=mingw32 --fcompiler=gfortran -m _bpmacoustic BPM_Acoustic_Model.f90


C     ******************************************************************
C     * ROUTINES TO CONVERT FROM MACH NUMBER TO OTHER NON-DIMENSIONAL  *
C     * COMPRESSIBLE FLOW QUANTITIES. USE F2PY TO COMPILE INTO A       *
C     * PYTHON MODULE.                                                 *
C     *                                                                *
C     * ALL ACCEPT THE SAME PARAMETERS,                                *
C     * Y, DOUBLE 1-D ARRAY : OUTPUT QUANTITY;                         *
C     * M, DOUBLE 1-D ARRAY : INPUT MACH NUMBER;                       *
C     * G, DOUBLE SCALAR : INPUT SPECIFIC HEAT RATIO;                  *
C     * N, INTEGER SCALAR : LENGTH OF ARRAYS (HIDDEN BY F2PY).         *
C     *                                                                *
C     * JAMES BRIND, DECEMBER 2020                                     *
C     ******************************************************************
C
      SUBROUTINE TO_T(Y,M,G,N)
C     1-(G-1)/2*M^2
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      GM1_2 = (G-1.0D0)*0.5D0
C     MAIN LOOP
      DO I=1,N
            Y(I) = 1.0D0 + GM1_2 * M(I) *M(I)
      ENDDO
      END
C
      SUBROUTINE PO_P(Y,M,G,N)
C     (1-(G-1)/2*M^2)^(G/(G-1))
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 G_GM1
      GM1_2 = (G-1.0D0)*0.5D0
      G_GM1 = G/(G-1.0D0)
C     MAIN LOOP
      DO I=1,N
            Y(I) = (1.0D0 + GM1_2 *M(I)*M(I) )**G_GM1
      ENDDO
      END
C
      SUBROUTINE RHOO_RHO(Y,M,G,N)
C     (1-(G-1)/2*M^2)^(1/(G-1))
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 RECIP_GM1
      GM1_2 = (G-1.0D0)*0.5D0
      RECIP_GM1 = 1.0D0/(G-1.0D0)
C     MAIN LOOP
      DO I=1,N
            Y(I) = (1.0D0 + GM1_2*M(I)*M(I))**RECIP_GM1
      ENDDO
      END
C
      SUBROUTINE V_CPTO(Y,M,G,N)
C     sqrt( (G-1)*M^2 / (1-(G-1)/2*M^2) )
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 GM1
      GM1_2 = (G-1.0D0)*0.5D0
      GM1 = G-1.0D0
C     MAIN LOOP
      DO I=1,N
C           NUMERIC FORM FOR LOW MA
            IF (M(I).lt.1.0D-2) THEN
                Y(I)=SQRT(GM1*M(I)*M(I)/(1.0D0+GM1_2*M(I)*M(I)))
            ELSE
C           NUMERIC FORM FOR HIGH MA
                Y(I)=SQRT(GM1/(1.0D0/M(I)/M(I)+GM1_2))
            ENDIF
      ENDDO
      END
C
      SUBROUTINE MCPTO_APO(Y,M,G,N)
C     G/SQRT(G-1)*M*(1+(G-1)/2*M^2)^(-(G+1)/(G-1)/2)
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 M_GP1_GM1_2
      REAL*8 GM1_2
      REAL*8 G_SQ_GM1
      GM1_2 = (G-1.0D0)/2.0D0
      M_GP1_GM1_2 = (G+1.0D0)/(G-1.0D0)/(-2.0D0)
      G_SQ_GM1 = G / SQRT(G-1.0D0)
C     MAIN LOOP
      DO I=1,N
        Y(I)=G_SQ_GM1*M(I)*(1.0D0+GM1_2*M(I)*M(I))**M_GP1_GM1_2
      ENDDO
      END
C
      SUBROUTINE MCPTO_AP(Y,M,G,N)
C     G/SQRT(G-1)*M*SQRT(1+(G-1)/2*M^2)
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 G_SQ_GM1
      GM1_2 = (G-1.0D0)/2.0D0
      G_SQ_GM1 = G / SQRT(G-1.0D0)
C     MAIN LOOP
      DO I=1,N
        Y(I)=G_SQ_GM1*M(I)*SQRT(1.0D0+GM1_2*M(I)*M(I))
      ENDDO
      END
C
      SUBROUTINE A_ACRIT(Y,M,G,N)
C     (2/(G+1)*(1+(G-1)/2*M^2))^((G+1)/(G-1)/2)/M
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GP1_GM1_2
      REAL*8 GM1_2
      REAL*8 GP1_2
      GM1_2 = (G-1.0D0)/2.0D0
      GP1_GM1_2 = (G+1.0D0)/(G-1.0D0)/2.0D0
      GP1_2 = (G+1.0D0)/2.0D0
C     MAIN LOOP
      DO I=1,N
        Y(I)=(((1.0D0+GM1_2*M(I)*M(I))/GP1_2)**GP1_GM1_2)/M(I)
      ENDDO
      END
C
      SUBROUTINE MASH(Y,M,G,N)
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 MSQ
      GM1_2 = (G-1.0D0)/2.0D0
C     MAIN LOOP
      DO I=1,N
        MSQ = M(I)*M(I)
C       NUMERIC FORM FOR LOW MA
        IF (MSQ.lt.1.0D-2) THEN
            Y(I)=SQRT((1.0D0+GM1_2*MSQ)/(G*MSQ-GM1_2))
C       NUMERIC FORM FOR HIGH MA
        ELSE
            Y(I)=SQRT((1.0D0/MSQ+GM1_2)/(G-GM1_2/MSQ))
        ENDIF
      ENDDO
      END
C
      SUBROUTINE POSH_PO(Y,M,G,N)
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 G_GM1
      REAL*8 M_GM1
      REAL*8 GP1_2
      REAL*8 G_GP1
      REAL*8 GM1_GP1
      REAL*8 MSQ
      GM1_2 = (G-1.0D0)/2.0D0
      G_GM1 = G/(G-1.0D0)
      G_GP1 = 2.0D0*G/(G+1.0D0)
      M_GM1 = (-1.0D0)/(G-1.0D0)
      GP1_2 = (G+1.0D0)/2.0D0
      GM1_GP1 = (G-1.0D0)/(G+1.0D0)
C     MAIN LOOP
      DO I=1,N
        MSQ = M(I)*M(I)
        Y(I)=(GP1_2/(1.0D0/MSQ+GM1_2))**G_GM1*(G_GP1*MSQ-GM1_GP1)**M_GM1
      ENDDO
      END


Subroutine BlockTDMA(Ap,Aw,Ae,B,X,M,N)
implicit none
integer k,M,N
real(8) Ap(M,M,N),Aw(M,M,N),Ae(M,M,N),B(M,N),X(M,N),c(M,M,N),d(M,N),invAp(M,M),Dp(M,M),invDp(M,M),Awc(M,M),Awd(M),cX(M)

c=0
d=0
Call invmatrix(invAp,Ap(:,:,1),M)
Call Matrixmultiply(invAp,Ae(:,:,1),c(:,:,1),M,M)
Call Matrixmultiply(invAp,B(:,1),d(:,1),M,1)
DO k=2,N
 Call Matrixmultiply(Aw(:,:,k),c(:,:,k-1),Awc,M,M)
 Call Matrixmultiply(Aw(:,:,k),d(:,k-1),Awd,M,1)
 Dp=Ap(:,:,k)-Awc
 Call invmatrix(invDp,Dp,M)
 Call Matrixmultiply(invDp,Ae(:,:,k),c(:,:,k),M,M)
 Call Matrixmultiply(invDp,B(:,k)+Awd,d(:,k),M,1)
end DO
X(:,N)=d(:,N)
DO k=N-1,1,-1
 Call Matrixmultiply(c(:,:,k),X(:,k+1),cX,M,1)
 X(:,k)=d(:,k)+cX
end DO

end Subroutine BlockTDMA

Subroutine invMatrix(invA,A,N)
implicit none
integer i,j,k,N,kp,iq
real(8) R,maxa,swap
real(8) invA(N,N),A(N,N),B(N,N)

B=0
DO i=1,N
 B(i,i)=1
end DO
DO k=1,N-1
 maxa=0
 kp=k
 DO i=k,N
  if(abs(A(i,k))>maxa) then
   maxa=abs(A(i,k))
   kp=i
  end if
 end DO
 if(kp/=k) then
  DO j=k,N
   swap=A(k,j)
   A(k,j)=A(kp,j)
   A(kp,j)=swap
  end DO
  DO j=1,N
   swap=B(k,j)
   B(k,j)=B(kp,j)
   B(kp,j)=swap
  end DO
 end if
 kp=k+1
 DO i=kp,N
  R=A(i,k)/A(k,k)
  DO j=kp,N
   A(i,j)=A(i,j)-R*A(k,j)
  end DO
  DO j=1,N
   B(i,j)=B(i,j)-R*B(k,j)
  end DO
 end DO
end DO
DO k=1,N
 invA(N,k)=B(N,k)/A(N,N)
 DO i=N-1,1,-1
  invA(i,k)=B(i,k)
  iq=i+1
  DO j=iq,N
   invA(i,k)=invA(i,k)-A(i,j)*invA(j,k)
  end DO
  invA(i,k)=invA(i,k)/A(i,i)
 end DO
end DO

end subroutine invmatrix

Subroutine Matrixmultiply(A,B,C,N,M)
implicit none
integer i,j,k,N,M
real(8) A(N,N),B(N,M),C(N,M)

C=0
DO j=1,M
 DO k=1,N
  DO i=1,N
   C(i,j)=C(i,j)+A(i,k)*B(k,j)
  end DO
 end DO
end DO

end subroutine Matrixmultiply


!Programa que usa el principio de recursividad para calcular el factorial de n

program recursividad
  implicit none
  integer num

  print *, "Ingrese un número entero menor a 4 bytes."
  read*, num

  print *, num,"! = ", factorial(num)

contains
  recursive function factorial(n) result(res)
    implicit none

    integer, intent(in) :: n
    integer res

    if (n == 0) then
       res = 1
    else
       res = n * factorial(n-1)
    end if

  end function factorial
end program recursividad


      INTEGER FUNCTION MA01CD( A, IA, B, IB )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute, without over- or underflow, the sign of the sum of two
C     real numbers represented using integer powers of a base (usually,
C     the machine base). Any base can be used, but it should the same
C     for both numbers. The result is an integer with value 1, 0, or -1,
C     depending on the sum being found as positive, zero, or negative,
C     respectively.
C
C     FUNCTION VALUE
C
C     MA01CD  INTEGER
C             The sign of the sum of the two numbers, which is usually
C             either 1, or -1. If both numbers are 0, or if they have
C             the same exponent and their sum is 0, the returned value
C             is 0.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     A       (input)  DOUBLE PRECISION
C             The first real scalar.
C
C     IA      (input)  INTEGER
C             Exponent of the base for the first real scalar. The scalar
C             is represented as A * BASE**(IA).
C
C     B       (input)  DOUBLE PRECISION
C             The first real scalar.
C
C     IB      (input)  INTEGER
C             Exponent of the base for the first real scalar. The scalar
C             is represented as B * BASE**(IB).
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Feb. 2010.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Computer arithmetic, overflow, underflow.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           IA, IB
      DOUBLE PRECISION  A, B
C     .. Local Scalars ..
      DOUBLE PRECISION  S, SA, SB
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, LOG, SIGN
C
C     .. Executable Statements ..
C
      IF( A.EQ.ZERO .AND. B.EQ.ZERO ) THEN
         MA01CD = 0
      ELSE IF( A.EQ.ZERO ) THEN
         MA01CD = SIGN( ONE, B )
      ELSE IF( B.EQ.ZERO ) THEN
         MA01CD = SIGN( ONE, A )
      ELSE IF( IA.EQ.IB ) THEN
         S = A + B
         IF( S.EQ.ZERO ) THEN
            MA01CD = 0
         ELSE
            MA01CD = SIGN( ONE, S )
         END IF
      ELSE
         SA = SIGN( ONE, A )
         SB = SIGN( ONE, B )
         IF( SA.EQ.SB ) THEN
            MA01CD = SA
         ELSE IF( IA.GT.IB ) THEN
            IF( ( LOG( ABS( A ) ) + IA - IB ).GE.LOG( ABS( B ) ) ) THEN
               MA01CD = SA
            ELSE
               MA01CD = SB
            END IF
         ELSE
            IF( ( LOG( ABS( B ) ) + IB - IA ).GE.LOG( ABS( A ) ) ) THEN
               MA01CD = SB
            ELSE
               MA01CD = SA
            END IF
         END IF
      END IF
C
      RETURN
C *** Last line of MA01CD ***
      END


program intrinsics_21
! Test mod / modulo intrinsics both declarations and executable statements.
! Single and double precision, real only.
integer, parameter :: dp = kind(0.d0)

real, parameter :: &
    s1 = modulo(-5., 3.), &
    s2 = modulo(5., -3.), &
    s3 = modulo(-5., -3.), &
    s4 = modulo(5., 3.), &
    s1b = mod(-5., 3.), &
    s2b = mod(5., -3.), &
    s3b = mod(-5., -3.), &
    s4b = mod(5., 3.)
real(dp), parameter :: &
    d1 = modulo(-5._dp, 3._dp), &
    d2 = modulo(5._dp, -3._dp), &
    d3 = modulo(-5._dp, -3._dp), &
    d4 = modulo(5._dp, 3._dp), &
    d1b = mod(-5._dp, 3._dp), &
    d2b = mod(5._dp, -3._dp), &
    d3b = mod(-5._dp, -3._dp), &
    d4b = mod(5._dp, 3._dp)
integer, parameter :: &
    j1 = modulo(-5, 3), &
    j2 = modulo(5, -3), &
    j3 = modulo(-5, -3), &
    j4 = modulo(5, 3), &
    j1b = mod(-5, 3), &
    j2b = mod(5, -3), &
    j3b = mod(-5, -3), &
    j4b = mod(5, 3)

real :: x1, x2
real(dp) :: y1, y2
integer :: i1, i2

i1 = -5; i2 = 3
x1 = i1; y1 = i1;
x2 = i2; y2 = i2;
print *, modulo(-5., 3.), modulo(-5._dp, 3._dp), modulo(x1, x2), modulo(y1, y2), s1, d1
print *, mod(-5., 3.), mod(-5._dp, 3._dp), mod(x1, x2), mod(y1, y2), s1b, d1b
print *, modulo(-5, 3), modulo(i1, i2), j1
print *, mod(-5, 3), mod(i1, i2), j1b

i1 = 5; i2 = -3
x1 = i1; y1 = i1;
x2 = i2; y2 = i2;
print *, modulo(5., -3.), modulo(5._dp, -3._dp), modulo(x1, x2), modulo(y1, y2), s2, d2
print *, mod(5., -3.), mod(5._dp, -3._dp), mod(x1, x2), mod(y1, y2), s2b, d2b
print *, modulo(5, -3), modulo(i1, i2), j2
print *, mod(5, -3), mod(i1, i2), j2b

i1 = -5; i2 = -3
x1 = i1; y1 = i1;
x2 = i2; y2 = i2;
print *, modulo(-5., -3.), modulo(-5._dp, -3._dp), modulo(x1, x2),modulo(y1, y2), s3, d3
print *, mod(-5., -3.), mod(-5._dp, -3._dp), mod(x1, x2), mod(y1, y2), s3b, d3b
print *, modulo(-5, -3), modulo(i1, i2), j3
print *, mod(-5, -3), mod(i1, i2), j3b

i1 = 5; i2 = 3
x1 = i1; y1 = i1;
x2 = i2; y2 = i2;
print *, modulo(5., 3.), modulo(5._dp, 3._dp), modulo(x1, x2), modulo(y1, y2), s4, d4
print *, mod(5., 3.), mod(5._dp, 3._dp), mod(x1, x2), mod(y1, y2), s4b, d4b
print *, modulo(5, 3), modulo(i1, i2), j4
print *, mod(5, 3), mod(i1, i2), j4b

end


program main
  implicit none
  integer(4) :: dow,mo,yr,ns

  ! Figure out day of week for each month
  dow = 1
  yr  = 1900
  ns  = 0

  do yr=1900,2000
     do mo=1,12
        if (yr>1900 .and. dow==0) then
           ns = ns + 1
        endif
        if (mo==1 & ! jan
             .or. mo==3 & ! mar
             .or. mo==5 & ! may
             .or. mo==7 & ! jul
             .or. mo==8 & ! aug
             .or. mo==10 & ! oct
             .or. mo==12) then ! dec
           dow = mod(dow+31,7)
        else if (mo==4 & ! apr
             .or. mo==6 & ! jun
             .or. mo==9 & ! sep
             .or. mo==11) then ! nov
           dow = mod(dow+30,7)
        else ! feb
           if (mod(yr,4)==0) then
              ! potential leap year
              if (mod(yr,100)==0) then
                 if (mod(yr,400)==0) then
                    ! leap year
                    dow = mod(dow+29,7)
                 else
                    ! no leap year
                    dow = mod(dow+28,7)
                 endif
              else
                 ! leap year
                 dow = mod(dow+29,7)
              endif
           endif
        endif
     enddo
  enddo

  write(*,*) "number of sundays on the first of the month: ",ns

end program main


cc Copyright (C) 2009: Zydrunas Gimbutas and Hong Xiao
cc Contact: Zydrunas Gimbutas <gimbutas@cims.nyu.edu>
cc          Hong Xiao <hxiao@ucdavis.edu>
cc
cc This software is being released under a modified FreeBSD license
cc (see COPYING in home directory).
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c       ... retrieve D_3 symmetric interpolation/quadrature rule for triangles
c
c       Input:
c
c       n - the interpolation degree (must not exceed 20)
c       vert1, vert2, vert3 - the vertices of the triangle
c
c       Output:
c
c       fort.11 - quadrature nodes and weights
c       fort.12 - quadrature nodes in gnuplot compatible format
c       fort.14 - triangle as constructed in gnuplot compatible format
c
c       in gnuplot:
c
c       plot 'fort.14' w l, 'fort.12'
c
c
        implicit real *8 (a-h,o-z)
        dimension rnodes(2,2000)
        dimension weights(2000)
        dimension vert1(2),vert2(2),vert3(2)
        dimension rints(2000),z(3),pols(100 000)
        dimension work(10 000 000)
c
c       SET ALL PARAMETERS
c
        call prini(6,13)
c
        PRINT *, 'ENTER n (1..20)'
        READ *, n
        call prinf('n=*',n,1)
c
c
        itype=1
c
        if( itype .eq. 1 ) then
c
c       ... standard equilateral triangle
c
c        (-1,-1/sqrt(3)), (1,-1/sqrt(3)), (0,2/sqrt(3))
c
        vert1(1)=-1
        vert1(2)=-1/sqrt(3.0d0)
        vert2(1)=+1
        vert2(2)=-1/sqrt(3.0d0)
        vert3(1)=0
        vert3(2)=2/sqrt(3.0d0)
c
        endif
c
        if( itype .eq. 2 ) then
c
c       ... standard simplex
c
        vert1(1)=0
        vert1(2)=0
        vert2(1)=1
        vert2(2)=0
        vert3(1)=0
        vert3(2)=1
c
        endif
c
c
c
c       ... retrieve D_3 symmetric inteerpolation/quadrature rule
c
        call triaintq(n,vert1,vert2,vert3,rnodes,
     1     weights,numnodes)
c
        call prinf('nummodes=*',numnodes,1)
        call prin2('rnodes=*',rnodes,2*numnodes)
        call prin2('weights=*',weights,numnodes)
c
        d=0
        do i=1,numnodes
        d=d+weights(i)
        enddo
c
        call prin2('sum of weights=*',d,1)
c
c       ... plot the triangle
c
        write(14,*) vert1(1),vert1(2)
        write(14,*) vert2(1),vert2(2)
        write(14,*) vert3(1),vert3(2)
        write(14,*) vert1(1),vert1(2)
c
c       ... dump the nodes into a file
c
        write(11,*) numnodes
        do i=1,numnodes
        write(11,1000) rnodes(1,i),rnodes(2,i),weights(i)
        write(12,*) rnodes(1,i),rnodes(2,i)
        enddo
 1010   format(i2)
 1000   format(4(e21.15,2x))
c

c
        mmax=n
c
c       construct the matrix of values of the orthogonal polynomials
c       at the user-provided nodes
c
        npols=(mmax+1)*(mmax+2)/2
c
c
        do 1200 j=1,npols
        rints(j)=0
 1200 continue
c
c
        do 2400 i=1,numnodes
c
        z(1)=rnodes(1,i)
        z(2)=rnodes(2,i)
c
        call ortho2eva(mmax,z,pols,work)
c
        do 2200 j=1,npols
c
        rints(j)=rints(j)+weights(i)*pols(j)

 2200 continue

 2400 continue
c
c
        call prin2('rints=*',rints,npols)
c
        area=sqrt(3.0d0)
c
        d=0
        d=(rints(1)-sqrt(area))**2
        do i=2,npols
        d=d+rints(i)**2
        enddo
c
        d=sqrt(d)/npols
c
        call prin2('error=*',d,1)
c

        stop
        end


PROGRAM meix

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

!       =========================================================
!       Purpose: This program computes the exponential integral
!                Ei(x) using subroutine EIX
!       Example:
!                  x        Ei(x)
!                -----------------------
!                  0    -.10000000+301
!                  1     .18951178E+01
!                  2     .49542344E+01
!                  3     .99338326E+01
!                  4     .19630874E+02
!                  5     .40185275E+02
!       =========================================================

DOUBLE PRECISION :: ei,x
WRITE(*,*)'Please enter x '
!        READ(*,*)X
x=5
WRITE(*,*)
WRITE(*,*)'   x         Ei(x)'
WRITE(*,*)'------------------------'
CALL eix(x,ei)
WRITE(*,10)x,ei
10      FORMAT(1X,f5.1,e18.8)
END PROGRAM meix

SUBROUTINE eix(x,ei)

!       ============================================
!       Purpose: Compute exponential integral Ei(x)
!       Input :  x  --- Argument of Ei(x)
!       Output:  EI --- Ei(x) ( x > 0 )
!       ============================================

DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: ei
IMPLICIT DOUBLE PRECISION (a-h,o-z)
IF (x == 0.0) THEN
  ei=-1.0D+300
ELSE IF (x <= 40.0) THEN
  ei=1.0D0
  r=1.0D0
  DO  k=1,100
    r=r*k*x/(k+1.0D0)**2
    ei=ei+r
    IF (DABS(r/ei) <= 1.0D-15) EXIT
  END DO
  20         ga=0.5772156649015328D0
  ei=ga+DLOG(x)+x*ei
ELSE
  ei=1.0D0
  r=1.0D0
  DO  k=1,20
    r=r*k/x
    ei=ei+r
  END DO
  ei=DEXP(x)/x*ei
END IF
RETURN
END SUBROUTINE eix


program tri_ppal

use residuotri_interface

implicit none

real(8), dimension(:), allocatable :: a, a_copia, b, b_copia,c ,c_copia,r, r_copia, res

integer :: n, i, j

real(8) :: deter

deter = 1.

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

allocate(a(n), a_copia(n), b(n-1), b_copia(n-1), c_copia(2:n), c(2:n), r(n), r_copia(n), res(n))

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

!print*,
!print*, 'Introduce a diagonal superior: '
!read*, b(1:n-1)
!print*,

!print*,
do i =1,n-1
  b(i) = 3
end do
do i =1,n
  a(i) = 1
end do
do i =2,n
  c(i) = 2
end do
!read*, c(2:n)
!print*,

do i =1,n
  r(i) = 4
end do

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

a_copia = a
b_copia = b
c_copia = c
r_copia = r

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

do i=2,n
  r(i)=r(i)-c(i)*r(i-1)
end do

r(n)=r(n)/a(n)

print*,
print*,18,r(18)
print*,19,r(19)
print*,20,r(20)
print*,

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

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

print*,'Penultimo z',c(2)
print*,'Ultimo z',c(n)
print*,'Primer x',a(1)
print*,'Segundo x',a(2)
print*,'Penultimo y',b(n-2)
print*,'Ultimo y',b(n-1)

do i =1,3
  print*,i,r(i)
end do

do i=1,n
  deter = deter * a(i)
end do

print*,'Deter',deter

print*,
print*, r
print*,

call residuotri(a_copia, c_copia, b_copia, r, r_copia, res)

end program


PROGRAM EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
USE LA_PRECISION, ONLY: WP => SP
USE F95_LAPACK, ONLY: LA_HPGVX
!  .. "Implicit Statement" ..
IMPLICIT NONE
!  .. "Local Scalars" ..
INTEGER :: I, J, N, ITYPE, IL, IU, M, INFO
REAL(WP), ALLOCATABLE :: W(:)
REAL(WP) :: ABSTOL
!  .. "Local Arrays" ..
INTEGER, ALLOCATABLE :: IFAIL(:)
COMPLEX(WP), ALLOCATABLE :: A(:), AA(:), B(:), BB(:), Z(:,:)
!  .. "Intrinsic Functions" ..
INTRINSIC AIMAG, INT
!  .. "Executable Statements" ..
print *, 'LA_HPGVX Example Program Results'
N = 5
ALLOCATE( A(N*(N+1)/2), AA(N*(N+1)/2), B(N*(N+1)/2), BB(N*(N+1)/2), &
          W(N), Z(N,N), IFAIL(N) )

OPEN(UNIT=21,FILE='hpgvu.ma',STATUS='old')
DO J=1,N*(N+1)/2
   READ(21,*) A(J)
ENDDO
CLOSE(21)

print *,'Matrix A:'
DO I=1,N*(N+1)/2
   WRITE(*,"('('(I3,1X,',',I3)')')") INT(A(I)), INT(AIMAG(A(I)))
ENDDO

OPEN(UNIT=21,FILE='hpgvu.mb',STATUS='old')
DO J=1,N*(N+1)/2
   READ(21,*) B(J)
ENDDO
CLOSE(21)

print *,'Matrix B:'
DO I=1,N*(N+1)/2
   WRITE(*,"('('(I3,1X,',',I3)')')") INT(B(I)), INT(AIMAG(B(I)))
ENDDO

print *, "CALL LA_HPGVX( A, B, W, 2, Z=Z, IL=4, IU=5, M=M, ", &
           "IFAIL=IFAIL, ABSTOL=1.0E-3_WP, INFO =INFO ) "
ITYPE=2; IL=4; IU=5; ABSTOL=1e-3
CALL LA_HPGVX( A, B, W, 2, Z=Z, IL=4, IU=5, M=M, &
               IFAIL=IFAIL, ABSTOL=1.0E-3_WP, INFO = INFO )

print *, 'W on exit:'
DO I=1,N
   WRITE(*,"(5(E14.6,1X))") W(I)
ENDDO

print *, 'IFAIL on exit : ',IFAIL

print *, 'M and INFO on exit:', M, INFO
print *, 'Z on exit : '
DO I=1,N
WRITE(*,"(5(1H(,2(F12.10,1X),1H),1X))") (Z(I,J), J = 1,M)
ENDDO

END PROGRAM


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
!     3/97
!
!     a program for testing slap, islap (ec, es, gc, gs)
!
!     (1) set a scalar field s as poly in x, y, z restricted to sphere
!
!     (2) compute scalar laplacian in array sclp using slap(ec, es, gc, gs)
!
!     (3) compare (2) with analytic scalar laplacian in sclpe
!
!     (4) compute the inverse  of (2) and compare with (1)
!
program tslap

    use spherepack

    ! Explicit typing only
    implicit none

    real(wp) :: cosp
    real(wp) :: cost
    real(wp) :: d2xdp2
    real(wp) :: d2xdt2
    real(wp) :: d2ydp2
    real(wp) :: d2ydt2
    real(wp) :: d2zdp2
    real(wp) :: d2zdt2
    real(wp) :: dlat
    real(wp) :: dphi
    real(wp) :: dxdp
    real(wp) :: dxdt
    real(wp) :: dydp
    real(wp) :: dydt
    real(wp) :: dzdp
    real(wp) :: dzdt
    real(wp) :: err2
    real(wp) :: err2s
    integer(ip) :: i
    integer(ip) :: icase
    integer(ip) :: error_flag
    integer(ip) :: j
    integer(ip) :: k
    real(wp) :: phi
    real(wp) :: sinp
    real(wp) :: sint
    real(wp) :: theta
    real(wp) :: x
    real(wp) :: y
    real(wp) :: z
    integer(ip), parameter :: nlat=15, nlon= 22, nt = 3
    integer(ip), parameter :: mdab = (nlon+2)/2
    integer(ip), parameter :: isym = 0
    real(wp), allocatable  :: wavetable(:)
    real(wp), dimension(mdab, nlat, nt) :: a, b
    real(wp), dimension(nlat, nlon, nt) :: s, se, sclp, sclpe
    real(wp), dimension(nt)             :: perturbation, xlm
    real(wp), dimension(nlat)           :: gaussian_latitudes, gaussian_weights
    real(wp), parameter                 :: ZERO = 0.0_wp, TWO = 2.0_wp

    ! Print dimension variables
    call iout(nlat, "nlat")
    call iout(nlon, "nlon")
    call iout(nt, "  nt")

    ! Set equally spaced colatitude and longitude increments
    dphi = TWO_PI/nlon
    dlat = PI/(nlat-1)

    ! Compute nlat-many gaussian points
    call compute_gaussian_latitudes_and_weights(nlat, &
        gaussian_latitudes, gaussian_weights, error_flag)

    call name("compute_gaussian_latitudes_and_weights")
    call iout(error_flag, " error_flag = ")
    call vecout(gaussian_latitudes, "gaussian_latitudes", nlat)

    ! Set helmholtz constant zero for laplacian inversion
    xlm = ZERO

    ! Test all laplacian and inversion routines
    do icase=1, 4
        call name("****")
        call name("****")
        call iout(icase, "icas")

        ! Set scalar field as poly in x, y, z restricted to the sphere
        do k=1, nt
            do j=1, nlon
                phi = real(j - 1, kind=wp) * dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, nlat
                    select case (icase)
                        case(0:2)
                            theta = real(i - 1, kind=wp) * dlat
                        case default
                            theta = gaussian_latitudes(i)
                    end select
                    cost = cos(theta)
                    sint = sin(theta)
                    x = sint*cosp
                    y = sint*sinp
                    z = cost
                    dxdt = cost*cosp
                    d2xdt2 = -x
                    dxdp = -cost*sinp
                    d2xdp2 = -x
                    dydt = cost*sinp
                    d2ydt2 = -y
                    dydp = cost*cosp
                    d2ydp2 = -y
                    dzdt = -sint
                    d2zdt2 = -z
                    dzdp = ZERO
                    d2zdp2 = ZERO
                    select case (k)
                        case (1)
                            s(i, j, k) = x+y
                            sclpe(i, j, k) = -TWO * (x+y)
                        case (2)
                            s(i, j, k) = x+z
                            sclpe(i, j, k) = -TWO * (x+z)
                        case (3)
                            s(i, j, k) = y+z
                            sclpe(i, j, k) = -TWO * (y+z)
                    end select
                end do
            end do
        end do

        ! Store exact solution
        se = s

        select case (icase)
            case (1)

                call name("**ec")

                call initialize_shaec(nlat, nlon, wavetable, error_flag)
                call name("shai")
                call iout(error_flag, "error_flag = ")

                call shaec(nlat, nlon, isym, nt, s, nlat, nlon, a, b, mdab, nlat, wavetable, error_flag)
                call name("sha ")
                call iout(error_flag, "error_flag = ")

                call initialize_shsec(nlat, nlon, wavetable, error_flag)
                call name("shsi")
                call iout(error_flag, "error_flag = ")

                call slapec(nlat, nlon, isym, nt, sclp, nlat, nlon, a, b, mdab, nlat, &
                    wavetable, error_flag)
                call name("slap")
                call iout(error_flag, "error_flag = ")
            case (2)

                call name("**es")

                call initialize_shaes(nlat, nlon, wavetable, error_flag)
                call name("shai")
                call iout(error_flag, "error_flag = ")

                call shaes(nlat, nlon, isym, nt, s, nlat, nlon, a, b, mdab, nlat, wavetable, error_flag)
                call name("sha ")
                call iout(error_flag, "error_flag = ")

                call initialize_shses(nlat, nlon, wavetable, error_flag)
                call name("shsi")
                call iout(error_flag, "error_flag = ")

                call slapes(nlat, nlon, isym, nt, sclp, nlat, nlon, a, b, mdab, nlat, &
                    wavetable, error_flag)
                call name("slap")
                call iout(error_flag, "error_flag = ")
            case (3)

                call name("**gc")

                call initialize_shagc(nlat, nlon, wavetable, error_flag)
                call name("shai")
                call iout(error_flag, "error_flag = ")

                call shagc(nlat, nlon, isym, nt, s, nlat, nlon, a, b, mdab, nlat, wavetable, error_flag)
                call name("sha ")
                call iout(error_flag, "error_flag = ")

                call initialize_shsgc(nlat, nlon, wavetable, error_flag)
                call name("shsi")
                call iout(error_flag, "error_flag = ")

                call slapgc(nlat, nlon, isym, nt, sclp, nlat, nlon, a, b, mdab, nlat, &
                    wavetable, error_flag)
                call name("slap")
                call iout(error_flag, "error_flag = ")
            case (4)

                call name("**gs")

                call initialize_shags(nlat, nlon, wavetable, error_flag)
                call name("shai")
                call iout(error_flag, "error_flag = ")

                call shags(nlat, nlon, isym, nt, s, nlat, nlon, a, b, mdab, nlat, wavetable, error_flag)
                call name("sha ")
                call iout(error_flag, "error_flag = ")

                call initialize_shsgs(nlat, nlon, wavetable, error_flag)
                call name("shsi")
                call iout(error_flag, "error_flag = ")

                call slapgs(nlat, nlon, isym, nt, sclp, nlat, nlon, a, b, mdab, nlat, &
                    wavetable, error_flag)
                call name("slap")
                call iout(error_flag, "error_flag = ")
        end select

        ! Compute discretization error" in sclp
        err2 = norm2(sclpe - sclp)
        call vout(err2, "err2")

        ! invert sclp
        s = ZERO
        select case (icase)
            case (1)

                call initialize_shaec(nlat, nlon, wavetable, error_flag)
                call shaec(nlat, nlon, isym, nt, sclp, nlat, nlon, a, b, mdab, nlat, &
                    wavetable, error_flag)

                call initialize_shsec(nlat, nlon, wavetable, error_flag)
                call name("shsi")
                call iout(error_flag, "error_flag = ")

                call islapec(nlat, nlon, isym, nt, xlm, s, nlat, nlon, a, b, mdab, nlat, &
                    wavetable, perturbation, error_flag)
                call name("isla")
                call iout(error_flag, "error_flag = ")
                call vecout(perturbation, "perturbation = ", nt)
            case (2)

                call initialize_shaes(nlat, nlon, wavetable, error_flag)
                call shaes(nlat, nlon, isym, nt, sclp, nlat, nlon, a, b, mdab, nlat, &
                    wavetable, error_flag)

                call initialize_shses(nlat, nlon, wavetable, error_flag)
                call name("shsi")
                call iout(error_flag, "error_flag = ")

                call islapes(nlat, nlon, isym, nt, xlm, s, nlat, nlon, a, b, mdab, nlat, &
                    wavetable, perturbation, error_flag)
                call name("isla")
                call iout(error_flag, "error_flag = ")
                call vecout(perturbation, "perturbation = ", nt)
            case (3)

                call initialize_shagc(nlat, nlon, wavetable, error_flag)
                call shagc(nlat, nlon, isym, nt, sclp, nlat, nlon, a, b, mdab, nlat, wavetable, error_flag)

                call initialize_shsgc(nlat, nlon, wavetable, error_flag)
                call name("shsi")
                call iout(error_flag, "error_flag = ")

                call islapgc(nlat, nlon, isym, nt, xlm, s, nlat, nlon, a, b, mdab, nlat, &
                    wavetable, perturbation, error_flag)
                call name("isla")
                call iout(error_flag, "error_flag = ")
                call vecout(perturbation, "perturbation = ", nt)
            case (4)

                call name("**gs")

                call initialize_shags(nlat, nlon, wavetable, error_flag)
                call shags(nlat, nlon, isym, nt, sclp, nlat, nlon, a, b, mdab, nlat, &
                    wavetable, error_flag)

                call initialize_shsgs(nlat, nlon, wavetable, error_flag)
                call name("shsi")
                call iout(error_flag, "error_flag = ")

                call islapgs(nlat, nlon, isym, nt, xlm, s, nlat, nlon, a, b, mdab, nlat, &
                    wavetable, perturbation, error_flag)
                call name("isla")
                call iout(error_flag, "error_flag = ")
                call vecout(perturbation, "perturbation = ", nt)
        end select

        ! Compare s with original
        err2s = norm2(se - s)
        call vout(err2s, "errs")
    end do

    ! Release memory
    deallocate (wavetable)

end program tslap


program P1011
    implicit none
    integer :: cases, i
    integer(8) :: x, y, even, odd
    read *, cases
    do i = 1, cases
        read *, x, y
        odd = 2 * int(ceiling(sqrt(real(y - x)))) - 1
        even = int(ceiling(sqrt(real(4 * (y - x) + 1)))) - 1
        write (*, '(I0)') min(odd, even)
    end do
end program P1011


SUBROUTINE interpolate_2D(x,y,z,z1_y1,z1_y2, z2_y1,z2_y2,x1,x2,y1,y2)
! Subroutine interpolates in two dimensions (x,y)
implicit none

real :: z1_y1, z2_y1 ! Values of x at y1
real :: z1_y2, z2_y2 ! Values of x at y2
real :: x1,x2,y1,y2,x,y,z, grad,inter
real :: grad1,grad2,inter1,inter2, z1,z2

!print*, 'Calling interpolate 2D'
!print*, x1,x2,y1,y2
!print*, z1_y1, z2_y1
!print*, z1_y2,z2_y2

grad1 = (z1_y2 - z1_y1)/(y2-y1)
inter1 = z1_y2-grad1*y2
z1 = grad1*y + inter1

grad2 = (z2_y2 - z2_y1)/(y2-y1)
inter2 = z2_y2-grad2*y2
z2 = grad2*y + inter2

grad = (z2-z1)/(x2-x1)
inter = z2 - grad*x2
z = grad*x + inter

!write(74,*)x/1.496e13,y,z,z1,z1_y1,z1_y2, z2,z2_y1,z2_y2, grad,inter

END SUBROUTINE interpolate_2D


program ej3
  implicit none

  !Programa que calcula sin(x) utilizando la serie de McLaurin

  real x, res
  integer n, precision, aux
  integer factorial
  res = 0

  print *, "Introduzca un valor real de x"
  read *, x

  print *, "Introduzca un valor real de la precisión a alcanzar (lim de la suma)"
  read *, precision

  do n = 0, precision
    res = real((x**n))/real(factorial(n)) + res
  end do

  print *, "e^(",x,") = ", res

end program ej3

integer function factorial(n)
  implicit none
  integer, intent(in) :: n
  integer(kind=16) i, ans

  ans = 1
  do i = 1, n
    ans = ans *i
  end do
  factorial = ans

end function factorial


	FUNCTION PR_UWND  ( sped, drct )
C************************************************************************
C* PR_UWND 								*
C*									*
C* This function computes UWND from SPED and DRCT or UKNT from SKNT	*
C* and DRCT.  The following equation is used:				*
C*									*
C*                  UWND = -SIN ( DRCT ) * SPED				*
C*									*
C* REAL PR_UWND  ( SPED, DRCT )						*
C*									*
C* Input parameters:							*
C*	SPED		REAL		Wind speed			*
C*	DRCT		REAL		Wind direction in degrees	*
C*									*
C* Output parameters:							*
C*	PR_UWND		REAL		U component			*
C**									*
C* Log:									*
C* P. Kocin/914		1980	Original source code			*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 8/88	Modified documentation			*
C************************************************************************
        INCLUDE 	'GEMPRM.PRM'
        INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( sped ) .or. ERMISS ( drct ) )  THEN
	    PR_UWND = RMISSD
	  ELSE
	    PR_UWND = (-SIN( drct * DTR )) * sped
	END IF
C*
	RETURN
	END


SUBROUTINE fourrow_sp(data,isign)

  USE nrtype; USE nrutil, ONLY : assert,swap

  IMPLICIT NONE
  COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data
  INTEGER(I4B), INTENT(IN) :: isign
  INTEGER(I4B) :: n,i,istep,j,m,mmax,n2
  REAL(DP) :: theta
  COMPLEX(SPC), DIMENSION(size(data,1)) :: temp
  COMPLEX(DPC) :: w,wp
  COMPLEX(SPC) :: ws

  n=size(data,2)
  call assert(iand(n,n-1)==0, 'n must be a power of 2 in fourrow_sp')
  n2=n/2
  j=n2
  do i=1,n-2
    if (j > i) call swap(data(:,j+1),data(:,i+1))
    m=n2
    do
      if (m < 2 .or. j < m) exit
      j=j-m
      m=m/2
    end do
    j=j+m
  end do
  mmax=1
  do
    if (n <= mmax) exit
    istep=2*mmax
    theta=PI_D/(isign*mmax)
    wp=cmplx(-2.0_dp*dsin(0.5_dp*theta)**2,dsin(theta),kind=dpc)
    w=cmplx(1.0_dp,0.0_dp,kind=dpc)
    do m=1,mmax
      ws=w
      do i=m,n,istep
        j=i+mmax
        temp=ws*data(:,j)
        data(:,j)=data(:,i)-temp
        data(:,i)=data(:,i)+temp
      end do
      w=w*wp+w
    end do
    mmax=istep
  end do
END SUBROUTINE fourrow_sp

SUBROUTINE fourrow_dp(data,isign)

  USE nrtype; USE nrutil, ONLY : assert,swap

  IMPLICIT NONE
  COMPLEX(DPC), DIMENSION(:,:), INTENT(INOUT) :: data
  INTEGER(I4B), INTENT(IN) :: isign
  INTEGER(I4B) :: n,i,istep,j,m,mmax,n2
  REAL(DP) :: theta
  COMPLEX(DPC), DIMENSION(size(data,1)) :: temp
  COMPLEX(DPC) :: w,wp

  COMPLEX(DPC) :: ws
  n=size(data,2)
  call assert(iand(n,n-1)==0, 'n must be a power of 2 in fourrow_dp')
  n2=n/2
  j=n2
  do i=1,n-2
    if (j > i) call swap(data(:,j+1),data(:,i+1))
    m=n2
    do
      if (m < 2 .or. j < m) exit
      j=j-m
      m=m/2
    end do
    j=j+m
  end do
  mmax=1
  do
    if (n <= mmax) exit
    istep=2*mmax
    theta=PI_D/(isign*mmax)
    wp=cmplx(-2.0_dp*dsin(0.5_dp*theta)**2,dsin(theta),kind=dpc)
    w=cmplx(1.0_dp,0.0_dp,kind=dpc)
    do m=1,mmax
      ws=w
      do i=m,n,istep
        j=i+mmax
        temp=ws*data(:,j)
        data(:,j)=data(:,i)-temp
        data(:,i)=data(:,i)+temp
      end do
      w=w*wp+w
    end do
    mmax=istep
  end do
END SUBROUTINE fourrow_dp


module gpfast
  implicit none
contains

  function kern(x0, x1, a)
    real(8) :: x0(:), x1(:), a, kern
    kern = exp(-sqrt(sum((x1-x0)**2))/(2*a**2))
  end function kern

  subroutine gp_matrix(x0, x1, a, K)
    real(8) :: x0(:,:), x1(:,:), a, K(:,:)
    integer :: k0, k1, n0, n1
    n0 = size(x0)
    n1 = size(x1)
    do k1 = 1, n1
      do k0 = 1, n0
        K(k0, k1) = kern(x0(:,k0), x1(:,k1), a)
      end do
    end do
  end subroutine gp_matrix

end module gpfast


DOUBLE PRECISION FUNCTION EVALFUNC(X,N)
  ! Interface to evaluate the objective function,
  ! for a design variable X with multiple N dimensions.
  !
  ! Igor A. Rodrigues Lopes
  ! 2015: Initial coding
  ! Mar 2021: Re-organised code with separate routines for different examples
  IMPLICIT NONE
  ! Parameters
  REAL(8) RP5 /0.5D0/
  REAL(8) R0 /0.0D0/
  REAL(8) R1 /1.0D0/
  REAL(8) R2 /2.0D0/
  REAL(8) R3 /3.0D0/
  ! Arguments
  INTEGER :: N
  REAL(8),DIMENSION(N) :: X
  ! ========================================================================================
  ! Select the appropriate problem by comment/uncommenting the appropriate lines
  ! call purelyQuadratic(EVALFUNC, X, N)
  call springs2(EVALFUNC, X, N)
  ! call springs6(EVALFUNC, X, N)
  ! call hyperelasticParameters(EVALFUNC, X, N)
  ! ========================================================================================
CONTAINS
  ! ========================================================================================
  subroutine purelyQuadratic(FValue, x, n)
    ! A purely quadratic function
    implicit none
    integer, intent(in) :: n
    real(8), dimension(n), intent(in) :: x
    real(8), intent(out) :: FValue
    !
    FValue = X(1)*X(1)-R3*X(1)*X(2)+R2*X(2)*R2*X(2)+X(1)-X(2)
  end subroutine purelyQuadratic
  ! ========================================================================================
  subroutine springs2 (energy, x, ndim)
    ! Minimization of the potential energy in a system with 2 springs (Vanderplaats, 1984).
    !
    ! Igor A. Rodrigues Lopes
    ! 2015: Initial coding
    ! ======================================================================================
    implicit none
    integer, intent(in)  :: ndim
    real(8), dimension(ndim), intent(in)  :: x
    real(8), intent(out) :: energy
    REAL(8) :: A1,A2,K1,K2,L1,L2,P1,P2 ! 2 spring
    ! Algorithm - 2 spring problem
    K1=8.0E0  ! Spring constant 1 (N/cm)
    K2=1.0E0  ! Spring constant 2 (N/cm)
    L1=10.0E0   ! Initial length 1 (cm)
    L2=10.0E0   ! Initial length 2 (cm)
    P1=5.0E0  ! Force 1 (N)
    P2=5.0E0  ! Force 2 (N)
    !
    A1=DSQRT(X(1)*X(1)+(L1-X(2))**2)
    A2=DSQRT(X(1)*X(1)+(L2+X(2))**2)
    energy=RP5*K1*(A1-L1)**2+RP5*K2*(A2-L2)**2-P1*X(1)-P2*X(2)
  end subroutine springs2
  ! ========================================================================================
  subroutine springs6 (energy, x, ndim)
    ! Minimization of the potential energy in a system with 6 springs (Vanderplaats, 1984).
    !
    ! Igor A. Rodrigues Lopes
    ! 2015: Initial coding
    ! ======================================================================================
    implicit none
    integer, intent(in)  :: ndim
    real(8), dimension(ndim), intent(in)  :: x
    real(8), intent(out) :: energy
    !
    REAL(8) R10 /10.0D0/
    REAL(8) R50 /50.0D0/
    INTEGER,PARAMETER :: NW=5, NS=6
    REAL(8),DIMENSION(NW) :: W
    REAL(8),DIMENSION(NS) :: K,DL,LO
    REAL(8) :: XO, YO, XN, YN
    integer :: i
    ! 6 spring problem
    XO=R0
    XN=60.0E0
    YO=R0
    YN=R0
    LO=10.0E0

    DO I=1,NW
       W(I)=R50*I
    ENDDO
    DO I=1,NS
       K(I)=R50*R10+R2*R10*R10*(NW/R3-I)*(NW/R3-I)
    ENDDO

    DL(1)=DSQRT((X(1)-XO)**R2+(X(2)-YO)**R2)-LO(1)
    DO I=2,NS-1
       DL(I)=DSQRT((X(2*I-1)-X(2*I-3))**R2+(X(2*I)-X(2*I-2))**R2)-LO(I)
    ENDDO
    DL(NS)=DSQRT((XN-X(2*NS-3))**R2+(YN-X(2*NS-2))**R2)-LO(NS)

    energy=R0
    DO I=1,NW
       energy=energy+W(I)*X(2*I)
    ENDDO
    DO I=1,NS
       energy=energy+RP5*K(I)*DL(I)*DL(I)
    ENDDO
  end subroutine springs6
  ! ========================================================================================
  subroutine hyperelasticParameters (FValue, x, ndim)
    ! Parameter identification for Ogden's hyperelastic model, given the stress response
    ! for uniaxial and biaxial deformation.
    !
    ! Igor A. Rodrigues Lopes
    ! 2015: Initial coding
    ! ======================================================================================
    implicit none
    integer, intent(in)  :: ndim
    real(8), dimension(ndim), intent(in)  :: x
    real(8), intent(out) :: FValue
    REAL(8),DIMENSION(10)   :: P1MUA, P2MUA, PMEB, LAMBDA, P1UA, P2UA, PEB
    REAL(8),DIMENSION(4)  :: AP, MUP
    REAL(8)         :: FUA, FEB, FC
    INTEGER         :: K, I
    ! ======================================================================================
    ! Hyperelastic parameter identification
    P1MUA(1)=49.1713758047908
    P1MUA(2)=95.5020609515927
    P1MUA(3)=139.194048890133
    P1MUA(4)=180.435931790392
    P1MUA(5)=219.403962336700
    P1MUA(6)=256.263042125065
    P1MUA(7)=291.167643234921
    P1MUA(8)=324.262668859696
    P1MUA(9)=355.684258151587
    P1MUA(10)=385.560539643794

    P2MUA(1)=24.1807151003576
    P2MUA(2)=47.3466758278295
    P2MUA(3)=69.5500055375245
    P2MUA(4)=90.8405113342239
    P2MUA(5)=111.265817399249
    P2MUA(6)=130.871490139650
    P2MUA(7)=149.701155567176
    P2MUA(8)=167.796609139805
    P2MUA(9)=185.197918133637
    P2MUA(10)=201.943516470978

    PMEB(1)=71.7371822572818
    PMEB(2)=136.769883566410
    PMEB(3)=195.863728736562
    PMEB(4)=249.697571912768
    PMEB(5)=298.874149043269
    PMEB(6)=343.929420777042
    PMEB(7)=385.340780268923
    PMEB(8)=423.534282861733
    PMEB(9)=458.891010936387
    PMEB(10)=491.752691255658

    LAMBDA(1)=1.02658363130423
    LAMBDA(2)=1.05387395206178
    LAMBDA(3)=1.08188974864453
    LAMBDA(4)=1.11065030683432
    LAMBDA(5)=1.14017542509914
    LAMBDA(6)=1.17048542822212
    LAMBDA(7)=1.20160118129295
    LAMBDA(8)=1.23354410407117
    LAMBDA(9)=1.26633618573131
    LAMBDA(10)=1.30000000000000

    IF(NDIM.NE.8.AND.NDIM.NE.6)THEN
      WRITE(*,*)'nr. of parameters for Ogden model must be 6 or 8, NDIM=',NDIM
      stop 1
    ENDIF
    DO I=1,NDIM/2
      AP(I)=X(I)
      MUP(I)=X(NDIM/2+I)
    ENDDO
    !
    P1UA=R0
    P2UA=R0
    PEB=R0
    FUA=R0
    FEB=R0
    FC=R0
    DO K=1,10
      DO I=1,NDIM/2
        P1UA(K)=P1UA(K)+MUP(I)*(LAMBDA(K)**(AP(I)-R1)-LAMBDA(K)**(-AP(I)-R1))
        P2UA(K)=P2UA(K)+MUP(I)*(R1-LAMBDA(K)**(-AP(I)))
        PEB(K)=PEB(K)+MUP(I)*(LAMBDA(K)**(AP(I)-R1)-LAMBDA(K)**(-R2*AP(I)-R1))
      ENDDO
      FUA=FUA+(P1UA(K)/P1MUA(K)-R1)**2+(P2UA(K)/P2MUA(K)-R1)**2
      FEB=FEB+(PEB(K)/PMEB(K)-R1)**2
    ENDDO
    FValue=FUA+FEB
  end subroutine hyperelasticParameters
  ! ========================================================================================
END FUNCTION


      FUNCTION expdev(idum)
      INTEGER idum
      REAL expdev
CU    USES ran1
      REAL dum,ran1
1     dum=ran1(idum)
      if(dum.eq.0.)goto 1
      expdev=-log(dum)
      return
      END

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


	program ising

    implicit  none

    ! The input parameters for this program are in "ising.in"
	! Variable declarations:

    integer :: i, j, m, n, m2, n2, i1   ! dummy integers

	integer, allocatable :: A(:,:)      ! matrix containing spins
	integer :: nrows, ncols             ! number  of rows  and  cols of A
	real :: temp, beta                  ! temperature, inverse temperature
	integer :: ConfigType               ! starting configuration type
	integer  :: npass                   ! number of passes for MC algorithm
	integer :: ipass                    ! the current pass number
	integer  :: nequil                  ! number of equilibration steps
	integer :: trial_spin               ! values of changed spin
	real :: high_temp                   ! starting temp for scan
	real :: low_temp                    ! final temp for scan
	real :: temp_interval               ! interval between scan points
	integer :: nscans                   ! number of scans (each at diff T)
	integer :: iscan,iscan1             ! current scan number
	real :: deltaU                      ! change in energy between 2 configs
	real :: deltaU1, deltaU2	        ! energy changes for lattice gas
	real :: log_eta                     ! log of random number to compare to
	real :: magnetization               ! magnetization of all spins in lattice
	real :: magnetization_ave           ! cumulative average magnetization
	real :: magnetization2_ave          ! cumulative average of mag. squared
	real :: energy                      ! energy of all spins in lattice
	real :: energy_ave                  ! cumulative average of energy
	real :: energy2_ave                 ! cumulative average of energy squared
	integer :: output_count             ! # times things have been added to averages

	real*8 :: ran0, rand_uniform

	print*, "   MONTE CARLO 2D ISING MODEL"
    print*, ""
	print*, "   Monte Carlo Statistics for 2D Ising Model with"
    print*, ""
    print*, "   periodic boundary conditions."
    print*, ""
    print*, "   The critical temperature is approximately 2.3, as seen on Chandler p. 123."
    print*, ""

    ! Read in input parameters from file "ising.in"

    open(unit=11,file='ising.in',status='old', action='read')
	read(11,*);
	read(11,*) nrows
	read(11,*);
	read(11,*) ncols
	read(11,*);
	read(11,*) npass
	read(11,*);
	read(11,*) nequil
	read(11,*);
	read(11,*) high_temp
	read(11,*);
	read(11,*) low_temp
	read(11,*);
	read(11,*) temp_interval
	read(11,*);
	read(11,*) ConfigType

	close(unit=11)

	! Set the dimensions of the matrix of spin arrays. This program uses
	! periodic boundary conditions, so the first two rows and columns are
	! the same as the last two.

    allocate(A(nrows+2,ncols+2))

	! Open output files:

    open(unit=32,file='spin-array',status='replace',action='write')
	write(32,*) nrows
	write(32,*) ncols
	nscans  =  int((high_temp  -  low_temp)/temp_interval)  +  1

	open(unit=33,file='magnetization',status='replace',action='write')
	write(33,*) "temp	ave_magnetization	ave_magnetization^2    susceptibility"
	open(unit=34,file='energy',status='replace',action='write')
	write(34,*)   "temp	ave_energy	ave_energy^2	C_v"
	scan_loop: do iscan = 1, nscans
	temp = high_temp - temp_interval*(iscan-1)
	print*, "Running program for T =", temp

	! Initialize variables

    beta  =  1.0/temp
	output_count   =   0
	energy_ave  =  0.0
	energy2_ave  =  0.0
	magnetization_ave  =  0.0
	magnetization2_ave  =  0.0

	! Set up the initial spin configuration.

    select case(ConfigType)
	case(1)  ! checkerboard setup
	A(1,1)  =  1
	do i = 1, nrows+1
	A(i+1,1)  =  -A(i,1)
	enddo
	do j = 1, ncols+1
	A(:,j+1)  =  -A(:,j)
	enddo
	case default
	print*, "Error! Check ConfigType parameter in ising.in"
	stop
	end select

	! Main loop containing Monte Carlo algorithm:

    MC_passes: do ipass = 0, npass

	! If ipass is greater than nequil (the number of equilibration steps),
	! calculate the magnetization and energy:

    if (ipass > nequil) then
	output_count  =  output_count  +  1
	magnetization     =     sum(A(2:nrows+1,2:nrows+1))/(ncols*nrows*1.0)
	magnetization_ave  =  magnetization_ave  +  magnetization
	magnetization2_ave   =   magnetization2_ave   +   magnetization**2
	energy  =  0.0
	do i = 2, nrows + 1
	do j = 2, ncols + 1
	energy = energy - A(m,n)*(A(m-1,n)+A(m+1,n)+A(m,n-1)+A(m,n+1))
	enddo
	enddo

	! Divide the energy by the total number of spins to get the ave
	! energy per spin, and divide by 2 to account for double counting.
	energy  =  energy/(ncols*nrows*2.0)
	energy_ave  =  energy_ave  +  energy
	energy2_ave  =  energy2_ave  +  energy**2
	endif

	! Randomly choose a spin to change:
	ran0=rand_uniform()
	m  = nint((nrows-1)*ran0 + 2)   ! choose a random row
	ran0=rand_uniform()
	n = nint((ncols-1)*ran0 + 2)   ! choose a random column
	trial_spin = -A(m,n)	! trial spin value
	! Find change in energy (deltaU) due to trial move.
	! If exp(-beta*deltaU) > eta, where eta is random, accept move:
	deltaU    =    -trial_spin*(A(m-1,n)+A(m+1,n)+A(m,n-1)+A(m,n+1))*2
	ran0=rand_uniform()
	log_eta = dlog(ran0 + 1.0d-10)   ! random number 0-1 (+ tiny offset)
	if (-beta*deltaU  >  log_eta)  then
	A(m,n)  =  trial_spin
	if (m == 2) A(nrows+2,n) = trial_spin
	if (m == nrows+1) A(1,n) = trial_spin
	if (n == 2) A(m,ncols+2) = trial_spin
	if (n == ncols+1) A(m,1) = trial_spin
	endif
	enddo MC_passes

	write(33,*)   temp,   abs(magnetization_ave/output_count),   &
	magnetization2_ave/output_count,         &
	beta*(magnetization2_ave/output_count - (magnetization_ave/output_count)**2)
	write(34,*)    temp,    energy_ave/output_count,    energy2_ave/output_count,    &
	(beta**2)*(energy2_ave/output_count - (energy_ave/output_count)**2)
	enddo  scan_loop
	close(32)
	close(33)
	close(34)
	open(40,file='temperature.dat',status= 'replace')
	write(40,*)    "temperature", "	i" ,"	 j","	spin A(i,j)"
	scan_loop1:do iscan1 = 1, nscans
	do i = 2, nrows + 1
	do j = 2, ncols + 1
        temp = high_temp - temp_interval*(iscan1-1)
	print*,  temp, i , j, A(i,j)
	write(40,*)   temp, i , j, A(i,j)
	enddo
	enddo
	enddo scan_loop1
	close(40)
	print*, "Program ising.f90 complete!"

	end program ising

!!########### UNIFORM RANDOM NUMBER GENERATOR ############

	function rand_uniform()

	  IMPLICIT REAL*8(A-H,O-Z)

! ----- variables for portable seed setting -----
	  INTEGER, DIMENSION(:), ALLOCATABLE :: ia_seed
	  INTEGER, DIMENSION(1:8) :: idt_seed
! ----- end of variables for seed setting -----

! ----- Set up random seed portably -----
	  CALL RANDOM_SEED(size=i_seed)
	  ALLOCATE(ia_seed(1:i_seed))
	  CALL RANDOM_SEED(get=ia_seed)
	  CALL DATE_AND_TIME(values=idt_seed)
	  ia_seed(i_seed)=idt_seed(8)
	  ia_seed(1)=idt_seed(8)*idt_seed(7)*idt_seed(6)
	  CALL RANDOM_SEED(put=ia_seed)
	  DEALLOCATE(ia_seed)
! ----- Done setting up random seed -----

	  CALL RANDOM_NUMBER(r)
	  rand_uniform = r

	  return

	end function rand_uniform


! Exercise 1, p. 62
!
! Calculating the temperature due to cold front passage

program ex_1

    use iso_fortran_env, only: real32, output_unit

    implicit none

    real(real32), parameter :: temp1 = 12.  ! temperature in Atlanta (°C)
    real(real32), parameter :: temp2 = 24.  ! temperature in Miami (°C)

    real(real32), parameter :: dx = 960.    ! distance between Atlanta & Miami (km)
    real(real32), parameter :: c = 20.      ! speed in km/h

    real(real32), parameter :: dt = 24.     ! time (h)

    real(real32) :: temp_result

    ! update temperature in Miami
    temp_result = temp2 - c * (temp2 - temp1) / dx * dt

    ! print result to screen
    write(output_unit, *) "Temperature after", dt, " hours is" , temp_result, "degrees."

end program ex_1


! $UWHPSC/codes/fortran/builtinfcns.f90

program builtinfcns

    implicit none
    real (kind=8) :: pi, x, y

    ! compute pi as arc-cosine of -1:
    pi = acos(-1.d0)  ! need -1.d0 for full precision!

    x = cos(pi)
    y = sqrt(exp(log(pi)))**2

    print *, "pi = ", pi
    print *, "x = ", x
    print *, "y = ", y

end program builtinfcns


module grid_utils

implicit none

private
public :: refineField, coarsenField

contains

subroutine refineField(field_src,field_dst,ratio)
  real, intent(in) :: field_src(:,:)
  real, intent(out) :: field_dst(:,:)
  integer, intent(in) :: ratio

  integer :: i,j
  integer :: i2,j2
  integer :: isub,jsub
  integer :: im,jm
  integer :: im_dst,jm_dst
  integer :: im_src,jm_src

  real :: a,b
  real :: w1,w2,w3,w4

  if (ratio == 1) then
    field_dst = field_src
    return
  end if

  ! Get size of source field:
  im_src = size(field_src, dim=1)
  jm_src = size(field_src, dim=2)

  ! Compute the size of target field:
  im = (im_src-1) *ratio + 1
  jm = (jm_src-1) *ratio + 1

  ! Get size of the target field dummy argument:
  im_dst = size(field_dst, dim=1)
  jm_dst = size(field_dst, dim=2)

  if (im_dst > im .or. jm_dst > jm) then
    write(*,*) 'RefineField: ERROR: &
              & Source field smaller than required by the target field size:'
    write(*,*) 'Source field:                im_src,jm_src = ',im_src,jm_src
    write(*,*) 'Interpolates to:                    im,jm  = ',im,jm
    write(*,*) 'Target field dummy argument: im_dst,jm_dst = ',im_dst,jm_dst
    return
  end if

  field_dst = 0

  ! Outer loop over the coarse grid:
  do j=1,jm_src-1
    do i=1,im_src-1
      i2 = (i-1)*ratio+1
      j2 = (j-1)*ratio+1
      do jsub=0,ratio-1
        do isub=0,ratio-1
          a = 1.-isub/real(ratio)
          b = 1.-jsub/real(ratio)
          w1 = a*b
          w2 = b*(1.-a)
          w3 = a*(1.-b)
          w4 = (1.-a)*(1.-b)
          field_dst(i2+isub,j2+jsub) = w1*field_src(i  ,j  )&
                                      +w2*field_src(i+1,j  )&
                                      +w3*field_src(i  ,j+1)&
                                      +w4*field_src(i+1,j+1)
        end do
      end do
    end do
  end do

  ! Close last row:
  do i=1,im_src-1
    i2 = (i-1)*ratio+1
    do isub=0,ratio-1
      w1 = 1.-isub/real(ratio)
      w2 = 1.-w1
      field_dst(i2+isub,jm) = w1*field_src(i,jm_src)&
                             +w2*field_src(i+1,jm_src)
    end do
  end do

  ! Close last column:
  do j=1,jm_src-1
    j2 = (j-1)*ratio+1
    do jsub=0,ratio-1
      w1 = 1.-jsub/real(ratio)
      w2 = 1.-w1
      field_dst(im,j2+jsub) = w1*field_src(im_src,j)&
                             +w2*field_src(im_src,j+1)
    end do
  end do

  ! Close top-right corner:
  field_dst(im,jm) = field_src(im_src, jm_src)

end subroutine refineField

subroutine coarsenField(field_src, field_dst, ratio)
  real, intent(in) :: field_src(:,:)
  real, intent(out) :: field_dst(:,:)
  integer, intent(in) :: ratio

  integer :: i,j
  integer :: isub,jsub
  integer :: im,jm

  integer :: stride

  real :: invNumPoints

  invNumPoints = (1 / dble(ratio))**2
  stride = ratio - 1

  im = size(field_dst, dim=1)
  jm = size(field_dst, dim=2)

  ! Loop over the coarse grid and average values from the fine grid:
  do j = 1, jm
    jsub = (j - 1) * ratio + 1
    do i = 1, im
      isub = (i - 1) * ratio + 1
      field_dst(i,j) = sum(field_src(isub:isub+stride,jsub:jsub+stride)) * invNumPoints
    end do
  end do

end subroutine coarsenField

end module grid_utils


program main
    implicit none
    integer, parameter :: li = selected_int_kind(10)
    integer, parameter :: dp = selected_real_kind(8)

    integer(li) :: a, b, m! 乘子, 增量, 模数
    common /group1/ a, b, m
    real(dp) :: x, y, z
    integer :: i

    interface
        function Lehmer_linear_congruential(seed_)
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            integer, intent(in), optional :: seed_
            real(dp) :: Lehmer_linear_congruential
        end function Lehmer_linear_congruential
    end interface

    m = 2**31
    a = 2**16 + 3
    b = 0
    open(unit=11, file='1.1.1.2-IBM-RANDU.txt', status='replace')
    do i = 1,10000
        x = Lehmer_linear_congruential()
        y = Lehmer_linear_congruential()
        z = Lehmer_linear_congruential()
        write(11, '(3f16.8)') x, y, z
    end do
    close(11)
end program main

function Lehmer_linear_congruential(seed_)
    ! Lehmer 线性同余法产生 [0,1) 区间上的均匀随机数
    implicit none
    integer, parameter :: li = selected_int_kind(10)
    integer, parameter :: dp = selected_real_kind(8)

    integer, intent(in), optional :: seed_
    real(dp) :: Lehmer_linear_congruential

    integer(li) :: a, b, m! 乘子, 增量, 模数
    common /group1/ a, b, m
    integer(li), save :: I_n = -1
    if (present(seed_)) then
        I_n = seed_
    else if (I_n == -1) then
        I_n = 1
    end if
    I_n = mod((a * I_n + b), m)
    Lehmer_Linear_Congruential = I_n / dble(m)
end function Lehmer_Linear_Congruential