174 lines
3.3 KiB
Fortran
174 lines
3.3 KiB
Fortran
subroutine intoex(pint)
|
|
C -----------------------
|
|
|
|
include 'fit.inc'
|
|
real pint(maxpar)
|
|
|
|
real al, fact
|
|
integer i,j
|
|
|
|
real voigt ! function
|
|
|
|
c internal to external parameters
|
|
|
|
do i= 1, nu
|
|
j=lcorsp(i)
|
|
if (j .gt. 0) then
|
|
if (lcode(i) .eq. 1) then
|
|
u(i) = pint(j)
|
|
else
|
|
al = alim(i)
|
|
u(i) = al + 0.5 *(sin(pint(j)) +1.0) * (blim(i) -al)
|
|
endif
|
|
endif
|
|
enddo
|
|
|
|
c correlated parameters
|
|
|
|
do j=1,ncor
|
|
i=icord(j)
|
|
fact=cfac(i)
|
|
if (icsw(i) .lt. 0) then
|
|
if (ififu .eq. 1) then
|
|
if (mod(i,5) .eq. 0) then
|
|
fact=1/voigt(0.0,u(i+1),u(i+2)) ! Int.Int is calculated from Max.Int
|
|
else
|
|
fact=voigt(0.0,u(i+2),u(i+3)) ! Max.Int is calculated from Int.Int
|
|
endif
|
|
endif
|
|
endif
|
|
u(i) = u(icto(i))*fact+coff(i)
|
|
enddo
|
|
ni=-1
|
|
return
|
|
end
|
|
|
|
|
|
|
|
subroutine extoin
|
|
c -----------------
|
|
|
|
include 'fit.inc'
|
|
|
|
integer i,j,k,l
|
|
real uplus, uminu
|
|
|
|
real pintf ! function
|
|
|
|
isw(1)=0
|
|
isw(2)=0
|
|
ncor=0
|
|
if (ififu .eq. 1) then ! remove peaks with zero intensity
|
|
i=5
|
|
do k=5,nu,5
|
|
if (i .ne. k) call fit_mov_par(k-2, i-2, 5)
|
|
if (u(k) .ne. 0 .or. u(k-1) .ne. 0 .or.
|
|
1 lcode(k) .gt. 0 .or. icsw(k) .gt. 0) then
|
|
u(i+1)=abs(u(i+1))
|
|
u(i+2)=abs(u(i+2))
|
|
i=i+5
|
|
endif
|
|
enddo
|
|
if (i .eq. 5 .and. nu .gt. 2) then
|
|
u(1)=u(1)-u(2)*u(3)
|
|
u(3)=0
|
|
endif
|
|
do k=i-2,nu,5
|
|
call fit_del_par(k, 5) ! remove correlations to deleted peak
|
|
enddo
|
|
nu=i-3
|
|
endif
|
|
npar=0
|
|
do k=1,nu
|
|
if (lcode(k) .gt. 0) then
|
|
if (npar .ge. maxpar) then
|
|
if (lcode(k) .gt. 0) lcode(k)=-lcode(k)
|
|
write(isyswr, '(x,3a)')
|
|
1 'To much variable parameters -> ',pnam(k),' fixed'
|
|
|
|
else
|
|
|
|
if (werr(k) .eq. 0) then
|
|
if (werrs(k) .gt. 0) then
|
|
werr(k)=werrs(k)
|
|
else
|
|
if (ififu .eq. 1 .and. mod(k,5) .eq. 3) then
|
|
werr(k)=sqrt(werr(k+2)**2+werr(k+3)**2)/10
|
|
endif
|
|
if (werr(k) .eq. 0) werr(k)=max(1e-5,abs(u(k))/10)
|
|
endif
|
|
endif
|
|
|
|
npar=npar+1
|
|
lcorsp(k)=npar
|
|
x(npar)=pintf(u(k),k)
|
|
uplus=u(k)+werr(k)
|
|
uminu=u(k)-werr(k)
|
|
dirin(npar)=(abs(pintf(uplus,k)-x(npar))
|
|
1 +abs(pintf(uminu,k)-x(npar)))/2
|
|
endif
|
|
else
|
|
lcorsp(k)=0
|
|
j=k
|
|
l=nu
|
|
do while (icsw(j) .ne. 0) ! go along correlation path
|
|
do i=1,ncor
|
|
if (icord(i) .eq. j) goto 8 ! already in ICORD
|
|
enddo
|
|
do i=l+1,nu
|
|
if (icord(i) .eq. j) goto 8 ! already in path list
|
|
enddo
|
|
icord(l)=j
|
|
l=l-1
|
|
j=icto(j)
|
|
if (j .lt. k) goto 8 ! already tested
|
|
if (j .gt. nu) goto 8 ! illegal par. no
|
|
enddo
|
|
8 do j=l+1,nu
|
|
ncor=ncor+1
|
|
icord(ncor)=icord(j)
|
|
enddo
|
|
endif
|
|
9 enddo
|
|
nfree=max(1,nxmax-nxmin+1-npar)
|
|
end
|
|
|
|
|
|
|
|
real function pintf(pexti, i)
|
|
C -----------------------------
|
|
include 'fit.inc'
|
|
|
|
integer i
|
|
real pexti
|
|
|
|
real alimi, blimi, yy
|
|
|
|
goto (100,200,300,400) lcode(i)
|
|
|
|
C no limits
|
|
100 pintf = pexti
|
|
return
|
|
|
|
C lower limit (not implemented)
|
|
200 continue
|
|
|
|
C upper limit (not implemented)
|
|
300 continue
|
|
|
|
C both limits
|
|
400 alimi = alim(i)
|
|
blimi = blim(i)
|
|
|
|
yy=2*(pexti-alimi)/(blimi-alimi)-1.0
|
|
if (yy .lt. -1.0) then
|
|
yy=-1.0
|
|
pexti=alimi
|
|
elseif (yy .gt. 1.0) then
|
|
yy=1.0
|
|
pexti=blimi
|
|
endif
|
|
|
|
pintf=asin(yy)
|
|
end
|