       subroutine fitprm
c
c      compute uncertainties in all values described by an
c      encoded math expression, held in integer code icdval,
c      as generated by encod and ordered by fixicd.
c
c     copyright 1995 university of washington         matt newville
c--------------------------------------------------------------------
       include 'fitcom.h'

       integer i, j, k, idp, iex, ierr, ilen, istrln
       integer nstart, id, idpath, inpath, jfeff, juser,n, idot
       character outstr*128, fil*128, stat*10
       double precision  tiny, scale, oldval, two, decod, eval
       double precision  dvdx(maxval,mvarys),   dpdx(mpthpr,mvarys)
       double precision  par(mpthpr), dpar(mpthpr), rfave, reff
       double precision  redchi, sum, dx, pold, thous, xnu, degen
       parameter (tiny = 1.0d-10, two = 2.d0)
       parameter (thous = 0.001d0)
       external  eval, istrln, decod
       data      stat, idp / 'unknown', 0/
c
       fil = 'feffit.prm'
       if (inpfil.ne.'feffit.inp') then
          call triml(inpfil)
          idot  = max(1,istrln(inpfil))
          if (index(inpfil(1:idot),'.').ne.0) then
 15          continue
             if (index(inpfil(idot:idot),'.').eq.0) then
                idot = idot - 1
                go to 15
             end if
          end if
          fil = inpfil(1:idot) //'prm'
       end if

c
       redchi =  chisqr
       xnu    = xnidp - numvar
       if (xnu.gt.0)     redchi =  chisqr / xnu
       scale = sqrt(dabs(redchi))
       call openfl(idp, fil, stat, iex, ierr)
       if (ierr.lt.0) call finmsg(1001,fil,' ',0)
       do 10 i = 1, nmathx
          delval(i) = zero
 10    continue
c
c  write preliminary message
       ilen   = max(1, istrln(versn))
       write(idp,9005) versn(1:ilen)
       write(idp,9002) '==================================='//
     $            '==================================='
c  list input data sets, titles for each
c  also, compute average r-factor
       if (ndata.eq.0) then
          write(idp,9003) 'no input data files.'
       else
          if (ndata.eq.1) then
             write(idp,9003) 'input data file:'
          else
             write(idp,9003) 'input data files:'
          endif
          rfave  = zero
          do 30 n = 1, ndata
             rfave = rfave + rfactr(n)
             if (ndata.gt.1)  write(idp,9009) '-> data set ',n
             if (datain(n)) then
                ilen = max(1, istrln(chifil(n)))
                outstr = 'input data chi file = '
     $               //chifil(n)(:ilen)//', skey = '//skey(n)
             else
                outstr = ' no input data file given'
             endif
             ilen = istrln(outstr)
             write(idp,9005) outstr(1:ilen)
c##<bkg
             if (bkgdat(n)) then
                ilen = max(1, istrln(bkgfil(n)))
                outstr = 'used bkg(k) from file = '
     $               //bkgfil(n)(:ilen)//', skey = '//skeyb(n)
                ilen = istrln(outstr)
                write(idp,9005) outstr(1:ilen)
             end if
             if (bkgfit(n)) then
                write(idp,9005) '  fitted background spline to data'
                write(idp,9905) '  with rbkg = ', rbkg(n),
     $               '  and n_knots = ',nbkg(n)
             end if
c##bkg>
 30       continue
          rfave = rfave / ndata
       end if
c then write down goodness of fit statistics
       if (ndata.gt.1)
     $      write(idp,9055) 'number of data sets           = ',ndata
       write(idp,9060) 'independent points in data    = ',xnidp
       write(idp,9055) 'number of variables in fit    = ',numvar
       write(idp,9060) 'degrees of freedom in fit     = ',xnidp -numvar
       write(idp,9035) 'r-factor of fit               = ',rfave
       if (chisqr.lt. 999 999) then
          write(idp,9035) 'chi-square                    = ',chisqr
       else
          write(idp,9036) 'chi-square                    = ',chisqr
       end if
       redchi =  chisqr
       if (xnu.gt.0) then
          redchi =  chisqr / xnu
          if (redchi.lt. 999 999) then
           write(idp,9035) 'reduced chi-square            = ',redchi
          else
           write(idp,9036) 'reduced chi-square            = ',redchi
          end if
       elseif (xnu.eq.0) then
          write(idp,9005) 'questionable fit: all independent ',
     $         'points were used in fit!'
       else
          write(idp,9005) 'invalid fit: more variables than',
     $         ' independent points !'
       end if
       write(idp,9003) ' '


c first, do best-fit and uncertainties in variables.
c pretty simple, but don't forget to rescale by redchi!
       if (numvar.le.0) write(idp,9003) '------ No Variables '

       write(idp,9002) '  uncertainties in variables and "set" values:'
       if (numvar.ge.1) then
          write(idp,9002)  '---- variables: '
          do 50 i = 1, numvar
             values(i) = xfinal(i)
             delval(i) = scale * delta(i)
             call wrtprm(idp, 0, 20, vnames(i), 0, values(i), delval(i))
 50       continue
       end if
c
c second, do the obvious constants, which have dval = zero.
       if (nconst.ge.1) then
          write(idp,9002)  '---- some obvious constants: '
          do 80 i = numvar+1, nconst+numvar
             delval(i)   = zero
             oldval    = values(i)
             values(i) = decod(icdval(1,i),micode,consts,values,oldval)
             call wrtprm(idp, 0, 20, vnames(i), 0, values(i), delval(i))
 80       continue
       end if
       nstart = nconst + numvar + 1
c
cc       print*, '##fitprm:  2'
c--------------------------------------------------------------
c here's the tricky part:
c     for the rest, we have to calculate derivatives of the
c     values with respect to the previous values.
c     this is done for each data set, with path = path 1
c     then we calculate the uncertainties in the path
c     parameters themselves.
       id        = 1
       idpath    = 1
       inpath    = jdtpth(idpath,id)
       if (inpath.le.0) go to 1000
       jfeff     = jpthff(inpath)
       ixpath    = jfeff
       if (jfeff.le.0) go to 1000
       consts(4) = refpth(jfeff)
       consts(5) = degpth(jfeff)
       if (numvar.ge.1) then
          do 200 j = 1, numvar
             dx        = max( tiny , delval(j) )
             values(j) = xfinal(j) - dx / two
             call setval(nstart,nmathx,icdval,maxval,micode,consts,
     $            mconst,values,icdloc,mlocal,mdata,ixlocl,id)
             values(j) = xfinal(j) + dx /two
             do 160 i = nstart, nmathx
                oldval    = values(i)
                values(i) = eval(icdval, maxval, micode, consts,
     $               mconst, values, oldval, icdloc,
     $               mlocal, mdata,  ixlocl,  id, i )
                dvdx(i,j) = (values(i) - oldval ) / dx
 160         continue
             values(j) = xfinal(j)
             call setval(nstart,nmathx,icdval,maxval,micode,consts,
     $            mconst,values,icdloc,mlocal,mdata,ixlocl,id)
 200      continue
       end if
c    now collect sum of squares of derivatives
c    to give delval of the set values.
       do 500 i = nstart, nmathx
          sum = zero
          if (numvar.ge.1) then
             do 480 j = 1, numvar
                sum = sum + (delval(j) * dvdx(i,j))**2
                if (j.lt.numvar) then
                   do 460 k = j+1, numvar
                      sum = sum + two  * delval(j)  * delval(k)
     $                     * dvdx(i,j) * dvdx(i,k)  * correl(j,k)
 460               continue
                end if
 480         continue
          end if
          delval(i) = sqrt(dabs ( sum ) )
 500   continue
c
c write 'em out
       write(idp,9002)  '---- more complicated set values: '
       do 900 i = nstart, nmathx
          call wrtprm(idp, 0, 20, vnames(i), 0, values(i), delval(i))
 900   continue
c
c now the path parameters
 1000  continue
       do 5000 id = 1, ndata
          if (ndata.gt.1)  write(idp,9009) ' ---------- data set ',id
          do 4000 idpath = 1, mdpths
             inpath    = jdtpth(idpath,id)
             if (inpath.eq.0)    go to 3990
             juser     =  jdtusr(idpath,id)
             write(idp,9009) '--- path: ', juser
             jfeff     = jpthff(inpath)
             if (jfeff.eq.0)     go to 3990
             reff      = refpth(jfeff)
             if (reff.le.thous)  go to 3990
             degen     = degpth(jfeff)
             ixpath    = jfeff
             consts(4) = reff
             consts(5) = degen
             if (numvar.ge.1) then
                do 1500 j = 1, numvar
                   dx        = max( tiny , delval(j) )
                   values(j) = xfinal(j) - dx / two
                   call setval(nstart,nmathx,icdval,maxval,micode,
     $        consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
                   do 1250 i = 1, mpthpr
                      par(i) = decod(icdpar(1, i, inpath), micode,
     $                     consts, values, defalt(i))
 1250              continue
                   values(j) = xfinal(j) + dx /two
                   call setval(nstart,nmathx,icdval,maxval,micode,
     $        consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
                   do 1350 i = 1, mpthpr
                      pold   = par(i)
                      par(i) = decod(icdpar(1, i, inpath), micode,
     $                     consts, values, defalt(i))
                      dpdx(i,j) = (par(i) - pold ) / dx
 1350              continue
                   values(j) = xfinal(j)
                   call setval(nstart,nmathx,icdval,maxval,micode,
     $        consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
                   do 1450 i = 1, mpthpr
                      par(i) = decod(icdpar(1, i, inpath), micode,
     $                     consts, values, defalt(i))
 1450              continue
 1500           continue
             else
                   call setval(nstart,nmathx,icdval,maxval,micode,
     $        consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
                do 1800 i = 1, mpthpr
                   par(i) = decod(icdpar(1, i, inpath), micode,
     $                  consts, values, defalt(i))
 1800           continue
             end if
c    now collect sum of squares of derivatives
c    to give delval of the path parameters
             do 2500 i = 1, mpthpr
                sum = zero
                if ((numvar.ge.1).and.(icdpar(1,1,inpath).ne.0)) then
                   do 2400 j = 1, numvar
                      sum = sum + (delval(j) * dpdx(i,j))**2
                      if (j.lt.numvar) then
                         do 2300 k = j+1, numvar
                            sum = sum + two * delval(j) * delval(k)
     $                          * dpdx(i,j) * dpdx(i,k) * correl(j,k)
 2300                    continue
                      end if
 2400              continue
                end if
                dpar(i) = sqrt(dabs ( sum ) )
 2500        continue
c print out
             do 3000 i = 1, mpthpr
                if (icdpar(1, i, inpath).ne.0) then
                   call wrtprm(idp,1,10,parnam(i),juser,par(i),dpar(i))
                end if
 3000        continue
 3990        continue
 4000     continue
 5000  continue
 8000  continue
       close(idp)

 9002  format(1x,'%', a)
 9003  format(1x,'% ', a)
 9005  format(1x,'%   ', a)
 9009  format(1x,'% ',a,i5)

 9035  format(5x,a,f14.6)
 9036  format(5x,a,e14.6)
 9055  format(5x,a,2x,i5)
 9060  format(5x,a,f11.3)

 9905  format(1x,'%   ', a,f6.3,1x,a,i3)
       return
c     end routine fitprm
       end

