Initial commit

gen/inex.f

@@ -0,0 +1,173 @@
+	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