*____________________________________________________________________________
        SUBROUTINE npstar(ycal,nv,inv,p)
*_____________________________________________________________________________
c
c Determines parameters for J(Q,Y) calculation and also checks the results for
c consistentcy between input parameters and calculated output.
c
        implicit none
c Frills Variables 
        real*8 x(1000),y(1000),p(50),bc,bs
        real*8 ypk(1000,20),ycal(1000)
        real*8 rx(1000),ry(1000)
        integer*4 nv,inv(1000),nd,npk,nrd,nptot
        logical moms
c Frills common blocks
        common /dats/ nd,x,y
        common /peak/ npk,ypk
c General Variables
        real*8 A1,a2,a4,a6
        real*8 jqy
        real*8 x1(1000)
        integer*4 i,j
c  General common blocks
        common /parm/ a2,a4,a6,A1
        common /jqys/ jqy
c
c Assign fitting parameters from Frills
c
        bc = p(1)
        bs = p(2)
	A1 = p(3)
        a2 = p(4)
        a4 = p(5)
        a6 = p(6)
c
c Calculate Function plus sloping background
c __ Calculation is made only at points where data is present
c
        DO i = 1,nv
           j = inv(i)
           x1(i) = x(j)
           ypk(j,1) = bc + bs*x(j)      ! Sloping background
           CALL nofp(x(j))
           ycal(j) = jqy
        END DO
        npk = 2
        RETURN
        END
c
c
*_____________________________________________________________________________
        SUBROUTINE nofp(Y)
*_____________________________________________________________________________
c
c Program to calculate n*(p) at as a FT of n*(s).
c ____ ie Uncondensed part of n(s) in the superfluid
c
c
        implicit none
        real*8 Qq,Sq,Y,Yv,te
        real*8 A1,a2,a4,a6,pi
        real*8 bound,epa,epr,wi(2000),err,wbar
        real*8 jqy
        real*8 F4
        real D01AMF
        integer*4 lw,liw,iw(500),inf,ifail,i,j,mn,lpt
        external F4,D01AMF
c
        common /parm/ a2,a4,a6,A1
        common /jqys/ jqy
        common /yval/ Yv
c
        yv = Y
c
           pi = 4.0*ATAN(1.0)
c
c Set up variables for Infinite integration
c
        lw = 2000
        liw = lw/4
        ifail = 0
        inf = 1
        bound = 0.0
        epa = 0.00001
        epr = 0.001
        CALL D01AMF(F4,bound,inf,epa,epr,jqy,err,wi,lw,iw,liw,ifail)
c       write (*,*) ' JQY_TOT : jqy = ',jqy
        jqy = A1*jqy
        RETURN
        END
c
c
*_____________________________________________________________________________
        REAL FUNCTION F4*8(s)           
*_____________________________________________________________________________
	implicit none
        real*8 a2,a4,a6
        real*8 s,arg,Y
        common /parm/ a2,a4,a6
	common /yval/ y
        arg = -a2*s**2/2+a4*s**4/24-a6*s**6/720
        IF (ABS(arg).LE.60.0) THEN
           F4 = EXP(arg)
	   F4 = F4*Cos(Y*s)
        ELSE
           F4 = 0.0
        END IF
        RETURN
        END











