spline.F90       coverage:  0.00 %func     0.00 %block


     1)   module spline_module
     2) 
     3) #include "petsc/finclude/petscsys.h"
     4)   
     5)   public
     6)   
     7)   contains
     8) 
     9) ! ************************************************************************** !
    10) 
    11) subroutine spline(x,y,n,y2)
    12) 
    13) 
    14) !----------------------description-------------------------------------!
    15) !
    16) !     cubic spline second derivative.
    17) !
    18) !     press, w.h., b.p. flannery, s.a. teukolsky, and w.t. vetterling.
    19) !     1986.  numerical recipes, the art of scientific computing,
    20) !     cambridge university press, cambridge.  pp. 86-89.
    21) 
    22)   use PFLOTRAN_Constants_module
    23) 
    24)       implicit none
    25)       
    26)       PetscInt :: i,n,k
    27)       PetscReal :: x(n),y(n),y2(n),u(n)
    28)       PetscReal :: sig,p,qn,un
    29) 
    30)       y2(1) = 0.d0
    31)       u(1) = 0.d0
    32)       do i = 2,n-1
    33)         sig = (x(i)-x(i-1))/(x(i+1)-x(i-1))
    34)         p = sig*y2(i-1)+2.d0
    35)         y2(i) = (sig-1.d0)/p
    36)         u(i) = (6.d0*((y(i+1)-y(i))/(x(i+1)-x(i)) - &
    37)         (y(i)-y(i-1))/(x(i)-x(i-1)))/ &
    38)         (x(i+1)-x(i-1)) - sig*u(i-1))/p
    39)       enddo
    40)       qn = 0.d0
    41)       un = 0.d0
    42)       y2(n) = (un-qn*u(n-1))/(qn*y2(n-1)+1.d0)
    43)       do k = n-1,1,-1
    44)         y2(k) = y2(k)*y2(k+1)+u(k)
    45)       enddo
    46) 
    47)       return
    48)       end subroutine spline
    49) 
    50) ! ************************************************************************** !
    51) 
    52) subroutine splint(xa,ya,y2a,n,x,y)
    53) 
    54) !     cubic spline interpolation.
    55) 
    56) !     press, w.h., b.p. flannery, s.a. teukolsky, and w.t. vetterling.
    57) !     1986.  numerical recipes, the art of scientific computing,
    58) !     cambridge university press, cambridge.  pp. 86-89.
    59) 
    60) 
    61)       implicit none
    62)       PetscInt :: n,k,klo,khi
    63)       PetscReal :: xa(n),ya(n),y2a(n)
    64)       PetscReal :: h,a,b,x,y
    65) 
    66)       klo = 1
    67)       khi = n
    68)    10 continue
    69)       if (khi-klo.gt.1) then
    70)         k = (khi+klo)/2
    71)         if (xa(k).gt.x) then
    72)           khi = k
    73)         else
    74)           klo = k
    75)         endif
    76)         goto 10
    77)       endif
    78)       h = xa(khi)-xa(klo)
    79)       a = (xa(khi)-x)/h
    80)       b = (x-xa(klo))/h
    81)       y = a*ya(klo)+b*ya(khi)+ &
    82)           ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.d0
    83) !     y1a = (ya(khi)-ya(klo))/h - &
    84) !           ((3.d+0*(a**2)-1.d+0)/6.d+0)*h*y2a(klo) + &
    85) !           ((3.d+0*(b**2)-1.d+0)/6.d+0)*h*y2a(khi)
    86) 
    87)       return
    88)       end subroutine splint
    89) 
    90) ! ************************************************************************** !
    91) 
    92) subroutine locate(xx,n,x,j)
    93) 
    94) !     given an array xx of length n, and given a value x, returns a
    95) !     value j such that x is between xx(j) and xx(j+1).  xx must be
    96) !     monotonic, either increasing or decreasing.  j=0 or j=n is 
    97) !     returned to indicate that x is out of range.
    98) !
    99) !     press, w.h., b.p. flannery, s.a. teukolsky, and w.t. vetterling.
   100) !     1986.  numerical recipes, the art of scientific computing.
   101) !     cambridge university press, cambridge.
   102) 
   103)       implicit none
   104)       PetscInt :: jl,ju,jm,j,n
   105)       PetscReal :: xx(n)
   106)       PetscReal :: x
   107)       
   108)       jl = 0
   109)       ju = n+1
   110)    10 continue
   111)       if (ju-jl.gt.1) then
   112)         jm = (ju+jl)/2
   113)         if ((xx(n).gt.xx(1)).eqv.(x.gt.xx(jm))) then
   114)           jl = jm
   115)         else
   116)           ju = jm
   117)         endif
   118)         goto 10
   119)       endif
   120)       j = jl
   121) 
   122)       return
   123)       end subroutine locate
   124) 
   125)   end module spline_module

generated by
Intel(R) C++/Fortran Compiler code-coverage tool
Web-Page Owner: Nobody