module STATE_INIT

implicit none
! The initializations are always carried out in QUAD as to prevent rare problems
! which could arise due to catastrophic cancellation.
integer,parameter  ::  ik = selected_int_kind(9)
integer,parameter  ::  dk = selected_real_kind(33)
integer,parameter  ::  qk = selected_real_kind(33)

contains

subroutine DINIT_KS(R0_d,V0_d,t0_d,mu,DU,TU,u0,Vpot_d)
! Description:
!     Starting from dimensional Cartesian coordinates and time, initializes the extended state
!     vector of the Kustaanheimo-Stiefel formulation (from now on "KS"). We try to follow the
!     naming convention used in "Stiefel E. L., Scheifele G. - Linear and Regular Celestial
!     Mechanics, 1974".
!
! ==============================================================================================
!
!                                            PREAMBLE
!
! ==============================================================================================

! VARIABLES
implicit none
! Arguments
real(dk),intent(in)     ::  R0_d(1:3),V0_d(1:3)  ! Dimensional position and velocity [km,km/s]
real(dk),intent(in)     ::  t0_d                 ! Dimensional time [s]
real(qk),intent(in)     ::  mu                   ! Grav parameter of the main body [km^3/s^2]
real(qk),intent(in)     ::  DU,TU                ! Ref. quantities for ND [km,1/s]
real(dk),intent(in)     ::  Vpot_d               ! Dimensional potential [km^2/s^2]
real(dk),intent(out)    ::  u0(:)                ! Extended KS state vector

! Locals
! -- State vectors and associated quantities
real(dk)            ::  x0(1:4)              ! Radius vector in R^4, ND
real(dk)            ::  xdot0(1:4)           ! Velocity vector in R^4, ND
real(dk)            ::  t0                   ! Initial time, ND
real(dk)            ::  r                    ! Radius magnitude, ND
! -- Energies and potentials
real(dk)            ::  h                    ! Total energy, ND
real(dk)            ::  Ksq                  ! Grav parameter of the main body, ND
real(dk)            ::  Kin                  ! Kinetic energy, ND
real(dk)            ::  Vpot                 ! Perturbing potential, ND

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

! STATE VECTOR DICTIONARY
! u(1:4)        u1,...,u4; KS-position, in R^4
! u(5:8)        u1',...,u4'; KS-velocity, in R^4
! u(9)          h; (-total energy) = (-Keplerian energy) + (-potential)
! u(10)         t; non-dimensional physical time

! ==============================================================================================
! 01. INITIALIZE POSITION AND VELOCITY IN R^4, NON-DIMENSIONALIZATIONS
! ==============================================================================================

x0(1:3) = R0_d/DU
x0(4)   = 0._dk
r       = sqrt(dot_product(x0,x0))
t0      = t0_d*TU

xdot0(1:3) = V0_d/(DU*TU)
xdot0(4)   = 0._dk

! Also, non-dimensionalize potential and grav parameter
Vpot = Vpot_d/(DU*TU)**2_ik
Ksq  = mu/(DU**3_ik*TU**2_ik)

! ==============================================================================================
! 02. INITIALIZE KS-POSITION AND KS-VELOCITY (state vector u)
! ==============================================================================================

! KS-POSITION
if ( x0(1) >= 0.) then
    u0(1) = 0._dk
    u0(4) = sqrt(.5_dk*(r + x0(1)) - u0(1)**2_ik)
    u0(2) = (x0(2)*u0(1) + x0(3)*u0(4))/(r + x0(1))
    u0(3) = (x0(3)*u0(1) - x0(2)*u0(4))/(r + x0(1))
else
    u0(2) = 0._dk
    u0(3) = sqrt(.5_dk*(r - x0(1)) - u0(2)**2_ik)
    u0(1) = (x0(2)*u0(2) + x0(3)*u0(3))/(r - x0(1))
    u0(4) = (x0(3)*u0(2) - x0(2)*u0(3))/(r - x0(1))
end if

! KS-VELOCITY
u0(5) = .5_dk*dot_product(u0(1:3),xdot0(1:3))
u0(6) = .5_dk*dot_product([-u0(2),u0(1),u0(4)],xdot0(1:3))
u0(7) = .5_dk*dot_product([-u0(3),-u0(4),u0(1)],xdot0(1:3))
u0(8) = .5_dk*dot_product([u0(4),-u0(3),u0(2)],xdot0(1:3))

! Total energy
Kin   = .5_dk*dot_product(xdot0,xdot0)
h     = Ksq/r - Kin - Vpot
u0(9) = h

! Initial time
u0(10) = t0

end subroutine DINIT_KS

function DFTIME_2D(R,V,mu)
! Computes the initial value of the fictitious time as the eccentric
! anomaly (for elliptic orbits) or Gudermannian anomaly (for hyperbolic orbits)
! for the K-S formulation.
! Only works for 2D.

! VARIABLES
implicit none
! Inputs
real(qk)  ::  R(1:3),V(1:3),mu
! Function definition
real(dk)  ::  DFTIME_2D
! Locals
real(dk)  ::  vsq,rv
real(dk)  ::  rN
real(dk)  ::  e_vec(1:3),ecc
real(dk)  ::  lon_per
real(dk)  ::  R_ep(1:2)
real(dk)  ::  f0

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

! Compute eccentricity and eccentricity vector
vsq = dot_product(V,V)
rv  = dot_product(R,V)
rN = sqrt(dot_product(R,R))
e_vec = ((vsq - mu/rN)*R - rv*V)/mu
ecc = sqrt(dot_product(e_vec,e_vec))

! Compute true anomaly
lon_per = atan2(e_vec(2),e_vec(1))
R_ep = [R(1)*cos(lon_per) + R(2)*sin(lon_per),&
-R(1)*sin(lon_per) + R(2)*cos(lon_per)]/rN
f0   = atan2(R_ep(2),R_ep(1))

! Compute fictitious time
if (ecc <= 1._dk) then
    ! s0 = Eccentric anomaly
    DFTIME_2D = atan2(sqrt(1._dk - ecc**2)*sin(f0),(ecc + cos(f0)))
else
    ! s0 = Gudermannian anomaly
    DFTIME_2D = 2._dk*atan(sqrt((ecc-1._dk)/(ecc+1._dk))*tan(.5_dk*f0))
end if

end function DFTIME_2D

function DHYPAN(R,V)
! Computes hyperbolic anomaly from DIMENSIONLESS R,V; where the reference
! quantities are "DU" for the length and "TU = sqrt(DU**3/mu)" for time.
real(qk)  ::  R(1:3), V(1:3)
real(qk)  ::  vsq,rmag,En,rv
real(dk)  ::  DHYPAN

vsq = dot_product(V,V)
rmag = sqrt(dot_product(R,R))
En  = .5_qk*vsq - 1._qk/rmag
rv  = dot_product(R,V)
DHYPAN = atanh((sqrt(2._qk*En)*rv)/(1._qk + 2._qk*En*rmag))

end function DHYPAN

subroutine DINIT_EDROMO(R0,V0,t0,DU,TU,z0,phi0,W_d,flag_time)
! Description:
!    Initializes the state vector for the EDromo formulation, starting from Cartesian
!    coordinates.
!
! Author:
!    Davide Amato
!    Space Dynamics Group
!    Technical University of Madrid
!    d.amato@upm.es
!    Last revision: 05-09-2015
! ==============================================================================================
!
!                                            PREAMBLE
!
! ==============================================================================================

! VARIABLES
implicit none

! Arguments
integer(ik),parameter   ::  neq = 8		        ! Number of elements of EDromo state vector
real(dk),intent(in)     ::  R0(1:3),V0(1:3)		! Dimensional position and velocity [km,km/s]
real(qk),intent(in)     ::  DU,TU               ! Ref. quantities for non-dimensionalization
real(dk),intent(in)     ::  phi0                ! Initial phi value
real(dk),intent(in)     ::  t0               	! Initial time value [s]
real(dk),intent(in)     ::  W_d                 ! Potential [km^2/s^2]
integer(ik),intent(in)  ::  flag_time		    ! = 0 physical time
         								        ! = 1 constant time element
								                ! = 2 linear time element
real(dk),intent(out)    ::  z0(1:neq)           ! EDromo state vector

! Local variables
real(dk)  ::  y(1:6)           		            ! Cartesian state vector, ND
real(dk)  ::  r0mag,v0mag      	                ! Radius and velocity magnitudes, ND
real(dk)  ::  rv0                               ! r dot v, ND
real(dk)  ::  h0(1:3),hmag0    	                ! Initial angular momentum and magnitude
real(dk)  ::  pot0           		            ! Potential, ND
real(dk)  ::  totEn0           		            ! Initial total energy, ND
real(dk)  ::  c0                                ! Generalized angular momentum
real(dk)  ::  cph,sph
real(dk)  ::  nu0,cnu,snu          	            ! Auxiliary variables
real(dk)  ::  i_vec(1:3),j_vec(1:3),k_vec(1:3)  ! Orbital frame unit vectors in inertial RF
real(dk)  ::  x_vec(1:3),y_vec(1:3)             ! Intermediate frame unit vectors in inertial RF
real(dk)  ::  aux                	            ! Auxiliary variables
real(dk)  ::  zero             		            ! Reference machine zero

! ==============================================================================================
!
!                                            EXECUTION
!
! ==============================================================================================

! ==============================================================================================
! 01. NON-DIMENSIONALIZATION
! ==============================================================================================
y(1:3) = R0/DU
y(4:6) = V0/(DU*TU)
pot0   = W_d/(DU*TU)**2_ik

! Compute machine zero for comparisons
zero = 10._dk*epsilon(0._dk)

! ==============================================================================================
! 02. IN-PLANE ELEMENTS
! ==============================================================================================
r0mag = sqrt(dot_product(y(1:3),y(1:3)))
v0mag = sqrt(dot_product(y(4:6),y(4:6)))

cph = cos(phi0)
sph = sin(phi0)

! Total energy
totEn0  = .5_dk*v0mag**2_ik - 1._dk/r0mag + pot0

! Angular momentum
h0 = DCROSS_PRODUCT(y(1:3),y(4:6))
hmag0 = sqrt(dot_product(h0,h0))

! Generalized angular momentum
c0 = sqrt(hmag0**2_ik + 2._dk*r0mag**2_ik*pot0)

! Dot product
rv0 = dot_product(y(1:3),y(4:6))

! IN-PLANE ELEMENTS
z0(1) = (1._dk + 2._dk*totEn0*r0mag)*cph + rv0*sqrt(-2._dk*totEn0)*sph
z0(2) = (1._dk + 2._dk*totEn0*r0mag)*sph - rv0*sqrt(-2._dk*totEn0)*cph
z0(3) = -1._dk/(2._dk*totEn0)

! ==============================================================================================
! 03. QUATERNION ELEMENTS
! ==============================================================================================

nu0 = phi0 + 2._dk*atan2(rv0,(c0 + r0mag*sqrt(-2._dk*totEn0)))
cnu = cos(nu0); snu = sin(nu0)

! Orbital frame unit vectors in IRF
i_vec = y(1:3)/r0mag
k_vec = h0/hmag0
j_vec = DCROSS_PRODUCT(k_vec,i_vec)

! Intermediate frame unit vectors in IRF
x_vec = i_vec*cnu - j_vec*snu
y_vec = j_vec*cnu + i_vec*snu

! SAFE INITIALIZATION OF THE QUATERNION
! The arguments of the roots have to be always positive, therefore we can safely use ABS()
aux = abs(1._dk + x_vec(1) + y_vec(2) + k_vec(3))
z0(7) = .5_dk*sqrt(aux)
! Check for singularities and NaNs
if ( aux <= zero ) then
    aux    = abs((.5_dk*(k_vec(3) + 1._dk)))
    z0(6)  = sqrt(aux)
    if ( aux <= zero ) then
        aux   = abs(.5_dk*(1._dk - y_vec(2)))
        z0(4) = sqrt(aux)
        if ( aux <= zero ) then
            z0(5) = 1._dk
        else
            z0(5) = y_vec(1)/(2._dk*z0(4))
        end if
    else
        z0(4) = k_vec(1)/(2._dk*z0(6))
        z0(5) = k_vec(2)/(2._dk*z0(6))
    end if
else
    z0(4) = (y_vec(3) - k_vec(2))/(4._dk*z0(7))
    z0(5) = (k_vec(1) - x_vec(3))/(4._dk*z0(7))
    z0(6) = (x_vec(2) - y_vec(1))/(4._dk*z0(7))
end if

! ==============================================================================
! 04. TIME / TIME ELEMENT
! ==============================================================================

if ( flag_time == 0_ik ) then
    ! Physical time
    z0(8) = t0*TU
elseif  ( flag_time == 1_ik ) then
    ! Constant time element
    z0(8) = t0*TU + z0(3)**1.5_dk*(z0(1)*sph - z0(2)*cph - phi0)
elseif  ( flag_time == 2_ik ) then
    ! Linear time element
    z0(8) = t0*TU + z0(3)**1.5_dk*(z0(1)*sph - z0(2)*cph)
end if

end subroutine DINIT_EDROMO

subroutine DINIT_GDROMO(R0,V0,t0,DU,TU,z0,phi0,W_d,flag_time)
! Description:
!    Initializes the state vector for the EDromo formulation, starting from Cartesian
!    coordinates.
!
! Author:
!    Davide Amato
!    Space Dynamics Group
!    Technical University of Madrid
!    d.amato@upm.es
!    Last revision: 05-09-2015
! ==============================================================================================
!
!                                            PREAMBLE
!
! ==============================================================================================

! VARIABLES

implicit none

! Arguments
integer(ik),parameter   ::  neq = 8		        ! Number of elements of HDromo state vector
real(dk),intent(in)     ::  R0(1:3),V0(1:3)		! Dimensional position and velocity [km,km/s]
real(qk),intent(in)     ::  DU,TU               ! Ref. quantities for non-dimensionalization
real(dk),intent(in)     ::  phi0                ! Initial phi value
real(dk),intent(in)     ::  t0               	! Initial time value [s]
real(dk),intent(in)     ::  W_d                 ! Potential [km^2/s^2]
integer(ik),intent(in)  ::  flag_time		    ! = 0 physical time
         								        ! = 1 constant time element
								                ! = 2 linear time element
real(dk),intent(out)    ::  z0(:)               ! HDromo state vector

! Local variables
real(dk)  ::  y(1:6)           		            ! Cartesian state vector, ND
real(dk)  ::  r0mag,v0mag      	                ! Radius and velocity magnitudes, ND
real(dk)  ::  h0(1:3),hmag0    	                ! Initial angular momentum and magnitude
real(dk)  ::  uu0,u0,lam0,s0      	            ! Initial radial and tangential velocities
real(dk)  ::  pot0           		            ! Potential, ND
real(dk)  ::  totEn0           		            ! Initial total energy, ND
real(dk)  ::  hg0,ecg0                          ! Generalized angular momentum and eccentricity
real(dk)  ::  cnu_0,snu_0          	            ! Auxiliary variables
real(dk)  ::  zeta,gamma          	            ! Auxiliary variables
real(dk)  ::  aux,aux1,aux2      	            ! Auxiliary variables
real(dk)  ::  zero             		            ! Reference machine zero
real(dk)  ::  xO_0(1:3),yO_0(1:3),zO_0(1:3)     ! Unit vectors of the LVLH reference frame (orbital frame)
real(dk)  ::  xI_0(1:3),yI_0(1:3)				! Unit vectors of the intermediate reference frame

! ==============================================================================================
!
!                                            EXECUTION
!
! ==============================================================================================

! ==============================================================================================
! 01. NON-DIMENSIONALIZATION
! ==============================================================================================
y(1:3) = R0/DU
y(4:6) = V0/(DU*TU)
pot0   = W_d/(DU*TU)**2_ik

! Compute machine zero for comparison
zero = 10._dk*epsilon(0._dk)

! ==============================================================================================
! 02. CONVERSION TO HDROMO ELEMENTS
! ==============================================================================================

r0mag = sqrt(dot_product(y(1:3),y(1:3)))
v0mag = sqrt(dot_product(y(4:6),y(4:6)))

! Radial velocity
uu0 = dot_product(y(1:3),y(4:6))
u0 = uu0/r0mag
! Angular momentum
h0 = DCROSS_PRODUCT(y(1:3),y(4:6))
hmag0 = sqrt(dot_product(h0,h0))
! Tangential velocity
lam0 = hmag0/r0mag

! Generalized transverse velocity
s0 = sqrt(lam0**2_ik + 2._dk*pot0)

! Total energy
totEn0  = v0mag**2_ik/2._dk - 1._dk/r0mag + pot0

z0(1) = (1._dk + 2._dk*totEn0*r0mag)*cosh(phi0) - uu0*sqrt(2._dk*totEn0)*sinh(phi0)
z0(2) = -(1._dk + 2._dk*totEn0*r0mag)*sinh(phi0) + uu0*sqrt(2._dk*totEn0)*cosh(phi0)
z0(3) = 1._dk/(2._dk*totEn0)

! Generalized angular momentum
hg0 = r0mag*s0

! Generalized eccentricity
ecg0 = sqrt(z0(1)**2_ik - z0(2)**2_ik)

! SAFE INITIALIZATION OF THE QUATERNION
! Auxiliary variables
zeta = z0(1)*sinh(phi0) + z0(2)*cosh(phi0)
gamma = sqrt(z0(1)**2_ik + z0(2)**2_ik)
aux1 = u0*hg0/(ecg0*gamma)
aux2 = (hg0**2_ik/r0mag - 1._dk)/(ecg0*gamma)

! Cosine and sine of the angle of rotation nu between the LVLH and the intermediate frames
cnu_0 = z0(1)*aux2 - z0(2)*aux1
snu_0 = z0(1)*aux1 + z0(2)*aux2

! x-y-z unit vectors of the LVLH reference frame (orbital frame)
xO_0 = y(1:3)/r0mag
zO_0 = h0/hmag0
yO_0 = DCROSS_PRODUCT(zO_0,xO_0)
! x-y-z unit vectors of the intermediate reference frame
xI_0 = xO_0*cnu_0 - yO_0*snu_0
yI_0 = xO_0*snu_0 + yO_0*cnu_0
! zI_0 = zO_0

! The arguments of the roots have to be always positive, therefore we can safely use ABS()
aux = abs(1._dk + xI_0(1) + yI_0(2) + zO_0(3))
z0(7) = .5_dk*sqrt(aux)
! Check for singularities and nans
if ( aux <= zero ) then
    aux    = abs((.5_dk*(zO_0(3) + 1._dk)))
    z0(6)  = sqrt(aux)
    if ( aux <= zero ) then
        aux   = abs((.5_dk*(1._dk-yI_0(2))))
        z0(4) = SQRT(aux)
        if ( aux <= zero ) then
            z0(5) = 1._dk
        else
            z0(5) = 1._dk/(2._dk*z0(4)) * yI_0(1)
        end if
    else
        z0(4) = 1._dk/(2._dk*z0(6)) * zO_0(1)
        z0(5) = 1._dk/(2._dk*z0(6)) * zO_0(2)
    end if
else
    z0(4) = 1._dk/(4._dk*z0(7))*( yI_0(3) - zO_0(2) )
    z0(5) = 1._dk/(4._dk*z0(7))*( zO_0(1) - xI_0(3) )
    z0(6) = 1._dk/(4._dk*z0(7))*( xI_0(2) - yI_0(1) )
end if

! Time/Time Element
if ( flag_time == 0_ik ) then
	! Physical time
    z0(8) = t0*TU
elseif  ( flag_time == 1_ik ) then
    ! Constant time element
    z0(8) = t0*TU - z0(3)**1.5_dk*(zeta - phi0)
elseif  ( flag_time == 2 ) then
    ! Linear time element
    z0(8) = t0*TU - z0(3)**1.5_dk*zeta
end if

end subroutine DINIT_GDROMO

function DCROSS_PRODUCT(a,b)
! Description:
!    Computes cross product of a*b.
!
! ==============================================================================

! VARIABLES
implicit none
! Function definition
real(dk)        :: DCROSS_PRODUCT(1:3)
! Arguments IN
real(dk)        :: a(1:3),b(1:3)

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

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

end function DCROSS_PRODUCT

end module


subroutine antialias2d(yh)
! performs 2d antialias 2/3 filter on vector yh
! zeros out modes (Nx/2 - b) ... (Nx/2) and (-Nx/2 + 1) ... (-Nx / 2 + b)
! === Parameters ===
! yh - 1d solution in fourier space. Wave
! === Output ===
! yh - anti aliased 1d solution in fourier space
    complex(dp), intent(inout)  :: yh(:,:)
    integer :: NpX, aX, bX, NpY, aY, bY

    NpX = size(yh, 1)
    NpY = size(yh, 2)

    aX  = NpX / 2
    bX  = NpX / 6

    aY  = NpY / 2
    bY  = NpY / 6

    yh( aX + 1 - bX : aX + 1 + bX, : ) = 0.0_dp;
    yh( : , aY + 1 - bY : aY + 1 + bY ) = 0.0_dp;

end subroutine antialias2d


c  Program TXPHO_ROUTINES

	INCLUDE 'VICMAIN_FOR'

	SUBROUTINE MAIN44

        INCLUDE 'pho'

	integer cnt, i, num, MillMode, TillMode, SunShadow, ViewShadow, status
	real*4 temp
c	real*8 dval1, IncAng, EmAng, PhasAng, pval
	real*8 dval1, pval
	real*8 MIllum(3),TIllum(3) !Illum(1,2,3)=[cos(inc),cos(em),cos(phase)]
	character*132 msg
	character*(pho_max_func_name_length) cval1
c	character*8 cval1
c	character*(pho_max_key_length) keylist(4)
	character*(pho_max_keywd_length) keylist(pho_max_param_func)

	integer pho

	call xvmessage(' program PHO_TEST', ' ')
	call xvmessage( ' ', ' ')

	call xveaction(' ',' ')

	call pho_init( pho, status)
c get the photometric function and there input parameters from the PDF
c and set these in the photometric object :

	call pho_get_Parms( pho, status)

	i = 0

c get the list of parameter keywords for the current photometric function :

	call pho_get_keys( pho, keylist, num, status)

c get the photometric function name :

	call pho_get_func( pho, cval1, status)

	msg = ' Function = '//cval1
	call xvmessage( msg, ' ')

	call xvmessage( ' ', ' ')

	  write( msg, 1000)  num
1000	  format( 'parameter number = ', i4)
	  call xvmessage( msg, ' ')

	do i=1,num
	  call pho_get_val( pho, keylist(i), dval1, status)
	  write( msg, 1010) keylist(i), dval1
1010	  format( a<pho_max_keywd_length>, ' = ', 1pe10.3)
	  call xvmessage( msg, ' ')
	enddo

c  reads in the function arguments from the PDF :

	call xvp('INC_ANG', temp, cnt)
	MIllum(1) = temp

	call xvp('EM_ANG', temp, cnt)
	MIllum(2) = temp

	call xvp('PHAS_ANG', temp, cnt)
	MIllum(3) = temp

	call xvmessage( ' ', ' ')

	write( msg, 1001) MIllum(1)
1001	format(' Incidence Angle = ', 1pd10.3)
	call xvmessage( msg, ' ')

	write( msg, 1002) MIllum(2)
1002	format(' Emission Angle = ', 1pd10.3)
	call xvmessage( msg, ' ')

	write( msg, 1003) MIllum(3)
1003	format(' Phase Angle = ', 1pd10.3)
	call xvmessage( msg, ' ')

	call xvmessage( ' ', ' ')

c get the bidirectional reflectance value :

	MillMode = illEllCos
	MIllum(1)=cos(MIllum(1)*rad_deg)
	MIllum(2)=cos(MIllum(2)*rad_deg)
	MIllum(3)=cos(MIllum(3)*rad_deg)

	SunShadow = illNoShadow
	ViewShadow = illNoShadow
	call pho_bidi_ref(pho,MillMode,SunShadow,ViewShadow,MIllum,pval,status)

	write( msg, 1004) pval
1004	format(' Bidirectional Reflectance Value = ', 1pd10.3)
	call xvmessage( msg, ' ')

c get the photometric function value :

	MillMode = illEllCos
	call pho_func(pho, MillMode, SunShadow, ViewShadow, MIllum,
     f	pval, status)

	write( msg, 1005) pval
1005	format(' Photometric Function value = ', 1pd10.3)
	call xvmessage( msg, ' ')

c get the photometric correction function value to nadir :

	MillMode = illEllCos
	TillMode = illEllCos

	TIllum(1) =1.0
	TIllum(2) =1.0
	TIllum(3) =1.0

	call pho_correct(pho,MillMode,SunShadow,ViewShadow,MIllum,
     f  TillMode,SunShadow,ViewShadow,TIllum,pval,status)

	write( msg, 1006) pval
1006	format(' to-nadir Correction Value = ', 1pd10.3)
	call xvmessage( msg, ' ')

	call xvmessage( ' ', ' ')

	call pho_free( pho, status)
	return
	end


      subroutine matinx2 ( a ,ierror)

c	'exact' inversion of 4 X 4 matrix

      implicit real*4 ( a-h, o-z )

      dimension a ( 4 , 4 ) , b ( 4 , 4 )
c      dimension c(4,4)
      integer i , j

      ierror=0
      absmax = 0.

      do 5010 i = 1 , 4
      do 5010 j = 1 , 4
c          c(i,j)=a(i,j)
	  if ( abs ( a ( i , j ) ) .gt. absmax ) absmax =abs( a ( i , j ))
5010  continue

      if ( absmax .eq. 0. ) then
c          stop 'singularity problem in matinx2'
	  ierror=1
          return
      end if

      fabsmx = 1.d00 / absmax

      do 5020 i = 1 , 4
      do 5020 j = 1 , 4
	  a ( i , j ) = a ( i , j ) * fabsmx
5020  continue

      b(1,1) = a(2,2) * a(3,3) * a(4,4) + a(2,3) * a(3,4) * a(4,2)
     1 + a(2,4) * a(3,2) * a(4,3) - a(2,2) * a(3,4) * a(4,3)
     2 - a(2,3) * a(3,2) * a(4,4) - a(2,4) * a(3,3) * a(4,2)
      b(2,1) = a(2,3) * a(3,1) * a(4,4) + a(2,4) * a(3,3) * a(4,1)
     1 + a(2,1) * a(3,4) * a(4,3) - a(2,3) * a(3,4) * a(4,1)
     2 - a(2,4) * a(3,1) * a(4,3) - a(2,1) * a(3,3) * a(4,4)
      b(3,1) = a(2,4) * a(3,1) * a(4,2) + a(2,1) * a(3,2) * a(4,4)
     1 + a(2,2) * a(3,4) * a(4,1) - a(2,4) * a(3,2) * a(4,1)
     2 - a(2,1) * a(3,4) * a(4,2) - a(2,2) * a(3,1) * a(4,4)
      b(4,1) = a(2,1) * a(3,3) * a(4,2) + a(2,2) * a(3,1) * a(4,3)
     1 + a(2,3) * a(3,2) * a(4,1) - a(2,1) * a(3,2) * a(4,3)
     2 - a(2,2) * a(3,3) * a(4,1) - a(2,3) * a(3,1) * a(4,2)
      b(1,2) = a(3,2) * a(4,4) * a(1,3) + a(3,3) * a(4,2) * a(1,4)
     1 + a(3,4) * a(4,3) * a(1,2) - a(3,2) * a(4,3) * a(1,4)
     2 - a(3,3) * a(4,4) * a(1,2) - a(3,4) * a(4,2) * a(1,3)
      b(2,2) = a(3,3) * a(4,4) * a(1,1) + a(3,4) * a(4,1) * a(1,3)
     1 + a(3,1) * a(4,3) * a(1,4) - a(3,3) * a(4,1) * a(1,4)
     2 - a(3,4) * a(4,3) * a(1,1) - a(3,1) * a(4,4) * a(1,3)
      b(3,2) = a(3,4) * a(4,2) * a(1,1) + a(3,1) * a(4,4) * a(1,2)
     1 + a(3,2) * a(4,1) * a(1,4) - a(3,4) * a(4,1) * a(1,2)
     2 - a(3,1) * a(4,2) * a(1,4) - a(3,2) * a(4,4) * a(1,1)
      b(4,2) = a(3,1) * a(4,2) * a(1,3) + a(3,2) * a(4,3) * a(1,1)
     1 + a(3,3) * a(4,1) * a(1,2) - a(3,1) * a(4,3) * a(1,2)
     2 - a(3,2) * a(4,1) * a(1,3) - a(3,3) * a(4,2) * a(1,1)
      b(1,3) = a(4,2) * a(1,3) * a(2,4) + a(4,3) * a(1,4) * a(2,2)
     1 + a(4,4) * a(1,2) * a(2,3) - a(4,2) * a(1,4) * a(2,3)
     2 - a(4,3) * a(1,2) * a(2,4) - a(4,4) * a(1,3) * a(2,2)
      b(2,3) = a(4,3) * a(1,1) * a(2,4) + a(4,4) * a(1,3) * a(2,1)
     1 + a(4,1) * a(1,4) * a(2,3) - a(4,3) * a(1,4) * a(2,1)
     2 - a(4,4) * a(1,1) * a(2,3) - a(4,1) * a(1,3) * a(2,4)
      b(3,3) = a(4,4) * a(1,1) * a(2,2) + a(4,1) * a(1,2) * a(2,4)
     1 + a(4,2) * a(1,4) * a(2,1) - a(4,4) * a(1,2) * a(2,1)
     2 - a(4,1) * a(1,4) * a(2,2) - a(4,2) * a(1,1) * a(2,4)
      b(4,3) = a(4,1) * a(1,3) * a(2,2) + a(4,2) * a(1,1) * a(2,3)
     1 + a(4,3) * a(1,2) * a(2,1) - a(4,1) * a(1,2) * a(2,3)
     2 - a(4,2) * a(1,3) * a(2,1) - a(4,3) * a(1,1) * a(2,2)
      b(1,4) = a(1,2) * a(2,4) * a(3,3) + a(1,3) * a(2,2) * a(3,4)
     1 + a(1,4) * a(2,3) * a(3,2) - a(1,2) * a(2,3) * a(3,4)
     2 - a(1,3) * a(2,4) * a(3,2) - a(1,4) * a(2,2) * a(3,3)
      b(2,4) = a(1,3) * a(2,4) * a(3,1) + a(1,4) * a(2,1) * a(3,3)
     1 + a(1,1) * a(2,3) * a(3,4) - a(1,3) * a(2,1) * a(3,4)
     2 - a(1,4) * a(2,3) * a(3,1) - a(1,1) * a(2,4) * a(3,3)
      b(3,4) = a(1,4) * a(2,2) * a(3,1) + a(1,1) * a(2,4) * a(3,2)
     1 + a(1,2) * a(2,1) * a(3,4) - a(1,4) * a(2,1) * a(3,2)
     2 - a(1,1) * a(2,2) * a(3,4) - a(1,2) * a(2,4) * a(3,1)
      b(4,4) = a(1,1) * a(2,2) * a(3,3) + a(1,2) * a(2,3) * a(3,1)
     1 + a(1,3) * a(2,1) * a(3,2) - a(1,1) * a(2,3) * a(3,2)
     2 - a(1,2) * a(2,1) * a(3,3) - a(1,3) * a(2,2) * a(3,1)

      det = a ( 1 , 1 ) * b ( 1 , 1 ) + a ( 1 , 2 ) * b ( 2 , 1 )
     1 + a ( 1 , 3 ) * b ( 3 , 1 ) + a ( 1 , 4 ) * b ( 4 , 1 )
c	if(abs(det).lt.1.e-2)then
c		print*,det
c                do i=1,4
c                   do j=1,4
c                       print*,'c(',i,',',j,')=',sngl(c(i,j))
c                   end do
c                end do
c	end if

c      print*,'en matinx (4)',det

      fdeta = fabsmx / det

c      print*,'en matinx (5)',fdeta

      do 5000 i = 1 , 4
      do 5000 j = 1 , 4
          a ( i , j ) = b ( i , j ) * fdeta
5000  continue
c      	if(abs(det).lt.1.e-2)then
c          do i=1,4
c             do j=1,4
c                sum=0.
c                do l=1,4
c                    sum=sum+a(i,l)*c(l,j)
c                end do
c                print*,'c*inversa(',i,',',j,')=',sum
c             end do
c           end do
c         end if

c      print*,'en matinx (6)',fdeta

      return
      end


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

subroutine savgol(y,w,f,y1,next)

!  Iterative and adaptive Sawitzky-Golay filering                               !
!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Updated 12/9-2006                                                            !
!                                                                               !
!-------------------------------------------------------------------------------!

implicit none

integer :: i,j,nyear,nptperyear,npt,nenvi,printflag,debugflag,win(3),next,m1,m2
integer :: failleft, failright
double precision :: wfact,y(npt),w(npt),y1(npt),yext(1:npt+2*next)  !! OBS next
double precision :: yfit(1:npt+2*next),wfit(1:npt+2*next),ymed
double precision :: yfitmean,yfitstd,ydiff,f(npt,3),c(3)

common /parameters/ nyear,nptperyear,npt,nenvi,printflag,debugflag,wfact,win

!---- Extend data circularly to improve fitting near the boundary of the -------
!     original data

yext = (/y(npt-next+1:npt),y,y(1:next)/)
wfit = (/w(npt-next+1:npt),w,w(1:next)/)
yfit = yext

!---- Iterative and adaptive Savitzky-Golay filter -----------------------------

do j = 1,nenvi

!---- Compute mean and standard deviation --------------------------------------

  yfitmean = sum(yfit)/(npt+2.d0*next)
  yfitstd = sqrt(dot_product(yfit-yfitmean,yfit-yfitmean)/(npt+2.d0*next-1.d0))

  do i = 1+next,npt+next

!---- Set fitting window -------------------------------------------------------

    m1 = i - win(j)
    m2 = i + win(j)

!---- Adapt fitting interval. Large variation use a smaller window -------------

    if (maxval(yfit(m1:m2)) - minval(yfit(m1:m2)) > 1.2d0*2.d0*yfitstd) then
      m1 = m1 + win(j)/3
      m2 = m2 - win(j)/3
    end if

!---- Check so that there are enough points, at least 3 at either side, with ---
!     weights different from zero. If not, extend fitting window

    failleft = 0
    do while ( (count(abs(wfit(m1:i)) > 1.d-10) < 3) .and. (failleft == 0) )
      m1 = m1 - 1
	  if (m1 < 1) then
        failleft = 1
        m1 = 1
      end if
    end do

    failright = 0
    do while ( (count(abs(wfit(i:m2)) > 1.d-10) < 3) .and. (failright == 0) )
      m2 = m2 + 1
	  if (m2 > npt+2*next) then
	    failright = 1
		m2 = npt+2*next
	  end if
    end do

!---- Fit polynomial if enough data values with non-zero weight ----------------

    if ((failleft == 0) .and. (failright == 0)) then

!---- Fit polynomial of degree two to the datavalues in the interval [m1,m2] ---
!     Observe that the basis functions need to be shifted in order to get a
!     better conditioning

      call linlsq(m2-m1+1,3,f(1:m2-m1+1,:),yext(m1:m2),wfit(m1:m2),c)

 ! Compute the fitted function

      yfit(i) = c(1)*f(i-m1+1,1) + c(2)*f(i-m1+1,2) + c(3)*f(i-m1+1,3)

!---- If not enough values with non-zero weigth replace with median value ------

	else

	   call median(yext(m1:m2),m2-m1+1,ymed)
	   yfit(i) = ymed

    end if

  end do

!---- Modify weights -----------------------------------------------------------

  if (j < nenvi) then
    call modweight(j,npt+2*next,wfit,yext,yfit)
  end if

end do

!---- Transfer fitted points in the intervall [1,npt] to y1 --------------------

y1 = yfit(1+next:npt+next)

!---- Output for debug purposes ------------------------------------------------

! write(*,*) 1,sum(y1)

end subroutine savgol


! chk_reduce.f90 --
!     Check if the compiler supports the reduce intrinsic function
!
program chk_reduce
    implicit none

    real, dimension(100) :: array
    real                 :: x

    call random_number( array )

    x = reduce( array, select_max )

contains
real function select_max( a, b )
    real, intent(in) :: a, b

    select_max = max( a, b )

end function select_max

end program chk_reduce


function dnrm2_c(n, x, incx) bind(c)
  use iso_c_binding

  integer(c_int), value :: n, incx
  real(c_double)        :: x(n), dnrm2_c

  real(kind(1.d0)) :: dnrm2

  dnrm2_c = dnrm2(n, x(1), incx)

  return

end function dnrm2_c

function dnrmf_c(m, n, a, lda) bind(c)

  use iso_c_binding

  integer(c_int), value :: m, n, lda
  real(c_double)        :: a(lda,n), dnrmf_c

  real(kind(1.d0)) :: dlange, w

  dnrmf_c = dlange('F', m, n, a(1,1), lda, w)

end function dnrmf_c


Submodule ( statistical_data_mod ) statistical_std_dev_smod
!
  Use kind_parameters_mod
!
  Implicit None
!
Contains
!
  Module Procedure Statistical_Std_Dev
!
    Real(KIND=rkind) :: mn
    If ( Size(this%data) .ne. 0 ) Then
       If ( Present ( mean ) ) Then
          mn = mean
       Else
          If ( this%Dmean ) Then
             mn = this%mean
          Else
             mn = Statistical_Mean ( this )
          End If
       End If
       If ( this%Dvariance ) Then
          std_dev = sqrt ( this%variance )
       Else
          std_dev = Sqrt ( Statistical_Variance ( this, mn ) )
       End If
    Else
       std_dev = Huge ( std_dev )
    End If
    this%std_dev = std_dev
    this%Dstd_dev = .true.
!
  End Procedure Statistical_Std_Dev
!
End Submodule statistical_std_dev_smod


program main
      implicit none
      integer::i,j,n=108
      !real(kind=8)::fx(200),fy(200),fz(200)
      !real(8)::v1,v2,f,k=0.0000001
      real(8),allocatable::a(:,:),rx(:),ry(:),rz(:),fx(:),fy(:),fz(:)

      allocate (a(n,n),rx(n),ry(n),rz(n),fx(n),fy(n),fz(n))

      open(1,file='argon.init')

      do  i=1,n
        read(1,*) (a(i,j),j=1,3)
        write(10,*)(a(i,j),j=1,3)
        rx(i) =a(i,1)
        ry(i) =a(i,2)
        rz(i) =a(i,3)
      end do
      call calc_force(n,rx,ry,rz,fx,fy,fz)

end program main

subroutine calc_force(n,rx,ry,rz,fx,fy,fz)
 implicit none
 integer::i,j,n
 real(8)::rx(200),ry(200),rz(200),boxl,sigsq,epslon,rxij,ryij,rzij,rijsq,sr2,sr6,sr12,rcutoffsq,rcutoff,sig,kb
 real(8)::fxij,fyij,fzij,fpr,fx(200),fy(200),fz(200)
 !real(8),allocatable::a(:,:)!,fx(:),fy(:),fz(:)
 n=108
 !do  i=1,n
  !write(15,*)rx(i),ry(i),rz(i)
 !end do

 boxl =17.158d0
 sig = 3.405d0
 sigsq = sig * sig
 kb = 1.38E-23
 epslon = 120.0d0 !* kb

 rcutoff = 0.50d0 * boxl
 rcutoffsq = rcutoff * rcutoff

 do i=1,n
  rx(i) = rx(i) - (boxl * anint(rx(i)/boxl))
  ry(i) = ry(i) - (boxl * anint(ry(i)/boxl))
  rz(i) = rz(i) - (boxl * anint(rz(i)/boxl))
 end do

 do i=1,n
  fx(i)=0.0d0; fy(i)=0.0d0; fz(i)=0.0d0
 end do

 do i=1,n-1
  do j=i+1,n
   rxij = rx(i) - rx(j)
   ryij = ry(i) - ry(j)
   rzij = rz(i) - rz(j)

   rxij = rxij - (boxl * anint(rxij/boxl))
   ryij = ryij - (boxl * anint(ryij/boxl))
   rzij = rzij - (boxl * anint(rzij/boxl))

   rijsq = rxij**2 + ryij**2 + rzij**2
   sr2 = sigsq/rijsq
   sr6 = sr2 * sr2 * sr2
   sr12 = sr6 * sr6

   if(rijsq<rcutoffsq) then
    fpr = (48.0d0 * epslon * (sr12 - (0.5d0*sr6)))/rijsq
    fxij = fpr * rxij
    fyij = fpr * ryij
    fzij = fpr * rzij

    fx(i) = fx(i) + fxij
    fy(i) = fy(i) + fyij
    fz(i) = fz(i) + fzij
    fx(j) = fx(j) - fxij
    fy(j) = fy(j) - fyij
    fz(j) = fz(j) - fzij

   end if
  end do

   write(22,*)fx(i),fy(i),fz(i)

 end do
end subroutine calc_force


      DOUBLE PRECISION FUNCTION MA02ID( TYP, NORM, N, A, LDA, QG,
     $                                  LDQG, DWORK )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the value of the one norm, or the Frobenius norm, or
C     the infinity norm, or the element of largest absolute value
C     of a real skew-Hamiltonian matrix
C
C                   [  A   G  ]          T         T
C             X  =  [       T ],   G = -G,   Q = -Q,
C                   [  Q   A  ]
C
C     or of a real Hamiltonian matrix
C
C                   [  A   G  ]          T         T
C             X  =  [       T ],   G =  G,   Q =  Q,
C                   [  Q  -A  ]
C
C     where A, G and Q are real n-by-n matrices.
C
C     Note that for this kind of matrices the infinity norm is equal
C     to the one norm.
C
C     FUNCTION VALUE
C
C     MA02ID  DOUBLE PRECISION
C             The computed norm.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYP     CHARACTER*1
C             Specifies the type of the input matrix X:
C             = 'S':         X is skew-Hamiltonian;
C             = 'H':         X is Hamiltonian.
C
C     NORM    CHARACTER*1
C             Specifies the value to be returned in MA02ID:
C             = '1' or 'O':  one norm of X;
C             = 'F' or 'E':  Frobenius norm of X;
C             = 'I':         infinity norm of X;
C             = 'M':         max(abs(X(i,j)).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     QG      (input) DOUBLE PRECISION array, dimension (LDQG,N+1)
C             On entry, the leading N-by-N+1 part of this array must
C             contain in columns 1:N the lower triangular part of the
C             matrix Q and in columns 2:N+1 the upper triangular part
C             of the matrix G. If TYP = 'S', the parts containing the
C             diagonal and the first supdiagonal of this array are not
C             referenced.
C
C     LDQG    INTEGER
C             The leading dimension of the array QG.  LDQG >= MAX(1,N).
C
C     Workspace
C
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             where LDWORK >= 2*N when NORM = '1', NORM = 'I' or
C             NORM = 'O'; otherwise, DWORK is not referenced.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DLANHA).
C
C     KEYWORDS
C
C     Elementary matrix operations, Hamiltonian matrix, skew-Hamiltonian
C     matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, TWO, ZERO
      PARAMETER          ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER          NORM, TYP
      INTEGER            LDA, LDQG, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), DWORK(*), QG(LDQG,*)
C     .. Local Scalars ..
      LOGICAL            LSH
      INTEGER            I, J
      DOUBLE PRECISION   DSCL, DSUM, SCALE, SUM, TEMP, VALUE
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLANGE, DLAPY2
      EXTERNAL           DLANGE, DLAPY2, LSAME
C     .. External Subroutines ..
      EXTERNAL           DLASSQ
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
C
C     .. Executable Statements ..
C
      LSH = LSAME( TYP, 'S' )
C
      IF ( N.EQ.0 ) THEN
         VALUE = ZERO
C
      ELSE IF ( LSAME( NORM, 'M' ) .AND. LSH ) THEN
C
C        Find max(abs(A(i,j))).
C
         VALUE = DLANGE( 'MaxElement', N, N, A, LDA, DWORK )
         IF ( N.GT.1 ) THEN
            DO 30  J = 1, N+1
               DO 10  I = 1, J-2
                  VALUE = MAX( VALUE, ABS( QG(I,J) ) )
   10          CONTINUE
               DO 20  I = J+1, N
                  VALUE = MAX( VALUE, ABS( QG(I,J) ) )
   20          CONTINUE
   30       CONTINUE
         END IF
C
      ELSE IF ( LSAME( NORM, 'M' ) ) THEN
C
C        Find max( abs( A(i,j) ), abs( QG(i,j) ) ).
C
         VALUE = MAX( DLANGE( 'MaxElement', N, N, A, LDA, DWORK ),
     $                DLANGE( 'MaxElement', N, N+1, QG, LDQG,
     $                        DWORK ) )
C
      ELSE IF ( ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR.
     $            LSAME( NORM, 'I' ) ) .AND. LSH ) THEN
C
C        Find the column and row sums of A (in one pass).
C
         VALUE = ZERO
         DO 40 I = 1, N
            DWORK(I) = ZERO
   40    CONTINUE
C
         DO 60 J = 1, N
            SUM = ZERO
            DO 50 I = 1, N
               TEMP = ABS( A(I,J) )
               SUM  = SUM + TEMP
               DWORK(I) = DWORK(I) + TEMP
   50       CONTINUE
            DWORK(N+J) = SUM
   60    CONTINUE
C
C        Compute the maximal absolute column sum.
C
         DO 90 J = 1, N+1
            DO 70  I = 1, J-2
               TEMP = ABS( QG(I,J) )
               DWORK(I) = DWORK(I) + TEMP
               DWORK(J-1) = DWORK(J-1) + TEMP
   70       CONTINUE
            IF ( J.LT.N+1 ) THEN
               SUM = DWORK(N+J)
               DO 80  I = J+1, N
                  TEMP = ABS( QG(I,J) )
                  SUM  = SUM + TEMP
                  DWORK(N+I) = DWORK(N+I) + TEMP
   80          CONTINUE
               VALUE = MAX( VALUE, SUM )
            END IF
   90    CONTINUE
         DO 100 I = 1, N
            VALUE = MAX( VALUE, DWORK(I) )
  100    CONTINUE
C
      ELSE IF ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR.
     $          LSAME( NORM, 'I' ) ) THEN
C
C        Find the column and row sums of A (in one pass).
C
         VALUE = ZERO
         DO 110 I = 1, N
            DWORK(I) = ZERO
  110   CONTINUE
C
         DO 130 J = 1, N
            SUM = ZERO
            DO 120 I = 1, N
               TEMP = ABS( A(I,J) )
               SUM  = SUM + TEMP
               DWORK(I) = DWORK(I) + TEMP
  120       CONTINUE
            DWORK(N+J) = SUM
  130    CONTINUE
C
C        Compute the maximal absolute column sum.
C
         DO 160 J = 1, N+1
            DO 140  I = 1, J-2
               TEMP = ABS( QG(I,J) )
               DWORK(I) = DWORK(I) + TEMP
               DWORK(J-1) = DWORK(J-1) + TEMP
  140       CONTINUE
            IF ( J.GT.1 )
     $         DWORK(J-1) = DWORK(J-1) + ABS( QG(J-1,J) )
            IF ( J.LT.N+1 ) THEN
               SUM = DWORK(N+J) + ABS( QG(J,J) )
               DO 150 I = J+1, N
                  TEMP = ABS( QG(I,J) )
                  SUM  = SUM + TEMP
                  DWORK(N+I) = DWORK(N+I) + TEMP
  150          CONTINUE
               VALUE = MAX( VALUE, SUM )
            END IF
  160    CONTINUE
         DO 170 I = 1, N
            VALUE = MAX( VALUE, DWORK(I) )
  170    CONTINUE
C
      ELSE IF ( ( LSAME( NORM, 'F' ) .OR.
     $            LSAME( NORM, 'E' ) ) .AND. LSH ) THEN
C
C        Find normF(A).
C
         SCALE = ZERO
         SUM = ONE
         DO 180 J = 1, N
            CALL DLASSQ( N, A(1,J), 1, SCALE, SUM )
  180    CONTINUE
C
C        Add normF(G) and normF(Q).
C
         DO 190 J = 1, N+1
            IF ( J.GT.2 )
     $         CALL DLASSQ( J-2, QG(1,J), 1, SCALE, SUM )
            IF ( J.LT.N )
     $         CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM )
  190    CONTINUE
         VALUE = SQRT( TWO )*SCALE*SQRT( SUM )
      ELSE IF ( LSAME( NORM, 'F' ) .OR. LSAME( NORM, 'E' ) ) THEN
         SCALE = ZERO
         SUM = ONE
         DO 200 J = 1, N
            CALL DLASSQ( N, A(1,J), 1, SCALE, SUM )
  200    CONTINUE
         DSCL = ZERO
         DSUM = ONE
         DO 210 J = 1, N+1
            IF ( J.GT.1 ) THEN
               CALL DLASSQ( J-2, QG(1,J), 1, SCALE, SUM )
               CALL DLASSQ( 1, QG(J-1,J), 1, DSCL, DSUM )
            END IF
            IF ( J.LT.N+1 ) THEN
               CALL DLASSQ( 1, QG(J,J), 1, DSCL, DSUM )
               CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM )
            END IF
  210    CONTINUE
         VALUE = DLAPY2( SQRT( TWO )*SCALE*SQRT( SUM ),
     $                   DSCL*SQRT( DSUM ) )
      END IF
C
      MA02ID = VALUE
      RETURN
C *** Last line of MA02ID ***
      END


      subroutine acal(a,n1dim,nrow,nfunc,wk,dz)
c---------------------------------------------------------------------
c      acal calculates the weights used in the sum for obtaining
c  model estimates in the backus gilbert inversion method for the
c  special case of integration quelling with orthonormal kernel
c  functions.  in this case the weights can be calculated as simple
c  sums.  the algorithm used here is a space economizer in that the
c  matrix of weights will overwrite the input matrix of discretized
c  kernels functions.
c
c  arguments-
c     a-an nrow x nfunc matrix
c       on input a is assumed to contain the discretized orthonormal
c       kernels functions in it's first nfunc columns.  these functions
c       are assumed to have been weighted by subroutine weight previous
c       to entry into this subroutine.  on output a will contain the
c       weights.  a(i,j) will contain the weight appropriate for the
c       jth function at the ith depth point.
c     n1dim-first dimension of a in calling program
c     nrow-number of rows in a
c     nfunc-number of columns in a
c     wk-work vector of length at least nrow
c
c  modifications-
c
c     june,1980-replaced earlier version that did not properly
c     take account of endpoint conditions but blindly did only a
c     simple sum.  this version is now restricted to use with
c     quadrature weights appropriate to simpson's rule.
c
c---------------------------------------------------------------------
      dimension a(n1dim,nfunc),wk(nrow)
c--inc is used by the blas
      data inc/1/
      do 100 i=1,nrow
  100      wk(i) = 1.0
      call weight(wk,nrow,nrow,1,dz)
      do 200 j=1,nfunc
           do 200 i=1,nrow
  200           a(i,j) = wk(i)*a(i,j)
c--now sum and shift
c--endpoint corrections dependent upon the quadrature scheme
c--being used.  this version uses simpson's rule with
c--trapezoidal endpoint corrections at even numbered points.
      do 400 j=1,nfunc
           call scopy(nrow,a(1,j),inc,wk,inc)
           a(1,j)=0.0
c--do odd numbered points first.  they require no correction with
c--simpson's rule.
           wk(1)=2.0*wk(1)
           do 300 i=3,nrow,2
  300           a(i,j)=a(i-2,j)+wk(i-1)+(wk(i)+wk(i-2))/2.0
c--now pick up odd numbered points by using a trapezoidal endpoint.
           do 350 i=2,nrow,2
  350           a(i,j) = a(i-1,j) + 0.75*wk(i-1) + 0.375*wk(i)
  400 continue
      return
      end

c $Id$


!  *******************************************************************
!  *                                                                 *
!  *                     Real*8 Function dlace1                      *
!  *                                                                 *
!  *******************************************************************
!  Double Precision Version 1.31
!  Written by Gordon A. Fenton, 1989
!  Latest Update: May 9, 2001
!
!  PURPOSE  returns the covariance between two points in a 1-D exponentially
!           damped oscillatory noise process.
!
!  Returns the covariance between two points separated by distance T
!  in an exponentiallly damped oscillatory noise process.
!  The covariance function for such a process is given by
!
!       B(T) = var*cos(dpb*T)*exp( -2*|T|/dthx )
!
!  where var is the point variance, dthx is the scale of fluctuation, and
!  dpb is the frequency of the oscillation, and where var, dpb, and dthx
!  are brought into this routine through the common block DPARAM.
!
!  If var < 0, then this function returns the variance of a local average
!  of the process, |var|*V(T), averaged over the distance T.
!  The variance function V(T) of the process averaged over a certain
!  distance T is calculated according to (see E.H. Vanmarcke, "Random Fields:
!  Analysis and Synthesis", MIT Press, 1984, Chapter 5).
!
!                         T
!       V(T) = (2/T) * INT  (1-s/T)*r(s) ds,
!                         0
!
!  where r(s) is the correlation function, r(s) = B(s)/B(0), so that
!  dlace1(T) = var * V(T).
!
!  REVISION HISTORY:
!  1.1	added lvarfn flag to end of /dparam/ common block. Set it to
!	true if the variance function is to be returned. Otherwise this
!	function returns the covariance. (Apr 29/00)
!  1.2	eliminated lvarfn -- now return covariances only if var < 0 (Feb 27/01)
!  1.3	reversed default - now return covariances if var > 0 (Apr 11/01)
!  1.31	revised above documentation to reflect revision 1.3 (May 9/01)
! =======================================================================
      real*8 function dlace1( T )
      implicit real*8 (a-h,o-z)
      common/dparam/ var, dpb, dthx, dthy, dthz
      data zero/0.d0/, two/2.d0/
      abs(x) = dabs(x)
      cos(x) = dcos(x)
      sin(x) = dsin(x)
      exp(x) = dexp(x)

      if( var .lt. zero ) then			! return variance function
         if( T .eq. zero ) then
            dlace1 = -var
         else
            ps = two/dthx
            s  = ps*ps + dpb*dpb
            r  = ps*ps - dpb*dpb
            a  = -ps*abs(T)
            b  = a*s + r
            c  = dpb*abs(T)
            d  = -two*var/(T*T*s*s)
            dlace1  = d*(exp(a)*(r*cos(c) - two*ps*dpb*sin(c)) - b)
         endif
      else					! return covariance
         if( dthx .eq. zero ) then
            if( T .eq. zero ) then
               dlace1 = var
            else
               dlace1 = zero
            endif
         else
            dlace1 = var*cos(dpb*T)*exp( -two*abs(T)/dthx )
         endif
      endif

      return
      end


      SUBROUTINE CFFTI1 (N,WA,IFAC)
      IMPLICIT NONE
      INTEGER :: N, IFAC(*), I, I1, IB, IDO, IDOT, II, IP, IPM, J, K1
      INTEGER :: L1, L2, LD, NF, NL, NQ, NR, NTRY, NTRYH(4)
      REAL :: WA(*), ARG, ARGH, ARGLD, FI, TPI
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J.le.4) GO TO 102
      GO TO 103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRYH(4)+2*(J-4)
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR.eq.0) GO TO 105
      GO TO 101
  105 NF = NF+1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      TPI = 6.28318530717959
      ARGH = TPI/FLOAT(N)
      I = 2
      L1 = 1
      DO 110 K1=1,NF
         IP = IFAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IDOT = IDO+IDO+2
         IPM = IP-1
         DO 109 J=1,IPM
            I1 = I
            WA(I-1) = 1.
            WA(I) = 0.
            LD = LD+L1
            FI = 0.
            ARGLD = FLOAT(LD)*ARGH
            DO 108 II=4,IDOT,2
               I = I+2
               FI = FI+1.
               ARG = FI*ARGLD
               WA(I-1) = COS(ARG)
               WA(I) = SIN(ARG)
  108       CONTINUE
            IF (IP .LE. 5) GO TO 109
            WA(I1-1) = WA(I-1)
            WA(I1) = WA(I)
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine calceigenvalues(c,al)
!
!     calculates the eigenvalues al of the symmetric 3x3 matrix c
!     the eigenvalues are sorted in increasing order
!
      implicit none
!
      integer idummy(3),three,kflag,i
!
      real*8 c(3,3),al(3),v1,v2,v3,bb,cc,cm,cn,tt,pi
!
      data kflag /1/
      data three /3/
!
!     calculation of the eigenvalues of c
!     Simo & Hughes Computational Inelasticity p 244
!
      pi=4.d0*datan(1.d0)
!
      v1=c(1,1)+c(2,2)+c(3,3)
      v2=c(2,2)*c(3,3)+c(1,1)*c(3,3)+c(1,1)*c(2,2)-
     &     (c(2,3)*c(2,3)+c(1,3)*c(1,3)+c(1,2)*c(1,2))
      v3=c(1,1)*(c(2,2)*c(3,3)-c(2,3)*c(2,3))
     &     -c(1,2)*(c(1,2)*c(3,3)-c(1,3)*c(2,3))
     &     +c(1,3)*(c(1,2)*c(2,3)-c(1,3)*c(2,2))
!
      bb=v2-v1*v1/3.d0
      cc=-2.d0*v1**3/27.d0+v1*v2/3.d0-v3
      if(dabs(bb).le.1.d-10) then
         if(dabs(cc).gt.1.d-10) then
            al(1)=-cc**(1.d0/3.d0)
         else
            al(1)=0.d0
         endif
         al(2)=al(1)
         al(3)=al(1)
      else
         cm=2.d0*dsqrt(-bb/3.d0)
         cn=3.d0*cc/(cm*bb)
         if(dabs(cn).gt.1.d0) then
            if(cn.gt.1.d0) then
               cn=1.d0
            else
               cn=-1.d0
            endif
         endif
         tt=datan2(dsqrt(1.d0-cn*cn),cn)/3.d0
         al(1)=cm*dcos(tt)
         al(2)=cm*dcos(tt+2.d0*pi/3.d0)
         al(3)=cm*dcos(tt+4.d0*pi/3.d0)
      endif
      do i=1,3
         al(i)=al(i)+v1/3.d0
      enddo
!
!     sorting
!
      call dsort(al,idummy,three,kflag)
!
      return
      end


      SUBROUTINE DOP853(N,FCN,X,Y,XEND,
     &                  RTOL,ATOL,ITOL,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
C ----------------------------------------------------------
C     NUMERICAL SOLUTION OF A SYSTEM OF FIRST 0RDER
C     ORDINARY DIFFERENTIAL EQUATIONS  Y'=F(X,Y).
C     THIS IS AN EXPLICIT RUNGE-KUTTA METHOD OF ORDER 8(5,3)
C     DUE TO DORMAND & PRINCE (WITH STEPSIZE CONTROL AND
C     DENSE OUTPUT)
C
C     AUTHORS: E. HAIRER AND G. WANNER
C              UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES
C              CH-1211 GENEVE 24, SWITZERLAND
C              E-MAIL:  Ernst.Hairer@math.unige.ch
C                       Gerhard.Wanner@math.unige.ch
C
C     THIS CODE IS DESCRIBED IN:
C         E. HAIRER, S.P. NORSETT AND G. WANNER, SOLVING ORDINARY
C         DIFFERENTIAL EQUATIONS I. NONSTIFF PROBLEMS. 2ND EDITION.
C         SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS,
C         SPRINGER-VERLAG (1993)
C
C     VERSION OF APRIL 25, 1996
C     (latest correction of a small bug: August 8, 2005)
C
C     Edited (22 Feb 2009) by J.C. Travers:
C       renamed HINIT->HINIT853 to avoid name collision with dopri5
C
C     INPUT PARAMETERS
C     ----------------
C     N           DIMENSION OF THE SYSTEM
C
C     FCN         NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE
C                 VALUE OF F(X,Y):
C                    SUBROUTINE FCN(N,X,Y,F,RPAR,IPAR)
C                    DOUBLE PRECISION X,Y(N),F(N)
C                    F(1)=...   ETC.
C
C     X           INITIAL X-VALUE
C
C     Y(N)        INITIAL VALUES FOR Y
C
C     XEND        FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE)
C
C     RTOL,ATOL   RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY
C                 CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N.
C                 ATOL SHOULD BE STRICTLY POSITIVE (POSSIBLY VERY SMALL)
C
C     ITOL        SWITCH FOR RTOL AND ATOL:
C                   ITOL=0: BOTH RTOL AND ATOL ARE SCALARS.
C                     THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF
C                     Y(I) BELOW RTOL*ABS(Y(I))+ATOL
C                   ITOL=1: BOTH RTOL AND ATOL ARE VECTORS.
C                     THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW
C                     RTOL(I)*ABS(Y(I))+ATOL(I).
C
C     SOLOUT      NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE
C                 NUMERICAL SOLUTION DURING INTEGRATION.
C                 IF IOUT.GE.1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP.
C                 SUPPLY A DUMMY SUBROUTINE IF IOUT=0.
C                 IT MUST HAVE THE FORM
C                    SUBROUTINE SOLOUT (NR,XOLD,X,Y,N,CON,ICOMP,ND,
C                                       RPAR,IPAR,IRTRN)
C                    DIMENSION Y(N),CON(8*ND),ICOMP(ND)
C                    ....
C                 SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH
C                    GRID-POINT "X" (THEREBY THE INITIAL VALUE IS
C                    THE FIRST GRID-POINT).
C                 "XOLD" IS THE PRECEDING GRID-POINT.
C                 "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN
C                    IS SET <0, DOP853 WILL RETURN TO THE CALLING PROGRAM.
C                    IF THE NUMERICAL SOLUTION IS ALTERED IN SOLOUT,
C                    SET  IRTRN = 2
C
C          -----  CONTINUOUS OUTPUT: -----
C                 DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION
C                 FOR THE INTERVAL [XOLD,X] IS AVAILABLE THROUGH
C                 THE FUNCTION
C                        >>>   CONTD8(I,S,CON,ICOMP,ND)   <<<
C                 WHICH PROVIDES AN APPROXIMATION TO THE I-TH
C                 COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE
C                 S SHOULD LIE IN THE INTERVAL [XOLD,X].
C
C     IOUT        SWITCH FOR CALLING THE SUBROUTINE SOLOUT:
C                    IOUT=0: SUBROUTINE IS NEVER CALLED
C                    IOUT=1: SUBROUTINE IS USED FOR OUTPUT
C                    IOUT=2: DENSE OUTPUT IS PERFORMED IN SOLOUT
C                            (IN THIS CASE WORK(5) MUST BE SPECIFIED)
C
C     WORK        ARRAY OF WORKING SPACE OF LENGTH "LWORK".
C                 WORK(1),...,WORK(20) SERVE AS PARAMETERS FOR THE CODE.
C                 FOR STANDARD USE, SET THEM TO ZERO BEFORE CALLING.
C                 "LWORK" MUST BE AT LEAST  11*N+8*NRDENS+21
C                 WHERE  NRDENS = IWORK(5)
C
C     LWORK       DECLARED LENGTH OF ARRAY "WORK".
C
C     IWORK       INTEGER WORKING SPACE OF LENGTH "LIWORK".
C                 IWORK(1),...,IWORK(20) SERVE AS PARAMETERS FOR THE CODE.
C                 FOR STANDARD USE, SET THEM TO ZERO BEFORE CALLING.
C                 "LIWORK" MUST BE AT LEAST NRDENS+21 .
C
C     LIWORK      DECLARED LENGTH OF ARRAY "IWORK".
C
C     RPAR, IPAR  REAL AND INTEGER PARAMETERS (OR PARAMETER ARRAYS) WHICH
C                 CAN BE USED FOR COMMUNICATION BETWEEN YOUR CALLING
C                 PROGRAM AND THE FCN, JAC, MAS, SOLOUT SUBROUTINES.
C
C-----------------------------------------------------------------------
C
C     SOPHISTICATED SETTING OF PARAMETERS
C     -----------------------------------
C              SEVERAL PARAMETERS (WORK(1),...,IWORK(1),...) ALLOW
C              TO ADAPT THE CODE TO THE PROBLEM AND TO THE NEEDS OF
C              THE USER. FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES.
C
C    WORK(1)   UROUND, THE ROUNDING UNIT, DEFAULT 2.3D-16.
C
C    WORK(2)   THE SAFETY FACTOR IN STEP SIZE PREDICTION,
C              DEFAULT 0.9D0.
C
C    WORK(3), WORK(4)   PARAMETERS FOR STEP SIZE SELECTION
C              THE NEW STEP SIZE IS CHOSEN SUBJECT TO THE RESTRICTION
C                 WORK(3) <= HNEW/HOLD <= WORK(4)
C              DEFAULT VALUES: WORK(3)=0.333D0, WORK(4)=6.D0
C
C    WORK(5)   IS THE "BETA" FOR STABILIZED STEP SIZE CONTROL
C              (SEE SECTION IV.2). POSITIVE VALUES OF BETA ( <= 0.04 )
C              MAKE THE STEP SIZE CONTROL MORE STABLE.
C              NEGATIVE WORK(5) PROVOKE BETA=0.
C              DEFAULT 0.0D0.
C
C    WORK(6)   MAXIMAL STEP SIZE, DEFAULT XEND-X.
C
C    WORK(7)   INITIAL STEP SIZE, FOR WORK(7)=0.D0 AN INITIAL GUESS
C              IS COMPUTED WITH HELP OF THE FUNCTION HINIT
C
C    IWORK(1)  THIS IS THE MAXIMAL NUMBER OF ALLOWED STEPS.
C              THE DEFAULT VALUE (FOR IWORK(1)=0) IS 100000.
C
C    IWORK(2)  SWITCH FOR THE CHOICE OF THE COEFFICIENTS
C              IF IWORK(2).EQ.1  METHOD DOP853 OF DORMAND AND PRINCE
C              (SECTION II.6).
C              THE DEFAULT VALUE (FOR IWORK(2)=0) IS IWORK(2)=1.
C
C    IWORK(3)  SWITCH FOR PRINTING ERROR MESSAGES
C              IF IWORK(3).LT.0 NO MESSAGES ARE BEING PRINTED
C              IF IWORK(3).GT.0 MESSAGES ARE PRINTED WITH
C              WRITE (IWORK(3),*) ...
C              DEFAULT VALUE (FOR IWORK(3)=0) IS IWORK(3)=6
C
C    IWORK(4)  TEST FOR STIFFNESS IS ACTIVATED AFTER STEP NUMBER
C              J*IWORK(4) (J INTEGER), PROVIDED IWORK(4).GT.0.
C              FOR NEGATIVE IWORK(4) THE STIFFNESS TEST IS
C              NEVER ACTIVATED; DEFAULT VALUE IS IWORK(4)=1000
C
C    IWORK(5)  = NRDENS = NUMBER OF COMPONENTS, FOR WHICH DENSE OUTPUT
C              IS REQUIRED; DEFAULT VALUE IS IWORK(5)=0;
C              FOR   0 < NRDENS < N   THE COMPONENTS (FOR WHICH DENSE
C              OUTPUT IS REQUIRED) HAVE TO BE SPECIFIED IN
C              IWORK(21),...,IWORK(NRDENS+20);
C              FOR  NRDENS=N  THIS IS DONE BY THE CODE.
C
C----------------------------------------------------------------------
C
C     OUTPUT PARAMETERS
C     -----------------
C     X           X-VALUE FOR WHICH THE SOLUTION HAS BEEN COMPUTED
C                 (AFTER SUCCESSFUL RETURN X=XEND).
C
C     Y(N)        NUMERICAL SOLUTION AT X
C
C     H           PREDICTED STEP SIZE OF THE LAST ACCEPTED STEP
C
C     IDID        REPORTS ON SUCCESSFULNESS UPON RETURN:
C                   IDID= 1  COMPUTATION SUCCESSFUL,
C                   IDID= 2  COMPUT. SUCCESSFUL (INTERRUPTED BY SOLOUT)
C                   IDID=-1  INPUT IS NOT CONSISTENT,
C                   IDID=-2  LARGER NMAX IS NEEDED,
C                   IDID=-3  STEP SIZE BECOMES TOO SMALL.
C                   IDID=-4  PROBLEM IS PROBABLY STIFF (INTERRUPTED).
C
C   IWORK(17)  NFCN    NUMBER OF FUNCTION EVALUATIONS
C   IWORK(18)  NSTEP   NUMBER OF COMPUTED STEPS
C   IWORK(19)  NACCPT  NUMBER OF ACCEPTED STEPS
C   IWORK(20)  NREJCT  NUMBER OF REJECTED STEPS (DUE TO ERROR TEST),
C                      (STEP REJECTIONS IN THE FIRST STEP ARE NOT COUNTED)
C-----------------------------------------------------------------------
C *** *** *** *** *** *** *** *** *** *** *** *** ***
C          DECLARATIONS
C *** *** *** *** *** *** *** *** *** *** *** *** ***
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Y(N),ATOL(*),RTOL(*),WORK(LWORK),IWORK(LIWORK)
      DIMENSION RPAR(*),IPAR(*)
      LOGICAL ARRET
      EXTERNAL FCN,SOLOUT
C *** *** *** *** *** *** ***
C        SETTING THE PARAMETERS
C *** *** *** *** *** *** ***
      NFCN=0
      NSTEP=0
      NACCPT=0
      NREJCT=0
      ARRET=.FALSE.
C -------- IPRINT FOR MONITORING THE PRINTING
      IF(IWORK(3).EQ.0)THEN
         IPRINT=6
      ELSE
         IPRINT=IWORK(3)
      END IF
C -------- NMAX , THE MAXIMAL NUMBER OF STEPS -----
      IF(IWORK(1).EQ.0)THEN
         NMAX=100000
      ELSE
         NMAX=IWORK(1)
         IF(NMAX.LE.0)THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &          ' WRONG INPUT IWORK(1)=',IWORK(1)
            ARRET=.TRUE.
         END IF
      END IF
C -------- METH   COEFFICIENTS OF THE METHOD
      IF(IWORK(2).EQ.0)THEN
         METH=1
      ELSE
         METH=IWORK(2)
         IF(METH.LE.0.OR.METH.GE.4)THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &          ' CURIOUS INPUT IWORK(2)=',IWORK(2)
            ARRET=.TRUE.
         END IF
      END IF
C -------- NSTIFF   PARAMETER FOR STIFFNESS DETECTION
      NSTIFF=IWORK(4)
      IF (NSTIFF.EQ.0) NSTIFF=1000
      IF (NSTIFF.LT.0) NSTIFF=NMAX+10
C -------- NRDENS   NUMBER OF DENSE OUTPUT COMPONENTS
      NRDENS=IWORK(5)
      IF(NRDENS.LT.0.OR.NRDENS.GT.N)THEN
         IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &           ' CURIOUS INPUT IWORK(5)=',IWORK(5)
         ARRET=.TRUE.
      ELSE
         IF(NRDENS.GT.0.AND.IOUT.LT.2)THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &       ' WARNING: PUT IOUT=2 FOR DENSE OUTPUT '
         END IF
         IF (NRDENS.EQ.N) THEN
            DO I=1,NRDENS
               IWORK(I+20)=I
            END DO
         END IF
      END IF
C -------- UROUND   SMALLEST NUMBER SATISFYING 1.D0+UROUND>1.D0
      IF(WORK(1).EQ.0.D0)THEN
         UROUND=2.3D-16
      ELSE
         UROUND=WORK(1)
         IF(UROUND.LE.1.D-35.OR.UROUND.GE.1.D0)THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &        ' WHICH MACHINE DO YOU HAVE? YOUR UROUND WAS:',WORK(1)
            ARRET=.TRUE.
         END IF
      END IF
C -------  SAFETY FACTOR -------------
      IF(WORK(2).EQ.0.D0)THEN
         SAFE=0.9D0
      ELSE
         SAFE=WORK(2)
         IF(SAFE.GE.1.D0.OR.SAFE.LE.1.D-4)THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &          ' CURIOUS INPUT FOR SAFETY FACTOR WORK(2)=',WORK(2)
            ARRET=.TRUE.
         END IF
      END IF
C -------  FAC1,FAC2     PARAMETERS FOR STEP SIZE SELECTION
      IF(WORK(3).EQ.0.D0)THEN
         FAC1=0.333D0
      ELSE
         FAC1=WORK(3)
      END IF
      IF(WORK(4).EQ.0.D0)THEN
         FAC2=6.D0
      ELSE
         FAC2=WORK(4)
      END IF
C --------- BETA FOR STEP CONTROL STABILIZATION -----------
      IF(WORK(5).EQ.0.D0)THEN
         BETA=0.0D0
      ELSE
         IF(WORK(5).LT.0.D0)THEN
            BETA=0.D0
         ELSE
            BETA=WORK(5)
            IF(BETA.GT.0.2D0)THEN
               IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &          ' CURIOUS INPUT FOR BETA: WORK(5)=',WORK(5)
            ARRET=.TRUE.
         END IF
         END IF
      END IF
C -------- MAXIMAL STEP SIZE
      IF(WORK(6).EQ.0.D0)THEN
         HMAX=XEND-X
      ELSE
         HMAX=WORK(6)
      END IF
C -------- INITIAL STEP SIZE
      H=WORK(7)
C ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK -----
      IEK1=21
      IEK2=IEK1+N
      IEK3=IEK2+N
      IEK4=IEK3+N
      IEK5=IEK4+N
      IEK6=IEK5+N
      IEK7=IEK6+N
      IEK8=IEK7+N
      IEK9=IEK8+N
      IEK10=IEK9+N
      IEY1=IEK10+N
      IECO=IEY1+N
C ------ TOTAL STORAGE REQUIREMENT -----------
      ISTORE=IECO+8*NRDENS-1
      IF(ISTORE.GT.LWORK)THEN
        IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &   ' INSUFFICIENT STORAGE FOR WORK, MIN. LWORK=',ISTORE
        ARRET=.TRUE.
      END IF
      ICOMP=21
      ISTORE=ICOMP+NRDENS-1
      IF(ISTORE.GT.LIWORK)THEN
        IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &   ' INSUFFICIENT STORAGE FOR IWORK, MIN. LIWORK=',ISTORE
        ARRET=.TRUE.
      END IF
C -------- WHEN A FAIL HAS OCCURRED, WE RETURN WITH IDID=-1
      IF (ARRET) THEN
         IDID=-1
         RETURN
      END IF
C -------- CALL TO CORE INTEGRATOR ------------
      CALL DP86CO(N,FCN,X,Y,XEND,HMAX,H,RTOL,ATOL,ITOL,IPRINT,
     &   SOLOUT,IOUT,IDID,NMAX,UROUND,METH,NSTIFF,SAFE,BETA,FAC1,FAC2,
     &   WORK(IEK1),WORK(IEK2),WORK(IEK3),WORK(IEK4),WORK(IEK5),
     &   WORK(IEK6),WORK(IEK7),WORK(IEK8),WORK(IEK9),WORK(IEK10),
     &   WORK(IEY1),WORK(IECO),IWORK(ICOMP),NRDENS,RPAR,IPAR,
     &   NFCN,NSTEP,NACCPT,NREJCT)
      WORK(7)=H
      IWORK(17)=NFCN
      IWORK(18)=NSTEP
      IWORK(19)=NACCPT
      IWORK(20)=NREJCT
C ----------- RETURN -----------
      RETURN
      END
C
C
C
C  ----- ... AND HERE IS THE CORE INTEGRATOR  ----------
C
      SUBROUTINE DP86CO(N,FCN,X,Y,XEND,HMAX,H,RTOL,ATOL,ITOL,IPRINT,
     &   SOLOUT,IOUT,IDID,NMAX,UROUND,METH,NSTIFF,SAFE,BETA,FAC1,FAC2,
     &   K1,K2,K3,K4,K5,K6,K7,K8,K9,K10,Y1,CONT,ICOMP,NRD,RPAR,IPAR,
     &   NFCN,NSTEP,NACCPT,NREJCT)
C ----------------------------------------------------------
C     CORE INTEGRATOR FOR DOP853
C     PARAMETERS SAME AS IN DOP853 WITH WORKSPACE ADDED
C ----------------------------------------------------------
C         DECLARATIONS
C ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      parameter (
     &  c2  = 0.526001519587677318785587544488D-01,
     &  c3  = 0.789002279381515978178381316732D-01,
     &  c4  = 0.118350341907227396726757197510D+00,
     &  c5  = 0.281649658092772603273242802490D+00,
     &  c6  = 0.333333333333333333333333333333D+00,
     &  c7  = 0.25D+00,
     &  c8  = 0.307692307692307692307692307692D+00,
     &  c9  = 0.651282051282051282051282051282D+00,
     &  c10 = 0.6D+00,
     &  c11 = 0.857142857142857142857142857142D+00,
     &  c14 = 0.1D+00,
     &  c15 = 0.2D+00,
     &  c16 = 0.777777777777777777777777777778D+00)
      parameter (
     &  b1 =   5.42937341165687622380535766363D-2,
     &  b6 =   4.45031289275240888144113950566D0,
     &  b7 =   1.89151789931450038304281599044D0,
     &  b8 =  -5.8012039600105847814672114227D0,
     &  b9 =   3.1116436695781989440891606237D-1,
     &  b10 = -1.52160949662516078556178806805D-1,
     &  b11 =  2.01365400804030348374776537501D-1,
     &  b12 =  4.47106157277725905176885569043D-2)
      parameter (
     &  bhh1 = 0.244094488188976377952755905512D+00,
     &  bhh2 = 0.733846688281611857341361741547D+00,
     &  bhh3 = 0.220588235294117647058823529412D-01)
      parameter (
     &  er 1 =  0.1312004499419488073250102996D-01,
     &  er 6 = -0.1225156446376204440720569753D+01,
     &  er 7 = -0.4957589496572501915214079952D+00,
     &  er 8 =  0.1664377182454986536961530415D+01,
     &  er 9 = -0.3503288487499736816886487290D+00,
     &  er10 =  0.3341791187130174790297318841D+00,
     &  er11 =  0.8192320648511571246570742613D-01,
     &  er12 = -0.2235530786388629525884427845D-01)
      parameter (
     &  a21 =    5.26001519587677318785587544488D-2,
     &  a31 =    1.97250569845378994544595329183D-2,
     &  a32 =    5.91751709536136983633785987549D-2,
     &  a41 =    2.95875854768068491816892993775D-2,
     &  a43 =    8.87627564304205475450678981324D-2,
     &  a51 =    2.41365134159266685502369798665D-1,
     &  a53 =   -8.84549479328286085344864962717D-1,
     &  a54 =    9.24834003261792003115737966543D-1,
     &  a61 =    3.7037037037037037037037037037D-2,
     &  a64 =    1.70828608729473871279604482173D-1,
     &  a65 =    1.25467687566822425016691814123D-1,
     &  a71 =    3.7109375D-2,
     &  a74 =    1.70252211019544039314978060272D-1,
     &  a75 =    6.02165389804559606850219397283D-2,
     &  a76 =   -1.7578125D-2)
      parameter (
     &  a81 =    3.70920001185047927108779319836D-2,
     &  a84 =    1.70383925712239993810214054705D-1,
     &  a85 =    1.07262030446373284651809199168D-1,
     &  a86 =   -1.53194377486244017527936158236D-2,
     &  a87 =    8.27378916381402288758473766002D-3,
     &  a91 =    6.24110958716075717114429577812D-1,
     &  a94 =   -3.36089262944694129406857109825D0,
     &  a95 =   -8.68219346841726006818189891453D-1,
     &  a96 =    2.75920996994467083049415600797D1,
     &  a97 =    2.01540675504778934086186788979D1,
     &  a98 =   -4.34898841810699588477366255144D1,
     &  a101 =   4.77662536438264365890433908527D-1,
     &  a104 =  -2.48811461997166764192642586468D0,
     &  a105 =  -5.90290826836842996371446475743D-1,
     &  a106 =   2.12300514481811942347288949897D1,
     &  a107 =   1.52792336328824235832596922938D1,
     &  a108 =  -3.32882109689848629194453265587D1,
     &  a109 =  -2.03312017085086261358222928593D-2)
      parameter (
     &  a111 =  -9.3714243008598732571704021658D-1,
     &  a114 =   5.18637242884406370830023853209D0,
     &  a115 =   1.09143734899672957818500254654D0,
     &  a116 =  -8.14978701074692612513997267357D0,
     &  a117 =  -1.85200656599969598641566180701D1,
     &  a118 =   2.27394870993505042818970056734D1,
     &  a119 =   2.49360555267965238987089396762D0,
     &  a1110 = -3.0467644718982195003823669022D0,
     &  a121 =   2.27331014751653820792359768449D0,
     &  a124 =  -1.05344954667372501984066689879D1,
     &  a125 =  -2.00087205822486249909675718444D0,
     &  a126 =  -1.79589318631187989172765950534D1,
     &  a127 =   2.79488845294199600508499808837D1,
     &  a128 =  -2.85899827713502369474065508674D0,
     &  a129 =  -8.87285693353062954433549289258D0,
     &  a1210 =  1.23605671757943030647266201528D1,
     &  a1211 =  6.43392746015763530355970484046D-1)
      parameter (
     &  a141 =  5.61675022830479523392909219681D-2,
     &  a147 =  2.53500210216624811088794765333D-1,
     &  a148 = -2.46239037470802489917441475441D-1,
     &  a149 = -1.24191423263816360469010140626D-1,
     &  a1410 =  1.5329179827876569731206322685D-1,
     &  a1411 =  8.20105229563468988491666602057D-3,
     &  a1412 =  7.56789766054569976138603589584D-3,
     &  a1413 = -8.298D-3)
      parameter (
     &  a151 =  3.18346481635021405060768473261D-2,
     &  a156 =  2.83009096723667755288322961402D-2,
     &  a157 =  5.35419883074385676223797384372D-2,
     &  a158 = -5.49237485713909884646569340306D-2,
     &  a1511 = -1.08347328697249322858509316994D-4,
     &  a1512 =  3.82571090835658412954920192323D-4,
     &  a1513 = -3.40465008687404560802977114492D-4,
     &  a1514 =  1.41312443674632500278074618366D-1,
     &  a161 = -4.28896301583791923408573538692D-1,
     &  a166 = -4.69762141536116384314449447206D0,
     &  a167 =  7.68342119606259904184240953878D0,
     &  a168 =  4.06898981839711007970213554331D0,
     &  a169 =  3.56727187455281109270669543021D-1,
     &  a1613 = -1.39902416515901462129418009734D-3,
     &  a1614 =  2.9475147891527723389556272149D0,
     &  a1615 = -9.15095847217987001081870187138D0)
      parameter (
     &  d41  = -0.84289382761090128651353491142D+01,
     &  d46  =  0.56671495351937776962531783590D+00,
     &  d47  = -0.30689499459498916912797304727D+01,
     &  d48  =  0.23846676565120698287728149680D+01,
     &  d49  =  0.21170345824450282767155149946D+01,
     &  d410 = -0.87139158377797299206789907490D+00,
     &  d411 =  0.22404374302607882758541771650D+01,
     &  d412 =  0.63157877876946881815570249290D+00,
     &  d413 = -0.88990336451333310820698117400D-01,
     &  d414 =  0.18148505520854727256656404962D+02,
     &  d415 = -0.91946323924783554000451984436D+01,
     &  d416 = -0.44360363875948939664310572000D+01)
      parameter (
     &  d51  =  0.10427508642579134603413151009D+02,
     &  d56  =  0.24228349177525818288430175319D+03,
     &  d57  =  0.16520045171727028198505394887D+03,
     &  d58  = -0.37454675472269020279518312152D+03,
     &  d59  = -0.22113666853125306036270938578D+02,
     &  d510 =  0.77334326684722638389603898808D+01,
     &  d511 = -0.30674084731089398182061213626D+02,
     &  d512 = -0.93321305264302278729567221706D+01,
     &  d513 =  0.15697238121770843886131091075D+02,
     &  d514 = -0.31139403219565177677282850411D+02,
     &  d515 = -0.93529243588444783865713862664D+01,
     &  d516 =  0.35816841486394083752465898540D+02)
      parameter (
     &  d61 =  0.19985053242002433820987653617D+02,
     &  d66 = -0.38703730874935176555105901742D+03,
     &  d67 = -0.18917813819516756882830838328D+03,
     &  d68 =  0.52780815920542364900561016686D+03,
     &  d69 = -0.11573902539959630126141871134D+02,
     &  d610 =  0.68812326946963000169666922661D+01,
     &  d611 = -0.10006050966910838403183860980D+01,
     &  d612 =  0.77771377980534432092869265740D+00,
     &  d613 = -0.27782057523535084065932004339D+01,
     &  d614 = -0.60196695231264120758267380846D+02,
     &  d615 =  0.84320405506677161018159903784D+02,
     &  d616 =  0.11992291136182789328035130030D+02)
      parameter (
     &  d71  = -0.25693933462703749003312586129D+02,
     &  d76  = -0.15418974869023643374053993627D+03,
     &  d77  = -0.23152937917604549567536039109D+03,
     &  d78  =  0.35763911791061412378285349910D+03,
     &  d79  =  0.93405324183624310003907691704D+02,
     &  d710 = -0.37458323136451633156875139351D+02,
     &  d711 =  0.10409964950896230045147246184D+03,
     &  d712 =  0.29840293426660503123344363579D+02,
     &  d713 = -0.43533456590011143754432175058D+02,
     &  d714 =  0.96324553959188282948394950600D+02,
     &  d715 = -0.39177261675615439165231486172D+02,
     &  d716 = -0.14972683625798562581422125276D+03)
      DOUBLE PRECISION Y(N),Y1(N),K1(N),K2(N),K3(N),K4(N),K5(N),K6(N)
      DOUBLE PRECISION K7(N),K8(N),K9(N),K10(N),ATOL(*),RTOL(*)
      DIMENSION CONT(8*NRD),ICOMP(NRD),RPAR(*),IPAR(*)
      LOGICAL REJECT,LAST
      EXTERNAL FCN
      COMMON /CONDO8/XOLD,HOUT
C *** *** *** *** *** *** ***
C  INITIALISATIONS
C *** *** *** *** *** *** ***
      FACOLD=1.D-4
      EXPO1=1.d0/8.d0-BETA*0.2D0
      FACC1=1.D0/FAC1
      FACC2=1.D0/FAC2
      POSNEG=SIGN(1.D0,XEND-X)
C --- INITIAL PREPARATIONS
      ATOLI=ATOL(1)
      RTOLI=RTOL(1)
      LAST=.FALSE.
      HLAMB=0.D0
      IASTI=0
      CALL FCN(N,X,Y,K1,RPAR,IPAR)
      HMAX=ABS(HMAX)
      IORD=8
      IF (H.EQ.0.D0) H=HINIT853(N,FCN,X,Y,XEND,POSNEG,K1,K2,K3,IORD,
     &                       HMAX,ATOL,RTOL,ITOL,RPAR,IPAR)
      NFCN=NFCN+2
      REJECT=.FALSE.
      XOLD=X
      IF (IOUT.GE.1) THEN
          IRTRN=1
          HOUT=1.D0
          CALL SOLOUT(NACCPT+1,XOLD,X,Y,N,CONT,ICOMP,NRD,
     &                RPAR,IPAR,IRTRN)
          IF (IRTRN.LT.0) GOTO 79
      END IF
C --- BASIC INTEGRATION STEP
   1  CONTINUE
      IF (NSTEP.GT.NMAX) GOTO 78
      IF (0.1D0*ABS(H).LE.ABS(X)*UROUND)GOTO 77
      IF ((X+1.01D0*H-XEND)*POSNEG.GT.0.D0) THEN
         H=XEND-X
         LAST=.TRUE.
      END IF
      NSTEP=NSTEP+1
C --- THE TWELVE STAGES
      IF (IRTRN.GE.2) THEN
         CALL FCN(N,X,Y,K1,RPAR,IPAR)
      END IF
      DO 22 I=1,N
  22  Y1(I)=Y(I)+H*A21*K1(I)
      CALL FCN(N,X+C2*H,Y1,K2,RPAR,IPAR)
      DO 23 I=1,N
  23  Y1(I)=Y(I)+H*(A31*K1(I)+A32*K2(I))
      CALL FCN(N,X+C3*H,Y1,K3,RPAR,IPAR)
      DO 24 I=1,N
  24  Y1(I)=Y(I)+H*(A41*K1(I)+A43*K3(I))
      CALL FCN(N,X+C4*H,Y1,K4,RPAR,IPAR)
      DO 25 I=1,N
  25  Y1(I)=Y(I)+H*(A51*K1(I)+A53*K3(I)+A54*K4(I))
      CALL FCN(N,X+C5*H,Y1,K5,RPAR,IPAR)
      DO 26 I=1,N
  26  Y1(I)=Y(I)+H*(A61*K1(I)+A64*K4(I)+A65*K5(I))
      CALL FCN(N,X+C6*H,Y1,K6,RPAR,IPAR)
      DO 27 I=1,N
  27  Y1(I)=Y(I)+H*(A71*K1(I)+A74*K4(I)+A75*K5(I)+A76*K6(I))
      CALL FCN(N,X+C7*H,Y1,K7,RPAR,IPAR)
      DO 28 I=1,N
  28  Y1(I)=Y(I)+H*(A81*K1(I)+A84*K4(I)+A85*K5(I)+A86*K6(I)+A87*K7(I))
      CALL FCN(N,X+C8*H,Y1,K8,RPAR,IPAR)
      DO 29 I=1,N
  29  Y1(I)=Y(I)+H*(A91*K1(I)+A94*K4(I)+A95*K5(I)+A96*K6(I)+A97*K7(I)
     &   +A98*K8(I))
      CALL FCN(N,X+C9*H,Y1,K9,RPAR,IPAR)
      DO 30 I=1,N
  30  Y1(I)=Y(I)+H*(A101*K1(I)+A104*K4(I)+A105*K5(I)+A106*K6(I)
     &   +A107*K7(I)+A108*K8(I)+A109*K9(I))
      CALL FCN(N,X+C10*H,Y1,K10,RPAR,IPAR)
      DO 31 I=1,N
  31  Y1(I)=Y(I)+H*(A111*K1(I)+A114*K4(I)+A115*K5(I)+A116*K6(I)
     &   +A117*K7(I)+A118*K8(I)+A119*K9(I)+A1110*K10(I))
      CALL FCN(N,X+C11*H,Y1,K2,RPAR,IPAR)
      XPH=X+H
      DO 32 I=1,N
  32  Y1(I)=Y(I)+H*(A121*K1(I)+A124*K4(I)+A125*K5(I)+A126*K6(I)
     &   +A127*K7(I)+A128*K8(I)+A129*K9(I)+A1210*K10(I)+A1211*K2(I))
      CALL FCN(N,XPH,Y1,K3,RPAR,IPAR)
      NFCN=NFCN+11
      DO 35 I=1,N
      K4(I)=B1*K1(I)+B6*K6(I)+B7*K7(I)+B8*K8(I)+B9*K9(I)
     &   +B10*K10(I)+B11*K2(I)+B12*K3(I)
  35  K5(I)=Y(I)+H*K4(I)
C --- ERROR ESTIMATION
      ERR=0.D0
      ERR2=0.D0
      IF (ITOL.EQ.0) THEN
        DO 41 I=1,N
        SK=ATOLI+RTOLI*MAX(ABS(Y(I)),ABS(K5(I)))
        ERRI=K4(I)-BHH1*K1(I)-BHH2*K9(I)-BHH3*K3(I)
        ERR2=ERR2+(ERRI/SK)**2
        ERRI=ER1*K1(I)+ER6*K6(I)+ER7*K7(I)+ER8*K8(I)+ER9*K9(I)
     &      +ER10*K10(I)+ER11*K2(I)+ER12*K3(I)
  41    ERR=ERR+(ERRI/SK)**2
      ELSE
        DO 42 I=1,N
        SK=ATOL(I)+RTOL(I)*MAX(ABS(Y(I)),ABS(K5(I)))
        ERRI=K4(I)-BHH1*K1(I)-BHH2*K9(I)-BHH3*K3(I)
        ERR2=ERR2+(ERRI/SK)**2
        ERRI=ER1*K1(I)+ER6*K6(I)+ER7*K7(I)+ER8*K8(I)+ER9*K9(I)
     &      +ER10*K10(I)+ER11*K2(I)+ER12*K3(I)
  42    ERR=ERR+(ERRI/SK)**2
      END IF
      DENO=ERR+0.01D0*ERR2
      IF (DENO.LE.0.D0) DENO=1.D0
      ERR=ABS(H)*ERR*SQRT(1.D0/(N*DENO))
C --- COMPUTATION OF HNEW
      FAC11=ERR**EXPO1
C --- LUND-STABILIZATION
      FAC=FAC11/FACOLD**BETA
C --- WE REQUIRE  FAC1 <= HNEW/H <= FAC2
      FAC=MAX(FACC2,MIN(FACC1,FAC/SAFE))
      HNEW=H/FAC
      IF(ERR.LE.1.D0)THEN
C --- STEP IS ACCEPTED
         FACOLD=MAX(ERR,1.0D-4)
         NACCPT=NACCPT+1
         CALL FCN(N,XPH,K5,K4,RPAR,IPAR)
         NFCN=NFCN+1
C ------- STIFFNESS DETECTION
         IF (MOD(NACCPT,NSTIFF).EQ.0.OR.IASTI.GT.0) THEN
            STNUM=0.D0
            STDEN=0.D0
            DO 64 I=1,N
               STNUM=STNUM+(K4(I)-K3(I))**2
               STDEN=STDEN+(K5(I)-Y1(I))**2
 64         CONTINUE
            IF (STDEN.GT.0.D0) HLAMB=ABS(H)*SQRT(STNUM/STDEN)
            IF (HLAMB.GT.6.1D0) THEN
               NONSTI=0
               IASTI=IASTI+1
               IF (IASTI.EQ.15) THEN
                  IF (IPRINT.GT.0) WRITE (IPRINT,*)
     &               ' THE PROBLEM SEEMS TO BECOME STIFF AT X = ',X
                  IF (IPRINT.LE.0) GOTO 76
               END IF
            ELSE
               NONSTI=NONSTI+1
               IF (NONSTI.EQ.6) IASTI=0
            END IF
         END IF
C ------- FINAL PREPARATION FOR DENSE OUTPUT
         IF (IOUT.GE.2) THEN
C ----    SAVE THE FIRST FUNCTION EVALUATIONS
            DO 62 J=1,NRD
               I=ICOMP(J)
               CONT(J)=Y(I)
               YDIFF=K5(I)-Y(I)
               CONT(J+NRD)=YDIFF
               BSPL=H*K1(I)-YDIFF
               CONT(J+NRD*2)=BSPL
               CONT(J+NRD*3)=YDIFF-H*K4(I)-BSPL
               CONT(J+NRD*4)=D41*K1(I)+D46*K6(I)+D47*K7(I)+D48*K8(I)
     &                  +D49*K9(I)+D410*K10(I)+D411*K2(I)+D412*K3(I)
               CONT(J+NRD*5)=D51*K1(I)+D56*K6(I)+D57*K7(I)+D58*K8(I)
     &                  +D59*K9(I)+D510*K10(I)+D511*K2(I)+D512*K3(I)
               CONT(J+NRD*6)=D61*K1(I)+D66*K6(I)+D67*K7(I)+D68*K8(I)
     &                  +D69*K9(I)+D610*K10(I)+D611*K2(I)+D612*K3(I)
               CONT(J+NRD*7)=D71*K1(I)+D76*K6(I)+D77*K7(I)+D78*K8(I)
     &                  +D79*K9(I)+D710*K10(I)+D711*K2(I)+D712*K3(I)
   62       CONTINUE
C ---     THE NEXT THREE FUNCTION EVALUATIONS
            DO 51 I=1,N
  51           Y1(I)=Y(I)+H*(A141*K1(I)+A147*K7(I)+A148*K8(I)
     &            +A149*K9(I)+A1410*K10(I)+A1411*K2(I)+A1412*K3(I)
     &            +A1413*K4(I))
            CALL FCN(N,X+C14*H,Y1,K10,RPAR,IPAR)
            DO 52 I=1,N
  52           Y1(I)=Y(I)+H*(A151*K1(I)+A156*K6(I)+A157*K7(I)
     &            +A158*K8(I)+A1511*K2(I)+A1512*K3(I)+A1513*K4(I)
     &            +A1514*K10(I))
            CALL FCN(N,X+C15*H,Y1,K2,RPAR,IPAR)
            DO 53 I=1,N
  53           Y1(I)=Y(I)+H*(A161*K1(I)+A166*K6(I)+A167*K7(I)
     &            +A168*K8(I)+A169*K9(I)+A1613*K4(I)+A1614*K10(I)
     &            +A1615*K2(I))
            CALL FCN(N,X+C16*H,Y1,K3,RPAR,IPAR)
            NFCN=NFCN+3
C ---     FINAL PREPARATION
            DO 63 J=1,NRD
               I=ICOMP(J)
               CONT(J+NRD*4)=H*(CONT(J+NRD*4)+D413*K4(I)+D414*K10(I)
     &            +D415*K2(I)+D416*K3(I))
               CONT(J+NRD*5)=H*(CONT(J+NRD*5)+D513*K4(I)+D514*K10(I)
     &            +D515*K2(I)+D516*K3(I))
               CONT(J+NRD*6)=H*(CONT(J+NRD*6)+D613*K4(I)+D614*K10(I)
     &            +D615*K2(I)+D616*K3(I))
               CONT(J+NRD*7)=H*(CONT(J+NRD*7)+D713*K4(I)+D714*K10(I)
     &            +D715*K2(I)+D716*K3(I))
  63        CONTINUE
            HOUT=H
         END IF
         DO 67 I=1,N
         K1(I)=K4(I)
  67     Y(I)=K5(I)
         XOLD=X
         X=XPH
         IF (IOUT.GE.1) THEN
            CALL SOLOUT(NACCPT+1,XOLD,X,Y,N,CONT,ICOMP,NRD,
     &                  RPAR,IPAR,IRTRN)
            IF (IRTRN.LT.0) GOTO 79
         END IF
C ------- NORMAL EXIT
         IF (LAST) THEN
            H=HNEW
            IDID=1
            RETURN
         END IF
         IF(ABS(HNEW).GT.HMAX)HNEW=POSNEG*HMAX
         IF(REJECT)HNEW=POSNEG*MIN(ABS(HNEW),ABS(H))
         REJECT=.FALSE.
      ELSE
C --- STEP IS REJECTED
         HNEW=H/MIN(FACC1,FAC11/SAFE)
         REJECT=.TRUE.
         IF(NACCPT.GE.1)NREJCT=NREJCT+1
         LAST=.FALSE.
      END IF
      H=HNEW
      GOTO 1
C --- FAIL EXIT
  76  CONTINUE
      IDID=-4
      RETURN
  77  CONTINUE
      IF (IPRINT.GT.0) WRITE(IPRINT,979)X
      IF (IPRINT.GT.0) WRITE(IPRINT,*)' STEP SIZE TOO SMALL, H=',H
      IDID=-3
      RETURN
  78  CONTINUE
      IF (IPRINT.GT.0) WRITE(IPRINT,979)X
      IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &     ' MORE THAN NMAX =',NMAX,'STEPS ARE NEEDED'
      IDID=-2
      RETURN
  79  CONTINUE
      IF (IPRINT.GT.0) WRITE(IPRINT,979)X
 979  FORMAT(' EXIT OF DOP853 AT X=',E18.4)
      IDID=2
      RETURN
      END
C
      FUNCTION HINIT853(N,FCN,X,Y,XEND,POSNEG,F0,F1,Y1,IORD,
     &                       HMAX,ATOL,RTOL,ITOL,RPAR,IPAR)
C ----------------------------------------------------------
C ----  COMPUTATION OF AN INITIAL STEP SIZE GUESS
C ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Y(N),Y1(N),F0(N),F1(N),ATOL(*),RTOL(*)
      DIMENSION RPAR(*),IPAR(*)
C ---- COMPUTE A FIRST GUESS FOR EXPLICIT EULER AS
C ----   H = 0.01 * NORM (Y0) / NORM (F0)
C ---- THE INCREMENT FOR EXPLICIT EULER IS SMALL
C ---- COMPARED TO THE SOLUTION
      DNF=0.0D0
      DNY=0.0D0
      ATOLI=ATOL(1)
      RTOLI=RTOL(1)
      IF (ITOL.EQ.0) THEN
        DO 10 I=1,N
        SK=ATOLI+RTOLI*ABS(Y(I))
        DNF=DNF+(F0(I)/SK)**2
  10    DNY=DNY+(Y(I)/SK)**2
      ELSE
        DO 11 I=1,N
        SK=ATOL(I)+RTOL(I)*ABS(Y(I))
        DNF=DNF+(F0(I)/SK)**2
  11    DNY=DNY+(Y(I)/SK)**2
      END IF
      IF (DNF.LE.1.D-10.OR.DNY.LE.1.D-10) THEN
         H=1.0D-6
      ELSE
         H=SQRT(DNY/DNF)*0.01D0
      END IF
      H=MIN(H,HMAX)
      H=SIGN(H,POSNEG)
C ---- PERFORM AN EXPLICIT EULER STEP
      DO 12 I=1,N
  12  Y1(I)=Y(I)+H*F0(I)
      CALL FCN(N,X+H,Y1,F1,RPAR,IPAR)
C ---- ESTIMATE THE SECOND DERIVATIVE OF THE SOLUTION
      DER2=0.0D0
      IF (ITOL.EQ.0) THEN
        DO 15 I=1,N
        SK=ATOLI+RTOLI*ABS(Y(I))
  15    DER2=DER2+((F1(I)-F0(I))/SK)**2
      ELSE
        DO 16 I=1,N
        SK=ATOL(I)+RTOL(I)*ABS(Y(I))
  16    DER2=DER2+((F1(I)-F0(I))/SK)**2
      END IF
      DER2=SQRT(DER2)/H
C ---- STEP SIZE IS COMPUTED SUCH THAT
C ----  H**IORD * MAX ( NORM (F0), NORM (DER2)) = 0.01
      DER12=MAX(ABS(DER2),SQRT(DNF))
      IF (DER12.LE.1.D-15) THEN
         H1=MAX(1.0D-6,ABS(H)*1.0D-3)
      ELSE
         H1=(0.01D0/DER12)**(1.D0/IORD)
      END IF
      H=MIN(100*ABS(H),H1,HMAX)
      HINIT853=SIGN(H,POSNEG)
      RETURN
      END
C
      FUNCTION CONTD8(II,X,CON,ICOMP,ND)
C ----------------------------------------------------------
C     THIS FUNCTION CAN BE USED FOR CONINUOUS OUTPUT IN CONNECTION
C     WITH THE OUTPUT-SUBROUTINE FOR DOP853. IT PROVIDES AN
C     APPROXIMATION TO THE II-TH COMPONENT OF THE SOLUTION AT X.
C ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION CON(8*ND),ICOMP(ND)
      COMMON /CONDO8/XOLD,H
C ----- COMPUTE PLACE OF II-TH COMPONENT
      I=0
      DO 5 J=1,ND
      IF (ICOMP(J).EQ.II) I=J
   5  CONTINUE
      IF (I.EQ.0) THEN
         WRITE (6,*) ' NO DENSE OUTPUT AVAILABLE FOR COMP.',II
         CONTD8=-1
         RETURN
      END IF
      S=(X-XOLD)/H
      S1=1.D0-S
      CONPAR=CON(I+ND*4)+S*(CON(I+ND*5)+S1*(CON(I+ND*6)+S*CON(I+ND*7)))
      CONTD8=CON(I)+S*(CON(I+ND)+S1*(CON(I+ND*2)+S*(CON(I+ND*3)
     &        +S1*CONPAR)))
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine calcdatarget(ifront,co,nnfront,istartfront,
     &     iendfront,isubsurffront,damax,datarget,acrack,nstep)
!
!     calculate the crack propagation increment:
!     it is the minimum of:
!     - the user-defined increment
!     - one fifth of the minimum crack front curvature
!     - one fifth of the smallest crack length
!
      implicit none
!
      integer i,j,ifront(*),nnfront,istartfront(*),nstep,m,
     &     isubsurffront(*),iendfront(*),istart,iend
!
      real*8 datarget,damax,acrack(nstep,*),co(3,*),
     &     xp,yp,zp,xa,ya,za,xn,yn,zn,xlpa,xlan,xlnp,dd,rcur
!
      datarget=damax
!
!     loop over all fronts
!
      do i=1,nnfront
        if(isubsurffront(i).eq.1) then
          istart=istartfront(i)
          iend=iendfront(i)
        else
          istart=istartfront(i)+1
          iend=iendfront(i)-1
        endif
!
!     loop over nodes belonging to front
!
        do j=istart,iend
          if(j.eq.istart) then
!
!     previous node
!
            if(isubsurffront(i).eq.1) then
              xp=co(1,ifront(iend))
              yp=co(2,ifront(iend))
              zp=co(3,ifront(iend))
            else
              xp=co(1,ifront(j-1))
              yp=co(2,ifront(j-1))
              zp=co(3,ifront(j-1))
            endif
!
!     actual node
!
            xa=co(1,ifront(j))
            ya=co(2,ifront(j))
            za=co(3,ifront(j))
          else
!
!     new previous node is old actual node
!
            xp=xa
            yp=ya
            zp=za
!
!     new actual node is old next node
!
            xa=xn
            ya=yn
            za=zn
          endif
!
!     next node
!
          if((j.eq.iend).and.(isubsurffront(i).eq.1)) then
            xn=co(1,ifront(istart))
            yn=co(2,ifront(istart))
            zn=co(3,ifront(istart))
          else
            xn=co(1,ifront(j+1))
            yn=co(2,ifront(j+1))
            zn=co(3,ifront(j+1))
          endif
!
!     calculate the radius of a circle going through the previous,
!     actual and next node (formula of Heron)
!
          if(j.eq.istart) then
            xlpa=dsqrt((xa-xp)**2+(ya-yp)**2+(za-zp)**2)
          else
            xlpa=xlan
          endif
          xlan=dsqrt((xn-xa)**2+(yn-ya)**2+(zn-za)**2)
          xlnp=dsqrt((xp-xn)**2+(yp-yn)**2+(zp-zn)**2)
          dd=(xlpa+xlan+xlnp)/2.d0
!
!         radius of the circle
!
          rcur=xlpa*xlan*xlnp/
     &         (4.d0*dsqrt(dd*(dd-xlpa)*(dd-xlan)*(dd-xlnp)))
!
c     datarget=min(datarget,rcur/5.d0,acrack(j)/5.d0)
          datarget=min(datarget,rcur/5.d0)
          do m=1,nstep
            datarget=min(datarget,acrack(m,j)/5.d0)
          enddo
        enddo
      enddo
!
      return
      end


      PROGRAM xtqli
C     driver for routine tqli
      INTEGER NP
      REAL TINY
      PARAMETER(NP=10,TINY=1.0e-6)
      INTEGER i,j,k
      REAL a(NP,NP),c(NP,NP),d(NP),e(NP),f(NP)
      DATA c/5.0,4.3,3.0,2.0,1.0,0.0,-1.0,-2.0,-3.0,-4.0,
     *     4.3,5.1,4.0,3.0,2.0,1.0,0.0,-1.0,-2.0,-3.0,
     *     3.0,4.0,5.0,4.0,3.0,2.0,1.0,0.0,-1.0,-2.0,
     *     2.0,3.0,4.0,5.0,4.0,3.0,2.0,1.0,0.0,-1.0,
     *     1.0,2.0,3.0,4.0,5.0,4.0,3.0,2.0,1.0,0.0,
     *     0.0,1.0,2.0,3.0,4.0,5.0,4.0,3.0,2.0,1.0,
     *     -1.0,0.0,1.0,2.0,3.0,4.0,5.0,4.0,3.0,2.0,
     *     -2.0,-1.0,0.0,1.0,2.0,3.0,4.0,5.0,4.0,3.0,
     *     -3.0,-2.0,-1.0,0.0,1.0,2.0,3.0,4.0,5.0,4.0,
     *     -4.0,-3.0,-2.0,-1.0,0.0,1.0,2.0,3.0,4.0,5.0/
      do 12 i=1,NP
        do 11 j=1,NP
          a(i,j)=c(i,j)
11      continue
12    continue
      call tred2(a,NP,NP,d,e)
      call tqli(d,e,NP,NP,a)
      write(*,'(/1x,a)') 'Eigenvectors for a real symmetric matrix'
      do 16 i=1,NP
        do 14 j=1,NP
          f(j)=0.0
          do 13 k=1,NP
            f(j)=f(j)+c(j,k)*a(k,i)
13        continue
14      continue
        write(*,'(/1x,a,i3,a,f10.6)') 'Eigenvalue',i,' =',d(i)
        write(*,'(/1x,t7,a,t17,a,t31,a)') 'Vector','Mtrx*Vect.','Ratio'
        do 15 j=1,NP
          if (abs(a(j,i)).lt.TINY) then
            write(*,'(1x,2f12.6,a12)') a(j,i),f(j),'div. by 0'
          else
            write(*,'(1x,2f12.6,e14.6)') a(j,i),f(j),
     *           f(j)/a(j,i)
          endif
15      continue
        write(*,'(/1x,a)') 'press ENTER to continue...'
        read(*,*)
16    continue
      END

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


!!## MODULE: FUNCTION  HashP
MODULE FUN_HashP
!!### PURPOSE
!! Turns string into a number based upon a prime-number oriented
!! hashing rule.

!!### DETAILS
!! Testing this hash on a dictionary of words, these rules resulted
!! in a very even distribution of hash values---the number of words
!! far outweighed the number of available integers, but approximately
!! the same number of words were hashed to the same value.
!! Words that hashed to the same value were not similar, thus collision
!! resolution would be somewhat simple, to use <PrimeHash> in a
!! hash table implementation.

!!### AUTHOR
!! William A. Wieselquist | william.wieselquist@gmail.com

!!### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_S !!((01-A-KND_IntrinsicTypes.f90))

!!### EXTERNAL PROCEDURES
USE FUN_Default                     !!((04-A-FUN_Default.f90))

!!### DEFAULT IMPLICIT
IMPLICIT NONE

!!### DEFAULT ACCESS
PRIVATE

!!### INTEFACE
INTERFACE HashP
 MODULE PROCEDURE HashP_S
END INTERFACE

!!### PUBLIC ACCESS
PUBLIC :: HashP

!!### LOCAL PARAMETERS
!! @ mapping of ascii indices to hash numbers
!! @ ascii value of lower case "a"
!! @ ascii value of lower case "z"
!! @ DEFAULT value for optional case sensitivity input [DEFAULT_CaseSensitive]
!! @ DEFAULT value for optional full spectrum input [DEFAULT_FullSpectrum]
INTEGER,PARAMETER :: hash_map(0:127) = &
(/000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,&
  000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,&
  001,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,&
  002,003,005,007,011,013,017,019,023,029,000,000,000,000,000,000,&
  000,031,037,041,043,047,053,059,061,067,071,073,079,083,089,097,&
  101,103,107,109,113,127,131,137,139,149,151,000,000,000,000,001,&
  000,157,163,167,173,179,181,191,193,197,199,211,223,227,229,233,&
  239,241,251,257,263,269,271,277,281,000,000,000,000,000,000,000/)
INTEGER,PARAMETER :: ascii_a                 = IACHAR("a")
INTEGER,PARAMETER :: ascii_z                 = IACHAR("z")
LOGICAL,PARAMETER :: DEFAULT_CaseSensitive   = .FALSE.
LOGICAL,PARAMETER :: DEFAULT_FullSpectrum    = .FALSE.

!!## MODULE PROCEDURES
CONTAINS

!!### PURE FUNCTION: HashP_S
PURE FUNCTION HashP_S( word , &
  CaseSensitive , &
  FullSpectrum  ) &
  RESULT(Hash)

!!#### REQUIRED INPUT
!! @ input word to hash <word>
CHARACTER(LEN=*,KIND=KIND_S),INTENT(IN) :: word

!!#### OPTIONAL INPUT
!! @ whether or not to generate a case sensitive hash <CaseSensitive>
!! @ to have negative hash values and thus represent the whole spectrum
!!   of integers, words with an odd number of characters
!!   receive negative hash values if full spectrum is true <FullSpectrum>
LOGICAL,OPTIONAL,INTENT(IN) :: CaseSensitive
LOGICAL,OPTIONAL,INTENT(IN) :: FullSpectrum

!!#### REQUIRED OUTPUT
!! @ integer hash value <HASH>
INTEGER  :: HASH

!!#### LOCAL VARIABLES
LOGICAL :: LOCAL_CaseSensitive !LOCAL value for the optional CaseSensitive input
LOGICAL :: LOCAL_FullSpectrum  !LOCAL value for the optional FullSpectrum input
INTEGER :: i,j                 !character index
INTEGER :: ascii               !ascii value for ith character
INTEGER :: LEN_word            !length of the word
INTEGER,PARAMETER :: limit = HUGE(HASH)/1000
!!--begin--
!set options
LOCAL_CaseSensitive = DEFAULT( DEFAULT_CaseSensitive , CaseSensitive )
LOCAL_FullSpectrum  = DEFAULT( DEFAULT_FullSpectrum  , FullSpectrum  )

!get word length
LEN_word = LEN(word)

!get the hash
HASH = 0
IF( .NOT.LOCAL_CaseSensitive )THEN
 DO i=1,LEN_word
  ascii = IACHAR(word(i:i))
  IF( ascii_a<=ascii .AND. ascii<=ascii_z )THEN
   ascii = ascii - 32
  END IF
  j = LEN_word-i+1
  HASH = HASH + ( j + j**2 + j**3 - 2 )*hash_map(ascii)
  IF( HASH>limit )HASH = HASH/2 + MOD(HASH,limit)
 END DO
ELSE
 DO i=1,LEN_word
  ascii = IACHAR(word(i:i))
  j = LEN_word-i+1
  HASH = HASH + ( j + j**2 + j**3 - 2 )*hash_map(ascii)
  IF( HASH>limit )HASH = HASH/2 + MOD(HASH,limit)
 END DO
END IF

!make odd-length words have negative hashes if FullSpectrum==.TRUE.
IF( LOCAL_FullSpectrum )THEN
 IF( MOD(LEN_word,2)/=0 )THEN
  HASH = -HASH
 ENDIF
ENDIF

!!--end--
END FUNCTION

END MODULE


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   1cl :    A one-cell, two-substrate enzyme model
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION S,A,S0,A0,AL,RH,RK,D,R,DRDS,DRDA,DRDK

       S=U(1)
       A=U(2)

       S0=PAR(1)
       A0=PAR(2)
       AL=PAR(3)
       RH=PAR(4)
       RK=PAR(5)

       D=1+S+RK*S**2
       R=S*A/D

       F(1)=   (S0-S) - RH*R
       F(2)=AL*(A0-A) - RH*R

       IF(IJAC.EQ.0)RETURN

       DRDS=( A*D - S*A*(1+2*RK*S) ) / D**2
       DRDA=S/D
       DRDK=-S**3*A/D**2

       DFDU(1,1)=-1 - RH*DRDS
       DFDU(1,2)=   - RH*DRDA
       DFDU(2,1)=   - RH*DRDS
       DFDU(2,2)=-AL- RH*DRDA

      IF(IJAC.EQ.1)RETURN

!      *Parameter derivatives

       DFDP(1,1)=1
       DFDP(1,2)=0
       DFDP(1,3)=0
       DFDP(1,4)=-R
       DFDP(1,5)=-RH*DRDK

       DFDP(2,1)=0
       DFDP(2,2)=AL
       DFDP(2,3)=A0-A
       DFDP(2,4)=-R
       DFDP(2,5)=-RH*DRDK

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

       PAR(1)=110.
       PAR(2)=500.
       PAR(3)=0.2
       PAR(4)=2.021628
       PAR(5)=0.1

       U(1)=4.555974E+01
       U(2)=1.777987E+02

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS