module ppum
use types, only: dp
use constants, only: pi
use bsplines, only: bspline, bspline_der, bspline_der2
use mesh, only: meshexp
use quadrature, only: gauss_pts, gauss_wts
use utils, only: stop_error, assert
use linalg, only: eigh
implicit none
private
public do_ppum_basis

contains

    elemental function h(r, rc)
    ! C^3 cutoff function h(r)
    real(dp), intent(in) :: r  ! Point at which to evaluate, must be r >= 0
    real(dp), intent(in) :: rc ! Cutoff radius; h(r) = 0 for r >= rc
    real(dp) :: h
    if (r < rc) then
        h = 1 + 20*(r/rc)**7-70*(r/rc)**6+84*(r/rc)**5-35*(r/rc)**4
    else
        h = 0
    end if
    end function

    elemental function hp(r, rc)
    ! C^3 cutoff function h'(r)
    real(dp), intent(in) :: r  ! Point at which to evaluate, must be r >= 0
    real(dp), intent(in) :: rc ! Cutoff radius; h(r) = 0 for r >= rc
    real(dp) :: hp
    if (r < rc) then
        hp = 140*r**6/rc**7 - 420*r**5/rc**6 + 420*r**4/rc**5 - 140*r**3/rc**4
    else
        hp = 0
    end if
    end function

    subroutine do_ppum_basis(p, xmin, xmax, Ne, penr, npenr, alpha, ortho, Nq, &
            eps, ft_only, xq, wq, B, Bp)
    integer, intent(in) :: p, Ne
    integer, intent(in) :: penr ! polynomial order of the poly enrichment, e.g.
        ! penr = 3 means cubic polynomials (i.e. 4 basis functions spanned by:
        ! 1, x, x^2, x^3)
    integer, intent(in) :: npenr ! number of non-polynomial enrichments, e.g.
        ! npenr = 2 means two non-polynomial enrichments will be added to the
        ! polynomial basis/enrichments of the order penr.
    integer, intent(in) :: Nq, ortho
    real(dp), intent(in) :: xmin, xmax, alpha, eps
    logical, intent(in) :: ft_only
    real(dp), allocatable, intent(out) :: xq(:), wq(:), B(:,:), Bp(:,:)
    logical, allocatable :: Bactive(:,:)
    integer ::  N_intervals, Nq_total
    real(dp) :: rmin, rmax, dx
    real(dp) :: xa, xb, jac, x0
    real(dp), allocatable :: t(:), xiq(:), wtq(:), x(:), hq(:)
    real(dp), allocatable :: W(:,:), Wp(:,:), Wpp(:,:), S(:), Sp(:), Spp(:)
    real(dp), allocatable :: wi(:,:), wip(:,:), wipp(:,:)
    real(dp), allocatable :: Sm(:,:), eigs(:), vecs(:,:)
    real(dp), allocatable :: enr(:,:,:), enrp(:,:,:), enrn(:,:,:), enrnp(:,:,:)
    real(dp), allocatable :: mesh(:)
    real(dp) :: rc
    integer :: i, j, u, bindex, Nb
    integer :: n, k, m, Nenr
    Nenr = (penr+1) + npenr
    k = p+1
    if (mod(p, 2) == 0) then
        n = k+2
    else
        if (p == 1) then
            n = k+1
        else
            n = k+3
        end if
    end if
    bindex = n/2+1
    print *, "Evaluating basis functions"
    print *, "Constructing B-spline n =", n, ", k =", k
    N_intervals = n-k+1

    allocate(mesh(2*Ne))
    dx = (xmax-xmin)/Ne*(alpha-1)/2
    mesh(1) = xmin
    do i = 1, Ne-1
        mesh(2*i)   = (xmax-xmin)/Ne * i + xmin - dx
        mesh(2*i+1) = (xmax-xmin)/Ne * i + xmin + dx
    end do
    mesh(2*Ne) = xmax

    Nq_total = Nq*(2*Ne-1)

    allocate(xq(Nq_total), wq(Nq_total))
    allocate(t(n+k), xiq(Nq), wtq(Nq), x(Nq))
    allocate(W(Nq_total,Ne), Wp(Nq_total,Ne), Wpp(Nq_total,Ne))
    allocate(S(Nq_total), wi(Nq_total,Ne))
    allocate(Sp(Nq_total), wip(Nq_total,Ne))
    allocate(Spp(Nq_total), wipp(Nq_total,Ne))
    allocate(enr(Nq_total,Nenr,Ne))
    allocate(enrp(Nq_total,Nenr,Ne))
    allocate(enrn(Nq_total,Nenr,Ne))
    allocate(enrnp(Nq_total,Nenr,Ne))
    allocate(Sm(Nenr,Nenr))
    allocate(eigs(Nenr))
    allocate(vecs(Nenr,Nenr))
    allocate(Bactive(Nenr,Ne))
    allocate(hq(Nq_total))

    ! Loop over the mesh, and constract a global quadrature rule. Integrals of a
    ! function hq evaluated at the points xq are calculated using: sum(wq*hq)
    xiq = gauss_pts(Nq)
    wtq = gauss_wts(Nq)
    do i = 1, 2*Ne-1
        xa = mesh(i)
        xb = mesh(i+1)
        jac = (xb-xa)/2
        x = (xiq(:)+1) * jac + xa
        xq((i-1)*Nq+1:i*Nq) = x
        wq((i-1)*Nq+1:i*Nq) = wtq*jac
    end do

    ! Construct weight functions Wi(x)
    do i = 1, Ne
        dx = (xmax-xmin)/Ne*(alpha-1)/2
        rmin = (xmax-xmin)/Ne * (i-1) + xmin - dx
        rmax = (xmax-xmin)/Ne * i + xmin + dx
        t(:k-1) = rmin
        t(k:n+1) = meshexp(rmin, rmax, 1._dp, N_intervals)
        t(n+2:) = rmax
        W(:,i)   = bspline     (t, bindex, k, xq)
        Wp(:,i)  = bspline_der (t, bindex, k, xq)
        Wpp(:,i) = bspline_der2(t, bindex, k, xq)
    end do

    ! Construct PU functions using Shepard constructions
    S = 0
    Sp = 0
    Spp = 0
    do i = 1, Ne
        S = S + W(:,i)
        Sp = Sp + Wp(:,i)
        Spp = Spp + Wpp(:,i)
    end do
    do i = 1, Ne
        wi(:,i) = W(:,i)/S
        wip(:,i) = (Wp(:,i)*S - W(:,i)*Sp)/S**2
        wipp(:,i) = (Wpp(:,i)*S**2 - 2*Wp(:,i)*S*Sp - W(:,i)*S*Spp &
            + 2*W(:,i)*Sp**2)/S**3
    end do

    ! Construct enrichment functions enr(x)
    enr = 0
    enrp = 0
    do i = 1, Ne
        dx = (xmax-xmin)/Ne*(alpha-1)/2
        rmin = (xmax-xmin)/Ne * (i-1) + xmin - dx
        rmax = (xmax-xmin)/Ne * i + xmin + dx
        x0 = (rmin+rmax)/2
        x0 = min(abs(rmin),abs(rmax),abs(x0))
        jac = (rmax-rmin)/2
        do m = 0, penr ! m is the polynomial order, e.g. m=2 is quadratic
            j = m+1 ! j is the basis function number, starts from 1
            enr(:,j,i) = legendre_p((xq-rmin)/jac-1, m) * &
                sqrt(m + 1._dp/2)/sqrt(jac)
            enrp(:,j,i) = legendre_p_der((xq-rmin)/jac-1, m)/jac * &
                sqrt(m + 1._dp/2)/sqrt(jac)
            where (xq < rmin .or. xq > rmax)
                enr(:,j,i) = 0
                enrp(:,j,i) = 0
            end where
        end do
        do m = 1, npenr ! loop over non-poly enrichments
            j = m + penr+1 ! total enrichment basis function index
            rc = 300._dp
            select case(m)
                case (1)
                    if (abs(x0) <= 5) then
                        enr(:,j,i) = exp(-xq**2/2) / pi**(1._dp/4) &
                            * h(abs(xq), rc)
                        enrp(:,j,i) = (hp(abs(xq), rc)*sign(1._dp, xq) &
                            - xq*h(abs(xq), rc)) * exp(-xq**2/2) / pi**(1._dp/4)
                    else
                        enr(:,j,i) = 0
                        enrp(:,j,i) = 0
                    end if
                case (2)
                    enr(:,j,i) = xq*exp(-xq**2/2) / pi**(1._dp/4)*sqrt(2._dp)
                    enrp(:,j,i) = (1-xq**2)*exp(-xq**2/2) &
                        / pi**(1._dp/4)*sqrt(2._dp)
                case default
                    call stop_error("non-poly enrichment index not implemented")
            end select
            where (xq < rmin .or. xq > rmax)
                enr(:,j,i) = 0
                enrp(:,j,i) = 0
            end where
        end do
    end do

    ! Orthogonalize the enrichment enr(x) -> enrn(x)
    print *, "Orthogonalization (eigs per element):"
    Bactive = .false.
    do i = 1, Ne
        dx = (xmax-xmin)/Ne*(alpha-1)/2
        rmin = (xmax-xmin)/Ne * (i-1) + xmin
        rmax = (xmax-xmin)/Ne * i + xmin
        if (.not. ft_only) then
            rmin = rmin - dx
            rmax = rmax + dx
        end if
        do j = 1, Nenr
        do k = 1, Nenr
            hq = enr(:,j,i)*enr(:,k,i)*wq
            where (xq < rmin) hq = 0
            where (xq > rmax) hq = 0
            Sm(j,k) = sum(hq)
        end do
        end do
        call eigh(Sm, eigs, vecs)
        print "(200es8.1)", eigs
        do j = 1, Nenr
            enrn(:,j,i) = 0
            enrnp(:,j,i) = 0
            do k = 1, Nenr
                enrn (:,j,i) = enrn (:,j,i) + vecs(k,j)*enr (:,k,i)
                enrnp(:,j,i) = enrnp(:,j,i) + vecs(k,j)*enrp(:,k,i)
            end do
            if (eigs(j) > eps) then
                Bactive(j,i) = .true.
                enrn (:,j,i) = enrn (:,j,i) / sqrt(eigs(j))
                enrnp(:,j,i) = enrnp(:,j,i) / sqrt(eigs(j))
            end if
        end do
    end do

    !do i = 1, Ne
    !    do j = 1, Nenr
    !    do k = 1, Nenr
    !        Sm(j,k) = sum(enrn(:,j,i)*enrn(:,k,i)*wq)
    !    end do
    !    print *, j, Sm(j,:)
    !    end do
    !    call eigh(Sm, eigs, vecs)
    !    print *, eigs
    !    print *
    !end do
    !stop "OK"

    ! Use the orthogonalized functions
    select case (ortho)
        case (0)
            ! Do not use orthogonalized functions
            Bactive = .true.
        case (1)
            ! use orthogonalized functions
            enr = enrn
            enrp = enrnp
        case default
            call stop_error("Invalid 'ortho'.")
    end select

    ! Construct basis functions B = wi*enr
    allocate(B(Nq_total,count(Bactive)))
    allocate(Bp(Nq_total,count(Bactive)))
    Nb = 0
    do i = 1, Ne
        do j = 1, Nenr
            if (Bactive(j,i)) then
                Nb = Nb+1
                B(:,Nb)  = wi(:,i)*enr(:,j,i)
                Bp(:,Nb) = wip(:,i)*enr(:,j,i)+wi(:,i)*enrp(:,j,i)
            end if
        end do
    end do
    call assert(Nb == count(Bactive))

    !open(newunit=u, file="pu.txt", status="replace")
    !write(u,*) xq
    !do i = 1, Ne
    !    write(u,*) W(:,i)
    !end do
    !do i = 1, Ne
    !    write(u,*) wi(:,i)
    !end do
    !do i = 1, Ne
    !    write(u,*) wip(:,i)
    !end do
    !do i = 1, Ne
    !    write(u,*) wipp(:,i)
    !end do
    !close(u)

    !open(newunit=u, file="enr.txt", status="replace")
    !do i = 1, Ne
    !    do j = 1, Nenr
    !        write(u,*) enr(:,j,i)
    !        write(u,*) enrp(:,j,i)
    !    end do
    !end do
    !close(u)

    !open(newunit=u, file="ppum.txt", status="replace")
    !do i = 1, Ne
    !    do j = 1, Nenr
    !        write(u,*) B(:,j,i)
    !        write(u,*) Bp(:,j,i)
    !    end do
    !end do
    !close(u)
    end subroutine

    function legendre_p(x, n) result(r)
    real(dp), intent(in) :: x(:)
    integer, intent(in) :: n
    real(dp) :: r(size(x))
    select case (n)
        case (0)
            r = 1
        case (1)
            r = x
        case (2)
            r = (3*x**2-1)/2
        case (3)
            r = (5*x**3-3*x)/2
        case (4)
            r = (35*x**4-30*x**2+3)/8
        case (5)
            r = (63*x**5-70*x**3+15*x)/8
        case (6)
            r = (231*x**6-315*x**4+105*x**2-5)/16
        case (7)
            r = (429*x**7-693*x**5+315*x**3-35*x)/16
        case (8)
            r = (6435*x**8-12012*x**6+6930*x**4-1260*x**2+35)/128
        case (9)
            r = (12155*x**9-25740*x**7+18018*x**5-4620*x**3+315*x)/128
        case (10)
            r = (46189*x**10-109395*x**8+90090*x**6-30030*x**4+3465*x**2-63)/256
        case default
            call stop_error("n is too high")
    end select
    end function

    function legendre_p_der(x, n) result(r)
    real(dp), intent(in) :: x(:)
    integer, intent(in) :: n
    real(dp) :: r(size(x))
    select case (n)
        case (0)
            r = 0
        case (1)
            r = 1
        case (2)
            r = (6*x)/2
        case (3)
            r = (15*x**2-3)/2
        case (4)
            r = (140*x**3-60*x)/8
        case (5)
            r = (315*x**4-210*x**2+15)/8
        case (6)
            r = (1386*x**5-1260*x**3+210*x)/16
        case (7)
            r = (3003*x**6-3465*x**4+945*x**2-35)/16
        case (8)
            r = (51480*x**7-72072*x**5+27720*x**3-2520*x)/128
        case (9)
            r = (109395*x**8-180180*x**6+90090*x**4-13860*x**2+315)/128
        case (10)
            r = (461890*x**9-875160*x**7+540540*x**5-120120*x**3+6930*x)/256
        case default
            call stop_error("n is too high")
    end select
    end function

end module

program test_ppum
use types, only: dp
use ppum, only: do_ppum_basis
use linalg, only: eigh
use utils, only: stop_error, assert
use schroed_util, only: lho
implicit none
integer :: ppu, Ne, penr, npenr, Nq, Nq_total, i, j, u, ortho, Nb
real(dp) :: alpha, xmin, xmax, eps, condA, condB
real(dp), allocatable :: xq(:), wq(:)
real(dp), allocatable :: B(:,:), Bp(:,:), eigs(:)
logical :: ft_only

ppu = 3
penr = 3
npenr = 1
Ne = 1
alpha = 1.5_dp
xmin = -10
xmax = 10
ortho = 1
eps = 1e-15_dp
Nq = 64
ft_only = .false.

open(newunit=u, file="ppum_conv.txt", status="replace")
do i = 1, 10
    call do_ppum_basis(ppu, xmin, xmax, Ne, penr, npenr, alpha, ortho, Nq, &
        eps, ft_only, xq, wq, B, Bp)
    Nb = size(B,2)
    print *, "Nb =", Nb
    call lho(xq, wq, B, Bp, eigs, condA, condB)
    call assert(size(eigs) >= 4)
    write(u,*) Nb, condA, condB, eigs(:4)

    ! Adjust this to ~250 for a longer convergence study
    if (Nb > 70) exit
    Ne = Ne*2
end do
close(u)

end program


SUBROUTINE p117(input_file,output_file)
!-------------------------------------------------------------------------
! Program 11.7 Forced vibration analysis of an elastic solid in plane
!              strain using rectangular 8-node quadrilaterals. Lumped or
!              consistent mass. Mesh numbered in x- or y-direction.
!              Implicit time integration using the "theta" method.
!              No global matrix assembly. Diagonally preconditioned
!              conjugate gradient solver.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::cg_iters,cg_limit,i,j,iel,k,loaded_nodes,ndim=2,ndof=16,nels,   &
   neq,nip=9,nlen,nn,nod=8,nodof=2,npri,nprops=3,np_types,nr,nres,nst=3,  &
   nstep,nxe,nye
 REAL(iwp)::alpha,area,beta,cg_tol,c1,c2,c3,c4,det,dtim,fk,fm,one=1.0_iwp,&
   theta,time,up,zero=0.0_iwp
 LOGICAL::consistent=.FALSE.,cg_converged
 CHARACTER(LEN=15)::argv,element='quadrilateral'
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),nf(:,:),node(:),  &
   num(:)
 REAL(iwp),ALLOCATABLE::bee(:,:),coord(:,:),d(:),dee(:,:),der(:,:),       &
   deriv(:,:),diag_precon(:),d1x0(:),d1x1(:),d2x0(:),d2x1(:),ecm(:,:),    &
   fun(:),g_coord(:,:),jac(:,:),km(:,:),loads(:),mm(:,:),p(:),points(:,:),&
   prop(:,:),storkm(:,:,:),stormm(:,:,:),u(:),val(:,:),weights(:),x(:),   &
   xnew(:),x0(:),x1(:),x_coords(:),y_coords(:)
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,cg_tol,cg_limit,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(nf(nodof,nn),points(nip,ndim),g(ndof),g_coord(ndim,nn),         &
   dee(nst,nst),coord(nod,ndim),jac(ndim,ndim),weights(nip),der(ndim,nod),&
   deriv(ndim,nod),bee(nst,ndof),km(ndof,ndof),num(nod),g_num(nod,nels),  &
   g_g(ndof,nels),mm(ndof,ndof),ecm(ndof,ndof),fun(nod),etype(nels),      &
   prop(nprops,np_types),x_coords(nxe+1),y_coords(nye+1),                 &
   storkm(ndof,ndof,nels),stormm(ndof,ndof,nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords,dtim,nstep,theta,npri,nres,fm,fk
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(x0(0:neq),d1x0(0:neq),x1(0:neq),d2x0(0:neq),loads(0:neq),       &
   d1x1(0:neq),d2x1(0:neq),d(0:neq),p(0:neq),x(0:neq),xnew(0:neq),        &
   diag_precon(0:neq),u(0:neq))
 READ(10,*)loaded_nodes
 ALLOCATE(node(loaded_nodes),val(loaded_nodes,ndim))
 READ(10,*)(node(i),val(i,:),i=1,loaded_nodes)
!---------------loop the elements to set up element data------------------
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'y')
   CALL num_to_g(num,nf,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
 END DO elements_1
 CALL sample(element,points,weights)
 diag_precon=zero
 WRITE(11,'(A,I5,A)')" There are",neq," equations"
 c1=(one-theta)*dtim
 c2=fk-c1
 c3=fm+one/(theta*dtim)
 c4=fk+theta*dtim
 CALL sample(element,points,weights)
 diag_precon=zero
!----element stiffness and mass integration, storage and preconditioner---
 elements_2: DO iel=1,nels
   CALL deemat(dee,prop(1,etype(iel)),prop(2,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   mm=zero
   area=zero
   gauss_pts_1: DO i=1,nip
     CALL shape_der(der,points,i)
     CALL shape_fun(fun,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
     area=area+det*weights(i)
     IF(consistent)THEN
       CALL ecmat(ecm,fun,ndof,nodof)
       ecm=ecm*det*weights(i)
       mm=mm+ecm
     END IF
   END DO gauss_pts_1
   IF(.NOT.consistent)CALL elmat(area,prop(3,etype(iel)),mm)
   storkm(:,:,iel)=km
   stormm(:,:,iel)=mm
   DO k=1,ndof
     diag_precon(g(k))=diag_precon(g(k))+mm(k,k)*c3+km(k,k)*c4
   END DO
 END DO elements_2
 diag_precon(1:)=one/diag_precon(1:)
 diag_precon(0)=zero
!-----------------------time stepping loop--------------------------------
 x0=zero
 d1x0=zero
 d2x0=zero
 time=zero
 WRITE(11,'(/A,I5)')" Result at node",nres
 WRITE(11,'(A)')                                                          &
   "    time        load        x-disp      y-disp     cg iters"
 WRITE(11,'(4E12.4)')time,load(time),x0(nf(:,nres))
 timesteps: DO j=1,nstep
   time=time+dtim
   loads=zero
   u=zero
   elements_3: DO iel=1,nels
     g=g_g(:,iel)
     km=storkm(:,:,iel)
     mm=stormm(:,:,iel)
     u(g)=u(g)+MATMUL(km*c2+mm*c3,x0(g))+MATMUL(mm/theta,d1x0(g))
   END DO elements_3
   u(0)=zero
   DO i=1,loaded_nodes
     loads(nf(:,node(i)))=                                                &
       val(i,:)*(theta*dtim*load(time)+c1*load(time-dtim))
   END DO
   loads=u+loads
   d=diag_precon*loads
   p=d
   x=zero
   cg_iters=0
!-----------------------pcg equation solution-----------------------------
   pcg: DO
     cg_iters=cg_iters+1
     u=zero
     elements_4: DO iel=1,nels
       g=g_g(:,iel)
       km=storkm(:,:,iel)
       mm=stormm(:,:,iel)
       u(g)=u(g)+MATMUL(mm*c3+km*c4,p(g))
     END DO elements_4
     u(0)=zero
     up=DOT_PRODUCT(loads,d)
     alpha=up/DOT_PRODUCT(p,u)
     xnew=x+p*alpha
     loads=loads-u*alpha
     d=diag_precon*loads
     beta=DOT_PRODUCT(loads,d)/up
     p=d+p*beta
     call checon(xnew,x,cg_tol,cg_converged)
     IF(cg_converged.OR.cg_iters==cg_limit)EXIT
   END DO pcg
   x1=xnew
   d1x1=(x1-x0)/(theta*dtim)-d1x0*(one-theta)/theta
   d2x1=(d1x1-d1x0)/(theta*dtim)-d2x0*(one-theta)/theta
   IF(j/npri*npri==j)                                                     &
     WRITE(11,'(4E12.4,I8)')time,load(time),x1(nf(:,nres)),cg_iters
   x0=x1
   d1x0=d1x1
   d2x0=d2x1
 END DO timesteps

CONTAINS
FUNCTION load(t) RESULT(load_result)
!-----------------------Load-time function--------------------------------
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::t
 REAL(iwp)::load_result
 load_result=COS(0.3_iwp*t)
RETURN
END FUNCTION load
END SUBROUTINE p117


program solarsystem
  use solver_class

  implicit none

  integer,parameter::numbodies=10
  real(8)::Tmax=250,h
  integer::Num_Steps=10000,m
  real(8),dimension(10)::masses
  real(8),dimension(10,3)::position
  real(8),dimension(10,3)::velocity
  real(8),dimension(numbodies,numbodies,4)::relposition,updaterel
  real(8),dimension(numbodies,3)::relforce
  real(8),dimension(numbodies,3)::updatedforce
  real(8),dimension(numbodies+1)::kinetic,potential,angular

  type(solver)::solar

  solar%mass(1)=1.d0
  solar%mass(2)=3.d-6
  solar%mass(3)=9.5d-4
  solar%mass(4)=3.227d-7
  solar%mass(5)=2.4478d-6
  solar%mass(6)=2.85812d-4
  solar%mass(7)=1.66012d-7
  solar%mass(8)=4.36576d-5
  solar%mass(9)=5.1503d-5
  solar%mass(10)=6.583d-9
  solar%position(1,1)=3.1647d-3
  solar%position(1,2)=4.4307d-3
  solar%position(1,3)=-1.51447d-4
  solar%velocity(1,1)=365.25*(-3.37957d-6)
  solar%velocity(1,2)=365.25*(6.606862d-6)
  solar%velocity(1,3)=365.25*(7.32297d-8)
  solar%position(2,1)=-9.8825d-1
  solar%position(2,2)=8.49978d-2
  solar%position(2,3)=-1.5199728d-4
  solar%velocity(2,1)=365.25*(-1.68024d-3)
  solar%velocity(2,2)=365.25*(-1.719988d-2)
  solar%velocity(2,3)=365.25*(4.34984d-7)
  solar%position(3,1)=-5.23294d0
  solar%position(3,2)=-1.52515d0
  solar%position(3,3)=1.233648d-1
  solar%velocity(3,1)=365.25*(2.022596d-3)
  solar%velocity(3,2)=365.25*(-6.88771645d-3)
  solar%velocity(3,3)=365.25*(-1.6694179d-5)
  solar%position(4,1)=7.78069d-1
  solar%position(4,2)=1.2797d0
  solar%position(4,3)=7.555377d-3
  solar%velocity(4,1)=365.25*(-1.143145d-2)
  solar%velocity(4,2)=365.25*(8.4664712d-3)
  solar%velocity(4,3)=365.25*(4.5782387d-4)
  solar%position(5,1)=-7.02894d-1
  solar%position(5,2)=1.359581d-1
  solar%position(5,3)=4.239547d-2
  solar%velocity(5,1)=365.25*(-3.8130624d-3)
  solar%velocity(5,2)=365.25*(-1.9968d-2)
  solar%velocity(5,3)=365.25*(-5.4012702e-5)
  solar%position(6,1)=-1.48071d0
  solar%position(6,2)=-9.935855d0
  solar%position(6,3)=2.31688d-1
  solar%velocity(6,1)=365.25*(5.212138d-3)
  solar%velocity(6,2)=365.25*(-8.3942195d-4)
  solar%velocity(6,3)=365.25*(-1.931769d-4)
  solar%position(7,1)=2.805339d-1
  solar%position(7,2)=1.7274317d-1
  solar%position(7,3)=-1.1844519d-2
  solar%velocity(7,1)=365.25*(-2.01015d-2)
  solar%velocity(7,2)=365.25*(2.5290758d-2)
  solar%velocity(7,3)=365.25*(3.9099347d-3)
  solar%position(8,1)=1.822435d1
  solar%position(8,2)=8.083455d0
  solar%position(8,3)=-2.0607748d-1
  solar%velocity(8,1)=365.25*(-1.623364d-3)
  solar%velocity(8,2)=365.25*(3.411947d-3)
  solar%velocity(8,3)=365.25*(3.381457d-5)
  solar%position(9,1)=2.8412218d1
  solar%position(9,2)=-9.4680088d0
  solar%position(9,3)=-4.598129d-1
  solar%velocity(9,1)=365.25*(9.7114038d-4)
  solar%velocity(9,2)=365.25*(2.99682d-3)
  solar%velocity(9,3)=365.25*(-8.375523d-5)
  solar%position(10,1)=9.890335d0
  solar%position(10,2)=-3.177864195d1
  solar%position(10,3)=5.3964748d-1
  solar%velocity(10,1)=365.25*(3.06860367d-3)
  solar%velocity(10,2)=365.25*(2.905788d-4)
  solar%velocity(10,3)=365.25*(-9.08614726d-4)

  open(3,file="Earth.dat")
  open(4,file="Jupiter.dat")
  open(5,file="energy.dat")
  open(7,file="momentum.dat")
  open(8,file="Mars.dat")
  open(9,file="Venus.dat")
  open(10,file="Saturn.dat")
  open(11,file="Mercury.dat")
  open(12,file="Uranus.dat")
  open(13,file="Neptune.dat")
  open(14,file="Pluto.dat")

  h=Tmax/Num_Steps
  do m=1,Num_Steps

     call relative_position(solar,numbodies,relposition)
     call forces(solar,Numbodies,relposition,relforce)
     call calc_position(solar,numbodies,relforce,h)
     call relative_position(solar,numbodies,updaterel)
     call forces(solar,numbodies,updaterel,updatedforce)
     call calc_velocities(solar,numbodies,relforce,updatedforce,h)
     call kinetic_energy(solar,numbodies,kinetic)
     call potential_energy(solar,numbodies,updaterel,potential)
     call angular_momentum(solar,numbodies,updaterel,angular)

!     write(5,*), kinetic(Numbodies+1), potential(numbodies+1)
!     write(7,*), angular(Numbodies+1)

     write(3,*),solar%position(2,1),solar%position(2,2),solar%position(2,3)
     write(4,*),solar%position(3,1),solar%position(3,2),solar%position(3,3)
     write(8,*),solar%position(4,1),solar%position(4,2),solar%position(4,3)
     write(9,*),solar%position(5,1),solar%position(5,2),solar%position(5,3)
     write(10,*),solar%position(6,1),solar%position(6,2),solar%position(6,3)
     write(11,*),solar%position(7,1),solar%position(7,2),solar%position(7,3)
     write(12,*),solar%position(8,1),solar%position(8,2),solar%position(8,3)
     write(13,*),solar%position(9,1),solar%position(9,2),solar%position(9,3)
     write(14,*),solar%position(10,1),solar%position(10,2),solar%position(10,3)

  end do

  close(3)
  close(4)
  close(5)
  close(7)
  close(8)
  close(9)
  close(10)
  close(11)
  close(12)
  close(13)
  close(14)
end program solarsystem


module EOS_CC
  implicit none
contains
subroutine compute_pref_eos_cc(p_ref,rho,a,b,esp1,esp2,rho0)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(in) :: a,b,esp1,esp2,rho0
  double precision,intent(inout) :: p_ref
  double precision :: v
  v = rho0/rho
  p_ref = a*v**(-esp1) - b*v**(-esp2)
end subroutine compute_pref_eos_cc

subroutine compute_dpref_eos_cc(dp_ref,rho,a,b,esp1,esp2,rho0)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(in) :: a,b,esp1,esp2,rho0
  double precision,intent(inout) :: dp_ref
  double precision :: v
  v = rho0/rho
  dp_ref = esp1*a*v**(1.d0-esp1)/rho0 &
          -esp2*b*v**(1.d0-esp2)/rho0
end subroutine compute_dpref_eos_cc

subroutine compute_dpref2_eos_cc(dp_ref,p_ref,rho,a,b,esp1,esp2,rho0)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(in) :: a,b,esp1,esp2,rho0
  double precision,intent(inout) :: p_ref,dp_ref
  double precision :: v,vpow1,vpow2
  v = rho0/rho
  vpow1  = v**(-esp1)
  vpow2  = v**(-esp2)
  p_ref  = a*vpow1 &
          -b*vpow2
  dp_ref = esp1*a*vpow1*v/rho0 &
          -esp2*b*vpow2*v/rho0
end subroutine compute_dpref2_eos_cc

subroutine compute_eiref_eos_cc(ei_ref,rho,a,b,esp1,esp2,rho0)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(in) :: a,b,esp1,esp2,rho0
  double precision,intent(inout) :: ei_ref
  double precision :: v
  v = rho0/rho
  ei_ref =-a*(v**(1.d0-esp1)-1.d0)/(rho0*(1.d0-esp1)) &
          +b*(v**(1.d0-esp2)-1.d0)/(rho0*(1.d0-esp2))
end subroutine compute_eiref_eos_cc

subroutine compute_deiref_eos_cc(dei_ref,rho,a,b,esp1,esp2,rho0)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(in) :: a,b,esp1,esp2,rho0
  double precision,intent(inout) :: dei_ref
  double precision :: v
  v = rho0/rho
  dei_ref = a*v**(2.d0-esp1)/rho0**2 &
           -b*v**(2.d0-esp2)/rho0**2
end subroutine compute_deiref_eos_cc

subroutine compute_deiref2_eos_cc(dei_ref,ei_ref,rho,a,b,esp1,esp2,rho0)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(in) :: a,b,esp1,esp2,rho0
  double precision,intent(inout) :: ei_ref,dei_ref
  double precision :: v,vpow1,vpow2
  v = rho0/rho
  vpow1 = v**(1.d0-esp1)
  vpow2 = v**(1.d0-esp2)
  ei_ref =-a*(vpow1-1.d0)/(rho0*(1.d0-esp1)) &
          +b*(vpow2-1.d0)/(rho0*(1.d0-esp2))
  dei_ref = a*vpow1*v/rho0**2 &
           -b*vpow2*v/rho0**2
end subroutine compute_deiref2_eos_cc

subroutine compute_gamma_eos_cc(gamma,rho,gamma0)
  implicit none
  double precision,intent(in) :: rho,gamma0
  double precision,intent(inout) :: gamma
  gamma = gamma0
end subroutine compute_gamma_eos_cc

subroutine compute_xi_eos_cc(xi,rho,gamma0)
  implicit none
  double precision,intent(in) :: rho,gamma0
  double precision,intent(inout) :: xi
  double precision :: gamma
  call compute_gamma_eos_cc(gamma,rho,gamma0)
  xi = 1.d0/gamma
end subroutine compute_xi_eos_cc

! compute the internal energy of product
subroutine compute_ei_eos_cc(ei,p,rho,a,b,esp1,esp2,rho0,gamma0,q0)
  implicit none
  double precision,intent(in) :: p,rho,a,b,esp1,esp2,rho0,gamma0,q0
  double precision,intent(inout) :: ei
  double precision :: p_ref, ei_ref,gamma
  call compute_pref_eos_cc(p_ref,rho,a,b,esp1,esp2,rho0)
  call compute_eiref_eos_cc(ei_ref,rho,a,b,esp1,esp2,rho0)
  call compute_gamma_eos_cc(gamma,rho,gamma0)
  ei = (p - p_ref)/(rho*gamma) + ei_ref - q0
end subroutine compute_ei_eos_cc

! compute the dedrho
subroutine compute_dedr_eos_cc(dedr,p,rho,a,b,esp1,esp2,rho0,gamma0)
  implicit none
  double precision,intent(in) :: p,rho
  double precision,intent(in) :: a,b,esp1,esp2,rho0,gamma0
  double precision,intent(inout) :: dedr
  double precision :: p_ref, gamma
  double precision :: dprefdr
  double precision :: derefdr
  double precision :: v,vpow1,vpow2
  v = rho0/rho
  vpow1  = v**(-esp1)
  vpow2  = v**(-esp2)
  p_ref  = a*vpow1 &
          -b*vpow2
  dprefdr = esp1*a*vpow1*v/rho0 &
           -esp2*b*vpow2*v/rho0
  derefdr = a*vpow1*v**2/rho0**2 &
           -b*vpow2*v**2/rho0**2
  call compute_gamma_eos_cc(gamma,rho,gamma0)
  dedr = (-dprefdr*gamma*rho-(p-p_ref)*gamma)/(rho*gamma)**2 + derefdr
end subroutine compute_dedr_eos_cc

! compute dedp
subroutine compute_dedp_eos_cc(dedp,rho,gamma0)
  implicit none
  double precision,intent(in) :: rho,gamma0
  double precision,intent(inout) :: dedp
  double precision :: gamma
  call compute_gamma_eos_cc(gamma,rho,gamma0)
  dedp = 1.0/(gamma*rho)
end subroutine compute_dedp_eos_cc

! compute the sound speed
subroutine compute_sound2_eos_cc(c2,p,rho,a,b,esp1,esp2,rho0,gamma0)
  implicit none
  double precision,intent(in) :: p,rho,a,b,esp1,esp2,rho0,gamma0
  double precision,intent(inout) :: c2
  double precision :: dedp,dedr
  call compute_dedr_eos_cc(dedr,p,rho,a,b,esp1,esp2,rho0,gamma0)
  call compute_dedp_eos_cc(dedp,rho,gamma0)
  c2 = (p/rho**2-dedr)/dedp
end subroutine compute_sound2_eos_cc

end module


        subroutine refmodelcalc(lambda,reflambda,beta,T,pixel,fwhmobj, &
            psf,ncp,refmodel,nref)

! Calculate model image at wavelength lambda based on gaussian object of
! size 'fwhmobj' [pixels], temperature T [K], and unity central optical depth
! at reference wavelength.
! Output refmodel is an array nref by nref with centre pixel (iref,iref).
! Output units: Jy/pixel.

        implicit real (a-h,o-z)
        implicit integer (i-n)

        real,   intent(in),                           &
        &       dimension(ncp,ncp)      ::   psf         ! point spread func

        real,   intent(out),                        &
        &       dimension(nref,nref)    ::   refmodel    ! reference model

        real,   allocatable             ::   tau(:,:), image(:,:)
        real,   allocatable             ::   kernel(:,:)
        real lambda
        real,      parameter   :: pi      = 3.141593

        allocate (image(nref,nref))
        image = 0.
        iref = nref/2 + 1
        fwhm = fwhmobj*pixel * 0.01 ! make it very narrow
        coef = -4.*log(2.)*(pixel/fwhm)**2

        allocate (tau(nref,nref))
        tau = 0.
        do j = 1,nref
        do i = 1,nref
            tau(i,j) = exp(coef*(float(i-iref)**2 + float(j-iref)**2))
        enddo
        enddo
        !tau = tau/sum(tau)
        image = tau*(reflambda/lambda)**beta * planckfn(lambda,T)*pixel**2
        deallocate(tau)

! Convolve with PSF.
        allocate (kernel(ncp+1, ncp+1))
        icp = ncp/2 + 1
        kernel = 0.
        do j = 1,ncp
        do i = 1,ncp
            kernel(ncp-i+2, ncp-j+2) = psf(i,j)
        enddo
        enddo
        kernel = kernel/sum(kernel)

        refmodel = 0.
        do j = icp, nref-icp
        do i = icp, nref-icp
            csum = 0.
            do jj = 1,ncp+1
            do ii = 1,ncp+1
                csum = csum + kernel(ii,jj)*image(i+ii-icp, j+jj-icp)
            enddo
            enddo
            refmodel(i,j) = csum
        enddo
        enddo
        deallocate(kernel)
        deallocate(image)
        return

        end subroutine refmodelcalc


      subroutine rdat(nowcrp)
c
c     + + + PURPOSE + + +
c     Sets up the input to HDRIVE.  It gets the distance and time
c     location for depth calculations.  Converts ALPHA and rainfall
c     excess rates to internal length, for T from 0 to T(N), for N
c     between 1 and NS+1.
c
c     Called from IRS.
c     Author(s): Stone
c     Reference in User Guide: NONE
c
c     Changes:
c         1) Neither parameter is used (XTIME & NF).  Deleted
c            from RDAT, and it's call in IRS.
c         2) "do 10" & "do 20" loops combined.
c         3) Local variable CHEZYC deleted.
c         4) Since S is a REAL (not double precision), the line:
c                 if (s(i1).eq.0.d0) s(i1) = 1.d-10
c              was changed to:
c                 if (s(i1).eq.0.0) s(i1) = 1.e-10
c              and
c                 si(i) = 0.d0
c              was changed to:
c                 si(i) = 0.0
c
c     Version: This module recoded from WEPP version 91.10.
c     Date recoded: 05/08/91.
c     Recoded by: Charles R. Meyer.
c     Adapted to v91.39 by dcf - 9/13/91
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pmxcrp.inc'
      include 'pmxhil.inc'
      include 'pmxpln.inc'
      include 'pmxslp.inc'
      include 'pmxtim.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      integer nowcrp
c
c     + + + ARGUMENT DEFINITIONS + + +
c     nowcrp - number of current crop
c
c     + + + COMMON BLOCKS + + +
      include 'ccntour.inc'
c       read: conseq(mxcrop,mxplan),cntslp(conseq),rowlen(conseq)
c
      include 'cconsta.inc'
c       read: accgav
c
      include 'cdist2.inc'
c       read: slplen(mxplan)
c
      include 'cffact.inc'
c       read: frcteq(iplane)
c
      include 'cintgrl.inc'
c      write: si(mxhtim+1)
c
      include 'cpass1.inc'
c       read: s(mxtime)
      include 'cpass2.inc'
c       read: t(mxtime)
      include 'cpass3.inc'
c     modify: ns
c      write: len
c
      include 'cprams.inc'
c     modify: alpha(mxplan)
c      write: m,tstar
c
      include 'cslope2.inc'
c       read: avgslp
c
      include 'cstruc.inc'
c       read: iplane
c
c     + + + LOCAL VARIABLES + + +
      integer i, i1, ns2
c
c     + + + LOCAL DEFINITIONS + + +
c     i1     - I minus 1
c     ns2    - NS minus 2
c
c     + + + END SPECIFICATIONS + + +
c
c
c     depth-discharge exponent
c
      m = 1.5
c
c     Get distance and time locations for depth calculations
c
c     use average OFE slope and OFE length if no contours
c
      if (conseq(nowcrp,iplane).eq.0) then
        alpha(iplane) = sqrt(avgslp(iplane)*8.0*accgav/frcteq(iplane))
        len = slplen(iplane)
c
c     else - use contour slope and length
c          Fixed bug 1-22-2010 dcf - parentheses on sqrt now applies to whole expression
c
      else
        alpha(iplane) = sqrt(cntslp(conseq(nowcrp,iplane)) * 8.0 *
     1      accgav / frcteq(iplane))
        len = rowlen(conseq(nowcrp,iplane))
      end if
c
c
c     XXX -- Is this really NECESSARY? -- CRM -- 5/8/91
      tstar = t(ns)
c
      ns = ns - 1
c
      ns2 = ns + 2
c     4) Since S is a REAL (not double precision), the line:
c     if (s(i1).eq.0.d0) s(i1) = 1.d-10
c     was changed to:
c     if (s(i1).eq.0.0) s(i1) = 1.e-10
c     and
c     si(i) = 0.d0
c     was changed to:
c     si(i) = 0.0
c
c     change #4 above was not made as Jeff Stone stated.  Warnings
c     cropped up because of that.
c     double precision settings for SI have been removed
c     12-16-93 09:18am  sjl
c
c
      si(1) = 0.d0
c     si(1) = 0.0
      do 10 i = 2, mxtime + 1
        i1 = i - 1
        if (i.lt.ns2) then
c
c         Compute SI(N) as the integral of S with respect to T,
c         from 0 to T(N) for N between 1 and NS+1.
c         XXX -- How is S related to T?  Ie, what does the equation
c         look like?  -- CRM 5/8/91
c
c         if (s(i1).eq.0.0) s(i1) = 1.e-10
          if (s(i1).eq.0.d0) s(i1) = 1.d-10
          si(i) = si(i1) + s(i1) * (t(i)-t(i1))
        else
c
c         Rainfall excess preparation for HDRIVE
c
c         4) Since S is a REAL (not double precision), the line:
c         if (s(i1).eq.0.d0) s(i1) = 1.d-10
c         was changed to:
c         if (s(i1).eq.0.0) s(i1) = 1.e-10
c         and
c         si(i) = 0.d0
c         was changed to:
c         si(i) = 0.0
c
c         change #4 above was not made as Jeff Stone stated.  Warnings
c         cropped up because of that.
c         double precision settings for SI have been removed
c         12-16-93 09:18am  sjl
c
          si(i) = 0.d0
c         si(i) = 0.0
        end if
c
   10 continue
c
      return
      end


      SUBROUTINE BHMIE(X,REFREL,NANG,S1,S2,QEXT,QSCA,QBACK,GSCA)
! Declare parameters:
! Note: important that MXNANG be consistent with dimension of S1 and S2
!       in calling routine!
      INTEGER MXNANG,NMXX
!      PARAMETER(MXNANG=1000,NMXX=15000)
      PARAMETER(MXNANG=1000,NMXX=1500000)
! Arguments:
      INTEGER NANG
      REAL GSCA,QBACK,QEXT,QSCA,X
      COMPLEX REFREL
      COMPLEX S1(2*MXNANG-1),S2(2*MXNANG-1)
! Local variables:
      INTEGER J,JJ,N,NSTOP,NMX,NN
      DOUBLE PRECISION CHI,CHI0,CHI1,DANG,DX,EN,FN,P,PII,PSI,PSI0,PSI1,
     &                 THETA,XSTOP,YMOD
      DOUBLE PRECISION AMU(MXNANG),PI(MXNANG),PI0(MXNANG),PI1(MXNANG),
     &                 TAU(MXNANG)
      DOUBLE COMPLEX AN,AN1,BN,BN1,DREFRL,XI,XI1,Y
      DOUBLE COMPLEX D(NMXX)
!***********************************************************************
! Subroutine BHMIE is the Bohren-Huffman Mie scattering subroutine
!    to calculate scattering and absorption by a homogenous isotropic
!    sphere.
! Given:
!    X = 2*pi*a/lambda
!    REFREL = (complex refr. index of sphere)/(real index of medium)
!    NANG = number of angles between 0 and 90 degrees
!           (will calculate 2*NANG-1 directions from 0 to 180 deg.)
!           if called with NANG<2, will set NANG=2 and will compute
!           scattering for theta=0,90,180.
! Returns:
!    S1(1 - 2*NANG-1) = -i*f_22 (incid. E perp. to scatt. plane,
!                                scatt. E perp. to scatt. plane)
!    S2(1 - 2*NANG-1) = -i*f_11 (incid. E parr. to scatt. plane,
!                                scatt. E parr. to scatt. plane)
!    QEXT = C_ext/pi*a**2 = efficiency factor for extinction
!    QSCA = C_sca/pi*a**2 = efficiency factor for scattering
!    QBACK = (dC_sca/domega)/pi*a**2
!          = backscattering efficiency [NB: this is (1/4*pi) smaller
!            than the "radar backscattering efficiency"; see Bohren &
!            Huffman 1983 pp. 120-123]
!    GSCA = <cos(theta)> for scattering
!
! Original program taken from Bohren and Huffman (1983), Appendix A
! Modified by B.T.Draine, Princeton Univ. Obs., 90/10/26
! in order to compute <cos(theta)>
! 91/05/07 (BTD): Modified to allow NANG=1
! 91/08/15 (BTD): Corrected error (failure to initialize P)
! 91/08/15 (BTD): Modified to enhance vectorizability.
! 91/08/15 (BTD): Modified to make NANG=2 if called with NANG=1
! 91/08/15 (BTD): Changed definition of QBACK.
! 92/01/08 (BTD): Converted to full double precision and double complex
!                 eliminated 2 unneed lines of code
!                 eliminated redundant variables (e.g. APSI,APSI0)
!                 renamed RN -> EN = double precision N
!                 Note that DOUBLE COMPLEX and DCMPLX are not part
!                 of f77 standard, so this version may not be fully
!                 portable.  In event that portable version is
!                 needed, use src/bhmie_f77.f
! 93/06/01 (BTD): Changed AMAX1 to generic function MAX
!***********************************************************************
!*** Safety checks
      IF(NANG.GT.MXNANG)STOP'***Error: NANG > MXNANG in bhmie'
      IF(NANG.LT.2)NANG=2
!*** Obtain pi:
      PII=4.*ATAN(1.D0)
      DX=X
      DREFRL=REFREL
      Y=X*DREFRL
      YMOD=ABS(Y)
!
!*** Series expansion terminated after NSTOP terms
!    Logarithmic derivatives calculated from NMX on down
      XSTOP=X+4.*X**0.3333+2.
      NMX=MAX(XSTOP,YMOD)+15
! BTD experiment 91/1/15: add one more term to series and compare results
!      NMX=AMAX1(XSTOP,YMOD)+16
! test: compute 7001 wavelengths between .0001 and 1000 micron
! for a=1.0micron SiC grain.  When NMX increased by 1, only a single
! computed number changed (out of 4*7001) and it only changed by 1/8387
! conclusion: we are indeed retaining enough terms in series!
      NSTOP=XSTOP
!
      IF(NMX.GT.NMXX)THEN
          WRITE(0,*)'Error: NMX > NMXX=',NMXX,' for |m|x=',YMOD
          STOP
      ENDIF
!*** Require NANG.GE.1 in order to calculate scattering intensities
      DANG=0.
      IF(NANG.GT.1)DANG=.5*PII/DBLE(NANG-1)
      DO 1000 J=1,NANG
          THETA=DBLE(J-1)*DANG
          AMU(J)=COS(THETA)
 1000 CONTINUE
      DO 1100 J=1,NANG
          PI0(J)=0.
          PI1(J)=1.
 1100 CONTINUE
      NN=2*NANG-1
      DO 1200 J=1,NN
          S1(J)=(0.,0.)
          S2(J)=(0.,0.)
 1200 CONTINUE
!
!*** Logarithmic derivative D(J) calculated by downward recurrence
!    beginning with initial value (0.,0.) at J=NMX
!
      D(NMX)=(0.,0.)
      NN=NMX-1
      DO 2000 N=1,NN
          EN=NMX-N+1
          D(NMX-N)=(EN/Y)-(1./(D(NMX-N+1)+EN/Y))
 2000 CONTINUE
!
!*** Riccati-Bessel functions with real argument X
!    calculated by upward recurrence
!
      PSI0=COS(DX)
      PSI1=SIN(DX)
      CHI0=-SIN(DX)
      CHI1=COS(DX)
      XI1=DCMPLX(PSI1,-CHI1)
      QSCA=0.E0
      GSCA=0.E0
      P=-1.
      DO 3000 N=1,NSTOP
          EN=N
          FN=(2.E0*EN+1.)/(EN*(EN+1.))
! for given N, PSI  = psi_n        CHI  = chi_n
!              PSI1 = psi_{n-1}    CHI1 = chi_{n-1}
!              PSI0 = psi_{n-2}    CHI0 = chi_{n-2}
! Calculate psi_n and chi_n
          PSI=(2.E0*EN-1.)*PSI1/DX-PSI0
          CHI=(2.E0*EN-1.)*CHI1/DX-CHI0
          XI=DCMPLX(PSI,-CHI)
!
!*** Store previous values of AN and BN for use
!    in computation of g=<cos(theta)>
          IF(N.GT.1)THEN
              AN1=AN
              BN1=BN
          ENDIF
!
!*** Compute AN and BN:
          AN=(D(N)/DREFRL+EN/DX)*PSI-PSI1
          AN=AN/((D(N)/DREFRL+EN/DX)*XI-XI1)
          BN=(DREFRL*D(N)+EN/DX)*PSI-PSI1
          BN=BN/((DREFRL*D(N)+EN/DX)*XI-XI1)
!
!*** Augment sums for Qsca and g=<cos(theta)>
          QSCA=QSCA+(2.*EN+1.)*(ABS(AN)**2+ABS(BN)**2)
          GSCA=GSCA+((2.*EN+1.)/(EN*(EN+1.)))*
     &         (REAL(AN)*REAL(BN)+IMAG(AN)*IMAG(BN))
          IF(N.GT.1)THEN
              GSCA=GSCA+((EN-1.)*(EN+1.)/EN)*
     &        (REAL(AN1)*REAL(AN)+IMAG(AN1)*IMAG(AN)+
     &         REAL(BN1)*REAL(BN)+IMAG(BN1)*IMAG(BN))
          ENDIF
!
!*** Now calculate scattering intensity pattern
!    First do angles from 0 to 90
          DO 2500 J=1,NANG
              JJ=2*NANG-J
              PI(J)=PI1(J)
              TAU(J)=EN*AMU(J)*PI(J)-(EN+1.)*PI0(J)
              S1(J)=S1(J)+FN*(AN*PI(J)+BN*TAU(J))
              S2(J)=S2(J)+FN*(AN*TAU(J)+BN*PI(J))
 2500     CONTINUE
!
!*** Now do angles greater than 90 using PI and TAU from
!    angles less than 90.
!    P=1 for N=1,3,...; P=-1 for N=2,4,...
          P=-P
          DO 2600 J=1,NANG-1
              JJ=2*NANG-J
              S1(JJ)=S1(JJ)+FN*P*(AN*PI(J)-BN*TAU(J))
              S2(JJ)=S2(JJ)+FN*P*(BN*PI(J)-AN*TAU(J))
 2600     CONTINUE
          PSI0=PSI1
          PSI1=PSI
          CHI0=CHI1
          CHI1=CHI
          XI1=DCMPLX(PSI1,-CHI1)
!
!*** Compute pi_n for next value of n
!    For each angle J, compute pi_n+1
!    from PI = pi_n , PI0 = pi_n-1
          DO 2800 J=1,NANG
              PI1(J)=((2.*EN+1.)*AMU(J)*PI(J)-(EN+1.)*PI0(J))/EN
              PI0(J)=PI(J)
 2800     CONTINUE
 3000 CONTINUE
!
!*** Have summed sufficient terms.
!    Now compute QSCA,QEXT,QBACK,and GSCA
      GSCA=2.*GSCA/QSCA
      QSCA=(2./(DX*DX))*QSCA
      QEXT=(4./(DX*DX))*REAL(S1(1))
      QBACK=(ABS(S1(2*NANG-1))/DX)**2/PII
      RETURN
      END


SUBROUTINE UpdateGhostLayerY(var,S,Nx,Ny,DiffStencils,beta,GhostGridX,GhostGridY)
! By Allan P. Engsig-Karup.
USE Precision
USE DataTypes
IMPLICIT NONE
TYPE (Diff_def) :: DiffStencils
INTEGER :: Nx, Ny, rank, beta, i,j, GhostGridX, GhostGridY
REAL(KIND=long), DIMENSION(Nx,Ny) :: var, S
REAL(KIND=long), DIMENSION(2*beta+1) :: Stencil
rank = 2*beta+1
! two boundaries
j=1
DO i = 1+GhostGridX, Nx-GhostGridX
    Stencil = DiffStencils%StencilY(j+GhostGridY,1:rank,1)
    var(i,j) = (S(i,j+GhostGridY)-DOT_PRODUCT(Stencil(2:rank),var(i,2:rank) )) / Stencil(1)
END DO
j = Ny
DO i = 1+GhostGridX, Nx-GhostGridX
    Stencil = DiffStencils%StencilY(j-GhostGridY,1:rank,1)
    var(i,j) = (S(i,j-GhostGridY)-DOT_PRODUCT(Stencil(1:rank-1),var(i,j-rank+1:j-1) )) / Stencil(rank)
END DO
END SUBROUTINE UpdateGhostLayerY


program calc_rh

use m_precision
use m_constants_math
use m_strings
use m_trajectory
use m_vector
use m_globals
use m_config_io

implicit none

character(len=256) :: cla_buf
character(len=:), allocatable :: traj_dir
character(len=:), allocatable :: fn
integer :: num_traj, nts_beg
integer :: traj_ver, istage
integer :: i, j, itraj, iframe, ofrm, ierr, fu
type(ivector_t) :: counter
type(dvector_t) :: rh
real(rp) :: dkirk, tr, rnb, rh_ifrm
real(rp) :: rim2, rjm2
real(rp) :: rijm, irijm, irijm2
real(rp) :: ri_dot_rj
real(rp) :: C1, C2, consij
real(rp), dimension(3) :: ri, rj, rij

call get_command_argument(1, cla_buf)
fn_cfg = trim(cla_buf)

call get_command_argument(2, cla_buf)
fn_traj = trim(cla_buf)

call get_command_argument(3, cla_buf)
traj_dir = trim(cla_buf)

call get_command_argument(4, cla_buf)
num_traj = str_to_i(cla_buf)

call get_command_argument(5, cla_buf)
nts_beg = str_to_i(cla_buf)

traj_ver = 2 !Trajectory version

!Read cfg file
call read_config(fn_cfg)

call ivector_init(counter)
call dvector_init(rh)

rnb = 1.0_rp/num_atoms

do itraj = 1, num_traj
    !Open file for reading trajectory
    fn = traj_dir // '/' // fn_traj //'.' // str_from_num(itraj)
    write(*,*) fn
    call traj%open(fn, 'r')
    write(*,*) '  numframes ', traj%num_frames

    do iframe = 1, traj%num_frames
        call traj%read(traj_ver, iframe, istage, nblks, nts, coordinates, ierr)
        if (nblks < nts_beg) cycle
        ofrm = iframe - nts_beg + 1

        do j = 2, num_atoms
            rj = coordinates(:,j)
            rjm2 = dot_product(rj,rj)
            do i = 1, (j-1)
                ri = coordinates(:,i)
                rim2 = dot_product(ri,ri)
                ri_dot_rj = dot_product(ri,rj)
                rij = rj - ri
                rijm = norm2(rij)
                irijm = 1.0_rp/rijm
                irijm2 = irijm*irijm

                if (rijm >= 2.0_rp) then
                  C1 =  1.0_rp + (2.0_rp/3.0_rp)*irijm2
                  C2 =  1.0_rp - 2.0_rp*irijm2
                  consij = 0.75_rp*irijm
                else
                  C1 = 1.0_rp - 9.0_rp*rijm/(32.0_rp)
                  C2 = 3.0_rp*rijm/(32.0_rp)
                  consij = 1.0_rp
                end if

                tr = consij*( C1 + C2*rij(1)*rij(1)*irijm2 ) &
                   + consij*( C1 + C2*rij(2)*rij(2)*irijm2 ) &
                   + consij*( C1 + C2*rij(3)*rij(3)*irijm2 )

                dkirk = dkirk + 2*tr !Twice since symmetric
            end do
        end do

        dkirk = dkirk + 3*num_atoms !Diagonal components
        dkirk = dkirk*rnb*rnb/3
        rh_ifrm = 1.0_rp/dkirk

        if (ofrm > rh%len) then
            call rh%append( rh_ifrm )
            call counter%append( 1 )
        else
            call rh%set_val( ofrm, rh%get_val(ofrm)+rh_ifrm )
            call counter%set_val( ofrm, counter%get_val(ofrm)+1 )
        end if
    end do

    !Close trajectory
    call traj%close()
end do

open(newunit=fu, file='tmp.txt', action='write', status='replace')
write(fu,*) 'rh'
do i = 1, rh%len
    if (counter%get_val(i) > 0) write(fu, *) rh%get_val(i)/counter%get_val(i)
end do
close(fu)

call rh%delete()
call counter%delete()

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

end program


   PROGRAM max_min
   IMPLICIT NONE

   INTEGER (KIND=8),PARAMETER::nH=100,nS=2000
   INTEGER (KIND=8),PARAMETER::N=10000
   REAL (KIND=8),PARAMETER:: Jmp=0.420
   REAL (KIND=8),PARAMETER:: Jc=0.433, H0=0.43
   REAL (KIND=8),PARAMETER:: Smin=-1.,Smax=1,z=4.

   INTEGER (KIND=8) :: i,iS
   REAL    (KIND=8) :: T,J,S,delS,JMF,P_av

   REAL (KIND=8),DIMENSION(nS) :: Smp,P,F,FMF

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

!!!! =====================================================================================
!!! F by mean field

   OPEN(11,file='FMF.dat')

   JMF=(0.25/Jc)*Jmp
  ! JMF=1./z

   WRITE(*,*)'JMF=',JMF

   IF (nS==1) THEN
      delS=0.
   ELSE
      delS=(Smax-Smin)/real(nS)
   END IF

   DO iS=1,nS
      S=Smin+delS*real(iS-0.5)

      FMF(iS)=-0.5*z*JMF*S*S + S*0.5*log((1.+S)/(1.-S))+0.5*log(1.-(S*S))

      !FMF(iS)=-log(2.)+0.5*(1.-z*JMF)*S*S+(1./12.)*(S**4.)

   WRITE(11,*)S,FMF(iS)
   END DO

!!!! =====================================================================================
!!! F by numerical method

!!! Doc gia tri
   OPEN(unit=12,file='P0420.txt')
   OPEN(unit=13,file='F.dat')

   P_av=0.
   DO i=1,nS
      READ(12,*)T,J,Smp(i),P(i)
      P_av=P_av+P(i)
   END DO
   WRITE(*,*)'Pav=',P_av

   DO i=1,nS
         F(i)=-log(P(i)/P(1001))/10000.
         !F(i)=-log(P(i)/P(1001))/real(N)
      !WRITE(12,*)Smp(i)/N,F(i)*FMF(1001)/F(1001)

      WRITE(13,*)Smp(i)/N,F(i),F(i)*100.
   END DO

   CLOSE(11)
   CLOSE(12)
   CLOSE(13)

   END PROGRAM max_min


      subroutine clawpack46_tag4refinement(mx,my,mbc,
     &      meqn, xlower,ylower,dx,dy,blockno,
     &      q, tag_threshold, init_flag,tag_patch)
      implicit none

      integer mx,my, mbc, meqn, tag_patch, init_flag
      integer blockno
      double precision xlower, ylower, dx, dy
      double precision tag_threshold
      double precision q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision xp,yp,zp

      integer*8 cont, get_context
      logical fclaw2d_map_is_used

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision beta, theta(2)
      common /annulus_comm/ beta, theta

      integer mapping
      common /mapping_comm/ mapping

      integer refine_pattern
      common /refine_comm/ refine_pattern

      integer i,j, mq
      double precision qmin, qmax, xc, yc, xc1, yc1, zc1
      double precision r, rrefine, x,y, rw, ravg, th
      logical constant_theta, constant_r

      tag_patch = 0

      cont = get_context()

      rrefine = (1 + beta)/2.d0

c     # Refine based only on first variable in system.
      mq = 1
      qmin = q(1,1,mq)
      qmax = q(1,1,mq)

      ravg = (1 + beta)/2.d0
      rw = (1-beta)/4.d0
      do j = 1,my
         do i = 1,mx
            xc = xlower + (i-0.5)*dx
            yc = ylower + (j-0.5)*dy
            call fclaw2d_map_brick2c(cont,blockno,xc,yc,xc1,yc1,zc1)

            r = beta + (1-beta)*yc1
            th = pi2*(theta(1) + (theta(2)-theta(1))*xc1)
c           # constant_theta = cos(th) .lt. 0 .and. abs(sin(th)) .lt. 0.5
            !! constant_theta = t1 .le. th .and. th .le. t2
            constant_theta = th .gt. pi/2.d0
            constant_r = r > ravg
            if (refine_pattern .eq. 0 .and. constant_theta) then
                tag_patch = 1
                return
            elseif (refine_pattern .eq. 1 .and. constant_r) then
                tag_patch = 1
                return
            endif

c            call fclaw2d_map_brick2c(cont,blockno,xc,yc,xc1,yc1,zc1)
c            call annulus_transform_coordinates(xc1,yc1,x,y,mapping)
c            r = beta + (1-beta)*y
c            qmin = min(q(i,j,mq),qmin)
c            qmax = max(q(i,j,mq),qmax)
c            if (q(i,j,mq) .gt. tag_threshold .and.
c     &          q(i,j,mq) .lt. 1-tag_threshold) then
c                tag_patch = 1
c                return
cc                if (r .gt. rrefine) then
cc                   tag_patch = 1
cc                   return
cc                endif
c            endif
         enddo
      enddo

      end


*> \brief \b SSYCONVF_ROOK
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SSYCONVF_ROOK + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO, WAY
*       INTEGER            INFO, LDA, N
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       REAL               A( LDA, * ), E( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*> If parameter WAY = 'C':
*> SSYCONVF_ROOK converts the factorization output format used in
*> SSYTRF_ROOK provided on entry in parameter A into the factorization
*> output format used in SSYTRF_RK (or SSYTRF_BK) that is stored
*> on exit in parameters A and E. IPIV format for SSYTRF_ROOK and
*> SSYTRF_RK (or SSYTRF_BK) is the same and is not converted.
*>
*> If parameter WAY = 'R':
*> SSYCONVF_ROOK performs the conversion in reverse direction, i.e.
*> converts the factorization output format used in SSYTRF_RK
*> (or SSYTRF_BK) provided on entry in parameters A and E into
*> the factorization output format used in SSYTRF_ROOK that is stored
*> on exit in parameter A. IPIV format for SSYTRF_ROOK and
*> SSYTRF_RK (or SSYTRF_BK) is the same and is not converted.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          Specifies whether the details of the factorization are
*>          stored as an upper or lower triangular matrix A.
*>          = 'U':  Upper triangular
*>          = 'L':  Lower triangular
*> \endverbatim
*>
*> \param[in] WAY
*> \verbatim
*>          WAY is CHARACTER*1
*>          = 'C': Convert
*>          = 'R': Revert
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>
*>          1) If WAY ='C':
*>
*>          On entry, contains factorization details in format used in
*>          SSYTRF_ROOK:
*>            a) all elements of the symmetric block diagonal
*>               matrix D on the diagonal of A and on superdiagonal
*>               (or subdiagonal) of A, and
*>            b) If UPLO = 'U': multipliers used to obtain factor U
*>               in the superdiagonal part of A.
*>               If UPLO = 'L': multipliers used to obtain factor L
*>               in the superdiagonal part of A.
*>
*>          On exit, contains factorization details in format used in
*>          SSYTRF_RK or SSYTRF_BK:
*>            a) ONLY diagonal elements of the symmetric block diagonal
*>               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
*>               (superdiagonal (or subdiagonal) elements of D
*>                are stored on exit in array E), and
*>            b) If UPLO = 'U': factor U in the superdiagonal part of A.
*>               If UPLO = 'L': factor L in the subdiagonal part of A.
*>
*>          2) If WAY = 'R':
*>
*>          On entry, contains factorization details in format used in
*>          SSYTRF_RK or SSYTRF_BK:
*>            a) ONLY diagonal elements of the symmetric block diagonal
*>               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
*>               (superdiagonal (or subdiagonal) elements of D
*>                are stored on exit in array E), and
*>            b) If UPLO = 'U': factor U in the superdiagonal part of A.
*>               If UPLO = 'L': factor L in the subdiagonal part of A.
*>
*>          On exit, contains factorization details in format used in
*>          SSYTRF_ROOK:
*>            a) all elements of the symmetric block diagonal
*>               matrix D on the diagonal of A and on superdiagonal
*>               (or subdiagonal) of A, and
*>            b) If UPLO = 'U': multipliers used to obtain factor U
*>               in the superdiagonal part of A.
*>               If UPLO = 'L': multipliers used to obtain factor L
*>               in the superdiagonal part of A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*>          E is REAL array, dimension (N)
*>
*>          1) If WAY ='C':
*>
*>          On entry, just a workspace.
*>
*>          On exit, contains the superdiagonal (or subdiagonal)
*>          elements of the symmetric block diagonal matrix D
*>          with 1-by-1 or 2-by-2 diagonal blocks, where
*>          If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
*>          If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
*>
*>          2) If WAY = 'R':
*>
*>          On entry, contains the superdiagonal (or subdiagonal)
*>          elements of the symmetric block diagonal matrix D
*>          with 1-by-1 or 2-by-2 diagonal blocks, where
*>          If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
*>          If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
*>
*>          On exit, is not changed
*> \endverbatim
*.
*> \param[in] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          On entry, details of the interchanges and the block
*>          structure of D as determined:
*>          1) by SSYTRF_ROOK, if WAY ='C';
*>          2) by SSYTRF_RK (or SSYTRF_BK), if WAY ='R'.
*>          The IPIV format is the same for all these routines.
*>
*>          On exit, is not changed.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup singleSYcomputational
*
*> \par Contributors:
*  ==================
*>
*> \verbatim
*>
*>  November 2017,  Igor Kozachenko,
*>                  Computer Science Division,
*>                  University of California, Berkeley
*>
*> \endverbatim
*  =====================================================================
      SUBROUTINE SSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO, WAY
      INTEGER            INFO, LDA, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL               A( LDA, * ), E( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E+0 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*
*     .. External Subroutines ..
      EXTERNAL           SSWAP, XERBLA
*     .. Local Scalars ..
      LOGICAL            UPPER, CONVERT
      INTEGER            I, IP, IP2
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      CONVERT = LSAME( WAY, 'C' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5

      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SSYCONVF_ROOK', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( UPPER ) THEN
*
*        Begin A is UPPER
*
         IF ( CONVERT ) THEN
*
*           Convert A (A is upper)
*
*
*           Convert VALUE
*
*           Assign superdiagonal entries of D to array E and zero out
*           corresponding entries in input storage A
*
            I = N
            E( 1 ) = ZERO
            DO WHILE ( I.GT.1 )
               IF( IPIV( I ).LT.0 ) THEN
                  E( I ) = A( I-1, I )
                  E( I-1 ) = ZERO
                  A( I-1, I ) = ZERO
                  I = I - 1
               ELSE
                  E( I ) = ZERO
               END IF
               I = I - 1
            END DO
*
*           Convert PERMUTATIONS
*
*           Apply permutations to submatrices of upper part of A
*           in factorization order where i decreases from N to 1
*
            I = N
            DO WHILE ( I.GE.1 )
               IF( IPIV( I ).GT.0 ) THEN
*
*                 1-by-1 pivot interchange
*
*                 Swap rows i and IPIV(i) in A(1:i,N-i:N)
*
                  IP = IPIV( I )
                  IF( I.LT.N ) THEN
                     IF( IP.NE.I ) THEN
                        CALL SSWAP( N-I, A( I, I+1 ), LDA,
     $                              A( IP, I+1 ), LDA )
                     END IF
                  END IF
*
               ELSE
*
*                 2-by-2 pivot interchange
*
*                 Swap rows i and IPIV(i) and i-1 and IPIV(i-1)
*                 in A(1:i,N-i:N)
*
                  IP = -IPIV( I )
                  IP2 = -IPIV( I-1 )
                  IF( I.LT.N ) THEN
                     IF( IP.NE.I ) THEN
                        CALL SSWAP( N-I, A( I, I+1 ), LDA,
     $                              A( IP, I+1 ), LDA )
                     END IF
                     IF( IP2.NE.(I-1) ) THEN
                        CALL SSWAP( N-I, A( I-1, I+1 ), LDA,
     $                              A( IP2, I+1 ), LDA )
                     END IF
                  END IF
                  I = I - 1
*
               END IF
               I = I - 1
            END DO
*
         ELSE
*
*           Revert A (A is upper)
*
*
*           Revert PERMUTATIONS
*
*           Apply permutations to submatrices of upper part of A
*           in reverse factorization order where i increases from 1 to N
*
            I = 1
            DO WHILE ( I.LE.N )
               IF( IPIV( I ).GT.0 ) THEN
*
*                 1-by-1 pivot interchange
*
*                 Swap rows i and IPIV(i) in A(1:i,N-i:N)
*
                  IP = IPIV( I )
                  IF( I.LT.N ) THEN
                     IF( IP.NE.I ) THEN
                        CALL SSWAP( N-I, A( IP, I+1 ), LDA,
     $                              A( I, I+1 ), LDA )
                     END IF
                  END IF
*
               ELSE
*
*                 2-by-2 pivot interchange
*
*                 Swap rows i-1 and IPIV(i-1) and i and IPIV(i)
*                 in A(1:i,N-i:N)
*
                  I = I + 1
                  IP = -IPIV( I )
                  IP2 = -IPIV( I-1 )
                  IF( I.LT.N ) THEN
                     IF( IP2.NE.(I-1) ) THEN
                        CALL SSWAP( N-I, A( IP2, I+1 ), LDA,
     $                              A( I-1, I+1 ), LDA )
                     END IF
                     IF( IP.NE.I ) THEN
                        CALL SSWAP( N-I, A( IP, I+1 ), LDA,
     $                              A( I, I+1 ), LDA )
                     END IF
                  END IF
*
               END IF
               I = I + 1
            END DO
*
*           Revert VALUE
*           Assign superdiagonal entries of D from array E to
*           superdiagonal entries of A.
*
            I = N
            DO WHILE ( I.GT.1 )
               IF( IPIV( I ).LT.0 ) THEN
                  A( I-1, I ) = E( I )
                  I = I - 1
               END IF
               I = I - 1
            END DO
*
*        End A is UPPER
*
         END IF
*
      ELSE
*
*        Begin A is LOWER
*
         IF ( CONVERT ) THEN
*
*           Convert A (A is lower)
*
*
*           Convert VALUE
*           Assign subdiagonal entries of D to array E and zero out
*           corresponding entries in input storage A
*
            I = 1
            E( N ) = ZERO
            DO WHILE ( I.LE.N )
               IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN
                  E( I ) = A( I+1, I )
                  E( I+1 ) = ZERO
                  A( I+1, I ) = ZERO
                  I = I + 1
               ELSE
                  E( I ) = ZERO
               END IF
               I = I + 1
            END DO
*
*           Convert PERMUTATIONS
*
*           Apply permutations to submatrices of lower part of A
*           in factorization order where i increases from 1 to N
*
            I = 1
            DO WHILE ( I.LE.N )
               IF( IPIV( I ).GT.0 ) THEN
*
*                 1-by-1 pivot interchange
*
*                 Swap rows i and IPIV(i) in A(i:N,1:i-1)
*
                  IP = IPIV( I )
                  IF ( I.GT.1 ) THEN
                     IF( IP.NE.I ) THEN
                        CALL SSWAP( I-1, A( I, 1 ), LDA,
     $                              A( IP, 1 ), LDA )
                     END IF
                  END IF
*
               ELSE
*
*                 2-by-2 pivot interchange
*
*                 Swap rows i and IPIV(i) and i+1 and IPIV(i+1)
*                 in A(i:N,1:i-1)
*
                  IP = -IPIV( I )
                  IP2 = -IPIV( I+1 )
                  IF ( I.GT.1 ) THEN
                     IF( IP.NE.I ) THEN
                        CALL SSWAP( I-1, A( I, 1 ), LDA,
     $                              A( IP, 1 ), LDA )
                     END IF
                     IF( IP2.NE.(I+1) ) THEN
                        CALL SSWAP( I-1, A( I+1, 1 ), LDA,
     $                              A( IP2, 1 ), LDA )
                     END IF
                  END IF
                  I = I + 1
*
               END IF
               I = I + 1
            END DO
*
         ELSE
*
*           Revert A (A is lower)
*
*
*           Revert PERMUTATIONS
*
*           Apply permutations to submatrices of lower part of A
*           in reverse factorization order where i decreases from N to 1
*
            I = N
            DO WHILE ( I.GE.1 )
               IF( IPIV( I ).GT.0 ) THEN
*
*                 1-by-1 pivot interchange
*
*                 Swap rows i and IPIV(i) in A(i:N,1:i-1)
*
                  IP = IPIV( I )
                  IF ( I.GT.1 ) THEN
                     IF( IP.NE.I ) THEN
                        CALL SSWAP( I-1, A( IP, 1 ), LDA,
     $                              A( I, 1 ), LDA )
                     END IF
                  END IF
*
               ELSE
*
*                 2-by-2 pivot interchange
*
*                 Swap rows i+1 and IPIV(i+1) and i and IPIV(i)
*                 in A(i:N,1:i-1)
*
                  I = I - 1
                  IP = -IPIV( I )
                  IP2 = -IPIV( I+1 )
                  IF ( I.GT.1 ) THEN
                     IF( IP2.NE.(I+1) ) THEN
                        CALL SSWAP( I-1, A( IP2, 1 ), LDA,
     $                              A( I+1, 1 ), LDA )
                     END IF
                     IF( IP.NE.I ) THEN
                        CALL SSWAP( I-1, A( IP, 1 ), LDA,
     $                              A( I, 1 ), LDA )
                     END IF
                  END IF
*
               END IF
               I = I - 1
            END DO
*
*           Revert VALUE
*           Assign subdiagonal entries of D from array E to
*           subgiagonal entries of A.
*
            I = 1
            DO WHILE ( I.LE.N-1 )
               IF( IPIV( I ).LT.0 ) THEN
                  A( I + 1, I ) = E( I )
                  I = I + 1
               END IF
               I = I + 1
            END DO
*
         END IF
*
*        End A is LOWER
*
      END IF

      RETURN
*
*     End of SSYCONVF_ROOK
*
      END


! Test the MVBITS intrinsic subroutine
INTEGER*4 :: from, to, result
integer*8 :: from8, to8

DATA from / z'0003FFFC' /
DATA to / z'77760000' /
DATA result / z'7777FFFE' /

CALL mvbits(from, 2, 16, to, 1)
if (to /= result) CALL abort()

to8 = 0_8
from8 = b'1011'*2_8**32
call mvbits (from8, 33, 3, to8, 2)
if (to8 /= b'10100') call abort
end


! Update the array of conditioning matrices "m" with new samples from
! a TOD. The "pixidx" array contains the zero-based indexes in the Healpix
! map of the polarization angles in the array "angle". Note that
! "pixidx" must be a *zero-based* array! The routine internally does the
! conversion to Fortran indexing (which is 1-based).
subroutine update_condmatr(numpix, pixidx, angle, m)
    implicit none

    integer(kind=8), intent(in) :: numpix
    integer(kind=4), dimension(:), intent(in) :: pixidx
    real(kind=8), dimension(size(pixidx)), intent(in) :: angle
    real(kind=8), dimension(numpix, 9), intent(inout) :: m

    real(kind=8) :: cos2angle
    real(kind=8) :: sin2angle
    real(kind=8) :: sincos2angle
    integer :: i
    integer(kind=4) :: pixidx1

    do i = 1, size(pixidx)
        ! Python indexing to Fortran indexing
        pixidx1 = pixidx(i) + 1

        cos2angle = cos(2.0 * angle(i))
        sin2angle = sin(2.0 * angle(i))
        sincos2angle = sin2angle * cos2angle

        m(pixidx1, 1) = m(pixidx1, 1) + 1
        m(pixidx1, 2) = m(pixidx1, 2) + cos2angle
        m(pixidx1, 3) = m(pixidx1, 3) + sin2angle
        m(pixidx1, 4) = m(pixidx1, 4) + cos2angle
        m(pixidx1, 5) = m(pixidx1, 5) + cos2angle * cos2angle
        m(pixidx1, 6) = m(pixidx1, 6) + sincos2angle
        m(pixidx1, 7) = m(pixidx1, 7) + sin2angle
        m(pixidx1, 8) = m(pixidx1, 8) + sincos2angle
        m(pixidx1, 9) = m(pixidx1, 9) + sin2angle * sin2angle
    end do
end subroutine update_condmatr

subroutine binned_map(signal, pixidx, mappixels, hits)
    implicit none

    real(kind=8), dimension(:), intent(in) :: signal
    integer(kind=8), dimension(size(signal)), intent(in) :: pixidx
    real(kind=8), dimension(:), intent(inout) :: mappixels
    integer(kind=8), dimension(size(mappixels)), intent(inout) :: hits

    integer :: i

    mappixels = 0.0
    hits = 0

    do i = 1, size(signal)
        mappixels(pixidx(i) + 1) = mappixels(pixidx(i) + 1) + signal(i)
        hits(pixidx(i) + 1) = hits(pixidx(i) + 1) + 1
    end do

    do i = 1, size(mappixels)
        if (hits(i) .gt. 0) then
            mappixels(i) = mappixels(i) / hits(i)
        end if
    end do

end subroutine binned_map


! Program to test intrinsic bitops
program intrinsic_bitops
   implicit none
   integer(kind=4) :: i, j, k, o, t
   integer(kind=8) :: a, b, c

   o = 0
   i = 2
   j = 3
   k = 12
   a = 5

   if (.not. btest (i, o+1)) call abort
   if (btest (i, o+2)) call abort
   if (iand (i, j) .ne. 2) call abort
   if (ibclr (j, o+1) .ne. 1) call abort
   if (ibclr (j, o+2) .ne. 3) call abort
   if (ibits (k, o+1, o+2) .ne. 2) call abort
   if (ibset (j, o+1) .ne. 3) call abort
   if (ibset (j, o+2) .ne. 7) call abort
   if (ieor (i, j) .ne. 1) call abort
   if (ior (i, j) .ne. 3) call abort
   if (ishft (k, o+2) .ne. 48) call abort
   if (ishft (k, o-3) .ne. 1) call abort
   if (ishft (k, o) .ne. 12) call abort
   if (ishftc (k, o+30) .ne. 3) call abort
   if (ishftc (k, o-30) .ne. 48) call abort
   if (ishftc (k, o+1, o+3) .ne. 9) call abort
   if (not (i) .ne. -3) call abort
   if (ishftc (a, 1, bit_size(a)) .ne. 10) call abort
   if (ishftc (1, 1, 32) .ne. 2) call abort
end program


*> \brief \b ZGET22
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W,
*                          WORK, RWORK, RESULT )
*
*       .. Scalar Arguments ..
*       CHARACTER          TRANSA, TRANSE, TRANSW
*       INTEGER            LDA, LDE, N
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   RESULT( 2 ), RWORK( * )
*       COMPLEX*16         A( LDA, * ), E( LDE, * ), W( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZGET22 does an eigenvector check.
*>
*> The basic test is:
*>
*>    RESULT(1) = | A E  -  E W | / ( |A| |E| ulp )
*>
*> using the 1-norm.  It also tests the normalization of E:
*>
*>    RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp )
*>                 j
*>
*> where E(j) is the j-th eigenvector, and m-norm is the max-norm of a
*> vector.  The max-norm of a complex n-vector x in this case is the
*> maximum of |re(x(i)| + |im(x(i)| over i = 1, ..., n.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANSA
*> \verbatim
*>          TRANSA is CHARACTER*1
*>          Specifies whether or not A is transposed.
*>          = 'N':  No transpose
*>          = 'T':  Transpose
*>          = 'C':  Conjugate transpose
*> \endverbatim
*>
*> \param[in] TRANSE
*> \verbatim
*>          TRANSE is CHARACTER*1
*>          Specifies whether or not E is transposed.
*>          = 'N':  No transpose, eigenvectors are in columns of E
*>          = 'T':  Transpose, eigenvectors are in rows of E
*>          = 'C':  Conjugate transpose, eigenvectors are in rows of E
*> \endverbatim
*>
*> \param[in] TRANSW
*> \verbatim
*>          TRANSW is CHARACTER*1
*>          Specifies whether or not W is transposed.
*>          = 'N':  No transpose
*>          = 'T':  Transpose, same as TRANSW = 'N'
*>          = 'C':  Conjugate transpose, use -WI(j) instead of WI(j)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,N)
*>          The matrix whose eigenvectors are in E.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is COMPLEX*16 array, dimension (LDE,N)
*>          The matrix of eigenvectors. If TRANSE = 'N', the eigenvectors
*>          are stored in the columns of E, if TRANSE = 'T' or 'C', the
*>          eigenvectors are stored in the rows of E.
*> \endverbatim
*>
*> \param[in] LDE
*> \verbatim
*>          LDE is INTEGER
*>          The leading dimension of the array E.  LDE >= max(1,N).
*> \endverbatim
*>
*> \param[in] W
*> \verbatim
*>          W is COMPLEX*16 array, dimension (N)
*>          The eigenvalues of A.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension (N*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is DOUBLE PRECISION array, dimension (2)
*>          RESULT(1) = | A E  -  E W | / ( |A| |E| ulp )
*>          RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16_eig
*
*  =====================================================================
      SUBROUTINE ZGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W,
     $                   WORK, RWORK, RESULT )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          TRANSA, TRANSE, TRANSW
      INTEGER            LDA, LDE, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   RESULT( 2 ), RWORK( * )
      COMPLEX*16         A( LDA, * ), E( LDE, * ), W( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      CHARACTER          NORMA, NORME
      INTEGER            ITRNSE, ITRNSW, J, JCOL, JOFF, JROW, JVEC
      DOUBLE PRECISION   ANORM, ENORM, ENRMAX, ENRMIN, ERRNRM, TEMP1,
     $                   ULP, UNFL
      COMPLEX*16         WTEMP
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, ZLANGE
      EXTERNAL           LSAME, DLAMCH, ZLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           ZGEMM, ZLASET
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Initialize RESULT (in case N=0)
*
      RESULT( 1 ) = ZERO
      RESULT( 2 ) = ZERO
      IF( N.LE.0 )
     $   RETURN
*
      UNFL = DLAMCH( 'Safe minimum' )
      ULP = DLAMCH( 'Precision' )
*
      ITRNSE = 0
      ITRNSW = 0
      NORMA = 'O'
      NORME = 'O'
*
      IF( LSAME( TRANSA, 'T' ) .OR. LSAME( TRANSA, 'C' ) ) THEN
         NORMA = 'I'
      END IF
*
      IF( LSAME( TRANSE, 'T' ) ) THEN
         ITRNSE = 1
         NORME = 'I'
      ELSE IF( LSAME( TRANSE, 'C' ) ) THEN
         ITRNSE = 2
         NORME = 'I'
      END IF
*
      IF( LSAME( TRANSW, 'C' ) ) THEN
         ITRNSW = 1
      END IF
*
*     Normalization of E:
*
      ENRMIN = ONE / ULP
      ENRMAX = ZERO
      IF( ITRNSE.EQ.0 ) THEN
         DO 20 JVEC = 1, N
            TEMP1 = ZERO
            DO 10 J = 1, N
               TEMP1 = MAX( TEMP1, ABS( DBLE( E( J, JVEC ) ) )+
     $                 ABS( DIMAG( E( J, JVEC ) ) ) )
   10       CONTINUE
            ENRMIN = MIN( ENRMIN, TEMP1 )
            ENRMAX = MAX( ENRMAX, TEMP1 )
   20    CONTINUE
      ELSE
         DO 30 JVEC = 1, N
            RWORK( JVEC ) = ZERO
   30    CONTINUE
*
         DO 50 J = 1, N
            DO 40 JVEC = 1, N
               RWORK( JVEC ) = MAX( RWORK( JVEC ),
     $                         ABS( DBLE( E( JVEC, J ) ) )+
     $                         ABS( DIMAG( E( JVEC, J ) ) ) )
   40       CONTINUE
   50    CONTINUE
*
         DO 60 JVEC = 1, N
            ENRMIN = MIN( ENRMIN, RWORK( JVEC ) )
            ENRMAX = MAX( ENRMAX, RWORK( JVEC ) )
   60    CONTINUE
      END IF
*
*     Norm of A:
*
      ANORM = MAX( ZLANGE( NORMA, N, N, A, LDA, RWORK ), UNFL )
*
*     Norm of E:
*
      ENORM = MAX( ZLANGE( NORME, N, N, E, LDE, RWORK ), ULP )
*
*     Norm of error:
*
*     Error =  AE - EW
*
      CALL ZLASET( 'Full', N, N, CZERO, CZERO, WORK, N )
*
      JOFF = 0
      DO 100 JCOL = 1, N
         IF( ITRNSW.EQ.0 ) THEN
            WTEMP = W( JCOL )
         ELSE
            WTEMP = DCONJG( W( JCOL ) )
         END IF
*
         IF( ITRNSE.EQ.0 ) THEN
            DO 70 JROW = 1, N
               WORK( JOFF+JROW ) = E( JROW, JCOL )*WTEMP
   70       CONTINUE
         ELSE IF( ITRNSE.EQ.1 ) THEN
            DO 80 JROW = 1, N
               WORK( JOFF+JROW ) = E( JCOL, JROW )*WTEMP
   80       CONTINUE
         ELSE
            DO 90 JROW = 1, N
               WORK( JOFF+JROW ) = DCONJG( E( JCOL, JROW ) )*WTEMP
   90       CONTINUE
         END IF
         JOFF = JOFF + N
  100 CONTINUE
*
      CALL ZGEMM( TRANSA, TRANSE, N, N, N, CONE, A, LDA, E, LDE, -CONE,
     $            WORK, N )
*
      ERRNRM = ZLANGE( 'One', N, N, WORK, N, RWORK ) / ENORM
*
*     Compute RESULT(1) (avoiding under/overflow)
*
      IF( ANORM.GT.ERRNRM ) THEN
         RESULT( 1 ) = ( ERRNRM / ANORM ) / ULP
      ELSE
         IF( ANORM.LT.ONE ) THEN
            RESULT( 1 ) = ( MIN( ERRNRM, ANORM ) / ANORM ) / ULP
         ELSE
            RESULT( 1 ) = MIN( ERRNRM / ANORM, ONE ) / ULP
         END IF
      END IF
*
*     Compute RESULT(2) : the normalization error in E.
*
      RESULT( 2 ) = MAX( ABS( ENRMAX-ONE ), ABS( ENRMIN-ONE ) ) /
     $              ( DBLE( N )*ULP )
*
      RETURN
*
*     End of ZGET22
*
      END


!      - comments start with "!" rather than "C"
!      - continuation lines are avoided
      double precision pi,pisq,pisqo6
      parameter(pi=3.1415926535897932385d0,pisq=pi*pi,pisqo6=pisq/6d0)
      double precision twopi,fourpi,pion4,pion10,pisqm8,rt2onpi
      parameter(twopi=2d0*pi)
      parameter(fourpi=4d0*pi)
      parameter(pion4=pi/4d0)
      parameter(pion10=pi/10d0)
      parameter(pisqm8=pisq-8d0)
! sqrt(2d0/pi)
      parameter(rt2onpi=0.797884560802865d0)
!-----------------------------------------------------
      double precision cf,ca,xn,xnsq,xn4,v,tr,qu,qd,qe,aem,Von4,ninth
      double precision Nc,Ncinv
      parameter(cf=4d0/3d0,ca=3d0,xn=3d0,Nc=3d0,xnsq=9d0,v=8d0,tr=0.5d0)
      parameter(Von4=2d0,ninth=1d0/9d0,xn4=xnsq-4d0,Ncinv=1d0/3d0)
      parameter(qu=2d0/3d0,qd=-1d0/3d0,qe=-1d0)
      parameter(aem=1d0/137.035989d0)
      double precision spinave,aveqq,aveqg,avegg
      parameter(spinave=0.25d0)
      parameter(aveqq=0.25d0/xnsq,aveqg=0.25d0/xn/v,avegg=0.25d0/v**2)
!-----------------------------------------------------
      double precision zip,half,one,two,three,four,eight
      parameter(zip=0d0,half=0.5d0,one=1d0,two=2d0)
      parameter(three=3d0,four=4d0,eight=8d0)
      double precision rt2,twort2,fourrt2
      parameter(rt2=1.4142135623730950488d0)
      parameter(twort2=two*rt2,fourrt2=four*rt2)
      double precision dfbGeV2,fbGeV2,pbGeV2,nbGeV2,overa
      parameter(nbGeV2=0.389379d6)
      parameter(pbGeV2=0.389379d9)
      parameter(fbGeV2=0.389379d12)
!----decifemtobarns
      parameter(dfbGeV2=0.389379d13)
      parameter(overa=pbGeV2/xn/256d0/pi)
!-----------------------------------------------------
      double complex im,impi,czip,cone,ctwo
      parameter(im=(0d0,1d0),impi=(0d0,3.1415926535897932385d0))
      parameter(czip=(0d0,0d0),cone=(1d0,0d0),ctwo=(2d0,0d0))
!-----------------------------------------------------
      include 'nf.f'
      include 'mxpart.f'
      integer nloop,fn
      parameter(fn=-5,nloop=2)


c=======================================================================
c
c     subroutine OPSR
c
c     Optimization utility for ALLOCSR - Sharpe Ratio maximization
c
c-----------------------------------------------------------------------
      SUBROUTINE opsr ( n, cov, rho, rfr,
     &                  neq, nin, ccst, bcst, cinf, csup,
     &                  iwork, dwork, wopt, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : size of portfolio                               integer
c       cov    : covariance matrix (n*n)                          double
c       rho    : mean returns vector (n)                          double
c       rfr    : risk-free rate                                   double
c       neq    : number of initial equality constraints          integer
c       nin    : number of initial inequality constraints        integer
c       ccst   : matrix of constraints (n*(neq + nin))            double
c       bcst   : vector of constraints (neq + nin)                double
c       cinf   : assets inferior limit (n)                        double
c       csup   : assets superior limit (n)                        double
c
c     WORKSPACE
c       iwork  : 5*n + 2*nin + neq + 4                           integer
c       dwork  : n*(4*n + nin + neq + 25) + 5*nin + 3*neq + 15    double
c
c     OUTPUT
c       wopt   : optimal portfolio (n)                            double
c       info   : = 0 successful exit                             integer
c
c     CALL
c       CTSR : utility function
c       QP   : quadratic solver (vectorized version)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin
      DOUBLE PRECISION rfr
      DOUBLE PRECISION cov(*), rmean(*), cinf(*), csup(*), wopt(*),
     &                 ccst(n,*), bcst(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, neqtot, nintot, piw, pdlin, pdw, pdlagr, pdbcs, pdccs,
     &        pdcov, pdinf, pdsup, j, k
      DOUBLE PRECISION EPS
      PARAMETER ( EPS = 1.E-6)
c
c     external subroutines
      EXTERNAL ctsr, qp
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw  = 1
c     piw  : pointer for QP internal workspace, who needs
c            ( 3*(n+1) + 2*nintot + neqtot + 1 )
c             with neqtot = neq + 1
c                  nintot = nin + 2*n
c
c     Total size of iwork array = ( 5*n + 2*nin + neq + 4 )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdlin  = 1
c     pdlin  : pointer for linear part vector, so ( n + 1 ) more
      pdlagr = pdlin + ( n + 1 )
c     pdlagr : pointer for Lagrange multipliers vector
c              ( n + 1 + nintot + neqtot ),
c           so ( n + 1 + nin + 1 + neq + 2*n) more
      pdbcs  = pdlagr +  ( 3*n + nin + neq + 2)
c     pdbcs  : pointer for the constraints vector ( nintot + neqtot ),
c              so ( nin + 1 + neq + 2*n) more
      pdccs  = pdbcs +  ( nin + neq + 1 + 2*n)
c     pdccs  : pointer for the constraints matrix
c              ( n + 1 )*( nintot + neqtot ),
c           so ( n + 1) *( nin + 1 + neq + 2*n) more
      pdw    = pdccs + ( (n + 1)*( nin + neq + 1 + 2*n) )
c     pdw    : pointer for QP internal workspace who needs
c              ((n+1)*(n+1) + 6*(n+1) + 2*(nin + 2*n))
      pdcov  = pdw + ((n+1)*(n+1) + 6*(n+1) + 2*(nin + 2*n))
c     pdcov  : pointer for temporary cov. matrix (n+1)*(n+1)
      pdinf  = pdcov + ((n+1)*(n+1))
c     pdinf  : pointer for temporary lower bounds (n+1)
      pdsup  = pdinf + (n + 1)
c     pdsup  : pointer for temporary upper bounds (n+1)
c
c     Total size of dwork array = n + 1
c                               + 3*n + nin + neq + 2
c                               + 2*n + nin + neq + 1
c                               + (n + 1)*( nin + neq + 1 + 2*n )
c                               + (n + 1)*(n + 1) + 6*(n+1) + 2*(nin + 2*n)
c                               + (n + 1)*(n + 1)
c                               + (n + 1)
c                               + (n + 1)
c                               = n*(4*n + nin + neq + 25) + 5*nin + 3*neq + 15
c
c-----------------------------------------------------------------------
c
c     construction of the constraints matrix and vector, and linear part
      CALL ctsr ( n, rmean, rfr, neq, nin, ccst, bcst, cinf, csup,
     &            neqtot, nintot, dwork(pdccs), dwork(pdbcs),
     &            dwork(pdlin))
c
c     new cov. matrix cov = | cov  0  |
c                           |  0  eps |
      DO i = 1,((n+1)*(n+1))
         dwork(pdcov + i) = 0.
      ENDDO
      DO i = 1,n
        DO j = 1,n
            k = i + n*(j-1)
            dwork(pdcov + i + (n+1)*(j-1)) = cov(k)
        ENDDO
      ENDDO
      dwork(pdcov + (n+1)*(n+1)) = eps
c
c     lower/upper bounds of the new problem
      DO i = 1,n
        dwork(pdinf + i) =  0.
        dwork(pdsup + i) =  100000.
      ENDDO
      dwork(pdinf + n + 1) = 0.
      dwork(pdsup + n + 1) = 100000.
c
c     write input data
c     write C and b
c      ioecr = 10
c      i = n + 1
c      open(unit=1,file='n.txt',status='unknown')
c	write(1,*) neqtot
c	write(1,*) nintot
c	write(1,*) n
c	close(unit=1)
c
c      open(ioecr,status='unknown',file='cov.txt')
c      call IMPRM ( ioecr, 'cov :', i, i, dwork(pdcov+1) )
c      open(ioecr,status='unknown',file='lin.txt')
c      call IMPRV ( ioecr, 'linear part :', i, dwork(pdlin) )
c
c      open(ioecr,status='unknown',file='C.txt')
c      call IMPRM ( ioecr, 'C :', n+1, neqtot + nintot, dwork(pdccs) )
c      open(ioecr,status='unknown',file='b.txt')
c      call IMPRV ( ioecr, 'b :', neqtot + nintot, dwork(pdbcs) )
c
c      open(ioecr,status='unknown',file='cinf.txt')
c      call IMPRV ( ioecr, 'Cinf :', i, dwork(pdinf+1) )
c      open(ioecr,status='unknown',file='csup.txt')
c      call IMPRV ( ioecr, 'Csup :', i, dwork(pdsup+1) )
c
c     quadratic solver
      CALL qp ( (n+1), dwork(pdcov+1), dwork(pdlin), dwork(pdccs),
     &           dwork(pdbcs), dwork(pdinf+1), dwork(pdsup+1),
     &           neqtot, nintot,
     &           iwork(piw), dwork(pdw), dwork(pdlagr), wopt,
     &           info )
c
      RETURN
      END


	PROGRAM MODEL_TABLE
C
C	MAKES A TABLE FOR PLOTTING BY MONGO
C
	integer*4	NMODEL(1100)
	real		MODELAV(1100),MODELSQ(1100),VDATA(1)
C
	DATA TWOPI /6.2831853/
	DATA IREADIN /0/
C
C	READ IN ACCUMULATED DATA
C
	IF(IREADIN.EQ.0) THEN
	  OPEN(UNIT=101,NAME='NMODEL.DAT',TYPE='OLD')
	  READ(101,*,END=11) NMODEL
 11	  CLOSE(UNIT=101)
	  OPEN(UNIT=101,NAME='MODELAV.DAT',TYPE='OLD')
	  READ(101,*,END=12) MODELAV
 12	  CLOSE(UNIT=101)
	  OPEN(UNIT=101,NAME='MODELSQ.DAT',TYPE='OLD')
	  READ(101,*,END=13) MODELSQ
 13	  CLOSE(UNIT=101)
	  IREADIN = 1
	ENDIF
C
C	PROCESS ACCUMULATED DATA
C
	OPEN(UNIT=101,NAME='MODEL_TABLE.DAT',TYPE='NEW')
	DO INDEX = 1,1098
C
	  TAV = MODELAV(INDEX)
	  TSQ = MODELSQ(INDEX) - TAV**2
	  ANGLE = (INDEX-1)*360./1098.
	  WRITE(101,*) INDEX,ANGLE,TAV,TSQ
	ENDDO
 	CLOSE(UNIT=101)
	STOP
	END


*DECK ORTHOL
      SUBROUTINE ORTHOL (A, M, N, NRDA, IFLAG, IRANK, ISCALE, DIAG,
     +   KPIVOT, SCALES, COLS, CS)
C***BEGIN PROLOGUE  ORTHOL
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (ORTHOL-S)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C   Reduction of the matrix A to upper triangular form by a sequence of
C   orthogonal HOUSEHOLDER transformations pre-multiplying A
C
C   Modeled after the ALGOL codes in the articles in the REFERENCES
C   section.
C
C **********************************************************************
C   INPUT
C **********************************************************************
C
C     A -- Contains the matrix to be decomposed, must be dimensioned
C           NRDA by N
C     M -- Number of rows in the matrix, M greater or equal to N
C     N -- Number of columns in the matrix, N greater or equal to 1
C     IFLAG -- Indicates the uncertainty in the matrix data
C             = 0 when the data is to be treated as exact
C             =-K when the data is assumed to be accurate to about
C                 K digits
C     ISCALE -- Scaling indicator
C               =-1 if the matrix A is to be pre-scaled by
C               columns when appropriate.
C               Otherwise no scaling will be attempted
C     NRDA -- Row dimension of A, NRDA greater or equal to M
C     DIAG,KPIVOT,COLS -- Arrays of length at least n used internally
C         ,CS,SCALES
C
C **********************************************************************
C   OUTPUT
C **********************************************************************
C
C     IFLAG - Status indicator
C            =1 for successful decomposition
C            =2 if improper input is detected
C            =3 if rank of the matrix is less than N
C     A -- Contains the reduced matrix in the strictly upper triangular
C          part and transformation information in the lower part
C     IRANK -- Contains the numerically determined matrix rank
C     DIAG -- Contains the diagonal elements of the reduced
C             triangular matrix
C     KPIVOT -- Contains the pivotal information, the column
C               interchanges performed on the original matrix are
C               recorded here.
C     SCALES -- Contains the column scaling parameters
C
C **********************************************************************
C
C***SEE ALSO  BVSUP
C***REFERENCES  G. Golub, Numerical methods for solving linear least
C                 squares problems, Numerische Mathematik 7, (1965),
C                 pp. 206-216.
C               P. Businger and G. Golub, Linear least squares
C                 solutions by Householder transformations, Numerische
C                 Mathematik  7, (1965), pp. 269-276.
C***ROUTINES CALLED  CSCALE, R1MACH, SDOT, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900402  Added TYPE section.  (WRB)
C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  ORTHOL
      DIMENSION A(NRDA,*),DIAG(*),KPIVOT(*),COLS(*),CS(*),SCALES(*)
C
C **********************************************************************
C
C     MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED
C     BY THE FUNCTION R1MACH.
C
C***FIRST EXECUTABLE STATEMENT  ORTHOL
      URO = R1MACH(3)
C
C **********************************************************************
C
      IF (M .GE. N  .AND.  N .GE. 1  .AND.  NRDA .GE. M) GO TO 1
      IFLAG=2
      CALL XERMSG ('SLATEC', 'ORTHOL', 'INVALID INPUT PARAMETERS.', 2,
     +   1)
      RETURN
C
    1 ACC=10.*URO
      IF (IFLAG .LT. 0) ACC=MAX(ACC,10.**IFLAG)
      SRURO=SQRT(URO)
      IFLAG=1
      IRANK=N
C
C     COMPUTE NORM**2 OF JTH COLUMN AND A MATRIX NORM
C
      ANORM=0.
      DO 2 J=1,N
         KPIVOT(J)=J
         COLS(J)=SDOT(M,A(1,J),1,A(1,J),1)
         CS(J)=COLS(J)
         ANORM=ANORM+COLS(J)
    2 CONTINUE
C
C     PERFORM COLUMN SCALING ON A WHEN SPECIFIED
C
      CALL CSCALE(A,NRDA,M,N,COLS,CS,DUM,DUM,ANORM,SCALES,ISCALE,0)
C
      ANORM=SQRT(ANORM)
C
C
C     CONSTRUCTION OF UPPER TRIANGULAR MATRIX AND RECORDING OF
C     ORTHOGONAL TRANSFORMATIONS
C
C
      DO 50 K=1,N
         MK=M-K+1
         IF (K .EQ. N) GO TO 25
         KP=K+1
C
C        SEARCHING FOR PIVOTAL COLUMN
C
         DO 10 J=K,N
            IF (COLS(J) .GE. SRURO*CS(J)) GO TO 5
            COLS(J)=SDOT(MK,A(K,J),1,A(K,J),1)
            CS(J)=COLS(J)
    5       IF (J .EQ. K) GO TO 7
            IF (SIGMA .GE. 0.99*COLS(J)) GO TO 10
    7       SIGMA=COLS(J)
            JCOL=J
   10    CONTINUE
         IF (JCOL .EQ. K) GO TO 25
C
C        PERFORM COLUMN INTERCHANGE
C
         L=KPIVOT(K)
         KPIVOT(K)=KPIVOT(JCOL)
         KPIVOT(JCOL)=L
         COLS(JCOL)=COLS(K)
         COLS(K)=SIGMA
         CSS=CS(K)
         CS(K)=CS(JCOL)
         CS(JCOL)=CSS
         SC=SCALES(K)
         SCALES(K)=SCALES(JCOL)
         SCALES(JCOL)=SC
         DO 20 L=1,M
            ASAVE=A(L,K)
            A(L,K)=A(L,JCOL)
   20       A(L,JCOL)=ASAVE
C
C        CHECK RANK OF THE MATRIX
C
   25    SIG=SDOT(MK,A(K,K),1,A(K,K),1)
         DIAGK=SQRT(SIG)
         IF (DIAGK .GT. ACC*ANORM) GO TO 30
C
C        RANK DEFICIENT PROBLEM
         IFLAG=3
         IRANK=K-1
         CALL XERMSG ('SLATEC', 'ORTHOL',
     +      'RANK OF MATRIX IS LESS THAN THE NUMBER OF COLUMNS.', 1, 1)
         RETURN
C
C        CONSTRUCT AND APPLY TRANSFORMATION TO MATRIX A
C
   30    AKK=A(K,K)
         IF (AKK .GT. 0.) DIAGK=-DIAGK
         DIAG(K)=DIAGK
         A(K,K)=AKK-DIAGK
         IF (K .EQ. N) GO TO 50
         SAD=DIAGK*AKK-SIG
         DO 40 J=KP,N
            AS=SDOT(MK,A(K,K),1,A(K,J),1)/SAD
            DO 35 L=K,M
   35          A(L,J)=A(L,J)+AS*A(L,K)
   40       COLS(J)=COLS(J)-A(K,J)**2
   50 CONTINUE
C
C
      RETURN
      END


*----------------------------------------------------------------------*
      subroutine nrmvec(ndim,eigvec,eigvi)
*----------------------------------------------------------------------*
*     normalize the eigenvectors in array eigvec(ndim,ndim)
*     imaginary pairs are handled as described in rg(), eispack.f
*----------------------------------------------------------------------*

      implicit none

      include 'stdunit.h'

      integer, parameter ::
     &     ntest = 00

      integer, intent(in) ::
     &     ndim
      real(8), intent(in) ::
     &     eigvi(ndim)
      real(8), intent(inout) ::
     &     eigvec(ndim,ndim)

      integer ::
     &     ivec
      real(8) ::
     &     xnrm

      real(8), external ::
     &     inprod

      ivec = 0
      do while (ivec.lt.ndim)
        ivec = ivec+1

        xnrm = inprod(eigvec(1,ivec),eigvec(1,ivec),ndim)

        if (eigvi(ivec).ne.0d0) then
          if (ivec+1.gt.ndim) then
            write(lulog,*) 'inconsistency in eigenvalue structure'
            call quit(1,'nrmvec','inconsistent eigenvalues')
          end if

          xnrm = xnrm + inprod(eigvec(1,ivec+1),eigvec(1,ivec+1),ndim)
        end if

        xnrm = sqrt(xnrm)

        call scalve(eigvec(1,ivec),1d0/xnrm,ndim)

        if (eigvi(ivec).ne.0d0) then
          call scalve(eigvec(1,ivec+1),1d0/xnrm,ndim)
          ivec = ivec+1
        end if

      end do

      return

      end


       SUBROUTINE inter( dim, npoints, itype, arg,
     $     xarr, yarr, ynew, hh)
*-------------------------------------------------------------------
* Copyright (C) 1994 Arve Kylling
*
* 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; either version 1, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY of FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* To obtain a copy of the GNU General Public License write to the
* Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
* USA.
*-------------------------------------------------------------------
*
*     Interpolates at the x-point arg from x-value array xarr and
*     y-value array yarr. xarr and yarr are expected to have
*     descending arguments, i.e. for atmospheric applications
*     xarr typically holds the altitude and inter expects
*     xarr(1) = altitude at top of atmosphere.
*
*     Input variables:
*     dim       Array dimension of xarr and yarr
*     npoints   No. points in arrays xarr and yarr
*     itype     Interpolation type
*     arg       Interpolation argument
*     xarr      array of x values
*     yarr      array of y values
*
*     Output variables:
*     ynew      Interpolated function value at arg
*     hh        gradient or scale height value
*
      INTEGER dim
      REAL  arg, hh, xarr(dim), yarr(dim), ynew
*
       IF ( arg .LE. xarr(1) .AND. arg .GE. xarr(npoints)) THEN
         DO 10 iq = 1 , npoints-1
           IF ( arg .LE. xarr(iq) .AND. arg .GT. xarr(iq+1)) ip = iq
   10    CONTINUE
         IF ( arg .EQ. xarr(npoints)) ip = npoints - 1
       ELSEIF ( arg .GT. xarr(1)) THEN
         ip = 1
       ELSEIF ( arg .LT. xarr(npoints)) THEN
         ip = npoints - 1
       ENDIF
*
*     Interpolate function value at arg from data points ip to ip+1
*
*
*     exponential interpolation
*
       IF ( itype .EQ. 1 ) THEN
          IF ( yarr(ip+1) .EQ. yarr(ip) ) THEN
             hh   = 0.0
             ynew = yarr(ip)
          ELSE
             hh   = -( xarr(ip+1) - xarr(ip) ) /
     $            LOG( yarr(ip+1) / yarr(ip))
             ynew = yarr(ip) * EXP(- ( arg - xarr(ip) ) / hh )
          ENDIF
*
*     linear interpolation
*
       ELSEIF ( itype .EQ. 2 ) THEN
         hh = ( yarr(ip+1) - yarr(ip) ) / ( xarr(ip+1) - xarr(ip) )
         ynew = yarr(ip) + hh*( arg - xarr(ip) )
*
      ENDIF
      RETURN
      END


! { dg-options "-fgraphite-identity -g -O3 -ffast-math" }
MODULE erf_fn
CONTAINS
  SUBROUTINE CALERF(ARG,RESULT,JINT)
    DIMENSION A(5),B(4),C(9),D(8),P(6),Q(5)
    IF (Y <= THRESH) THEN
       DO I = 1, 3
          XNUM = (XNUM + A(I)) * YSQ
          XDEN = (XDEN + B(I)) * YSQ
       END DO
       RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
    END IF
  END SUBROUTINE CALERF
END MODULE erf_fn