subroutine fit_newpeak ! ---------------------- include 'fit.inc' if (ififu .ne. 1) then write(isyswr,*) 'Command NEWPEAK works for peak functions only' return endif if (nu .lt. 7) then call fit_fun(0, 0, 0.0,0.0) return endif if (nu .gt. maxext-5) then write(isyswr, *) 'Max.', maxpeak,' peaks allowed' return endif call fit_create_peak call fit_cop_par(nu-9, nu-4, 5) u(nu-4)=u(nu-9)+(u(nu-6)+u(nu-5))*2 if (lcode(nu-4) .eq. 0) call fit_rel(nu-4) 90 call fit_set(0,0.0,0.0,0.0,0.0) call fit_print(1) 99 return end subroutine fit_create_peak include 'fit.inc' integer k,i nu=nu+5 k=nu/5 write(pnam(nu-4), '(a6,i2)') 'Posi. ',k write(pnam(nu-3), '(a6,i2)') 'MaxInt',k write(pnam(nu-2), '(a6,i2)') 'IntInt',k write(pnam(nu-1), '(a6,i2)') 'Fwhm G',k write(pnam(nu ), '(a6,i2)') 'Fwhm L',k write(psho(nu-4), '(a1,i2)') 'P',k write(psho(nu-3), '(a1,i2)') 'M',k write(psho(nu-2), '(a1,i2)') 'I',k write(psho(nu-1), '(a1,i2)') 'G',k write(psho(nu ), '(a1,i2)') 'L',k do i=nu-4,nu if (k .le. 9) psho(i)(2:3)=psho(i)(3:3) lcode(i)=1 icsw(i)=0 u(i)=0 werr(i)=0 enddo lcode(nu-3)=0 icsw(nu-3)=-1 icto(nu-3)=nu-2 lcode(nu)=0 end subroutine fit_mov_par(from, to, size) include 'fit.inc' integer from, to, size integer n1,n2,i,j n1=1 n2=nu goto 10 entry fit_cop_par(from, to, size) n1=to n2=to+size-1 10 do j=1,nu if (icto(j) .ge. to .and. icto(j) .lt. to+size .and. 1 icsw(j) .gt. 0) then icsw(j)=0 endif enddo i=to do j=from,from+size-1 u(i)=u(j) werr(i)=werr(j) lcode(i)=lcode(j) icsw(i)=icsw(j) icto(i)=icto(j) cfac(i)=cfac(j) coff(i)=coff(j) werrs(i)=werrs(j) alim(i)=alim(j) blim(i)=blim(j) i=i+1 enddo do j=n1,n2 if (icto(j) .ge. from .and. icto(j) .lt. from+size) then icto(j)=icto(j)+to-from endif enddo return entry fit_del_par(from, size) do j=1,nu if (icto(j) .ge. from .and. icto(j) .lt. from+size .and. 1 icsw(j) .gt. 0) then icsw(j)=0 endif enddo do i=from,from+size-1 u(i)=0 lcode(i)=0 icsw(i)=0 enddo end