  	subroutine curfit (y,npts,nterms,a,sigmaa,flambda,
     1 yfit,chisqr,eps,itmax,x,conv,weight,ipt,s0,wsum)
c
c assymmetric parabola in chi-square to keep fit below image
c
	common /termpointer/ lista,peak,cent,wid
	dimension lista(11),cent(3),wid(3)
	real*4 peak
      dimension y(1),a(11),sigmaa(11),yfit(1),x(3,1)
      dimension alpha(11,11),beta(11),deriv(11)
     1,b(11)
	real*4 tau(11)
	real*4 weight(1)
	integer ipt(1)
      real*8 array(11,11),det
	logical conv,bigger
	integer termou
	dimension s0(3)
	data tau /3*0.,0.003,2*1.e-2,1.,2*10.,.1,1./
	data termou/2/

	tau(8)=sqrt(wid(1))
	tau(9)=sqrt(wid(2))
	tau(10)=sqrt(wid(3))

	conv=.true.
  	chisqr=0.
      free=wsum-float(nterms)
      if(free) 110,110,20
c
c
20	s00=s0(1)
	sm=s0(2)/2.*free
	sc=s0(3)/2.*free
c	
      iter = 0
      fnu = 10.
      go to 34
c
c     test for convergence
c
   31 continue
	ddel=abs(a(1)-a(2))*(a(1)+a(2))/
     &       (wid(1)+wid(2)+0.5*(a(1)+a(2))**2)
	do 32 i=1,nterms
	 li=lista(i)
         del = abs(a(li)-b(li))
	if (li.le.3) then
	 del = del/abs(a(li)) / (1.+wid(li)/a(li)**2)
	else if (li.eq.4) then
	 del = del/(tau(li)+abs(a(li)))*ddel
	else if (li.eq.7 .or. li.eq.11) then
	 del = 2.*abs(a(li))*del/(1.+a(li)**2)
	else
         del = del/(tau(li)+abs(a(li)))
	endif
   32    if(del.gt.eps)iflag = 1
      if(iflag.eq.0)go to 101
      iflag = 0
      iter = iter + 1
      if(iter.gt.itmax)go to 101
      flambda=flambda/fnu
      do 33 j = 1,11
   33    a(j) = b(j)
c
c    evaluate alpha and beta matrices.
c
   34 continue
	do 35 j=1,nterms
	lj=lista(j)
	if (lj.eq.11) then
	  beta(j)=4.*sm*(peak-a(11)**2-a(7)**2)*a(11)
	else if (lj.eq.7) then
	  beta(j)=4.*sm*(peak-a(11)**2-a(7)**2)*a(7)
	else if(lj.ge.8) then
	  beta(j)=2.*sc*4.*(cent(lj-7)-a(lj))/wid(lj-7)
	else
          beta(j) = 0.
	endif
       do 35 k=1,j
	lk=lista(k)
	if ( (lk.eq.11 .or. lk.eq.7) .and. 
     &       (lj.eq.11 .or. lj.eq.7) ) then
	  alpha(j,k)=8.*sm*a(lk)*a(lj)
	else if (lk.ge.8 .and. lj.eq.lk) then
	  alpha(j,k)=2.*4.*sc/wid(lj-7)
	else
          alpha(j,k) = 0.
	endif
   35 continue
	call quadini (a)
      do 50 i=1,npts
      ix = ipt(i)
      call fderiv (ix,a,deriv,x,nterms,fff)
	yfit(ix)=fff
      res = (y(ix)-yfit(ix))
	rr=1.
	if (res.le.0.) rr=1.+s00
      do 46 j=1,nterms
	lj=lista(j)
      beta(j)=beta(j)+deriv(lj)*(res*weight(ix)*rr)
      do 46 k=1,j
	lk=lista(k)
   46 alpha(j,k)=
     &    alpha(j,k)+deriv(lj)*deriv(lk)*(weight(ix)*rr)
   50 continue
      do 53 j=1,nterms
      do 53 k=1,j
   53 alpha(k,j)=alpha(j,k)
c
c     evaluate chi square at starting point.
c
	if (chisqr.eq.0.) then
	  chisq1=
     &   fchisq(y,npts,free,yfit,weight,ipt,1.e30,bigger,s0,a)
	else
	      chisq1=chisqr
	endif
	write (termou,'(1x,a,1p,8g9.2)') 
     &    'chisqr ',chisq1,a(1),a(2),a(4),a(3),a(5),a(6)
c
c     invert modified curvature matrix to find new parameters.
c
      int = 0
   71 int = int + 1
ccc	if (flambda.gt.2390.) goto 116
      if(int-25)72,116,116
   72 do 74 j=1,nterms
      do 73 k=1,nterms
      if(alpha(j,j)*alpha(k,k).eq.0.0)go to 116
   73 array(j,k)=alpha(j,k)/sqrt(alpha(j,j)*alpha(k,k))
   74 array(j,j)=1.+flambda
      call matinv(array,nterms,det)
	do 85 j=1,11
85	b(j)=a(j)
      do 84 j=1,nterms
      lj=lista(j)
      do 83 k=1,nterms
   83 b(lj)=b(lj)+beta(k)*array(j,k)/sqrt(alpha(j,j)*alpha(k,k))
   84 continue

	d4=b(4)-a(4)
	d4=0.6*tanh(d4/0.6)
	b(4)=a(4)+d4

	do 22 i=1,3
	dd=b(i)-a(i)
	if (dd.lt.0.) then
		dd=0.5*a(i)*tanh(dd/a(i)/0.5)
		if (a(i).le.1.e-6) dd=0.
	endif
	b(i)=a(i)+dd
22	continue

	dd=b(11)-a(11)
	if (dd.lt.0.) then
		if (a(11).le.1.e-6) then
			dd=0.
		else
			dd=0.5*a(11)*tanh(dd/a(11)/0.5)
		endif
	endif
	b(11)=a(11)+dd

	dd=b(7)-a(7)
	if (dd.lt.0.) then
		if (a(7).le.1.e-6) then
			dd=0.
		else 
			dd=0.5*a(7)*tanh(dd/a(7)/0.5)
		endif
	endif
	b(7)=a(7)+dd

c
c
c     if chi square increased, increase flambda and try again.
	call quadini(b)
      do 92 i=1,npts
      ix = ipt(i)
   92 yfit(ix)=functn(ix,b,x,nterms)
      chisqr=
     &  fchisq(y,npts,free,yfit,weight,ipt,chisq1,bigger,s0,b)
	if (.not.bigger) goto 31
96   	flambda=flambda*fnu
      go to 71
c
  101 if(iter-itmax)103,102,102
  102 write(termou,111)iter
	conv=.false.
      go to 100
  103 write(termou,112)iter
c
c     compute error matrix
c
100	continue
c
c     evaluate the standard deviations of the parameters.
c
      do 105 j=1,nterms
  105    sigmaa(lista(j))=sqrt(array(j,j)/ alpha(j,j)*chisqr)
	do 106 j=1,11
106	a(j)=b(j)
  110 return
  111 format(/1x,'W-CURFIT, not converged after ',i3,' iterations',/)
  112 format(/1x,'I-CURFIT, converged after ',i3,' iterations ',/)
  115 format(1x,'W-CURFIT, no convergence in inner loop, or zero element
     *(s) in curvature matrix       =>bad initial guesses.')
  116 write(termou,115)
	write (termou,*) ' int ',int,' flambda ',flambda
	write (termou,*) ' a ',a
	write (termou,*) ' b ',b
	conv=.false.
      go to 110
	end
c       
 	subroutine matinv(array,norder,det)
	dimension array(11,11),ik(11),jk(11)
        real*8 array,amax,save,det
	det=1.0
	do 100 k=1,norder
c
c	find largest element in array
c 
	   amax=0.0
   21	   do 30 i=k,norder
		do 30 j=k,norder
		if(abs(amax)-abs(array(i,j)))24,24,30
   24           amax=array(i,j)
	        ik(k)=i
		jk(k)=j
   30      continue
c 
c	interchange rows and columns to put amax in array(k,k)
c
	   if(amax)41,32,41
   32      det=0.0
	   go to 140
   41      i=ik(k)
	   if(i-k)21,51,43
   43	   do 50 j=1,norder
	      save=array(k,j)
	      array(k,j)=array(i,j)
   50	   array(i,j)=-save
   51	   j=jk(k)
	   if(j-k)21,61,53
   53	   do 60 i=1,norder
	      save=array(i,k)
	      array(i,k)=array(i,j)
   60	   array(i,j)=-save
c
c	accumulate elements of inverse matrix
c
   61	   do 70 i=1,norder
	      if(i-k)63,70,63
   63	      array(i,k)=-array(i,k)/amax
   70	   continue
	   do 80 i=1,norder
	      do 80 j=1,norder
	         if(i-k)74,80,74
   74	         if(j-k)75,80,75
   75	         array(i,j)=array(i,j)+array(i,k)*array(k,j)
   80	   continue
	   do 90 j=1,norder
	      if(j-k)83,90,83
   83	      array(k,j)=array(k,j)/amax
   90	   continue
	   array(k,k)=1.0/amax
  100	det=det*amax
c
c	restore ordering of matrix
c
	do 130 l=1,norder
	   k=norder-l+1
	   j=ik(k)
	   if(j-k)111,111,105
  105	   do 110 i=1,norder
	      save=array(i,k)
	      array(i,k)=-array(i,j)
  110	   array(i,j)=save
  111	   i=jk(k)
	   if(i-k)130,130,113
  113	   do 120 j=1,norder
	      save=array(k,j)
	      array(k,j)=-array(i,j)
  120	   array(i,j)=save
  130	continue
  140	return
	end

	function 
     &   fchisq (y,npts,free,yfit,weight,ipt,chiold,bigger,s0,a)
	common /termpointer/ lista,peak,cent,wid
	dimension lista(11),cent(3),wid(3)
	real*4 peak
	dimension a(11)
	dimension y(1), yfit(1), weight(1), ipt(1)
	logical bigger
	dimension s0(3)
	bigger=.false.
	old=chiold
	chisq = 0.
	fchisq = 0.
	if (free) 13, 13, 20
13	fchisq = 0.
	goto 40
c
c	accumulate chi square
c
20	continue
	s00=s0(1)
	chisq=s0(2)*(peak-a(11)**2-a(7)**2)**2
	do 21 i=1,3
21	chisq=chisq+s0(3)*4.*(cent(i)-a(7+i))**2/wid(i)
	do 30 i=1,npts
	ip=ipt(i)
	res=y(ip)-yfit(ip)
	rr=1.
	if (res.le.0.) rr=1.+s00
	chisq=chisq+res**2*weight(ip)/free*rr
	if (chisq.gt.old) then
		bigger=.true.
		goto 40
	endif
30	continue
c
c	divide by number of degrees of freedom
c
32	fchisq = chisq
40	return
	end

