c*******************************************************************************
c subroutine written by anuj bhagwati
c ghost-written by peter bagley, god bless him !
c july 13,1989	
c when invoked by a dimat  input file with operation title 'MINI'
c this subroutine is called
c its output  is a sextupole disribution1 that minimizes the weighted
c sums of squares of the horizontal and vertical chromaticities,
c horizontal and vertical beta_partials w.r.t. delta at the I.P.,
c horizontal dispersion_partial w.r.t. delta at the I.P.
c and a weight function  to somewhat hold the sextupole strength's reasonable
c weights are input interactively from the keyboard
c their choice may be critical in good values for the functions!
c*******************************************************************************
	subroutine mini

  	implicit DOUBLE PRECISION(a-h,o-z), integer (i-n)

c	external func

c these are the common blocks from matrix, simply copied over
c n from the unnamed common is renamed to n1 since the imsl
c routine wants a variable called n

	common /minitwo/bxarcmax(2),byarcmax(2),etaarcmax(2),
     &    bxirmax(2),
     &	  byirmax(2)
     &	  ,etairmax(2),cavbetax(2),cavbetay(2),caveta(2,2),cavtune
     &	  ,aperarcmax(2),separation,nbunchs
       	common amat(350,6,27),norlst(2500),
     1	xpel(350),ypel(350),
     1	expel,n1,logpar(350)
      	common/inout/iin,iout,isout,iso
      	common /inputt/ kode(350),name(350,4),iadr(350),eldat(5000)
     1	,madr(350),kcount,na
	common /mat1/temp1(6,27),iflag1,nelstrt,nelend
      	common/mat/temp(6,27),norder,mprint,imat,nmat,ifite,nelm,nop,
     1	nlist(40)
	common /gplot/igplot,idev,ndispl
      	common/prodct/kodepr,nel,nof
      	common/const/pi,twopi,crdeg,cmagen,clight,emass,erad,echg
      	common/fout/outfl(300)
c      	common/func/betax,alphax,etax,etapx,betay,alphay,etay,etapy,
c     1  starte,ende,deltae,dnu,mfprnt,kod,nlum,nint,nbunch
      	common/twf/betaox,alphox,etaox,etapox,anux,
     1            betaoy,alphoy,etaoy,etapoy,anuy,ie
      	common/length/tleng,aleng(350),acleng(2500)
      	common/lum/ uo,taux,alphx,alphy,tauy,
     1  alphe,taue,sige,sigx,epsx,
     1	sigy,epsy,sigxt,sigyt,energy,taurev
      	common/cbeam/bsig(6,6),bsigf(6,6),mbprt,nform
	common /bmax/bvarc,bharc,bvir,bhir,ir1,ir2,ir3,ir4
 	common /twiher/npnt,jfite(10),ipnt
	common/minia/detaddelta,betas(2000,2),
     1               ibeta_adr(2000),initbeta_count,miniinvoke

c these are the common blocks from anal, simply copied over

        common/analc/compf,rnu0x,cetax,cetapx,calphx,cbetax,
     1	rmu1x,chromx,alph1x,beta1x,
     1	rmu0y,rnu0y,cetay,cetapy,calphy,cbetay,
     1	rmu1y,chromy,alph1y,beta1y,rmu0x,
     1	cosx,alx1,alx2,vx1,vxp1,vx2,vxp2,
     1	cosy,aly1,aly2,vy1,vyp1,vy2,vyp2,nstabx,nstaby,nstab,nwrncp

c these are declarations of use in this subroutine only.
c idindex is a count of the number of array elements of type 's'
c ie. sextupoles.ifuncnumber is used in reading the weights
c for d2,d3 see comments in reals for d1
c idummy, jdummy are just loop indices
c the others are required by the imsl routine zxssq (see documentation)
c m represents the number of functions to be minimised.

        integer ifuncnumber,idummy,kdummy,m,n,      
     1		ixjac,iopt
	common/numfunc/ifuncnumber

	integer idindex,qs(2,4),d2(350),d3(350),igr,d4(2500)
	real*4 dx(350)
	common/sext/idindex,qs,d2,d3,dx,igr,d4

c sextupole strengths are stored at different  locations in eldat
c they aren't sequential. to use the imsl routine, the variables
c ie the  sextupole strengths must be in elements 1..n of an array
c this is what is to be read into d1. d2 (above) stores where in eldat the
c same indexed element in d1 came from.to be safe, the sizes
c of these arrays  are set to 250.d3 tells us which elements of the
c element spec. list are sextupoles. until a machine has more than
c 250 kinds of sextupoles , we're safe.
c weight merely holds the weights for the various functions,
c the weighted sums of squares of which are to be minimised
c parm..ssq are required for the imsl routine  zxssq (see documentation)
c the temps represent my inability to do fortran i/o

	real weight(100),goal(100),f(100)
C     1 ,eps,parm(4),delta,ssq,temp00,temp01,temp02,temp03,temp04,temp05	
	 
	real*4 d1(350),grad(350),confid,epsminop
	logical init 
      	common/weights/weight,goal,f
	real*4 f0
	common /twoeng/htune(4),vtune(4),hbeta(4),vbeta(4)
     &	  ,ener(4),xdisp(4),htune0,vtune0,hbeta0,vbeta0,weightsext
     &	  ,halpha0,valpha0,ydisp(4)

	integer twochara(72)
	common/hi/h(350)
	common /ooout/params
	common /jtwiss/stwiss(10,4,100),itwiss(100),ntwiss(2500),
     1                 lname(100),ltwiss
	logical ltwiss(2000)
	logical quad(2000),irquad(2000),bypass(2000),sept(2000),cross(2000),
     &	  bend(2000)
	logical ibefore(2000),iafter(2000)
	dimension ncrosssav(2000)
	common /storeat/ quad,irquad,bypass,sept,cross,bend,
     &	  ibefore,iafter,ncrosssav
	character*72 string
	character* 15 params(100)
	character*2 chartw
	data params/'b*x h(3)','b*x l(2)',
     &		    'b*y h(3)','b*y l(2)',
     &	            ' Qx high',' Qx low ',
     &		    ' Qy high',' Qy low ',
     &		    'eta high','Qxp high',
     &		    'Qxp low ','Qyp high',
     &		    'Qyp low ',' eta low',
     &		    ' alphav ',' alphah ',
     &		    'f lie   ','b*x h(4)',
     &		    'b*x l(1)','b*y h(4)',
     &		    'b*y l(1)','bxarc  ',
     &		    'byarc ',' epsx(1)',
     &		    'epsxplus','eps+-ep-',
     &		    'dx+ -dx-',' al+-al-',
     &		    'aper arc','sep arc ',
     &		    'y dis IP','h dis IP',
     &		    'etarc   ','det h+v ',
     &		    'dethv   ','coup    ',
     &		    'maxkick ','path dif',
     &              'detymax ','detxmax ',
     &              ' scmax  ',59*' '/
c
	common /middle/emit(2),interm,intprt,iemitt,idec,nesave(2000)
c
	write(6,1069)
1069	format(' nbunchs? ',$)
	accept *,nbunchs
	nbeam=1
	if(nbunchs.gt.1)nbeam=2
c  read in weights for  the functions to  be minimised 
c weight can't be zero. see output section for why this is so
       
c	type *,'Input weights here. Weights must be reals.'
c	type *,'There is no limit on their size'
c	type *,'The fn. minimised is sum of [weight(i)*f(i)**2]'   
        type *,'If you have no more functions,input -99.0'
c	type *,'The program assumes that horizontal and vertical'
c	type *,'chromaticities and dbeta*/ddelta"s and deta*/ddelta'
c	type *,'are always on the list'

       	    
10001	format(x,' Weight for betaH high then low energy :',$)
c	write (6,10001)
c	write (13,10001)
c	read(5,*)temp01,temp02,goal(1),goal(2)

10002	format(x,' Weight for betaV high then low energy :',$)
c	write (6,10002)
c	write (13,10002)
c	read(5,*)temp03,temp04,goal(3),goal(4)

10003	format(x,' Weight for horiz. tune, high then low energy :',$)
c	write (6,10003)
c	write (13,10003)
c	read(5,*)temp05,temp06,goal(5),goal(6)

10004	format(x,' Weight for vert. tune, high then low energy :',$)
c	write (6,10004)
c	write (13,10004)
c	read(5,*)temp07,temp08,goal(7),goal(8)

10005	format(x,' Weight for horiz chrom, high/low E and values :',$)
c	write (6,10005)
c	write (13,10005)
c	read(5,*)temp10,temp11,goal(10),goal(11)

10006	format(x,' Weight for vert chrom, high/low E and values :',$)
c	write (6,10006)
c	write (13,10006)
c	read(5,*)temp12,temp13,goal(12),goal(13)

10007	format(x,' Weight for eta, high then low energy :',$)
c	write (6,10007)
c	write (13,10007)
c	read(5,*)temp09,temp14,goal(9),goal(14)

3 	continue

c       	weight(1)=temp01
c	weight(2)=temp02
c	weight(3)=temp03
c	weight(4)=temp04
c	weight(5)=temp05
c	weight(6)=temp06
c	weight(7)=temp07
c	weight(8)=temp08
c	weight(9)=temp09
c	weight(10)=temp10
c	weight(11)=temp11
c	weight(12)=temp12
c	weight(13)=temp13
c	weight(14)=temp14
c
	ifuncnumber=0
1 	continue
        if (ifuncnumber.eq.41)goto 2

10008	format(x,' Weight and goal for function ',I8,1x,a13,$)
	write (6,10008)ifuncnumber+1,params(ifuncnumber+1)
	write (13,10008)ifuncnumber+1
	read(5,10018)temp00,goal00,string
10018	format(2f,a)

      	if (temp00.ne.-99.0) then
		ifuncnumber=ifuncnumber+1
		weight(ifuncnumber)=temp00
		goal(ifuncnumber)=goal00
		goto 1
	endif

2 	continue

30002	read(5,30014)string
30014	format(a)
	read(string,30012)twochara        
30012	format(72a1)
	type 30012,twochara
	do 30001 i=1,na
	do 30006 l=1,69
	do m=1,4
	if(twochara(l-1+m).ne.name(i,m))goto 30004
	end do
	ifuncnumber=ifuncnumber+1
	lname(ifuncnumber)=i
	read(5,30003)temp00,itw,goal00
30003	format(f,i,f)
	weight(ifuncnumber)=temp00
	goal(ifuncnumber)=goal00
	itwiss(ifuncnumber)=itw
	encode(3,30011,chartw)itwiss(ifuncnumber)
30011	format(i2)
	params(ifuncnumber)=string(1:4)//' '//chartw
	goto 30002
30004	if(twochara(l).eq.'z'.or.twochara(l).eq.'Z')goto 30005 
30006	continue
30001	continue
	goto 30002	
30005	continue
c read through the name array till a sext. is found.
c when it is, check the strength* is non-zero.if it  is,i'm going
c to assume it's really there and can be changed.
c put the  strength in d1, where it came from in eldat in d2,in name in d3
c *the elements are read in sequentially.parameters are stored in eldat,
c also sequentially. iadr tells us where in eldat the first parameter
c of an element is.the +1 is because strength is the second of the sext.
c parameters.                   

	type 90018
90018	format(' IR quads ?',$)
90002	accept 20002,twochara
	l=1
90001	continue
        do idummy=1,na
          if((name(idummy,1).eq.twochara(l))
     &	    .and.(name(idummy,2).eq.twochara(l+1))
     &	    .and.(name(idummy,3).eq.twochara(l+2))
     &	    .and.(name(idummy,4).eq.twochara(l+3))
     &	    .and.(eldat(iadr(idummy)+1).ne.0.0))then
		    do ie=1,nelm
		    if(idummy.eq.norlst(ie))irquad(ie)=.true.
	            end do
	        l=l+4
		goto 90001
    		endif
	end do
	l=l+1
	if(l.lt.69.and.twochara(l).ne.'Z')goto 90001
	if(twochara(l).ne.'Z')goto 90002
	type 9131
9131	format(' IR quads')
	do i=1,nelm
	if(irquad(i))type 9129,(name(norlst(i),l),l=1,4)
	end do
9129	format(1x,4a1)
c
20002	format(72a1)
20005	idindex=0     ! no. of sext. already found        
20006	type 20001
20001	format(' Elements to vary ?',$)
70002	accept 20002,twochara
	l=1
70001	continue
        do idummy=1,na
          if((name(idummy,1).eq.twochara(l))
     &	    .and.(name(idummy,2).eq.twochara(l+1))
     &	    .and.(name(idummy,3).eq.twochara(l+2))
     &	    .and.(name(idummy,4).eq.twochara(l+3))
     &	    .and.(eldat(iadr(idummy)+1).ne.0.0))then
				idindex=idindex+1 		
				h(idindex)=1.d0
				if(name(idummy,1).eq.'K')
     &				  h(idindex)=1000.d0       
     				d1(idindex)=eldat(iadr(idummy)+ 1)
     &				  *h(idindex)
                                d2(idindex)=iadr(idummy)+ 1
    				d3(idindex)=idummy			       
				d4(idummy)=idindex
		l=l+4
		goto 70001
    		endif
	end do
	l=l+1
	if(l.lt.69.and.twochara(l).ne.'Z')goto 70001
	if(twochara(l).ne.'Z')goto 70002
   29	continue                                            
c now, the betas at each sextupole are calculated and put in the 
c array betas. betas(#,1) has beta-x at the #'th sextupole
c similarly for y in betas(#,2)
c ibeta_adr(#) tells us where in eldat the strength of  
c the sextupole is. 
     
c   	call initbetas
     
c imsl-type  initialisations.m represents the no. of functions.
     

	m=ifuncnumber
	n=idindex                                         
        ixjac=ifuncnumber
20000	format(x,
     &	  'input confid,dx0,eps,maxfn,loops,rent :',$)
	type 20000
c  reasonable values confid=0.01,dx=0.025,epsminop=0.,maxfun=100,loops=1
	accept *,confid,dx0,epsminop,maxfun,loops,rent                  
	type 131,idindex
131	format(' Number of variable elements ',i)
	do i=1,idindex
	type 129,(name(d3(i),l),l=1,4),d1(i)
	dx(i)=dx0
129	format(1x,4a1,f)
	end do     
	iopt=0

c this sets up things so when matrix is called, it does the right thing

        norder=2        ! second order computation
	mprint=-1       ! no printing
c	kod=500         ! correct part of MATRIX is called

	
c        call zxssq(func,m,n,nsig,eps,delta,maxfn,iopt,parm,d1,ssq,f,
c     1			xjac,ixjac,xjtj,work,infer,ier)


	iprnt=10
	init=.true.
	nloop=0
	do i=1,n
	df=rent*(1.-2*ran(iran))
	d1(i)=d1(i)+df
	end do
        if(loops.eq.0)goto 17
	call calcf(n,d1,f0)
	call ooom
100	 call minop(n,d1,f0,grad,confid,epsminop,maxfun,iprnt,init)
	init=.false.
	nloop=nloop+1
c output stuff here
c i haven't checked weight.ne.zero later on
c so, if a weight is input as zero it'll cause a divide by zero error

 17     intprto=intprt
	intprt=-5
	call calcf(n,d1,f0)
        intprt=intprto
        if(loops.eq.0)goto 11
        write(6,10500)
        write(13,10500)
	write(iout,10500)
10500   format(x,'pole strengths are to be:')
          
      	do i=1,n
	        write(6,11000)(name(d3(i),in),in=1,4),	          
     1			eldat(iadr(d3(i))+ 1)         
	        write(13,11000)(name(d3(i),in),in=1,4),	          
     1			eldat(iadr(d3(i))+ 1)         
		 write(iout,11000)(name(d3(i),in),in=1,4),	          
     1			eldat(iadr(d3(i))+ 1)         
11000	format(x,4a1,x,'2',1x,g12.6)                                
	enddo
11001   format (x,'Finally, the functions are:',g12.6)
11002   format (x,'Horizontal dbeta*/ddelta :',g12.6)
11003   format (x,'Vertical dbeta*/ddelta :',g12.6)
11004   format (x,'Horizontal chromaticity :',g12.6)
11005	format (x,'Vertical chromaticity :',g12.6)
11006	format (x,'Horizontal deta*/ddelta :',g12.6)
                                         
c	write(6,11001)
c 	write(6,11002)f(1)/sqrt(weight(1))
c	write(6,11003)f(2)/sqrt(weight(2))
c	write(6,11004)f(3)/sqrt(weight(3))
c	write(6,11005)f(4)/sqrt(weight(4))
c	write(6,11006)f(5)/sqrt(weight(5))

c	write(13,11001)
c 	write(13,11002)f(1)/sqrt(weight(1))
c	write(13,11003)f(2)/sqrt(weight(2))
c	write(13,11004)f(3)/sqrt(weight(3))
c	write(13,11005)f(4)/sqrt(weight(4))
c	write(13,11006)f(5)/sqrt(weight(5))

c	write(iout,11001)
c 	write(iout,11002)f(1)/sqrt(weight(1))
c	write(iout,11003)f(2)/sqrt(weight(2))
c	write(iout,11004)f(3)/sqrt(weight(3))
c	write(iout,11005)f(4)/sqrt(weight(4))
c	write(iout,11006)f(5)/sqrt(weight(5))
                                         
	kdummy=5
10	if (ifuncnumber.gt.kdummy)then
	  kdummy=kdummy+1                                
c	  write(6,12000)(f(kdummy)/sqrt(weight(kdummy))) 
c	  write(13,12000)(f(kdummy)/sqrt(weight(kdummy))) 
c	  write(iout,12000)(f(kdummy)/sqrt(weight(kdummy))) 
12000	  format(x,'the  function value is',g12.6)
          goto 10
	endif

11 	continue      
	call ooom                        
	if(nloop.lt.loops)goto 100 
 	return
	end

	subroutine ooom
  	implicit DOUBLE PRECISION(a-h,o-z), integer (i-n)
	common /middle/emit(2),interm,intprt,iemitt,idec,nesave(2000)
	real f(100),weight(100),goal(100)
	common /out/sq,val(100)
	common/weights/weight,goal,f
	common /ooout/params
	character* 15 params(100)
	dimension nonzero(100)
	integer idindex,qs(2,4),d2(350),d3(350),igr,d4(2500)
	real*4 dx(350)
	common/sext/idindex,qs,d2,d3,dx,igr,d4
	common/numfunc/ifuncnumber
	common /twoeng/htune(4),vtune(4),hbeta(4),vbeta(4)
     &	  ,ener(4),xdisp(4),htune0,vtune0,hbeta0,vbeta0,weightsext
     &	  ,halpha0,valpha0,ydisp(4)
	common /radiation/epsxiq(2),curlydx(2),dzplus(2),dxplus(2),epsxplus(2),
     &	  compac(2),sigeplus(2)			 
	common /dif/ etah(5),hxhi(5),vxhi(5)
	data ncount/0/

	ncount=ncount+1
30001   format(3x,8(1x,f8.4))	
30002   format(3x,8(1x,f8.4))
30003   format(3x,8(1x,a8))	
30004   format(3x,8(1x,e12.6))
c  collect all parameters with weight ge 0
		j=0
		do 30 i=1,ifuncnumber
		  if(weight(i).le.0.)goto 30
		  j=j+1
		  nonzero(j)=i
c		  f(i)=val(i)*sqrt(weight(i))
30		continue
		jtot=j
		write(6,*)'ncount   ssq ',ncount,sq
		write(13,*)'ncount   ssq ',ncount,sq
	iwr=6
	nlines=jtot/8
10	do j=1,nlines
		write(iwr,30001)(f(nonzero(i)),i=(j-1)*8+1,(j-1)*8+8)
		write(iwr,30003)(params(nonzero(i)),i=(j-1)*8+1,(j-1)*8+8)
		write(iwr,30002)(val(nonzero(i)),i=(j-1)*8+1,(j-1)*8+8)
		write(iwr,*)' '
	end do
		write(iwr,30001)(f(nonzero(i)),i=8*nlines+1,jtot)
		write(iwr,30003)(params(nonzero(i)),i=8*nlines+1,jtot)
		write(iwr,30002)(val(nonzero(i)),i=8*nlines+1,jtot)
		write(iwr,*)' '
	if(iwr.eq.13)goto 20
	iwr=13
	goto 10
20	write(6,6906)htune0,vtune0,hbeta0,vbeta0
	write(6,6900)htune
	write(6,6901)vtune
	write(6,6902)hbeta
	write(6,6903)vbeta	
	write(6,6904)ener	
	write(6,6905)xdisp
	write(6,6907)(hxhi(i),i=1,4)
	write(6,6909)(vxhi(i),i=1,4)
	write(6,6908)(etah(i),i=1,4)
	write(6,6910)weightsext
	write(6,6911)epsxiq,curlydx
	write(6,6913)dxplus
6913	format(1x,' dxplus',2(1x,g12.6))
	write(6,6912)epsxplus,compac			 
6911	format(1x,' epsx ',2(1x,g12.6),' curlydx ',2(1x,g12.6))
6912	format(1x,' epsxplus ',2(1x,g12.6),' compac ',2(1x,g12.6))
	write(13,6906)htune0,vtune0,hbeta0,vbeta0
	write(13,6900)htune
	write(13,6901)vtune
	write(13,6902)hbeta
	write(13,6903)vbeta	
	write(13,6904)ener	
	write(13,6905)xdisp
	write(13,6907)(hxhi(i),i=1,4)
	write(13,6909)(vxhi(i),i=1,4)
	write(13,6908)(etah(i),i=1,4)
	write(13,6910)weightsext
	write(13,6911)epsxiq,curlydx
	write(13,6913)dxplus
	write(13,6912)epsxplus,compac			 
6900	format(' htune ',4(1x,g12.6))	
6901	format(' vtune ',4(1x,g12.6))	
6902	format(' hbeta ',4(1x,g12.6))	
6903	format(' vbeta ',4(1x,g12.6))	
6904	format(' ener  ',4(1x,g12.6))	
6905	format(' xdisp ',4(1x,g12.6))	
6906	format(' on energy parameters ',4(1x,g12.6))
6907	format(' horiz chrom ',4(1x,g12.6))
6909	format(' vert  chrom ',4(1x,g12.6))
6908    format(' eta ',4(1x,g12.6))
6910	format(' weighted quadratic sum of sextupoles ',g12.6)
	return
	end
c*******************************************************************************
 	subroutine calcf(n,d1,f0)

c common blocks from matrix

        implicit DOUBLE PRECISION(a-h,o-z), integer (i-n)
      	common amat(350,6,27),norlst(2500),
     1	xpel(350),ypel(350),
     1	expel,n1,logpar(350)
      	common/inout/iin,iout,isout,iso
      	common /inputt/ kode(350),name(350,4),iadr(350),eldat(5000)
     1	,madr(350),kcount,na
	common /mat1/temp1(6,27),iflag1,nelstrt,nelend
      	common/mat/temp(6,27),norder,mprint,imat,nmat,ifite,nelm,nop,
     1	nlist(40)
	common /gplot/igplot,idev,ndispl
      	common/prodct/kodepr,nel,nof
      	common/const/pi,twopi,crdeg,cmagen,clight,emass,erad,echg
      	common/fout/outfl(300)
c      	common/func/betax,alphax,etax,etapx,betay,alphay,etay,etapy,
c     1  starte,ende,deltae,dnu,mfprnt,kod,nlum,nint,nbunch
      	common/twf/betaox,alphox,etaox,etapox,anux,
     1            betaoy,alphoy,etaoy,etapoy,anuy,ie
      	common/length/tleng,aleng(350),acleng(2500)
      	common/lum/ uo,taux,alphx,alphy,tauy,
     1  alphe,taue,sige,sigx,epsx,
     1	sigy,epsy,sigxt,sigyt,energy,taurev
      	common/cbeam/bsig(6,6),bsigf(6,6),mbprt,nform
	common /bmax/bvarc,bharc,bvir,bhir,ir1,ir2,ir3,ir4
 	common /twiher/npnt,jfite(10),ipnt
	common/minia/detaddelta,betas(2000,2),
     1               ibeta_adr(2000),initbeta_count,miniinvoke
C        common/minia/miniinvoke,detaddelta,betas(2000,2),
C     1	ibeta_adr(2000),initbeta_count,tally6norm

c common blocks from anal

	common /etaspot/etas(5,4),closed(10),xprime(10),nnux(10),nnuy(10),
     &	  nnuxs(10),nnuys(10),aanux(10),aanuy(10)
	common/path/pathlength(18)
        common /maxarc/iexmax,ieymax,ieetamax
        character*3 cie
	common /minitwo/bxarcmax(2),byarcmax(2),etaarcmax(2),
     &    bxirmax(2),
     &	  byirmax(2)
     &	  ,etairmax(2),cavbetax(2),cavbetay(2),caveta(2,2),cavtune
     &	  ,aperarcmax(2),separation,nbunchs
        common/analc/compf,rnu0x,cetax,cetapx,calphx,cbetax,
     1	rmu1x,chromx,alph1x,beta1x,
     1	rmu0y,rnu0y,cetay,cetapy,calphy,cbetay,
     1	rmu1y,chromy,alph1y,beta1y,rmu0x,
     1	cosx,alx1,alx2,vx1,vxp1,vx2,vxp2,
     1	cosy,aly1,aly2,vy1,vyp1,vy2,vyp2,nstabx,nstaby,nstab,nwrncp

c imsl-routine stuff and  some indices for loops

	integer n,icount,jcount,mcount,ncount,nprint

c imsl-routine stuff and a temporary counter for the funny weight
c  function and other variables to make the code look nicer.

	real f(100),weight(100),goal(100),tally6,bx,by,s
	real*4 d1(n),f0
	common /out/sq,val(100)
	common /twoeng/htune(4),vtune(4),hbeta(4),vbeta(4)
     &	  ,ener(4),xdisp(4),htune0,vtune0,hbeta0,vbeta0,weightsext
     &	  ,halpha0,valpha0,ydisp(4)

	common /detx/detx(5,15),dety(5,15),sc(5,15),dethv(5,15),detintmax
      COMMON/TRI/WCO(15,6),GEN(5,4),PGEN(75,6),DIST,
     <A1(15),B1(15),A2(15),B2(15),XCOR(3,15),XPCOR(3,15),
     1AL1(15),AL2(15),MESH,NIT,NENER,NITX,NITS,NITM1,NANAL,NOPRT
	common/weights/weight,goal,f
	common /hi/h(350)
	integer idindex,qs(2,4),d2(350),d3(350),igr,d4(2500)
	real*4 dx(350)
	common/sext/idindex,qs,d2,d3,dx,igr,d4
	common /dif/ etah(5),hxhi(5),vxhi(5)
	common/numfunc/ifuncnumber
	common /alph/ab,halpha(15),valpha(15),detyspot(15),detyspotmax,
     &         detxspotmax,scspotmax
	common /jtwiss/stwiss(10,4,100),itwiss(100),ntwiss(2500),
     1                 lname(100),ltwiss
        logical ltwiss(2000)
	common /radiation/epsxiq(2),curlydx(2),dzplus(2),dxplus(2),epsxplus(2),
     &	  compac(2),sigeplus(2)			 
	common /separators/vse(6),kse(6),kseparator      
	logical sflag
	parameter (Ns=150)
	real*4 betass(2,Ns,4),phi(2,Ns,4),ss(Ns)
	common /ooout/params
	character* 15 params(100)
        dimension ibig(8)
	common /lie/sflag,nsex,betass,phi,ss
	data ncount/0/,nprint/1/
        data ifirst/0/

c the imsl routine  changes the array d1.however, the functions are to be
c evaluated using dimat subroutines, which use eldat.
c so, eldat is updated using d1, which  zxssq may /will/should!
c have changed; then we make new matrices for the elements which
c changed ie. the sextupoles.
c i've tested this  on other functions  and the imsl routine
c works ok

	ncount=ncount+1

        do icount=1,idindex
	       	eldat(d2(icount))=d1(icount)/h(icount)
	enddo

	do mcount=1,idindex
		call matgen(d3(mcount))
        enddo

c matrix is fixed so that when mini  is invoked
c it won't print out stuff.all it does is recompute
c the full turn transfer matrix, using promat and the updated amat
c from the call to matgen
c then anal extracts from the full turn matrix
c the functions we're interested in
c we may simply assign values to our f(i)'s now
c because of the way common blocks  have been setup
c however any  other functions are computed,
c if the common blocks are set up right
c there isn't a problem
                                                       
c	call matrix

	call trakfit(iv)
	sflag= igr .ne. 1
	call betamatch(n,d1,bxsquare,bysquare) 
c involve weights here
	if(ifirst.eq.0)then
	  xhih=0.
	  xhiv=0.
	  xhih=goal(10)
	  xhiv=goal(12)
	  ifirst=1
	endif
	if(nener.ge.4)then
	  ioff=1
	else
	  dnuh=0.5*xhih*(ener(2)-ener(1))
	  dnuv=0.5*xhiv*(ener(2)-ener(1))
	  ioff=0
	endif
	val(1)=hbeta(2+ioff)
	if(goal(1).gt.0.0)hbeta0=goal(1)
	f(1)=(sqrt(weight(1)))*(hbeta(2+ioff)-hbeta0)
     &	  /(hbeta0)
	val(2)=hbeta(1+ioff)
	f(2)=(sqrt(weight(2)))*(hbeta(1+ioff)-hbeta0)
     &	  /(hbeta0)
	if(goal(3).gt.0.0)vbeta0=goal(3)
	val(3)=vbeta(2+ioff)
	f(3)=(sqrt(weight(3)))*(vbeta(2+ioff)-vbeta0)
     &	  /(vbeta0)
	val(4)=vbeta(1+ioff)
	f(4)=(sqrt(weight(4)))*(vbeta(1+ioff)-vbeta0)
     &	  /(vbeta0)
	if(ioff.eq.1)then
	  val(18)=hbeta(4)
	  f(18)=(sqrt(weight(18)))*(hbeta(4)-hbeta0)
     &	    /(hbeta0)
	  val(19)=hbeta(1)
	  f(19)=(sqrt(weight(19)))*(hbeta(1)-hbeta0)
     &	    /(hbeta0)
	  val(20)=vbeta(4)              
	  f(20)=(sqrt(weight(20)))*(vbeta(4)-vbeta0)
     &	    /(vbeta0)
	  val(21)=vbeta(1)
	  f(21)=(sqrt(weight(21)))*(vbeta(1)-vbeta0)
     &	    /(vbeta0)
	endif
	if(goal(5).gt.0.)htune0=goal(5)
	val(5)=htune(2+ioff)
	  dnuh=xhih*ener(2+ioff)
	f(5)=(sqrt(weight(5)))*(htune(2+ioff)-dnuh-htune0)
     &	  /(dnuh+htune0)
	  dnuh=xhih*ener(1+ioff)
	val(6)=htune(1+ioff)
	f(6)=(sqrt(weight(6)))*(htune(1+ioff)-dnuh-htune0)
     &	  /(dnuh+htune0)
	if(goal(7).gt.0.)vtune0=goal(7)
	val(7)=vtune(2+ioff)
	  dnuv=xhiv*ener(2+ioff)
	f(7)=(sqrt(weight(7)))*(vtune(2+ioff)-dnuv-vtune0) 
     &	  /(dnuv+vtune0)
	  dnuv=xhiv*ener(1+ioff)
	val(8)=vtune(1+ioff) 
	f(8)=(sqrt(weight(8)))*(vtune(1+ioff)-dnuv-vtune0) 
     &	  /(dnuv+vtune0) 
	do l=1,nener/2
	  hxhi(l)=(htune(2*l)-htune(2*l-1))/(ener(2*l)-ener(2*l-1))
	  vxhi(l)=(vtune(2*l)-vtune(2*l-1))/(ener(2*l)-ener(2*l-1))
	  etah(l)=(xdisp(2*l)-xdisp(2*l-1))/(ener(2*l)-ener(2*l-1))
	end do
	val(10)=hxhi(1)
	f(10)=(sqrt(weight(10)))*(hxhi(1)-xhih)
	val(11)=hxhi(2)
	f(11)=(sqrt(weight(11)))*(hxhi(2)-xhih)
	val(12)=vxhi(1)
	f(12)=(sqrt(weight(12)))*(vxhi(1)-xhiv)
	val(13)=vxhi(2)
	f(13)=(sqrt(weight(13)))*(vxhi(2)-xhiv)
c	f(10)=(sqrt(weight(10)))*(1.-hxhih)
c	f(11)=(sqrt(weight(11)))*(1.-hxhil)
c	f(12)=(sqrt(weight(12)))*(1.-vxhih)
c	f(13)=(sqrt(weight(13)))*(1.-vxhil)
	val(9)=etah(1)
	f(9)=(sqrt(weight(9)))*(etah(1))
	val(14)=etah(2)
 	f(14)=(sqrt(weight(14)))*(etah(2))
	val(15)=0.
	val(16)=0.
	do i=1,nener
	  val(15)=val(15)+valpha(i)**2
	  val(16)=val(16)+halpha(i)**2
	end do
	val(15)=sqrt(val(15)/float(nener))
	val(16)=sqrt(val(16)/float(nener))
	f(15)=sqrt(weight(15))*(val(15)-goal(15))
	f(16)=sqrt(weight(16))*(val(16)-goal(16))

c f(6) the funny weight function s**2 * beta something or other

	if(1.gt.2)then
	  tally6=0

	  do jcount=1,initbeta_count

	    bx= betas(jcount,1)
	    by= betas(jcount,2)
	    s= eldat(ibeta_adr(jcount))

		if (bx.gt.by) then
		   tally6=tally6+((bx**3)*by*(s**2))**2
		else
		   tally6=tally6+((by**3)*bx*(s**2))**2
		endif

c	    tally6=tally6+(((bx*by)**3)*(s**2))**2

	  enddo
	  weightsext=tally6/tally6norm
	  val(15)=tally6/tally6norm
	  f(15)=(sqrt(weight(15)))*tally6/tally6norm
	endif
c
c
ccccc find even(odd) number sextupole that has largest amplitude 
ccccc and negative(positive) sign. The sum of their squares is f(16).
	shark=goal(17)    !1 times two family 
	smax=0.0
        do icount=1,idindex
	  idummy=d3(icount)
	  if(name(idummy,1).eq.'S')then
	     se=d1(icount)
	     if(abs(se).gt.smax)smax=abs(se)
	  endif
	enddo
	val(17)=smax
	f(17)=0.0
	if(smax.gt.shark)f(17)=sqrt(weight(17))*(smax-shark)**2
c
c  beta arc 
	betamax=bxarcmax(1)
	if(bxarcmax(2).gt.betamax)betamax=bxarcmax(2)
	val(22)=betamax
	f(22)=sqrt(weight(22))*(betamax-goal(22))
	if(f(22).lt.0.)f(22)=0.0
	betamax=byarcmax(1)
	if(byarcmax(2).gt.betamax)betamax=byarcmax(2)
	val(23)=betamax
	f(23)=sqrt(weight(23))*(betamax-goal(23))
	if(f(23).lt.0.)f(23)=0.0
c  emittance
	val(24)=epsxiq(1)*1.e6
	f(24)=sqrt(weight(24))*(epsxiq(1)*1.e6-goal(24))
	val(25)=epsxplus(1)*1.e6
	f(25)=sqrt(weight(25))*(epsxplus(1)*1.e6-goal(25))
	val(26)=(epsxplus(1)-epsxplus(2))*1.e6
	f(26)=sqrt(weight(26))*(val(26)-goal(26))
	val(27)=dxplus(1)-dxplus(2)
	f(27)=sqrt(weight(27))*(val(27)-goal(27))
	val(28)=compac(1)-compac(2)
	f(28)=sqrt(weight(28))*(val(28)-goal(28))
c  aperture arc
	apemax=aperarcmax(1)
	if(aperarcmax(2).gt.apemax)apemax=aperarcmax(2)
	val(29)=apemax
	f(29)=sqrt(weight(29))*(apemax-goal(29))
	if(f(29).lt.0.)f(29)=0.
c separation arcs
	val(30)=separation
	f(30)=sqrt(weight(30))*(goal(30)-separation)
	if(f(30).lt.0.)f(30)=0.
c disp at IP
	xd=0.
	yd=0.
	do j=1,nener
	  xd=xdisp(j)**2+xd
	  yd=ydisp(j)**2+yd
	end do
	val(31)=yd
	f(31)=sqrt(weight(31)*yd)
	val(32)=xd
	f(32)=sqrt(weight(32)*xd)
c max eta arc
	val(33)=etaarcmax(1)
	if(etaarcmax(2).gt.etaarcmax(1))val(33)=etaarcmax(2)
	f(33)=sqrt(weight(33))*(val(33)-goal(33))
	if(f(33).lt.0.)f(33)=0.
	dfx=0.d0
	dfy=0.d0
	dfhv=0.d0
	scs=0.d0
	do j=1,nener
	do i=1,nit
	  dfx=(1.d0-abs(detx(i,j)))**2+dfx
	  dfy=(1.d0-abs(dety(i,j)))**2+dfy
	  dfhv=(1.d0-abs(dethv(i,j)))**2+dfhv
	  scs=sc(i,j)+scs
	end do
	end do
	val(34)=dfx
	f(34)=sqrt(weight(34))*(dfx+dfy)
	val(35)=dfhv
	f(35)=sqrt(weight(35))*dfhv
	val(36)=scs
	f(36)=sqrt(weight(36))*scs
	if(nbunchs.gt.1)then
	vsemax=0.0
	do j=1,kseparator
	v=eldat(iadr(kse(j))+1)
	if(abs(v).gt.vsemax)vsemax=abs(v)
	end do
	val(37)=vsemax
	f(37)=sqrt(weight(37))*(val(37)-goal(37))
	endif
	q1=0.5*(pathlength(1)+pathlength(2))
	q2=0.5*(pathlength(3)+pathlength(4))
	val(38)=q1-q2
	f(38)=sqrt(weight(38))*val(38)
	val(39)=detyspotmax
	f(39)=sqrt(weight(39))*(1.0-detyspotmax)
	val(40)=detxspotmax
	f(40)=sqrt(weight(40))*(1.0-detxspotmax)
	val(41)=scspotmax
	f(41)=sqrt(weight(41))*scspotmax
	do l=42,ifuncnumber
	  val(l)=0.0
	  do i=1,nener
	    val(l)=val(l)+stwiss(itwiss(l),i,l)
	  end do
	  val(l)=val(l)/float(nener)
	  f(l)=sqrt(weight(l))*(val(l)-goal(l))
	end do

c put in any functions you want in here

c	f(9)=
c	f(10)=
	sq=0.0
	do i=1,ifuncnumber
c	  val(i)=f(i)/sqrt(weight(i))
	  sq=sq+f(i)**2
	end do
	sq=sqrt(sq)
	f0=sq
	if(igr.ne.1)then    !set igr=1 in calcg
	   if ((ncount/nprint)*nprint.eq.ncount) then
	     write(6,*)'ncount   ssq ',ncount,sq
             encode(3,2001,cie)iexmax
 2001        format(i3)
             params(22)=params(22)(1:5)//cie
             encode(3,2001,cie)ieymax
             params(23)=params(23)(1:5)//cie
             encode(3,2001,cie)ieetamax
             params(33)=params(33)(1:5)//cie
             do ii=1,8
                fbig=0.
                ibig(ii)=0
             do i=1,ifuncnumber
                do jj=1,ii
                   if(i.eq.ibig(jj))goto 40000
                   enddo
                   if(abs(f(i)).gt.fbig)then
                   fbig=abs(f(i))
                   ibig(ii)=i
                   endif
40000              continue
                   enddo
                   enddo
30001   format(3x,8(1x,f8.4))	
30002   format(3x,8(1x,f8.4))
30003   format(3x,8(1x,a8))	
		write(6,30001)(f(ibig(i)),i=1,8)
		write(6,30003)(params(ibig(i)),i=1,8)
		write(6,30002)(val(ibig(i)),i=1,8)
	   endif
	endif

	return
	end 

                               
 	subroutine calcg(n,d1,grad)

        implicit DOUBLE PRECISION(a-h,o-z), integer (i-n)
	integer idindex,qs(2,4),d2(350),d3(350),igr,d4(2500)
	real*4 dx(350)
	common/sext/idindex,qs,d2,d3,dx,igr,d4
	integer n,ncount,nprint
      	common /inputt/ kode(350),name(350,4),iadr(350),eldat(5000)
     1	,madr(350),kcount,na
	REAL*4 GRAD(N),D1(N),F0,FP
	data ncount/0/,nprint/1/
	DATA WAY/1./


calcg numerical computes the derivative of the function with respect
c  to each of the idindex variables
	igr=1
	ncount=ncount+1
	TYPE *,' START GRAD CALC ',NCOUNT
	CALL CALCF(N,D1,F0)
        do i=1,idindex
	dx0=dx(i)
	XX=D1(I)
	D1(I)=XX+WAY*dx0
	CALL CALCF(N,D1,FP)
	D1(I)=XX
	GRAD(I)=WAY*(FP-F0)/dx0
	END DO
	TYPE *,'  END GRAD CALC ',NCOUNT
	igr=0
	RETURN
	END
        SUBROUTINE MINOP(n,X,F,G,STEP,ACC,MAXFUN,idisp,INIT)
C RECORD OF LARGEST AND NEXT LARGEST CONTRIB TO F
	integer n,qz
	parameter (qz=250)
        logical init
        real*4 X(N), G(N),XA(QZ), GA(QZ),H(QZ,QZ), GG(QZ,QZ)
        DIMENSION V(QZ),U(QZ), WA(QZ), WB(QZ), WC(QZ), WT(QZ),WS(QZ)
        DIMENSION Y(QZ), Z(QZ), GZ(QZ), GV(QZ), PZ(QZ) 
C     ******************************************************************
C     * INITIATLIZE THE FOLLOWING PARAMETERS                           *
C     * NFCALL & NGCALL = NO. OF FUNCTION & GRADIENT CALLS RESP..      *
C     ******************************************************************
	NFCALL = 1
	FPREV=0    !RECORD LAST F
	NGCALL = 1
	IUPD = 1
	EPSSQ = ACC * ACC 
	IPTEST = 1
	DSS = STEP*STEP 
c	CALL MATUP(X)    !UPDATE MATRICES
	CALL CALCF (N,X,F)
	CALL CALCG (N,X,G)
	IF(.NOT.INIT) GO TO 8 !SAVE HESSIAN IF NOT FIRST RUN
	GSQ = 0 
	DO 3 I = 1,N
   3    GSQ = GSQ + G(I) * G(I) 
C 
C     ******************************************************************
C     * PREPARE FOR THE FIRST ITERATION BY INITIALIZING MATRICES H&GG  *
C     ******************************************************************
C 
	C = -SQRT( DSS / GSQ ) 
	GGDIAG = 0.01 * SQRT( GSQ) / STEP
	HDIAG = 1. / GGDIAG 
	DO 6 I= 1,N 
	DO 5 J = 1,N
	H(I,J) = 0.0D0
	GG(I,J) = 0.0D0 
    5   CONTINUE
	H(I,I) = HDIAG
	GG(I,I) = GGDIAG
    6   Z(I) = C * G(I) 
C 
    8   GSQ = 0 
	DO 9 I = 1, N 
    9   GSQ = GSQ + G(I) * G(I) 
	IF(F.GT..00002.AND.1.05*F.LT.FPREV) GO TO 18   !GO ON
C 5%MINIMUM IMPROVEMENT REQUIRED BELOW .6 *10**-4
	IF((GSQ.GT.EPSSQ).AND.(F.GT..00006)) GO TO 18
	RETURN		! RETURN ON GRADIENT, OR  FUNCTION VALUE
C     ******************************************************************
C     * TEST WHETHER MAXFUN CALLS OF CALCFG HAVE BEEN MADE             *
C     ******************************************************************
C 
   18   FPREV=F
	IF(NFCALL.EQ.1) CALL OOOm
	IF(NFCALL.GT.MAXFUN) RETURN !FUNC CALLS EXHAUSTED
C     ******************************************************************
C     * CALCUALTE NEWTON POINT                                         *
C     ******************************************************************
   26   WASQ = 0.0D0
	DO 28 I = 1,N 
	WA(I) = 0.0D0 
	DO 27 J= 1,N
   27   WA(I) = WA(I) - H(I,J) * G(J) 
   28   WASQ = WASQ + WA(I) * WA(I) 
	IF ( WASQ .LE. DSS) GO TO 39
	GGGG = 0
	HGGG = 0.0D0
	DO 30 I = 1, N
	WB(I) = 0.0D0 
	DO 29 J = 1,N 
   29   WB(I) = WB(I) + GG(I,J) * G(J)
	HGGG = HGGG - WA(I) * G(I)
   30   GGGG = GGGG + WB(I) * G(I)
	D = HGGG * GGGG 
	D = GSQ * GSQ / D 
	D = 0.2 + 0.8 * D 
	IF ( D * D * WASQ .GT. DSS ) GO TO 32 
	D = SQRT ( DSS / WASQ )
	DO 31 I = 1,N 
   31   WA(I) = D * WA(I) 
	GO TO 41
32	CONTINUE
C	IF ((GGGG *(GGGG * DSS)).GT. GSQ ** 3 ) GO TO 34 
	IF (((GGGG/GSQ) *(GGGG/GSQ) * DSS).GT. GSQ  ) GO TO 34 
C 
C     ******************************************************************
C     * THE CAUCHY POINT IS OUTSIDE CIRCLE, SO PICK THE POINT ON THE   *
C     * BOUNDARY                                                       *
C     ******************************************************************
	C = -SQRT ( DSS / GSQ) 
	DO 33 I = 1,N 
   33   WA(I) = C * G(I)
	GO TO 41
C 
C     ******************************************************************
C     * THE CAUCHY POINT IS INSIDE CIRCLE, USE DOG LEG STEP.           *
C     ******************************************************************
   34	continue
	DO 35 I = 1,N 
   35   WA(I) = D * WA(I) 
	CA = 0.0
	CB = 0
	C = -GSQ / GGGG 
C     ******************************************************************
C     * SET THE STEEPEST DESCENT CORRECTION IN WB AND THE DIFFERENCE   *
C     * BETWEEN WA AND WB IN WC.                                       *
C     ******************************************************************
	DO 36 I = 1, N
	WB(I) = C * G(I)
	WC(I)= WA(I) - WB(I)
	CA = CA + WB(I) * WC(I) 
   36   CB = CB + WC(I) * WC(I) 
C 
C     * FIND CORRECTION VECTOR AT THE INTERSECTION OF WA-WB AND CIRCLE *
	C = DSS -C * C * GSQ
	THETA = SIGN (C / (ABS(CA) + SQRT( CA * CA + C * CB)), CA) 
C     * TEST WHETHER TO USE THE GENERALIZED NEWTON STEP                *
	IF (THETA-1.) 37, 339, 339
   37   DO 38 I = 1, N
   38   WA(I) = WB(I) + THETA * WC(I) 
	GO TO 41
  339   CONTINUE
   39   CONTINUE
C 
   41   continue
        DO 42 I = 1,N 
   42   XA(I) = X(I) + WA(I)
	NFCALL = NFCALL + 1 
c	CALL MATUP(XA)    !MODIFY MATRICES
	CALL CALCF(N,XA,FA) 
   43   DSQ = 0.0D0 
	DO 44 I = 1,N 
   44   DSQ = DSQ + WA(I) * WA(I) 
C     ******************************************************************
C     * TEST IF FUNCTION VALUE IS DECREASED                            *
C     ******************************************************************
	IF((MOD(NFCALL,IDISP).EQ.1).AND.(FA.LT.F)) CALL OOOm
	IF (FA .LT. F-0.0000000001) GO TO 46 
	IF(F.LT..00006) RETURN  !MUST IMPROVE EACH ITER OR STOP
	DSS = 0.25 * DSQ
	GO TO 18
C     * CALCULATE SOME NUMBERS FOR REVISING STEP BOUND                 *
   46   NGCALL = NGCALL + 1 
c	CALL MATUP(XA)
	CALL CALCG(N,XA,GA) 
	DG = 0.0
	DGA = 0.0 
	DGGD = 0.0
	WBSQ = 0.0
	DO 47 I = 1, N
	WC(I) = 0.0D0 
	DO 47 J = 1,N 
   47   WC(I) = WC(I) + GG(I,J) * WA(J) 
C 
C     * SET  (Y-GS) IN WB                                              *
	DO 48 I = 1,N 
	U(I) = WC(I)
	WB(I) = GA(I) -G(I) - WC(I) 
	DG = DG + G(I) * WA(I)
	DGA = DGA + GA(I) * WA(I) 
	DGGD = DGGD + WC(I) * WA(I) 
   48   WBSQ = WBSQ + WB(I) *WB(I)
C     ******************************************************************
C     * TEST WHETHER TO DECREASE THE STEP-BOUND                        *
C     ******************************************************************
	IF (FA-F-0.1 * DG-0.05 * DGGD) 51, 51, 50 
   50   DSS = 0.25 * DSQ
	IF(DSS.GT.1E-15) GO TO 54    !GIVE UP, STEPS TOO SMALL
	TYPE 11112 
	RETURN
11112   FORMAT(' ESCAPED THE STEP SIZE TRAP....')
C     ******************************************************************
C     * TEST WHETHER TO INCREASE THE STEP-BOUND                        *
C     ******************************************************************
   51   DSS = DSQ 
	IF (WBSQ - 0.25 * GSQ) 53, 53, 52 
   52   IF (DG -DGA -DGA) 544, 53, 53
   53   DSS = 4.0 * DSQ 
C     * SET THE DIFFERENCE BETWEN GRADIENTS IN WC                      *
  544   continue
   54   continue
	DO 55 I = 1,N 
   55   WC(I) = GA(I) - G(I)
	F = FA
	B0 = 0.0
	DO 56 I = 1,N 
	X(I) = XA(I)
	G(I) = GA(I)
   56   B0 = B0 + WC(I) * WA(I) 
C     ******************************************************************
C     * TEST WHETHER WE NEED TO UPDATE H AND G                         *
C     ******************************************************************
	IF (B0 .GE. 1.0D-30)GO TO 58
C   WRITE(6,57)  NFCALL 
   57   FORMAT('FUNCTION DECREASED ON',I4,'TH ITERATION, NO UPDATE IS MADE
     1 ,SINCE Y*Z IS NEG. OR TOO SMALL')
	GO TO 8 
   58   IF (IUPD .EQ. 1) GO TO 63 
	IF (FLAG .EQ. 0.0) GO TO 60 
	DO  59 I = 1, N 
   59   Z(I) = WA(I)
	GO TO 63
   60   C2=0.0
	C3 = 0.0
	SUM = 0.0 
	DO 61 I = 1, N
	C2 = C2 + WS(I) * WA(I) 
	C3 = C3 + WT(I) * WA(I) 
   61   SUM = SUM +Y(I) * WA(I) 
	DO 62 I = 1, N
   62   Z(I) = C1 *(C2 * Z(I) + C3 * V(I)) - (SUM/ZWC) * Z(I) 
   63   IUPD = IUPD+1 
	DO 64 I = 1, N
	GV(I) = U(I) - WC(I)
	V(I) = WA(I)
	GZ(I) = 0.0 
	DO 64 J = 1, N
	GZ(I) = GZ(I) + GG(I,J) * Z(J)
   64   V(I) =V(I) - H(I,J) * WC(J) 
	ZGV = 0.0 
	VGV = 0.0 
	ZWC = 0.0 
	ZGZ = 0.0 
	VWC = 0.0 
	DO 65 I = 1, N
	ZWC = ZWC + Z(I) * WC(I)
	ZGZ = ZGZ + Z(I) * GZ(I)
	VWC = VWC + V(I) * WC(I)
	ZGV = ZGV + Z(I) * GV(I)
	VGV = VGV + V(I) * GV(I)
   65   CONTINUE
	C1 = 1. / (ZGZ * VGV - ZGV * ZGV) 
	C2 = ZWC * VGV - VWC * ZGV
	C3 = -ZWC * ZGV + VWC * ZGZ 
	VSQ =0.0
	ZV  =0.0
	A = 0.0 
	E = 0.0 
	DO 66 I = 1,N 
	Y(I) = C1 * (C2 * GZ(I) + C3 * GV(I)) 
	WS(I) = VGV * GZ(I) - ZGV * GV(I) 
	WT(I) = -ZGV * GZ(I) + ZGZ * GV(I)
	ZV  =  ZV + Z(I) * V(I) 
	VSQ = VSQ + V(I) * V(I) 
	A = A + WS(I) * WA(I) 
   66   E = E + WT(I) * WA(I) 
	B = 0.0 
	DO 67 I = 1,N 
	PZ(I) = C1 * ( A * Z(I) + E * V(I)) 
   67   B = B +PZ(I) * Y(I) 
	IF (B .GE. 1.0D-30) GO TO 70
	B = B0
C      WRITE (6,68)
   68   FORMAT(15X,'IMAGE PRODUCT NEG.OR TOO SMALL,ORIGINAL STEP USED') 
	DO 69 I = 1, N
	PZ(I) = WA(I) 
   69   GA(I) = WC(I) 
	GO TO 72
   70   continue
	DO 71 I = 1, N
   71   GA(I) = Y(I)
   72   CC = 0.0
	A  = 0.0
	DO 74 I = 1, N
	WB(I) = 0.0 
	GZ(I) = 0.0 
	DO  73 J = 1, N 
	GZ(I) = GZ(I) + GG(I,J) *PZ(J)
   73   WB(I) = WB(I) + H(I,J) * GA(J)
	A = A + GA(I) * WB(I) 
   74   CC = CC + PZ(I) * GZ(I) 
C     ******************************************************************
C     *  OPTIMAL CONDITIONING                                          *
C     ******************************************************************
	IF ( B .LE. 2.0D0 * A * CC / (A + CC)) GO TO 75 
	PHI = B / (B - A) 
	GO TO 76
   75   PHI = B * (CC - B)/(A * CC - B * B) 
   76   USQ = 0.0 
	UV  = 0.0 
C     ******************************************************************
C     * TEST WHETHER Z & V ARE LINEARLY INDEPENDENT                    *
C     ******************************************************************
	DO 77 I = 1, N
	U(I) = Z(I) - ( ZV / VSQ ) * V(I) 
	USQ = USQ + U(I) * U(I) 
   77   UV  = UV  + U(I) * V(I) 
	FLAG = 0.0
	IF (1.0D6 * UV * UV  .GE. VSQ * USQ ) FLAG =1.0 
C     ******************************************************************
C     *  IF FLAG = 1 THEN Z & V  ARE LINEARLY DEPENDENT                *
C     ******************************************************************
	SIGMA = 1.+ PHI * (A * CC/ (B * B) - 1.)
        IF ( SIGMA .LT. 1.0D-30) WRITE (6,78) 
   78   FORMAT(20X,' G IS ALMOST SINGULAR') 
	DO 79 I = 1, N
	WA(I) = (1./B) * PZ(I) - (1./A) * WB(I) 
	WC(I) = (1./B) * GZ(I) -CC/(B * B) * GA(I)
   79   U(I) = GA(I)- GZ(I) 
C     ******************************************************************
C     *  START TO UPDATE MATRICES H & GG                               *
C     ******************************************************************
	DO 80 I = 1, N
	DO 80 J = 1, N
	GG(I,J) = GG(I,J) + (1./B) * (U(I) * GA(J) + GA(I) * U(J))
     1         -(( B- CC ) / (B * B)) * GA(I) * GA(J) 
     1         -(PHI* A / SIGMA) * WC(I) * WC(J)
	H(I,J) = H(I,J) - (1./A) * WB(I) * WB(J) + (1./B) * PZ(I) * PZ(J) 
     1         + PHI * A * WA(I) * WA(J)
   80   CONTINUE
	GO TO 8 
	END 
C 
	subroutine trakfit(iv)
c  call  enanal to find closed orbit and transfer matrix 
c and fill common analc for fitting
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	common /rufunct/alpha(2),beta(2),gamma(2),cosmu(2),tune(2),W(2),phi
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
	common /tospt/tospot(2000,25,4),parsav(2000,25,6)
	common /trkfit/displace,xstart(5),en(15)
C	dimension bxsquare(10),bysquare(10)
	dimension lab(4)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500) 
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/TRI/WCO(15,6),GEN(5,4),PGEN(75,6),DIST,
     <A1(15),B1(15),A2(15),B2(15),XCOR(3,15),XPCOR(3,15),
     1AL1(15),AL2(15),MESH,NIT,NENER,NITX,NITS,NITM1,NANAL,NOPRT
      COMMON/CLSQ/ALSQ(15,2,4),IXY,NCOEF,NAPLT,JENER,LENER(15)
      COMMON /MVT/ U(5,4)
      COMMON/ANALC/p39(35),indum(4) 
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
c     COMPF,RNU0X,CETAX,CETAPX,CALPHX,CBETAX,
c     1RMU1X,CHROMX,ALPH1X,BETA1X,
c     1RMU0Y,RNU0Y,CETAY,CETAPY,CALPHY,CBETAY,
c     1RMU1Y,CHROMY,ALPH1Y,BETA1Y,RMU0X,
c     >COSX,ALX1,ALX2,VX1,VXP1,VX2,VXP2,
c     >COSY,ALY1,ALY2,VY1,VYP1,VY2,VYP2,NSTABX,NSTABY,NSTAB,NWRNCP
c
	common /twoeng/htune(4),vtune(4),hbeta(4),vbeta(4)
     &	  ,ener(4),xdisp(4),htune0,vtune0,hbeta0,vbeta0,weightsext
     &	  ,halpha0,valpha0,ydisp(4)
	dimension S(4,4)
	common /separators/vse(6),kse(6),kseparator
	common /minitwo/bxarcmax(2),byarcmax(2),etaarcmax(2),
     &    bxirmax(2),
     &	  byirmax(2)
     &	  ,etairmax(2),cavbetax(2),cavbetay(2),caveta(2,2),cavtune
     &	  ,aperarcmax(2),separation,nbunchs
	logical quad(2000),irquad(2000),bypass(2000),sept(2000),cross(2000),
     &	  bend(2000)
	logical ibefore(2000),iafter(2000)
	logical ltwiss(2000)
	dimension ncrosssav(2000)
	common /storeat/ quad,irquad,bypass,sept,cross,bend,
     &	  ibefore,iafter,ncrosssav
	common /jtwiss/stwiss(10,4,100),itwiss(100),ntwiss(2500),
     1                 lname(100),ltwiss
        integer ifuncnumber,n
	integer idindex,qs(2,4),d2(350),d3(350),igr,d4(2500)
	real*4 dx(350)
	common/sext/idindex,qs,d2,d3,dx,igr,d4
	common/numfunc/ifuncnumber
	data ifirstcall/0/
	data S/0.d0,-1.d0,2*0.d0,1.d0,6*0.d0,-1.d0,2*0.d0,1.d0,0.d0/
	data lab/'K','8','4','5'/
	nanal=1
	nitx=0
	dist=displace	
	if(ifirstcall.eq.0)then
c
c  identify different regions of transfer first time through
	nbeam=1
	if(nbunchs.gt.1)nbeam=2
	ncross=1            !ncross is the crossing point
	space=0.5*tleng/nbunchs  !space between bunch crossings
c  Cycle through elements
	Do 10 ie=1,nelm
	iee=ie
	ntwiss(ie)=0
	do l=1,ifuncnumber
	if(lname(l).eq.norlst(ie))then	
	ltwiss(ie)=.true.
	ntwiss(ie)=ntwiss(ie)+1
	endif
        end do
	quad(ie)=.false.
	bypass(ie)=.false.
	cross(ie)=.false.
	sept(ie)=.false.
	nel=norlst(ie)
	  ntemp3=name(norlst(ie),3)	  
	  ntemp2=name(norlst(ie),2)
	  ntemp4=name(norlst(ie),4)
	  ntemp1=name(norlst(ie),1)	  
	if(kode(nel).eq.2.and..not.ltwiss(ie))then 
	  quad(ie)=.true.              !element ie is a quad
c	  if((ntemp3.eq.'5'.or.ntemp4.eq.'1'.or.ntemp4.eq.'2'
c     &	    .or.ntemp4.eq.'3'.or.ntemp4.eq.'4')
c     &	    .and.(ntemp2.eq.'I'.or.ntemp2.eq.'O'))irquad(ie)=.true.	!ir quad
	endif                                                                 
	  if(ntemp2.eq.'R'.and.ntemp3.eq.'F'.and.ntemp4.eq.'C')then  !RF cavity
	    sept(ie)=.true.	!element is RF cavity
	    isept=ie                     !RF cavbity at element ie
	  endif
	if(kode(nel).eq.1)then    !element ie is a bend
	    bend(ie)=.true.
	   endif
c
	if(nbeam.gt.1.and.ncross*space.lt.acleng(ie))then
	  if(ncross*space-acleng(ie-1).lt.
     &	    acleng(ie)-ncross*space)then
	  ibefore(ie-1)=.true.
	  ncrosssav(ie-1)=ncross
	  else
	  iafter(ie)=.true.
	  ncrosssav(ie)=ncross
	  endif
	  ncross=ncross+1
	endif
c
10	continue
c  identify separators
	do i=1,na
	if(name(i,1).eq.'K')then
	  kseparator=kseparator+1
	  kse(kseparator)=i
	endif
	end do
c  set parameters for on energy numbers
	  nenersave=nener
	  nener=1
	  ensave=en(1)
	  en(1)=0.0
      DO 742  i=1,NENER
      DO 7208 J=1,5
 7208 WCO(I,J)=xstart(j)
  742 WCO(I,6)=en(i)        
      CALL ENANAL
      NANAL=1
c	  call betamatch(bxsquare,bysquare)
	  htune0=alsq(1,1,1)
	  vtune0=alsq(1,2,1)
	  hbeta0=alsq(1,1,2)
	  vbeta0=alsq(1,2,2)
c restore parameters for energy dependent calculations
	  nitx=0
	  dist=displace
	  nener=nenersave
	  en(1)=ensave
	  ifirstcall=1
	endif	  
      DO 42 i=1,NENER
      DO 208 J=1,5
  208 WCO(I,J)=xstart(j)
   42 WCO(I,6)=en(i)
      CALL ENANAL
      NANAL=1
c  assign to appropriate elements of analc for fitting
	do i=1,nener
	htune(i)=alsq(i,1,1)		!horizontal tune
	vtune(i)=alsq(i,2,1)		!vertical tune 
	hbeta(i)=alsq(i,1,2)		!horizontal beta
	vbeta(i)=alsq(i,2,2)		!vertical beta 
	ener(i)=wco(i,6)                !energy
	xdisp(i)=wco(i,1)               !position x
	ydisp(i)=wco(i,3)		! position y
	end do
	if(iv.eq.0)return

 400	continue
	type 1,htune
1	format(' htune(i)',4(1x,g10.4))
	type 2,vtune
2	format(' vtune(i)',4(1x,g10.4))
	type 3,hbeta
3	format(' hbeta(i)',4(1x,g10.4))
	type 4,vbeta
4	format(' vbeta(i)',4(1x,g10.4))
	type 5,xdisp
5	format(' xdisp(i)',4(1x,g10.4))
	return
	end

	subroutine betamatch(nd1,d1,bxsquare,bysquare)
	implicit DOUBLE PRECISION (a-h,o-z)
	integer nd1
	real*4 d1(nd1)
	common /middle/emit(2),interm,intprt,iemitt,idec,nesave(2000)
        common /maxarc/iexmax,ieymax,ieetamax
	common /minitwo/bxarcmax(2),byarcmax(2),etaarcmax(2),
     &    bxirmax(2),
     &	  byirmax(2)
     &	  ,etairmax(2),cavbetax(2),cavbetay(2),caveta(2,2),cavtune
     &	  ,aperarcmax(2),separation,nbunchs
	common /rufunct/alpha(2),beta(2),gamma(2),cosmu(2),tune(2),W(2),phi
	common /etaspot/etas(5,4),closed(10),xprime(10),nnux(10),nnuy(10),
     &	  nnuxs(10),nnuys(10),aanux(10),aanuy(10)
	common /alph/ab,halpha(15),valpha(15),detyspot(15),detyspotmax,
     &         detxspotmax,scspotmax
	common /orbsave/xsave(2000),ysave(2000)
	common /rotmat/R(4,4),Rinv(4,4)
	common /decetas/etauv(4)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA              OP
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,Nnn,LOGPAR(350)
      COMMON/DETL/DENER(15),NH,NV,NVH,NHVP(105),MDPRT,NDENER,
     1NUXS(45),NUX(45),NUYS(45),NUY(45),NCO,NHNVHV,MULPRT,NSIG
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO  
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/TRI/WCO(15,6),GEN(5,4),PGEN(75,6),DIST,
     <A1(15),B1(15),A2(15),B2(15),XCOR(3,15),XPCOR(3,15),
     1AL1(15),AL2(15),MESH,NIT,NENER,NITX,NITS,NITM1,NANAL,NOPRT
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
	common /radiation/epsxiq(2),curlydx(2),dzplus(2),dxplus(2),epsxplus(2),
     &	  compac(2),sigeplus(2)			 
	logical sflag
	parameter (ns=150)
	real*4 betas(2,ns,4),phis(2,ns,4),ss(ns)
	common /lie/sflag,nsex,betas,phis,ss
	dimension bxsquare(10),bysquare(10)
	dimension bxref(2000),byref(2000),betax(10),betay(10),
     &	  alxspot(10),alyspot(10)
	logical quad(2000),irquad(2000),bypass(2000),sept(2000),cross(2000),
     &	  bend(2000)
	logical ibefore(2000),iafter(2000)
	dimension ncrosssav(2000)
	common /storeat/ quad,irquad,bypass,sept,cross,bend,
     &	  ibefore,iafter,ncrosssav
	dimension aper(2),sep(2,50)
	dimension s(2)
	dimension betjazz(2,2000),etajazz(2,2000),disp(2,2000)
      COMMON/TWF/BETAOX,ALPHOX,ETAOX,ETAPOX,ANUX,
     >            BETAOY,ALPHOY,ETAOY,ETAPOY,ANUY,IEe
      COMMON/LUM/ UO,TAUX,ALPHX,ALPHY,TAUY,
     <  ALPHE,TAUE,SIGE,SIGX,EPSX,
     <SIGY,EPSY,SIGXT,SIGYT,ENERGY,TAUREV
c
	common /jtwiss/stwiss(10,4,100),itwiss(100),ntwiss(2500),
     1                 lname(100),ltwiss
	logical ltwiss(2000)
        integer ifuncnumber,n,nsig
	integer idindex,qs(2,4),d2(350),d3(350),igr,d4(2500)
	real*4 dx(350)
	common/sext/idindex,qs,d2,d3,dx,igr,d4
	common/numfunc/ifuncnumber
	data ifirst/0/
c
	if(ifirst.eq.1)goto 60  
	eps=0.15e-6	!emittance
	sige=6.4e-4	!energy spread
	ifirst=1
c
	nbeam=1
	if(nbunchs.gt.1)nbeam=2
	space=0.5*tleng/nbunchs
60	continue
	do i=1,2
        bxarcmaxx=0.
	bxarcmax(i)=0.
        byarcmaxx=0.
	byarcmax(i)=0.
	etaarcmax(i)=0
	bxirmax(i)=0
	byirmax(i)=0
	etairmax(i)=0
c	aperirmax((i)
	separation=999.
	aperarcmax(i)=0.
	end do
	mdo=0
        etaarcmaxx=0.
        narcquad=0
	do j=1,nener
	nnux(j)=0
	nnuxs(j)=0
	nnuy(j)=0
	nnuys(j)=0
	end do
	do iq=1,2
	call trmatrix(mdo,iq)
	end do
	nsex=0
        if(intprt.eq.-5)then
           write(14,1000)
 1000      format('# element betax(1) betax(2) betax(3) betax(4)' 
     &          ' betay(1)'
     &         ' betay(2) betay(3)'
     &         ' betay(4)   z ')
           write(15,1004)
 1004      format('# element eta(1)  etap(1)  eta(2)   etap(2)  '
     &          'disp(1)  disp(2)'
     &            '  z')
           write(16,1005)
 1005      format('# element crossing    sep(1)    sep(2)'
     &          'sep(2)-sep(1)    z')
           endif
	do 70 ie=1,nelm
	 iee=ie
	 if(quad(ie) .or. sept(ie) .or. bend(ie+1) .or. quad(ie+1)
     &	   .or. ltwiss(ie)
     &	   .or. ibefore(ie) .or. iafter(ie)) then
	   call transave(-ie,betax,betay,alxspot,alyspot) !Get beta at element
c
	   if (nener.lt.2) then
	     bxref(ie)=betax(1)
	     byref(ie)=betay(1)
	     return
c
	   endif
	   do j=1,nener/2	!treat each pair of energies
	     l=2*j-1
c
c
	     BETAOX=0.5*(betax(l)+betax(l+1))
	     ALPHOX=0.5*(alxspot(l)+alxspot(l+1))
	     ETAOX=etas(j,1)
	     ETAPOX=etas(j,2)
	     BETAOY=0.5*(betay(l)+betay(l+1))
	     ALPHOY=0.5*(alyspot(l)+alyspot(l+1))

c
	     if(nbunchs.gt.1)then
	     betjazz(j,ie)=betaox
	     etajazz(j,ie)=etaox
	     disp(j,ie)=0.5*(closed(l)+closed(l+1))
	     endif
c
	     if(irquad(ie))then
	       if(BETAOX.gt.bxirmax(j))bxirmax(j)=BETAOX       !max ir betax
	       if(BETAOY.gt.byirmax(j))byirmax(j)=BETAOY	!max ir betay
	       if(etas(j,1).gt.etairmax(j))etairmax(j)=etas(j,1) !max ir eta
c	       if(aper(jhl).gt.aperirmax(jhl))aperirmax(jhl)=aper(jhl) !max ir aperture
	     endif
c
c
	     if(quad(ie).and..not.irquad(ie))then
                if(j.eq.1)narcquad=narcquad+1
	      if(BETAOX.gt.bxarcmax(j))then
                bxarcmax(j)=BETAOX !max arc betax
                iexmax=ie
                endif
c              bxarcmax(j)=bxarcmax(j)+betaox**2
	      if(BETAOY.gt.byarcmax(j))then
                 byarcmax(j)=BETAOY !max arc betay
                 ieymax=ie
                 endif
c              byarcmax(j)=byarcmax(j)+betaoy**2
                 etaarcmax(j)=etaarcmax(j)+etas(j,1)**2
	      if(etas(j,1).gt.etaarcmaxx)then
                 etaarcmaxx=etas(j,1) !max arc eta
                 ieetamax=ie
                 endif
c	      if(aper(j).gt.aperarcmax(j))aperarcmax(j)=aper(j) !max arc aperture
	     endif
c
	     if(quad(ie))then
c  save parameters at sextupoles
	      if(sflag)then
	        nel=0
		if (kode(norlst(ie-1)).eq.3) nel=norlst(ie-1)
	        if (kode(norlst(ie+1)).eq.3) nel=norlst(ie+1)
	 	if (nel .ne. 0)then
		  if(j.eq.1)nsex=nsex+1
		  do l=0,1
		    ll=2*j-l
		    betas(1,nsex,ll)=betay(ll)
		    betas(2,nsex,ll)=betax(ll)
		    phis(1,nsex,ll)=aanuy(ll)*twopi
		    phis(2,nsex,ll)=aanux(ll)*twopi
		  end do
c  sext strength *length*2
		  ss(nsex)=eldat(iadr(nel)+1)*2*eldat(iadr(nel))  
		endif ! kode=3
	      endif ! sflag
	     endif ! non-IR quad
c  rf cavity
	     if(ltwiss(ie))then
	       do i=42,ifuncnumber
		 if(lname(i).eq.norlst(ie))then
		   if(itwiss(i).eq.5)stwiss(5,j,i)=etas(j,3)
		   if(itwiss(i).eq.6)stwiss(6,j,i)=etas(j,1)
		   if(itwiss(i).eq.7)stwiss(7,j,i)=etas(j,4)
		   if(itwiss(i).eq.8)stwiss(8,j,i)=etas(j,2)
		   do l=0,1
		     ll=2*j-l
		     if(itwiss(i).eq.1)stwiss(1,ll,i)=betay(ll)
		     if(itwiss(i).eq.2)stwiss(2,ll,i)=betax(ll)
		     if(itwiss(i).eq.3)stwiss(3,ll,i)=alyspot(ll)
		     if(itwiss(i).eq.4)stwiss(4,ll,i)=alxspot(ll)
		     if(itwiss(i).eq.9)stwiss(9,ll,i)=aanuy(2*j-l)
		     if(itwiss(i).eq.10)stwiss(10,ll,i)=aanux(2*j-l)
		   end do ! l
		 endif ! norlst
	       enddo ! i
	     endif ! ltwiss
c
c
c
	  if(ibefore(ie).or.iafter(ie))then
	  ieel=ie
	  if(ibefore(ie))ieel=ie+1
	  nel=norlst(ieel)
	  iad=iadr(nel)
	  quadk=0.
	  if(kode(nel).eq.2)quadk=eldat(iad+1)
	  zcross=-acleng(ie)+ncrosssav(ie)*space
	    bhc=betaox-2*alphox*zcross+
     &	      ((1.+alphox**2)/betaox-quadk*betaox)*zcross**2
	    alhc=alphox+(quadk*betaox-
     &	      (1.+alphox**2)/betaox)*zcross
	    etac=etas(j,1)+etas(j,2)*zcross
	    bvc=betaoy-2*alphoy*zcross+
     &	      ((1.+alphoy**2)/betaoy+quadk*betaoy)*zcross**2
	    alvc=alphoy+(quadk*betaoy-(1.+alphoy**2)/betaoy)*zcross
	    xx=0.5*(closed(2*j-1)+closed(2*j))
	    xxprime=0.5*(xprime(2*j-1)+xprime(2*j))
	    sep(j,ncrosssav(ie))=xx+xxprime*zcross
            s(j)=sep(j,ncrosssav(ie))*6.d0/sqrt(bhc)
	    if(j.eq.2.and.abs(s(2)-s(1)).lt.separation)separation=
     &	      abs(s(2)-s(1))
	endif	  
  	   end do ! j
c
c
c  emittance
	if((quad(ie+1).and.nbunchs.gt.1).or.bend(ie+1))then
	    do iq=1,nbeam  !positrons  electrons
	    ir=2*iq-2
	    if(nener.eq.4.and.nbeam.eq.1)ir=1
	    xsave(ie)=0.5*(closed(1+ir)+closed(2+ir))
	    BETAOX=0.5*(betax(1+ir)+betax(2+ir))
	    ALPHOX=0.5*(alxspot(1+ir)+alxspot(2+ir))
	    BETAOY=0.5*(betay(1+ir)+betay(2+ir))
	    ALPHOY=0.5*(alyspot(1+ir)+alyspot(2+ir))
	    if(nbeam.eq.1)then
	      etaox=0.5*(etas(1,1)+etas(2,1))
	      etapox=0.5*(etas(1,2)+etas(2,2))
	    endif
	    if(nbeam.gt.1)then
	    ETAOX=etas(iq,1)
	    ETAPOX=etas(iq,2)
	    endif
	  mdo=3
	  call trmatrix(mdo,iq)
	end do !positrons and electrons
	endif    ! next element quad or bend
  
c
	if(intprt.eq.-5)then
	n=norlst(ie)
c	write(13,1)ie,name(n,1),name(n,2),name(n,3),name(n,4)
c     &	  ,bxref(ie),(betax(i),i=1,nener),etas(1,1),etas(2,1)
        write(14,1001)ie,(betax(i),i=1,nener),(betay(i),i=1,nener),
     &       acleng(ie)
 1001     format(1x,i4,9f9.3)
c	write(13,2)ie,byref(ie),(betay(i),i=1,nener),
c     &       disp(1,ie),disp(2,ie)
c     &	  ,acleng(ie)
        write(15,1002)ie,etas(1,1),etas(1,2),etas(2,1),
     &         etas(2,2),disp(1,ie)
     &          ,disp(2,ie),acleng(ie)
 1002   format(1x,i4,7f9.3)
c	if(iafter(ie).or.ibefore(ie))write(13,3)ie,ncrosssav(ie),
c     &	  sep(1,ncrosssav(ie)),sep(2,ncrosssav(ie)),s(2)-s(1)
	if(iafter(ie).or.ibefore(ie))write(16,1003)ie,ncrosssav(ie),
     & 	     sep(1,ncrosssav(ie)),sep(2,ncrosssav(ie)),s(2)-s(1)
     &       ,acleng(ie)
 1003   format(1x,2i4,4f9.3)
1	format(1x,' x 'i4,1x,4a1,7f8.2)
2	format(1x,' y 'i4,5x,5f8.2,2(1x,f7.4),f7.2)                             
3	format(1x,' ie, cross, closed, sep ',2i4,3(1x,f10.4))
	endif
c
	endif
70	continue
c
        do j=1,nener/2
c              bxarcmax(j)=sqrt(bxarcmax(j)/narcquad)
c              byarcmax(j)=sqrt(byarcmax(j)/narcquad)
              etaarcmax(j)=sqrt(etaarcmax(j)/narcquad)
              end do
	mdo=4
	do iq=1,nbeam
	call trmatrix(mdo,iq)
	end do
c
	if(nbeam.gt.1)then
	do ie=1,nelm
	do iq=1,nbeam
	sigma=sqrt(epsxplus(iq)*betjazz(iq,ie)+(etajazz(iq,ie)*
     &	  sigeplus(iq))**2)
	aper(iq)=abs(disp(iq,ie))+8*sigma+0.005
	if(aper(iq).gt.aperarcmax(iq))aperarcmax(iq)=aper(iq)
	end do
	end do
	endif
c
	return
	end
                                                     
c     *******************
      SUBROUTINE transave(jspot,bxspot,byspot,alxspot,alyspot)
C     *******************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION L(5),M1(5)
      DOUBLE PRECISION M(5,5)
      DIMENSION A(25),B(16),V(5,4),Q(4,4)
c	dimension SAVEU(2000,25,4)	
	common /tospt/tospot(2000,25,4),parsav(2000,25,6)
	common /middle/emit(2),interm,intprt,iemitt,idec,nesave(2000)
	common /etaspot/etas(5,4),closed(10),xprime(10),nnux(10),nnuy(10),
     &	  nnuxs(10),nnuys(10),aanux(10),aanuy(10)
      	common/twf/betaox,alphox,etaox,etapox,anux,
     1            betaoy,alphoy,etaoy,etapoy,anuy,ie
	dimension closave(2000,10,4)
	dimension bxspot(10),byspot(10),alxspot(10),alyspot(10)
	dimension S(4,4),ufull(5,4),uspot(5,4)
	common /alph/ab,halpha(15),valpha(15),detyspot(15),detyspotmax,
     &         detxspotmax,scspotmax
      DIMENSION DAT(4,5)
      EQUIVALENCE (M(1,1),A(1)), (Q(1,1),B(1))
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN,
     <  NPTOT,MLOCAT,NTURN
      COMMON/TRI/WCO(15,6),GEN(5,4),PGEN(75,6),DIST,
     <A1(15),B1(15),A2(15),B2(15),XCOR(3,15),XPCOR(3,15),
     1AL1(15),AL2(15),MESH,NIT,NENER,NITX,NITS,NITM1,NANAL,NOPRT
      COMMON /MVT/ U(5,4)
      COMMON/CLSQ/ALSQ(15,2,4),IXY,NCOEF,NAPLT,JENER,LENER(15)
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      LOGICAL LOGPAR,LENER
	data S/0.d0,-1.d0,2*0.d0,1.d0,6*0.d0,-1.d0,2*0.d0,1.d0,0.d0/
      DATA DAT/ 1.0D0, 0.0D0, 1.0D0, 0.0D0, 0.309017D0, 0.951057D0,
     1 0.309017D0, 0.951057D0, -0.809017D0, 0.587785D0, -0.809016D0,
     2 -0.587785D0, -0.809017D0, -0.587785D0, 0.309017D0, -0.951056D0,
     3 0.309017D0, -0.951056D0, -0.809017D0, 0.587785D0/
	if(nitx.ne.0.and.nitx+1.ne.nit.and.jspot.gt.0)return
c	if(noptype(1).ne.'M'.or.noptype(2).ne.'O'.or.noptype(3).ne.'V'.
c     &	  or.noptype(4).ne.'E')return
c
c  jspot < 0 and do multiplication for that elements full turn transfer

	if(jspot.lt.0)goto 300
	ispot=iabs(jspot)
	itrend=ispot
c
       IF (NITS.LT.0.) GO TO 209
	if(intprt.ne.0)goto 209
      WRITE (IOUT,210)
  210 FORMAT ('-', 'INITIAL POSITIONS OF PARTICLES ', /)
      DO 211 I=1,NPART
  211 WRITE (IOUT,212) I, (PART(I,K),K=1,6)
  212 FORMAT(I4,6(E14.5))
  209 continue
      DO 216 IP=1,NENER
      DO 216 IL=1,5
      ILP=(IP-1)*5+IL
      IF(.NOT.LOGPAR(ILP))LENER(IP)=.FALSE.
  216 CONTINUE
      DO 218 IL=1,NENER
      IF(LENER(IL))GO TO 220
  218 CONTINUE
      WRITE(IOUT,48)
   48 FORMAT(' OPERATION STOPPED DUE TO LOSS OF PARTICLES ')
      STOP
  220 CONTINUE
c  to find transfer matrix to ispot
  260 DO 270 J=1,NENER
      IF(.NOT.LENER(J))GO TO 270
      IND5=J+J+J+J+J
      IND4=IND5-1
      IND3=IND4-1
      IND2=IND3-1
      IND1=IND2-1
      DO 271 I=1,4
      IND=I+1
      M(1,IND)=pgen(IND1,I)
      M(2,IND)=pgen(IND2,I)
      M(3,IND)=pgen(IND3,I)
      M(4,IND)=pgen(IND4,I)
      M(5,IND)=pgen(IND5,I)
      V(1,I)=PART(IND1,I)
      V(2,I)=PART(IND2,I)
      V(3,I)=PART(IND3,I)
      V(4,I)=PART(IND4,I)
  271 V(5,I)=PART(IND5,I)
c	parsav(ispot,j)=part(ind1,1)
      DO 275 I=1,5
  275 M(I,1)=1
      CALL DMINV(A,5,D,L,M1)
      DO 277 I=1,5
      DO 278 N=1,4
      U(I,N)=0.0D0
      DO 279 K=1,5
  279 U(I,N)=U(I,N)+M(I,K)*V(K,N)
  278 CONTINUE
  277 CONTINUE
	if(intprt.ne.0)goto 2831
  268 WRITE (IOUT,276) pgen(IND1,6),ispot
  276 FORMAT(//,10X,' THE ANALYSIS FOR ENERGY',E17.5,' TO ELEMENT ',i4)
      WRITE (IOUT,281)
  281 FORMAT('-', 'THE TRANSFER MATRIX IS ')
      DO 283 I=1,4
      WRITE (IOUT,282) (U(N,I),N=2,5)
  282 FORMAT ('-',4(E15.5))
  283 CONTINUE
 2831 CONTINUE
C TO FIND THE DETERMINANT.
	if(2.lt.1)then
      DET=((U(4,3)*U(5,4)-U(5,3)*U(4,4))*(U(2,1)*U(3,2)-U(2,2)*U(3,1)))
     1+ ((U(4,2)*U(5,4)-U(5,2)*U(4,4)) * (U(2,3)*U(3,1)-U(2,1)*U(3,3)))
     1+ ((U(4,2)*U(5,3)-U(5,2)*U(4,3)) * (U(2,1)*U(3,4)-U(2,4)*U(3,1)))
     1+ ((U(4,1)*U(5,4)-U(5,1)*U(4,4)) * (U(2,2)*U(3,3)-U(2,3)*U(3,2)))
     1+ ((U(4,1)*U(5,3)-U(5,1)*U(4,3)) * (U(2,4)*U(3,2)-U(2,2)*U(3,4)))
     1+ ((U(4,1)*U(5,2)-U(5,1)*U(4,2)) * (U(2,3)*U(3,4)-U(2,4)*U(3,3)))
      if(intprt.eq.0)WRITE(IOUT,284) DET
      IF((ABS(DET)-1.0D0).GT.0.5D0)then
	write(iout,284)det,ispot
c	STOP
      endif
	endif
c
	if(nitx.eq.0)then
c  det y at spot
	detxspot=u(2,1)*u(3,2)-u(3,1)*u(2,2)
	 detyspot(j)=u(4,3)*u(5,4)-u(5,3)*u(4,4)
	scspot=u(4,1)**2+u(5,1)**2+u(4,2)**2+u(5,2)**2+
     &	  u(2,3)**2+u(3,3)**2+u(2,4)**2+u(3,4)**2
	 if(abs(1.0-detyspot(j)).gt.abs(1.0-detyspotmax))
     &	  detyspotmax=detyspot(j)
	 if(abs(1.0-detxspot).gt.abs(1.0-detxspotmax))
     &	  detxspotmax=detxspot
         if(scspot.gt.scspotmax)scspotmax=scspot
	goto 270
	endif
c
  284 FORMAT ('-','THE DETERMINANT IS: ',E20.10,' at ',i)
  262 CONTINUE
C THE ROUTINE TO SAVE THE MATRIX U.
  265 DO 266 I=1,5
      IND=I+IND1-1
      DO 267 K=1,4
c     SAVEU(ISPOT,IND,K)=U(I,K)		!save transfer from start to ispot
  267 tospot(ispot,ind,k)=U(I,K)	!save transfer from start to ispot
  266 CONTINUE
 270	continue
	if(nitx.eq.0)return
c
c  save coordinates of on energy closed orbit
	do 102 n=1,nener
	do 102 k=1,4
102	closave(ispot,n,k)=part((n-1)*5+1,k)
c
	return
  300	continue			!come here to do multiplications
	ispot=iabs(jspot)
c
	do 312 n=1,nener
c  calculate vertical and horizontal eta
	if(2*(n/2).ne.n)goto 312
 	j=1+(n-2)*5
	delte=pgen(j+5,6)-pgen(j,6)
	if(delte.eq.0.d0)goto 100
	do 101 k=1,4
  101	etas(n/2,k)=(closave(ispot,n,k)-closave(ispot,n-1,k))/delte
 100	continue
	  xprime(n)=closave(ispot,n,2)
  312	  closed(n)=closave(ispot,n,1)    !x closed orbit
	if(intprt.lt.-1)goto 1303
	write(iout,1301),ispot
1301	format(/,' Closed and eta at element ',i4)
	write(iout,1302)(closave(ispot,n,1),n=1,nener)
	write(iout,1302)(etas(n/2,1),n=1,nener)
1302	format(3x,4e15.4)
c
1303	continue
c
	do 231 j=1,nener		!cycle through energies
	jener=j
	if(.not.lener(j))goto 231
C THE ROUTINE TO restore THE MATRIX U.
      do 232 k=2,5
      IND=k+j+j+j+j+j-5
      DO 233 i=1,4
      ufull(k-1,i)=tospot(itrend,ind,i)	!restore full turn from start to end
  233 uspot(k-1,i)=tospot(ispot,ind,i)	!restore transfer from start to ispot
  232 CONTINUE
c
c  beta at spot
c
   12 ANUX = ATAN2(uspot(2,1),uspot(1,1)*alsq(j,1,2)-
     &	uspot(2,1)*halpha(jener))
      ANUX = ANUX/TWOPI
      IF (ANUX.LT.0.0) GO TO 810
      NNUXS(j) = 0
805   ANUX = ANUX+NNUX(j)
      aanux(j)=anux
      GO TO 820
810   IF (NNUXS(j).NE.0) GO TO 805
      NNUX(j) = NNUX(j)+1
      NNUXS(j) = 1
      GO TO 805
820   ANUY = ATAN2(uspot(4,3),uspot(3,3)*alsq(j,2,2)-
     &	  uspot(4,3)*valpha(jener))
      ANUY = ANUY/TWOPI
      IF (ANUY.LT.0.0) GO TO 830
      NNUYS(j) = 0
825   ANUY = ANUY+NNUY(j)
      aanuy(j)=anuy
      GO TO 860
830   IF (NNUYS(j).NE.0) GO TO 825
      NNUY(j) = NNUY(j)+1
      NNUYS(j) = 1
      GO TO 825
860   GAMMAX = (1.0D0+halpha(jener)*halpha(jener))/alsq(j,1,2)
      GAMMAY = (1.0D0+valpha(jener)*valpha(jener))/alsq(j,2,2)
      XM1112 = uspot(1,1)*uspot(2,1)
      XM2111 = uspot(1,2)*uspot(1,1)
      XM1221 = uspot(2,1)*uspot(1,2)
      XM1222 = uspot(2,1)*uspot(2,2)
      Bxspot(jener) = uspot(1,1)*uspot(1,1)*alsq(j,1,2)-
     <	   2.0D0*XM1112*halpha(jener)+
     <     uspot(2,1)*uspot(2,1)*GAMMAX
      ALxspot(jener) = -XM2111*alsq(j,1,2)+(1.0D0+2.0D0*XM1221)*
     &	halpha(jener)-XM1222*GAMMAX
C
      YM1112 = uspot(3,3)*uspot(4,3)
      YM2111 = uspot(3,4)*uspot(3,3)
      YM1221 = uspot(4,3)*uspot(3,4)
      YM1222 = uspot(4,3)*uspot(4,4)
      byspot(jener)= uspot(3,3)*uspot(3,3)*alsq(j,2,2)
     <	   -2.0D0*YM1112*valpha(jener)+
     <     uspot(4,3)*uspot(4,3)*GAMMAY
      ALyspot(jener) = -YM2111*alsq(j,2,2)+(1.0D0+2.0D0*YM1221)*
     &	valpha(jener)-YM1222*GAMMAY

c  multiply pieces to get full turn. Tii=T0i-1 X T00 X T0i
c  T-1 = -STtransposeS
c  calculate Uinverse
c	do 301 i=1,4
c	  do 301 n=1,4
c	    uinv(i,n)=0.d0
c	    do 301 k=1,4
c	      do 301 n1=1,4
c 301            uinv(i,n)=uinv(i,n)-S(i,k)*uspot(n1,k)*S(n1,n) 
c  fullturn = uinv*u*uspot 
c	do 1230 i=1,4
c	  do 1230 n=1,4
c	    u(i+1,n)=0.d0
c	    do 1231 k=1,4
c	      do 1231 n1=1,4
c1231	      u(i+1,n)=u(i+1,n)
c     &	        +uinv(i,k)*ufull(k,n1)*uspot(n1,n)
c          IND=i+1+j+j+j+j+j-5
c	   saveu(ispot,ind,n)=uft(i+1,n)  	!save full turn at ispot
c 1230	  continue
c	if(intprt.lt.-1)goto 231
c      WRITE (IOUT,1281),ispot
c 1281 FORMAT('-', 'THE FULLTURN TRANSFER MATRIX AT ELEMENT ',i5)
c      DO 1283 I=1,4
c 1283 WRITE (IOUT,282) (U(N,I),N=2,5)
 231	continue
1217  RETURN
      END
C     ***********************
      SUBROUTINE TRACKT
C     **********************
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
cdlr
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
	character*3 ans
cdlr
      COMMON AMAT(350,6,27),NORLST(2500),XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/DETL/DENER(15),NH,NV,NVH,NHVP(105),MDPRT,NDENER,
     1NUXS(45),NUX(45),NUYS(45),NUY(45),NCO,NHNVHV,MULPRT,NSIG
      COMMON/FITL/COEF(20,6),VALF(20),WGHT(20),RVAL(20),XM(20)
     >  ,EM(20),WV,NELF(20,6),NPAR(20,6),IND(20,6),NPVAR(20),NVAL(20)
     >  ,NSTEP,NVAR,NCOND,ISTART,NDIV,IFITM,IFITD
cdlr
      COMMON/FUNC/BETAX,ALPHAX,ETAX,ETAPX,BETAY,ALPHAY,ETAY,ETAPY,
     <  STARTE,ENDE,DELTAE,DNU,MFPRNT,KOD,NLUM,NINT,NBUNCH
cdlr
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
	common/path/pathlength(18)
	common /middle/emit(2),interm,intprt,iemitt,idec,nesave(2000)
	common /minitwo/bxarcmax(2),byarcmax(2),etaarcmax(2),
     &    bxirmax(2),
     &	  byirmax(2)
     &	  ,etairmax(2),cavbetax(2),cavbetay(2),caveta(2,2),cavtune
     &	  ,aperarcmax(2),separation,nbunchs
  	logical quad(2000),irquad(2000),bypass(2000),sept(2000),cross(2000),
     &	  bend(2000)
	logical ibefore(2000),iafter(2000)
	logical ltwiss(2000)
	dimension ncrosssav(2000)
	common /storeat/ quad,irquad,bypass,sept,cross,bend,
     &	  ibefore,iafter,ncrosssav
	common /jtwiss/stwiss(10,4,100),itwiss(100),ntwiss(2500),
     1                 lname(100),ltwiss
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN
     +  ,NPTOT,MLOCAT,NTURN
       COMMON/V/VV(27),X1,X2,X3,X4,X5,X6
      COMMON/PLT/
     1XMIN,XMAX,YMIN,YMAX,XPMIN,XPMAX,YPMIN,YPMAX,
     >DELMIN,DELMAX,DNUMIN,DNUMAX,DBMIN,DBMAX,
     2MXXPR,MYYPR,MXY,MALL,NPLOT,NCCUM,NGRAPH,NCOL,NLINE
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/TRI/WCO(15,6),GEN(5,4),PGEN(75,6),DIST,
     <A1(15),B1(15),A2(15),B2(15),XCOR(3,15),XPCOR(3,15),
     1AL1(15),AL2(15),MESH,NIT,NENER,NITX,NITS,NITM1,NANAL,NOPRT
      COMMON/GEOM/XCO,XPCO,YCO,YPCO,NCASE,NJOB,
     <            EPSX(10),EPSY(10),XI(10),YI(10),XG(300,10),
     <            XPG(300,10),YG(300,10),YPG(300,10),LCASE(10)
      COMMON/MISSET/DX,DXR,DY,DYR,DZ,DZR,DDEL,HLMNEL,I,IEP,MNEL
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON/MIS/RMISA(7,50),MISELE(50),NMIS,ISEED,IXS,NOPT,
     > NMISE,MISSEL(50),NMRNGE(50),MSRNGE(2,10,50),MISFLG,MCHFLG
      COMMON/ERR/ERRVAL(7,50),NERELE(50),NERPAR(7,50),NERR,NEROPT,
     > NERRE,MERSEL(50),NERNGE(50),MERNGE(2,10,50),MERFLG
      COMMON/ERSAV/SAV(7),SAVMAT(6,27),IERSET,IER,IDE
      COMMON/MONIT/VALMON(12,4,3),MNAME(600,4),MONPOS(600),NMON
      COMMON/MONFIT/VALFA(12),WGHTA(12),ERRA(12),
     >AMULTA(12,6),ADDA(12,6),DELA(12),NPARA(12,6),NELFA(12,6),
     >NPVARA(12),INDA(12,6),VALR(12),
     >NMONA(12),NVALA(12),NVARA,NCONDA,IALFLG,MONFLG,MONLST,NOPTER,
     >IAFRST,ISDBEG,IMONSD,IMSBEG
      COMMON/CORR/CORVAL(600,4),ICRID(600),ICRPOS(600),ICRSET(600),
     >ICROPT(600),NCORR,NCURCR,ICRFLG,ICRCHK,ALMNEL,NPARC
      COMMON/ORBIT/SIZEX,SIZEY,RMSX,RMSY,RMSIX,RMSIY,
     >RTEMPX,RTEMPY,RMSPX(5),RMSPY(5),RPX,RPY,
     >RMAXX,RMAXY,RMINX,RMINY,MAXX,MAXY,MINX,MINY,PLENG,
     >IRNG,IRANGE(5),NPRORB,IORB,IREF,IPAGE,IPOINT
      COMMON/SYNC/ENOM,SYNDEL,ISYNFL,ISYNGO
      LOGICAL LOGPAR,MXXPR(101,51),MYYPR(101,51),MXY(101,51)
	dimension lab(4)
      DIMENSION INDEL(6,18),INDOR2(13,6,8),INDORD(13,6,18)
      DIMENSION INDOR1(13,6,10)
      EQUIVALENCE (INDOR1(1,1,1),INDORD(1,1,1))
      EQUIVALENCE(INDOR2(1,1,1),INDORD(1,1,11))
	data lab/'K','8','4','5'/
      DATA INDEL/2,1,2,1,3,1,
     <12,12,8,8,13,1,4,4,4,4,7,1,8,7,6,5,3,1,10,10,8,8,7,1,
     <6*0,6*0,4,2,4,2,1,1, 4,2,
     <4,2,1,1,2,2,2,2,1,1,6*0,3,7,2,6,1,1,
     <6*0,  8,8,12,12,13,1,  6*0, 8,8,8,8,11,1,6*0,6*0/
      DATA INDOR1/1,2,11*0, 2,12*0, 3,4,11*0, 4,12*0, 5,13,22,10*0,
     +  6,12*0, 1,2,6,7,8,12,13,17,18,19,22,27,0,
     <  1,2,6,7,8,12,13,17,18,19,22,27,0,
     <  3,4,9,10,14,15,21,24,5*0, 3,4,9,10,14,15,21,24,5*0,
     <  1,2,5,6,7,8,12,13,17,18,19,22,27, 6,12*0,
     <  1,2,12,17,9*0, 1,2,12,17,9*0, 3,4,21,24,9*0, 3,4,21,24,9*0,
     <  5,7,8,13,18,19,22,6*0, 6,12*0, 1,2,7,8,13,18,19,22,5*0,
     <  2,7,8,13,18,19,22,6*0, 3,4,9,10,14,15,7*0, 4,9,10,14,15,8*0,
     <5,13,22,10*0,6,12*0, 1,2,7,8,12,13,17,18,19,22,3*0,
     <1,2,7,8,12,13,17,18,19,22,3*0,3,4,9,10,14,15,21,24,5*0,
     <3,4,9,10,14,15,21,24,5*0,5,7,8,13,18,19,22,6*0,6,12*0,
     <78*0,78*0,1,2,3,4,9*0,2,4,11*0,1,2,3,4,9*0,
     <2,4,11*0, 5,12*0,6,12*0,
     <  1,2,3,4,9*0, 2,4,11*0,
     <  1,2,3,4,9*0, 2,4,11*0, 5,12*0, 6,12*0, 1,2,11*0, 1,2,11*0,
     <  3,4,11*0, 3,4,11*0, 5,12*0, 6,12*0/
       DATA INDOR2/78*0, 1,7,18,10*0,
     <  1,2,7,8,12,18,19,6*0, 3,9,11*0, 3,4,9,10,14,21,7*0,
     <  5,12*0, 6,12*0,78*0,
     <1,2,9,10,12,14,15,17,5*0,  1,2,9,10,12,14,15,17,5*0,
     <3,4,6,7,8,13,18,19,21,22,24,27,0,
     <3,4,6,7,8,13,18,19,21,22,24,27,0,
     <3,4,5,6,7,8,13,18,19,21,22,24,27, 6,12*0,
     <78*0,1,2,3,4,12,17,21,24,5*0,1,2,3,4,12,17,21,24,5*0,
     >1,2,3,4,12,17,21,24,5*0,1,2,3,4,12,17,21,24,5*0,
     >5,7,8,9,10,13,14,15,18,19,22,2*0,6,12*0,
     >78*0,78*0/
c
	common/detdat/idetloc(200),sghold(8),htune,vtune
	dimension charge(6)
	dimension bex(10),bey(10),ax(10),ay(10)
c check if idetloc has already been filled (there's nothing special about 35)

	if((idetloc(35).eq.0).and.((interm.eq.7).or.(interm.eq.8))) call detloc

	data charge/6*0.d0/	
C
C   PRINT INITIAL POSITIONS
C
	ncross=1
	mbunch=1
	if(nbunchs.gt.0)mbunch=nbunchs
	space=tleng/mbunch/2
      NORDER=2
c     	  call bastart
        IF(NPRINT.NE.-2)CALL TRAKPR(-1,1)
cdlr
	if(idlr.eq.0)then
	  type 1
1	  format(' Do you want to plot  trajectory ? ',$)
	  accept 2,ans
2	  format(a)
	    idlr=1
	  endif
cdlr
      NXREQ = NPLOT +NCTURN
      LSTREQ = NTURN/NPLOT*NPLOT
C
C   TURN LOOP NCTURN -> NTURN
C
   10 NCTURN=NCTURN+1
      ISYNGO=0
      IF(IALFLG.EQ.0)GOTO 601
      IF(IALFLG.EQ.1)GOTO 602
      ITRBEG=IAFRST
      ITREND=MONLST
      IXS=ISDBEG
      IMONSD=IMSBEG
      GOTO 603
  601 ITRBEG=1
      ITREND=NELM
      IXS=ISEED
      IMONSD=ISEED
      GOTO 603
  602 ITRBEG=1
      ITREND=IAFRST-1
      IXS=ISEED
      IMONSD=ISEED
  603 ILIST=1
C     WRITE(IOUT,33331)IALFLG,ISEED,IXS,ISDBEG,ITRBEG,ITREND
33331 FORMAT(' IN TRACKT IALFLG,ISEED,IXS,ISDBEG,ITRBEG,ITREND =',/,
     >I3,3I11,2I5)
      DO 110 IE=ITRBEG,ITREND
       IEP=IE
      NEL=NORLST(IE)
      MNEL=NEL
      IAD=IADR(NEL)
      KD=KODE(NEL)
      IF(((KD.EQ.1).OR.(KD.EQ.13).OR.(KD.EQ.14)).AND.(ISYNFL.NE.0))
     >CALL SYNPRE(IAD,NEL)
      IF(ICRFLG.EQ.1)CALL CORCHK(IE)
C     WRITE(IOUT,77771)ICRFLG,ICRCHK
77771 FORMAT('  IN TRACKT ICRFLG,ICRCHK ARE',2I6)
      IF(MISFLG.EQ.1)CALL MISCHK
C     IF((IREF.EQ.1).AND.(MCHFLG.NE.0))WRITE(IOUT,77772)MCHFLG,IE
77772 FORMAT('  IN TRACKT MCHFLG IS ',2I6)
      IF((MERFLG.EQ.1).OR.(ICRCHK.EQ.2))CALL ESET
C     IF(MCHFLG.NE.0)WRITE(IOUT,77772)MCHFLG,IE
      IF(IALFLG.NE.0)CALL MONCHK(IE)
      N=MADR(NEL)
      NT=KODE(NEL)
      IF(NT.EQ.5)CALL MULTIT(IAD)
      IF(NT.EQ.12)CALL ARBIT(IAD,NEL)
      IF(NT.EQ.11) GO TO 111
C
C   PROCEs THE PARTICLES
C
      DO 65 I=1,NPART
      IF(.NOT.LOGPAR(I)) GO TO 65
      TEST=(PART(I,1)/XPEL(NEL))**2+(PART(I,3)/YPEL(NEL))**2
      TEST=SQRT(TEST)
      IF(TEST.LT.EXPEL) GO TO 20
      WRITE(IOUT,10024)I,IE,(NAME(NEL,IZ),IZ=1,4),NCTURN
      IF(ISO.NE.0)WRITE(ISOUT,10024)I,IE,(NAME(NEL,IZ),IZ=1,4)
     <,NCTURN
10024 FORMAT(//,'  PARTICLE #',I6,' IS LOST BEFORE ELEMENT',I6,
     +  '(',4A1,')',
     +  ' DURING TURN:',I6,/,' ITS POSITION IS :',//)
      NCPART=NCPART-1
      LOGPAR(I)=.FALSE.
      WRITE(IOUT,10300)I,(PART(I,J),J=1,6)
      IF(ISO.NE.0)WRITE(ISOUT,10300)I,(PART(I,J),J=1,6)
10300 FORMAT(I4,6(E14.5))
      GO TO 65
C
C   SET UP PARTICLES AND THE ARRAY TO MULTIPLY
C
   20 CONTINUE
      IF(ICRCHK.EQ.1)CALL CSET
C     IF(MCHFLG.NE.0)WRITE(IOUT,77772)MCHFLG,IE
      IF(MCHFLG.EQ.1)CALL MSET
      X1=PART(I,1)
      X2=PART(I,2)
      X3=PART(I,3)
      X4=PART(I,4)
      X5=PART(I,5)
      X6=PART(I,6)
      IF(NT.EQ.12)GOTO 1200
      IF(NT.EQ.5)GOTO 500
      CALL COMPL
C
C   DO FAST MATRIX MULTIPLY
C
      IF(KODE(NEL).EQ.10) GO TO 40
      IIND=NT+1
C
C   PROCESS CODES 0-9
C
      IF(NT.NE.8)GO TO 33
      IKI=ABS(ELDAT(IAD+8))+.01
      IF(MOD(NCTURN,IKI).NE.0)GO TO 60
  33     DO 30 IM=1,6
      PART(I,IM)=0.0D0
      JMF=INDEL(IM,IIND)
      IF(IIND.EQ.7)JMF=27
      DO 30 JM=1,JMF
      IJM=INDORD(JM,IM,IIND)
      IF(IIND.EQ.7)IJM=JM
   30 PART(I,IM)=PART(I,IM)+AMAT(N,IM,IJM)*VV(IJM)
      IF(NT.NE.8)GO TO 60
	charge(2)=1.d0
	if(nbunchs.gt.1.and.I.gt.10)charge(2)=-1.d0
      DO 32  IK=1,6
   32 PART(I,IK)=PART(I,IK)+ELDAT(IAD+IK-1)*charge(ik)
C
C TREAT THE CASE OF A SYNCHROTRON OSCILLATION KICK
C
      MSYN = ELDAT(IAD+9)
      NSYN = ABS(FLOAT(MSYN))
      IF(MSYN.LT.0)PART(I,6)=DEL(I)*COS(TWOPI*NCTURN/NSYN)
      GO TO 60
C
C    TREAT CODE 5 OF MULTIPOLAR ELEMENT
C
  500 CALL MULTTR(X1,X2,X3,X4,X5,X6)
      PART(I,1)=X1
      PART(I,2)=X2
      PART(I,3)=X3
      PART(I,4)=X4
      PART(I,5)=X5
      PART(I,6)=X6
      GOTO 60
C
C  TREAT CODE 12 ARBITRARY ELEMENT
C
 1200 CALL TRAFCT(X1,X2,X3,X4,X5,X6,Y1,Y2,Y3,Y4,Y5,Y6,NCTURN)
      PART(I,1)=Y1
      PART(I,2)=Y2
      PART(I,3)=Y3
      PART(I,4)=Y4
      PART(I,5)=Y5
      PART(I,6)=Y6
      GOTO 60
C
C   DO CODE 10 : GENERAL MATRIX
C
   40 DO 50 IM=1,6
      PART(I,IM)=0.0D0
      DO 50 JM=1,27
      AMIJ=AMAT(N,IM,JM)
      IF (AMIJ.EQ.0D0)GOTO 50
      PART(I,IM)=PART(I,IM)+AMIJ*VV(JM)
   50 CONTINUE
   60 CONTINUE
      IF(MCHFLG.EQ.1)CALL MRESET
      IF(ICRCHK.EQ.1)CALL CRESET
      IF(ISYNGO.EQ.1)PART(I,6)=PART(I,6)-SYNDEL
   65 CONTINUE
      ISYNGO=0
C      IF(PART(1,6).NE.0.0D0)WRITE(IOUT,99999)NPART,IE,IEP,NEL,
C     >((PART(INP,JNP),JNP=1,6),INP=1,NPART)
      IF(NANAL.EQ.0)GO TO 63
      DO 64 IEN=1,NENER
      XCOR(NCTURN,IEN)=PART(IEN,1)
      XPCOR(NCTURN,IEN)=PART(IEN,2)
   64 CONTINUE
   63 IF (NJOB .EQ. 0) GO TO 62
      NCP = 1
      DO 61 IC = 1, NCASE
      XG (NCTURN,IC) = PART(NCP, 1) - XCO
      XPG(NCTURN,IC) = PART(NCP, 2) - XPCO
      IF (NJOB .EQ. 2) NCP = NCP + 1
      YG (NCTURN,IC) = PART(NCP, 3) - YCO
      YPG(NCTURN,IC) = PART(NCP, 4) - YPCO
      NCP=NCP+1
   61 CONTINUE
   62 CONTINUE
      IF(NCPART.EQ.0) RETURN
      IF(IREF.EQ.1)CALL PLPORB(IE,NEL,NELM)
      IF(MONFLG.GE.1)CALL DETLPR(IE,ILIST)
C     WRITE(IOUT,77777)MDPRT
      IF((MDPRT.EQ.-2).AND.(IFITD.NE.1))GOTO 76
      IF(MDPRT.EQ.0)GOTO75
      IF((MDPRT.LE.-1).AND.(IE.NE.NELM))GOTO76
      IF(IE.EQ.NELM)GOTO75
      CALL PRTTST(IE,ILIST,IPRT)
      IF(IPRT.NE.1)GOTO76
   75 CALL DETLPR(IE,ILIST)
   76 IF(NPRINT)100,70,90
C
C   PRINT AFTER EVERY ELEMENT
C
   70 CALL TRAKPR(0,IEP)
      GO TO 100
C
C   PRINT AFTER N TURNS AT M LOCATIONS
C
   90 IF(MOD(NCTURN,NPRINT).NE.0) GO TO 100
      CALL PRTTST(IE,ILIST,IPRT)
      IF(IPRT.NE.1)GOTO 100
      CALL TRAKPR(0,IEP)
C
C   PLOTTING AFTER EVERY ELEMENT?
C
  100	continue
1011  IF(NPLOT.NE.0) GO TO 111
      NZERO = 0
      NCCUM = 1
      CALL PLOTPR(IEP,NZERO)
  111 IF(IERSET.EQ.1)CALL ERESET
      IF(MONFLG.EQ.2)GOTO112
	if(ie.gt.nelm)goto 110
	 if(quad(ie) .or. sept(ie) .or. bend(ie+1) .or. quad(ie+1)
     &	   .or. ltwiss(ie)
     &	   .or. ibefore(ie) .or. iafter(ie)) goto 1111
c	if(kode(nel).eq.2)goto 1111
c	if(ncross*space.lt.acleng(ie))then
c	  ncross=ncross+1
c	  goto 1111
c	endif
c        if(ncross*space.lt.acleng(ie+1))goto 1111 !element ie passed ncross crossing point
c	if(interm.eq.0)goto 110	      !No intermediate transfer calculations
c	if(interm.eq.4)goto 1111      !All intermediate transfer calcs
c 	if(interm.ge.5.and.(nel.eq.norlst(ie+1)))goto 1111 	!symmetry point
c	if(interm.ne.6)goto 114		!Horizontal separators	
c	  if(name(norlst(ie),1).ne.lab(1)
c     &	      .and.name(norlst(ie),1).ne.lab(1))goto 114
c	  if(name(norlst(ie),3).eq.lab(2))goto 1111
c	  if(name(norlst(ie),2).eq.lab(3)
c     &		.and.name(norlst(ie),3).eq.lab(4))goto 1111
  114	if(ie.eq.itrend)goto 1111	!End of line
c	if(interm.gt.0)goto 110
c	do 113 jj=1,iabs(interm)
c	  if(ie.eq.nesave(jj))goto 110
c  113	continue
	goto 110
 1111	continue
 	call transave(ie,bex,bey,ax,ay)
  110 CONTINUE
	do i=1,nener
	pathlength(i)=part(5*i-4,5)
	end do
c     	  call bastart
  112 IF(IALFLG.EQ.1)ISDBEG=IXS
      IF(IALFLG.EQ.1)CALL DETLPR(ITREND,ILIST)
      IF(IALFLG.EQ.1)IMSBEG=IMONSD
C
C   CHECK THE PLOT REQUESTED FOR THIS TURN
C
      IF(NCTURN.LT.NTURN) GO TO 300
      IF(NPRINT.NE.-2)CALL TRAKPR(0,NELM)
  300 IF(NPLOT.LE.0) GO TO 200
      IF(NCTURN.NE.NXREQ) GO TO 200
      NZERO = 1
      IF(NCTURN.EQ.NPLOT) NZERO = 0
      IF(NCCUM.EQ.1) NZERO = 0
      IF(NCTURN.EQ.LSTREQ) NCCUM = 1
      CALL PLOTPR(NELM,NZERO)
      NXREQ = NXREQ+NPLOT
  200 IF(NCTURN.LT.NTURN) GO TO 10
cdlr
	misflg=-1
cdlr
      RETURN
      END
      SUBROUTINE trmatrix(mdo,i)
C   *****************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
	common /mat1/temp1(6,27),iflag1,nelstrt,nelend
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
	common /gplot/igplot,idev,ndispl
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
	common/minia/detaddelta,betas(2000,2),
     1               ibeta_adr(2000),initbeta_count,miniinvoke
      COMMON/FOUT/OUTFL(300)
      COMMON/FUNC/BETAX,ALPHAX,ETAX,ETAPX,BETAY,ALPHAY,ETAY,ETAPY,
     <  STARTE,ENDE,DELTAE,DNU,MFPRNT,KOD,NLUM,NINT,NBUNCH
      COMMON/TWF/BETAOX,ALPHOX,ETAOX,ETAPOX,ANUX,
     >            BETAOY,ALPHOY,ETAOY,ETAPOY,ANUY,IE
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
      COMMON/LUM/ UO,TAUX,ALPHX,ALPHY,TAUY,
     <  ALPHE,TAUE,SIGE,SIGX,EPSX,
     <SIGY,EPSY,SIGXT,SIGYT,ENERGY,TAUREV
      COMMON/CBEAM/BSIG(6,6),BSIGF(6,6),MBPRT,nform
	common /bmax/bvarc,bharc,bvir,bhir,ir1,ir2,ir3,ir4
 	common /twiher/npnt,jfite(10),ipnt
	common /orbsave/xsave(2000),ysave(2000)
	dimension ai1x(2),ai2x(2),ai3x(2),ai4x(2),ai5x(2)
	dimension ai1xk(2),ai2xk(2),ai3xk(2),ai4xk(2),ai5xk(2)
	dimension ai1y(2),ai2y(2),ai3y(2),ai4y(2),ai5y(2)
	common /radiation/epsxiq(2),curlydx(2),dzplus(2),dxplus(2),epsxplus(2),
     &	  compac(2),sigeplus(2)			 

       	data ipicb/2/,ipict/2/
	iflag1=0
	if(mdo.eq.0)then
	nint=1
C   SET INTEGRALS INITIALLY TO ZERO
C
      AI1X(i)=0.0D0
      AI2X(i)=0.0D0
      AI3X(i)=0.0D0
      AI4X(i)=0.0D0
      AI5X(i)=0.0D0
      AI1Xk(i)=0.0D0
      AI2Xk(i)=0.0D0
      AI3Xk(i)=0.0D0
      AI4Xk(i)=0.0D0
      AI5Xk(i)=0.0D0
      AI1Y(i)=0.0D0
      AI2Y(i)=0.0D0
      AI3Y(i)=0.0D0
      AI4Y(i)=0.0D0
      AI5Y(i)=0.0D0
C
	goto 840
	endif
c
c
C   IS THE NEXT ELEMENT A BEND or quad
C                                          
	if(mdo.ne.3.and.mdo.ne.2)goto 840	!not a bend or quad
C
      NEXT=IE+1
      NEXTEL=NORLST(NEXT)
      IF(NEXT.GT.NELM) GO TO 840
      KODN=KODE(NEXTEL)
      IBEND=0
      IF(KODN.EQ.1)IBEND=1
      IF(KODN.EQ.13)IBEND=1
      IF(KODN.EQ.14)IBEND=1
      NT=KODE(nextel)
C      IF(IBEND.EQ.0)GOTO 840
       IF(IBEND.EQ.0.and.(nt.ne.2.or.abs(xsave(ie)).
     &	  lt.0.000001))GOTO 840
C
C   GET THE PARAMETERS
C
      IAT=IADR(NEXTEL)
      ANG=ELDAT(IAT+1)*CRDEG
	if(nt.eq.2)ang=xsave(ie)*eldat(iat+1)*eldat(iat)
      AL=ELDAT(IAT)
      RAD=AL/ANG
	if(nt.ne.2)then
      FIELDN=ELDAT(IAT+2)
      PHI1=ELDAT(IAT+4)*CRDEG
      PHI2=ELDAT(IAT+8)*CRDEG
	else
	phi1=0.
	phi2=0.
	endif
      RAD2=RAD*RAD
      RAD3=RAD2*RAD
      AK2=(1.0D0-FIELDN)/RAD2
      AK=SQRT(ABS(AK2))
	if(nt.eq.2)then
	ak2=eldat(iat+1)
	ak=sqrt(ABS(ak2))
	fieldn=-ak2*rad2+1.d0
	endif
      ARG=AK*AL
      AL2=AL*AL
      ARG2=AK2*AL*AL
      ARG3=ARG2*ARG
      ARG4=ARG2*ARG2
      ARG5=ARG3*ARG2
      IF(AK2)1,2,3
1     C=COSH(ARG)
      S=SINH(ARG)
      GO TO 4
2     C=1.0D0
      S=0.0D0
      F1=1.0D0
      F2=.5D0
      F3=1.0D0/6.0D0
      F4=1.0D0/3.0D0
      F5=1.0D0/60.0D0
      GO TO 5
3     C=COS(ARG)
      S=SIN(ARG)
4     F1=S/ARG
      F2=(1.0D0-C)/ARG2
      F3=(ARG-S)/ARG3
      F4=(ARG-S*C)/ARG3
      F5=(3.0D0*ARG-4.0D0*S+S*C)/ARG5
C
C   FIND THE VALUES THAT CONTRIBUTE TO THE INTEGRALS
C
    5 IF(KODN.EQ.13)GOTO 870
      ETAP1=ETAPOX+ETAOX*TAN(PHI1)/RAD
      AVETA=ETAOX*F1+ETAP1*AL*F2+AL2*F3/RAD
      ETA2=ETAOX*C+ETAP1*S*AL/ARG+(AL2*(1.0D0-C))/(RAD*ARG2)
      AVEFOR=FIELDN*AVETA/RAD3+(ETAOX*TAN(PHI1)+ETA2*TAN(PHI2))/
     <  (2.0D0*AL*RAD2)
      ALPHA1=ALPHOX-BETAOX*TAN(PHI1)/RAD
      GAMMA=(1.0D0+ALPHOX*ALPHOX)/BETAOX
      T1=GAMMA*ETAOX*ETAOX
      T2=2.0D0*ALPHA1*ETAOX*ETAP1
      T3=BETAOX*ETAP1*ETAP1
      T4=-(GAMMA*ETAOX+ALPHA1*ETAP1)*F3*AL
      T5=(ALPHA1*ETAOX+BETAOX*ETAP1)*F2
      T45=2.0D0*AL*(T4+T5)/RAD
      T6=GAMMA*F5*AL2/2.0D0
      T7=ALPHOX*F2*F2*AL
      T8=BETAOX*F4/2.0D0
      T678=AL2*(T6-T7+T8)/RAD2
      HAV=T1+T2+T3+T45+T678
C
C   COMPUTE THE INTEGRALS
C
      AI1X(i)=AI1X(i)+AL*AVETA/RAD
      AI2X(i)=AI2X(i)+AL/RAD2
      AI3X(i)=AI3X(i)+AL/(ABS(RAD))**3
      AI4X(i)=AI4X(i)+(AL*AVETA/RAD3-2.0D0*AL*AVEFOR)
      AI5X(i)=AI5X(i)+AL*HAV/(ABS(RAD))**3
	if(nt.eq.2)then
      AI1Xk(i)=AI1Xk(i)+AL*AVETA/RAD
      AI2Xk(i)=AI2Xk(i)+AL/RAD2
      AI3Xk(i)=AI3Xk(i)+AL/(ABS(RAD))**3
      AI4Xk(i)=AI4Xk(i)+(AL*AVETA/RAD3-2.0D0*AL*AVEFOR)
      AI5Xk(i)=AI5Xk(i)+AL*HAV/(ABS(RAD))**3
	endif
      GO TO 840
  870 ETAP1=ETAPOY+ETAOY*TAN(PHI1)/RAD
      AVETA=ETAOY*F1+ETAP1*AL*F2+AL2*F3/RAD
      ETA2=ETAOY*C+ETAP1*S*AL/ARG+(AL2*(1.0D0-C))/(RAD*ARG2)
      AVEFOR=FIELDN*AVETA/RAD3+(ETAOY*TAN(PHI1)+ETA2*TAN(PHI2))/
     <  (2.0D0*AL*RAD2)
      ALPHA1=ALPHOY-BETAOY*TAN(PHI1)/RAD
      GAMMA=(1.0D0+ALPHOY*ALPHOY)/BETAOY
      T1=GAMMA*ETAOY*ETAOY
      T2=2.0D0*ALPHA1*ETAOY*ETAP1
      T3=BETAOY*ETAP1*ETAP1
      T4=-(GAMMA*ETAOY+ALPHA1*ETAP1)*F3*AL
      T5=(ALPHA1*ETAOY+BETAOY*ETAP1)*F2
      T45=2.0D0*AL*(T4+T5)/RAD
      T6=GAMMA*F5*AL2/2.0D0
      T7=ALPHOY*F2*F2*AL
      T8=BETAOY*F4/2.0D0
      T678=AL2*(T6-T7+T8)/RAD2
      HAV=T1+T2+T3+T45+T678
C
C   COMPUTE THE INTEGRALS
C
      AI1Y(i)=AI1Y(i)+AL*AVETA/RAD
      AI2Y(i)=AI2Y(i)+AL/RAD2
      AI3Y(i)=AI3Y(i)+AL/(ABS(RAD))**3
      AI4Y(i)=AI4Y(i)+(AL*AVETA/RAD3-2.0D0*AL*AVEFOR)
      AI5Y(i)=AI5Y(i)+AL*HAV/(ABS(RAD))**3
C
C
 840  continue
	if(mdo.ne.4)return
      AI1=AI1X(i)+AI1Y(i)
      AI2=AI2X(i)+AI2Y(i)
      AI3=AI3X(i)+AI3Y(i)
      AI4=AI4X(i)+AI4Y(i)
       AI5=AI5X(i)+AI5Y(i)
C
C
      IF(miniinvoke.eq.1.or.NLUM.EQ.0)GOTO 5000
      WRITE(IOUT,1100)AI1X(i),AI2X(i),AI3X(i),AI4X(i),AI5X(i)
 1100 FORMAT(/,'   SYNCHROTRON INTEGRALS ARE  ',//,
     >3X,'INTEGRAL X1=',E18.11,13X,'INTEGRAL X2=',E18.11,/,
     <       3X,'INTEGRAL X3=',E18.11,13X,'INTEGRAL X4=',E18.11,/,
     <       3X,'INTEGRAL X5=',E18.11,/)
      WRITE(IOUT,1101)AI1Y(i),AI2Y(i),AI3Y(i),AI4Y(i),AI5Y(i)
1101  FORMAT(/,3X,'INTEGRAL Y1=',E18.11,13X,'INTEGRAL Y2=',E18.11,/,
     <       3X,'INTEGRAL Y3=',E18.11,13X,'INTEGRAL Y4=',E18.11,/,
     <       3X,'INTEGRAL Y5=',E18.11,/)
5000  COMPAC(i) = (AI1+AI1Xk(i))/TLENG
      IF(ABS(AI2).LT.1.0E-30)RETURN
      AJX = 1.0D0-(AI4X(i)/AI2)
	CURLYDX(i)=AI4X(i)/AI2
	dxplus(i)=(AI4X(i)+AI4Xk(i))/(AI2+AI2Xk(i))
	dxminus=(AI4X(i)-AI4Xk(i))/(AI2+AI2Xk(i))
	AJXPLUS=1.D0-DXPLUS(i)
	AJXMINUS=1.D0-DXMINUS
      AJY = 1.0D 0-(AI4Y(i)/AI2)
	DY=AI4Y(i)/(AI2+AI2Xk(i))
	AJYPRETZ=1.D0-DY
      AJE = 2.0D0+(AI4/AI2)
	DZPLUS(i)=(AI4+AI4Xk(i))/(AI2+AI2Xk(i))
	DZMINUS=(AI4+AI4Xk(i))/(AI2+AI2Xk(i))
	AJEPLUS=2.D0+DZPLUS(i)
	AJEMINUS=2.D0+DZMINUS
      TAUREV = NINT*TLENG/CLIGHT
      FREV = 1.0D0/TAUREV
      ENERGY = STARTE
C
C   OUTPUT THE RESULTS
C
      if(miniinvoke.ne.1)then
      IF(ISO.NE.0)WRITE(ISOUT,734)COMPAC(i),AJX,AJY,AJE,TAUREV,FREV
734   FORMAT(/,' MOMENTUM COMPACTION=',E15.7,3X,'JX=',F8.5,3X,
     < 'JY=',F8.5,3X,
     <  'JE=',F8.5,/,' TAUREV=',E15.7,'(SEC)',3X,'FREV=',E15.7,
     <  '(HZ)'/)
	WRITE(IOUT,1737)AJXPLUS,AJXMINUS,AJYPRETZ,AJEPLUS,AJEMINUS
1737	FORMAT(/,' JXPLUS=',F8.5,5X,'JXMINUX=',F8.5,
     &	  /,' JYPRETZ=',F8.5,3X,'JEPLUS='F8.5,3X,'JEMINUS=',F8.5)
	WRITE(IOUT,1734)CURLYDX(i),DXPLUS(i),DXMINUS
1734	FORMAT(1x,
     &	  ' CURLYDX=',E15.7,3X,' DXPLUS=',E15.7,3X,' DXMINUS=',E15.7)
        endif
733   ALPH = 7.039346E-06*ENERGY**3*FREV*NINT
      UO = 1.4078692E-02*ENERGY**4*AI2*NINT
      ALPHX = ALPH*(AI2-AI4X(i))
	ALPHXPLUS=ALPH*AI2*(1.0D0-DXPLUS(i))
	ALPHXMINUS=ALPH*AI2*(1.0D0-DXMINUS)
      TAUX = 1.0D0/ALPHX
	TAUXPLUS=1.0D0/ALPHXPLUS
	TAUXMINUS=1.0D0/ALPHXMINUS
      ALPHY = ALPH*(AI2-AI4Y(i))
	ALPHYPRETZ=ALPH*(AI2+AI2Xk(i))*(1.D0-DY)
      TAUY = 1.0D0/ALPHY
	TAUYPRETZ=1.D0/ALPHYPRETZ
      ALPHE = ALPH*(2.0D0*AI2+AI4)
	ALPHEPLUS=ALPH*(AI2+AI2Xk(i))*(2.D0+DZPLUS(i))
	ALPHEMINUS=ALPH*(AI2+AI2Xk(i))*(2.D0+DZMINUS)
      TAUE = 1.0D0/ALPHE
	TAUEPLUS=1.D0/ALPHEPLUS
	TAUEMINUS=1.D0/ALPHEMINUS
      SIG = 1.211335E-03*ENERGY
      SIGE = SIG*SQRT(AI3/(2.0D0*AI2+AI4))
	TICK=((AI3+AI3Xk(i))/((AI2+AI2Xk(i))*
     &	  (2.D0+DZPLUS(i))))
	IF(TICK.GT.0.0)SIGEPLUS(i)=SIG*SQRT(TICK)
	IF(TICK.LT.0.0)TYPE *,' TICK < 0 IN TRMATRIX'
	TICK=((AI3+AI3Xk(i))/((AI2+AI2Xk(i))*
     &	  (2.D0+DZMINUS)))       
	IF(TICK.GT.0.0)SIGEMINUS=SIG*SQRT(TICK)
	IF(TICK.LT.0.0)TYPE *,' TICK < 0 IN TRMATRIX'
      EPSX = ABS(AI5X(i)/(AI2-AI4X(i)))*SIG**2
	EPSXPLUS(i)=ABS((AI5X(i)+AI5Xk(i))/((AI2+AI2Xk(i))*
     &	  (1.D0-DXPLUS(i))))*SIG**2
	EPSXMINUS=ABS((AI5X(i)+AI5Xk(i))/((AI2+AI2Xk(i))*
     &	  (1.D0-DXMINUS)))*SIG**2
      SIGX = SQRT(EPSX*BETAX)
      EPSY = ABS(AI5Y(i)/(AI2-AI4Y(i)))*SIG**2
      SIGY = SQRT(EPSY*BETAY)
      SIGXT=SQRT(SIGX**2+(ETAX*SIGE)**2)
      SIGYT=SQRT(SIGY**2+(ETAY*SIGE)**2)
      if(miniinvoke.ne.1)then
      WRITE(IOUT,735)ENERGY,UO,ALPHX,ALPHY,ALPHE,
     <  TAUX,TAUY,TAUE,SIGE,EPSX,SIGX,
     <SIGXT,EPSY,SIGY,SIGYT
	WRITE(IOUT,1735)ALPHXPLUS,ALPHXMINUS,TAUXPLUS,TAUXMINUS
1735	FORMAT(' ALPHXPLUS=',E15.7,3X,' ALPHXMINUS=',E15.7,/,
     &	  ' TAUXPLUS=',E15.7,3X,'TAUXMINUS=',E15.7)
	WRITE(IOUT,1736)ALPHYPRETZ,TAUYPRETZ,ALPHEPLUS,ALPHEMINUS,
     &	  TAUEPLUS,TAUEMINUS,SIGEPLUS,SIGEMINUS,EPSXPLUS,EPSXMINUS
1736	FORMAT(/,10X,' AYPRETZ = ',E13.5,'(/SEC)',5X,'TAUYPRETZ=',E13.5,
     &	  '(SEC)'
     &	  ,/,' AEPLUS = ',E13.5,'(/SEC)',5X,' AEMINUS = ',E13.5,'(/SEC)'
     &	  ,/,' TAUEPLUS=',E13.5,'(SEC)',5X,'TAUEMINUS=',E13.5,'(SEC)',
     &	  /,' SIGEPLUS=',E13.5,5X,'SIGEMINUS=',E13.5,
     &	  /,' EPSXPLUS=',E13.5,'(M-RAD)',5X,
     &	 'EPSXMINUS=',E13.5,'(M-RAD)')
      IF(ISO.NE.0)WRITE(ISOUT,735)ENERGY,UO,ALPHX
     <,ALPHY,ALPHE,
     <  TAUX,TAUY,TAUE,SIGE,EPSX,SIGX,
     <SIGXT,EPSY,SIGY,SIGYT
735   FORMAT(//,20X,' ENERGY = ',F8.4,'(GEV)',//,' ENERGY LOSS =',
     < E13.5,'(MEV/REV)'
     < ,/,' AX=',E13.5,'(/SEC)',5X,'AY=',E13.5,'(/SEC)',5X,'AE=',
     <  E13.5,'(/SEC)',/,' TAUX=',E13.5,'(SEC)',4X,'TAUY=',E13.5,'(SEC)'
     <  4X,'TAUE=',E13.5,'(SEC)',/,' SIGE=',E13.5,/,
     <  ' EPSX=',E13.5,'(M-RAD)',2X,'SIGX=',E13.5,'(M.)',5X,
     <'SIGXT=',E13.5,'(M.)',/,
     <  ' EPSY=',E13.5,'(M-RAD)',2X,'SIGY=',E13.5,'(M.)',5X,
     <'SIGYT=',E13.5,'(M.)',/)
      endif
      IF(NLUM.EQ.2) CALL LUMIN
      ENERGY = ENERGY+DELTAE
      IF(ENERGY.LE.ENDE) GO TO 733
      RETURN
      END
C     *************************
      SUBROUTINE ANAL
C     *************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON/ANALC/COMPF,RNU0X,CETAX,CETAPX,CALPHX,CBETAX,
     1RMU1X,CHROMX,ALPH1X,BETA1X,
     1RMU0Y,RNU0Y,CETAY,CETAPY,CALPHY,CBETAY,
     1RMU1Y,CHROMY,ALPH1Y,BETA1Y,RMU0X,
     >COSX,ALX1,ALX2,VX1,VXP1,VX2,VXP2,
     >COSY,ALY1,ALY2,VY1,VYP1,VY2,VYP2,NSTABX,NSTABY,NSTAB,NWRNCP
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG

caab see dimain, matrix for explanation of this block.
	common/minia/detaddelta,betas(2000,2),
     1               ibeta_adr(2000),initbeta_count,miniinvoke
	
      DIMENSION C(16),ETA(4)
      NSTABX=0
      NSTABY=0
      NSTAB=0
      NWRNCP=0
      DO 561 IM=1,4
      ETA(IM)=-TEMP(IM,6)
      DO 561 JM=1,4
      IC=(IM-1)*4 +JM
      C(IC)=TEMP(JM,IM)
  561 IF(IM.EQ.JM)C(IC)=C(IC)-1.0D0
      CALL DSIMQ (C,ETA,4,KS)
      IF(KS.NE.1) GO TO 562
      WRITE(IOUT,563)
      IF(ISO.NE.0)WRITE(ISOUT,563)
563   FORMAT(/,' SINGULAR SET OF EQUATIONS SENT TO DSIMQ',/)
      NSTAB=1
      RETURN
  562 COSX=.5D0*(TEMP(1,1)+TEMP(2,2))
      IF(ABS( COSX).GE.1.0D0)GOTO 1
      SIN=SQRT(1- COSX* COSX)
      SIN=SIGN(SIN,TEMP(1,2))
      RMU0X=ATAN2(SIN, COSX)
      IF(RMU0X.LT.0.0D0)RMU0X=TWOPI+RMU0X
      CBETAX=TEMP(1,2)/SIN
      CALPHX=.5D0*(TEMP(1,1)-TEMP(2,2))/SIN
      RNU0X=RMU0X/TWOPI
      DET1=ABS(TEMP(1,3)*TEMP(2,4)-TEMP(1,4)*TEMP(2,3))
      DET2=ABS(TEMP(3,1)*TEMP(4,2)-TEMP(3,2)*TEMP(4,1))
      EPS=DET1+DET2
      IF(EPS.GT.1.0D-09)NWRNCP=1
      CETAX=ETA(1)
      CETAPX=ETA(2)
      CETAY=ETA(3)
      CETAPY=ETA(4)
      IF (TLENG.EQ.0.0D0)GOTO 10
      COMPF=(TEMP(5,1)*CETAX+TEMP(5,2)*CETAPX+TEMP(5,6))/TLENG
      GOTO 11
   10 WRITE(IOUT,99999)
99999 FORMAT(/,' LENGTH IS ZERO: COMPACTION FACTOR CANNOT BE COMPUTED',
     >/)
      COMPF=0.0D0
   11 IF (NORDER.EQ.1) GO TO 2
      A110=2.0D0*TEMP(1,7)*ETA(1)+TEMP(1,8)*ETA(2)+TEMP(1,9)*ETA(3)
     >+TEMP(1,10)*ETA(4) +TEMP(1,12)
      A214=TEMP(2,8)*ETA(1)+2.0D0*TEMP(2,13)*ETA(2)+TEMP(2,14)*ETA(3)
     >+TEMP(2,15)*ETA(4)+TEMP(2,17)
      A317=TEMP(3,9)*ETA(1)+TEMP(3,14)*ETA(2)+2.0D0*TEMP(3,18)*ETA(3)
     >+TEMP(3,19)*ETA(4) +TEMP(3,21)
      A419=TEMP(4,10)*ETA(1)+TEMP(4,15)*ETA(2)+TEMP(4,19)*ETA(3)
     >+2.0D0*TEMP(4,22)*ETA(4)+TEMP(4,24)
      A114=TEMP(1,8)*ETA(1)+2.0D0*TEMP(1,13)*ETA(2)+TEMP(1,14)*ETA(3)
     >+TEMP(1,15)*ETA(4)+TEMP(1,17)
      A319=TEMP(3,10)*ETA(1)+TEMP(3,15)*ETA(2)+TEMP(3,19)*ETA(3)
     >+2.0D0*TEMP(3,22)*ETA(4)+TEMP(3,24)
      RMU1X=-.5D0*(A110+A214)/SIN
      CHROMX=RMU1X/TWOPI
      BETA1X=(A114-CBETAX* COSX*RMU1X)/SIN
      ALPH1X=(.5D0*(A110-A214)-RMU1X*CALPHX* COSX)/SIN	
    2 COSY=.5D0*(TEMP(3,3)+TEMP(4,4))
      IF(ABS(COSY).GE.1.0D0)GOTO 3

      SIN=SQRT(1-COSY*COSY)
      SIN=SIGN(SIN,TEMP(3,4))
      RMU0Y=ATAN2(SIN,COSY)
      IF(RMU0Y.LT.0.0D0)RMU0Y=TWOPI+RMU0Y
      CBETAY=TEMP(3,4)/SIN
      CALPHY=.5D0*(TEMP(3,3)-TEMP(4,4))/SIN
      RNU0Y=RMU0Y/TWOPI
      IF (NORDER.EQ.1) GO TO 4
      RMU1Y=-.5D0*(A317+A419)/SIN
      CHROMY=RMU1Y/TWOPI
      BETA1Y=(A319-CBETAY*COSY*RMU1Y)/SIN
      ALPH1Y=(.5D0*(A317-A419)-RMU1Y*CALPHY*COSY)/SIN
    4 continue
	RETURN
    1 NSTABX=1
      IF(COSX.EQ.1) GOTO 5
      ALX1 = COSX + SQRT(COSX*COSX-1)
      ALX2 = COSX - SQRT(COSX*COSX-1)
      A12=TEMP(1,2)
      A11=TEMP(1,1)
      VXP1=A11-ALX1
      DENOM=SQRT(A12*A12+VXP1*VXP1)
      VX1=-A12/DENOM
      VXP1=VXP1/DENOM
      VXP2=A11-ALX2
      DENOM=SQRT(A12*A12+VXP2*VXP2)
      VX2=-A12/DENOM
      VXP2=VXP2/DENOM
      GOTO 2
    5 NSTABX = 2
      GOTO 2
    3 NSTABY=1
      IF(COSY.EQ.1) GOTO 6
      ALY1 = COSY + SQRT(COSY*COSY-1)
      ALY2 = COSY - SQRT(COSY*COSY-1)
      A34=TEMP(3,4)
      A33=TEMP(3,3)
      VYP1=A33-ALY1
      DENOM=SQRT(A34*A34+VYP1*VYP1)
      VY1=-A34/DENOM
      VYP1=VYP1/DENOM
      VYP2=A33-ALY2
      DENOM=SQRT(A34*A34+VYP2*VYP2)
      VY2=-A34/DENOM
      VYP2=VYP2/DENOM
      GOTO 4
    6 NSTABY = 2
      GOTO 4
      END
C     ****************************
      SUBROUTINE OPTITL(ITITOP,KOD)
C     ****************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO

caab changed dimension of iop to (4,24) from (4,23)
caab changed iop data

      DIMENSION ITITOP(80),IOP(4,24)
      DATA IOP/'S','I','M','P','L','E','A','S','M','O','V','E',
     >'T','R','A','C','M','O','D','I','M','A','T','R',
     >'M','A','C','H','H','A','R','D','B','E','A','M',
     >'D','E','T','A','G','E','O','M','L','I','N','E','M','I','S','A',
     >'E','R','R','O','S','E','T','M','S','E','T','E','S','E','E','D',
     >'A','L','I','G','R','E','F','E','C','O','R','R','S','E','T','C',
     >'S','Y','N','C','E','L','E','M','M','I','N','I'
     >/
caab changed noper to 24
      NOPER=24
      DO 1 IO=1,NOPER
      DO 2 JO=1,4
      IF(ITITOP(JO).NE.IOP(JO,IO))GOTO 1
    2 CONTINUE
      GOTO 4
    1 CONTINUE
    3 WRITE(IOUT,10010)
10010 FORMAT(/,'   ERROR IN OPERATION NAME : JOB STOPPED ')
      CALL HALT
      STOP
    4 IF(IO.LE.2)KOD=100+(IO-1)*10
      IF((IO.GT.2).AND.(IO.LE.6))KOD=(IO-1)*100
      IF((IO.GE.7).AND.(IO.LE.8))KOD=500+(IO-6)*10
      IF(IO.EQ.9)KOD=515
caab  kod is assigned to mini by this formula 
caab  io=24 therefore kod is assigned the value 20000 
      IF(IO.GE.10)KOD=(IO-4)*100
      RETURN
      END 
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ICHAR(6) - CHARACTER BUFFER FOR DESCRIPTION OF MACHINE NAMES
C PARM(400) - PARAMETER BUFFER DESCRIPTION OF MACHINE ELEMENT PARAMETERS
C     TITLE(20) - TITLE OF THE RUN
CDATA(2) - USED TO INPUT
CNNAME(4) - INPUT BUFFER FOR THE MACHINE DURING MACHINE DEFINITION
CNCARD(73) - NOT USED
CKCHARS(15) - VALID START CHARACTERS FOR THE MACHINE ELEMENT NAMES
CKCODE(15) - CORRESPONDING CODES FOR THE MACHINE ELEMENTS
COPLIST(1600) - BUFFER FOR INPUT OF PARAMETERS FOR AN OPERATION
C
cdlr change data(2) to data(5) 7/23/84
      DIMENSION ICHAR(6),PARM(400),TITLE(20),DATA(5),NNAME(4)
     +,KCHARS(15),KCODE(15),OPLIST(1600)
	common /trkfit/displace,xstart(5),en(15)
	common /opname/noptype(4)
      DIMENSION ITITOP(80),MFIT(4)
C
CUNNAMED COMMON
C     AMAT(350,6,27) - EACH ELEMENT ON INPUT HAS A MATRIX COMPUTED
CFOR IT. IT WILL TAKE ONE OF THE 6X27 LEVELS - EACH ELEMENT HAS A 6X27
CMATRIX ASSOCIATED WITH IT.
CNORLST2500) - THE ORDER LIST OF THE ELEMENTS
C     XPEL(350) - HORIZONTAL BOUNDARIES FOR THE ELEMENTS
C     YPEL(350) - VERTICAL BOUNDARIES FOR THE ELEMENTS
CEXPEL - EXPULSION FACTOR
CN - NUMBER OF CURRENT ELEMENT BEING PROCESSED.
CLOGPAR(350) - LOGICAL VALUES TO INDICATE WHETHER PARTICLES
CARE LOST OR NOT IN CERTAIN OPERATIONS
C
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
c
c  common gplot holds parameters for plotting with grinnel or versatec
c  igplot=1 then plot, idev=1 grinnel,2=versatec,  ndispl=grinnel number
	common /gplot/igplot,idev,ndispl
C
CCOMMON/INOUT/
CIIN - INPUT LOGICAL UNIT NUMBER
CIOUT - OUTPUT LOGICAL UNIT NUMBER
C
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
C
CCOMMON/INPUTT/
CKODE(350) - CODES OF THE MACHINE ELEMENTS
CNAME(350,4) - 4 CHARACTER NAMES OF THE MACHINE ELEMENTS
CIADR(350) - POINTER INTO ELDAT FOR PARAMETERS OF THE
CMACHINE ELEMENTS
CELDAT(5000) - PARAMETERS FOR THE MACHINE ELEMENTS
CMADR(350) - LEVEL IN AMAT(I,6,27) WHICH THE ELEMENT
CMATRIX RESIDES.
CKCOUNT - KICK COUNT
C
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
C
CCOMMON /CONST/ - CONSTANTS
C
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
C
c
c  temp1 holds transfer from nelstrt to nelend
CCOMMON/MAT/GENERAL USE
CTEMP(6,27) - TEMPORARY MATRIX STORAGE      
CNORDER - 1 - COMPUTE TO FIRST ORDER
C 2 - COMPUTE TO SECOND ORDER
CMPRINT - PRINT CONTROL - SEE MANUAL
CNELM - NUMBER OF MACHINE ELEMENTS
CNOP -
CNLIST(40) - PRINTING LIST
C
	common /mat1/temp1(6,27),iflag1,nelstrt,nelend
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
C
CCOMMON/FUNC/OP CODE 5NN
CBETAX ... ETAPY -
CMFPRNT - PRINT CONTROL - SEE MANUAL
CKOD - OPERATION CODE
CSTARTE - START ENERGY
CENDE - END ENERGY
CDELTAE - CHANGE IN ENERGY
C       NLUM - 0 NO LUM COMPUTATIONS, 1 LUM COMPUTATIONS
C       DNU - DNU MAXIMUM ADOPTED FOR LUM COMPUTATIONS
C       NINT - NUMBER OF INTERACTION POINTS
C       NBUNCH - NUMBER OF BUNCHES.USUALLY NINT=2*NBUNCH
C
      COMMON/FUNC/BETAX,ALPHAX,ETAX,ETAPX,BETAY,ALPHAY,ETAY,ETAPY,
     <  STARTE,ENDE,DELTAE,DNU,MFPRNT,KOD,NLUM,NINT,NBUNCH
      COMMON/LAYOUT/XHI,YHI,ZHI,THETAI,PHIHI,PSIHI,CONVH,
     >SRH,XRH,YRH,ZRH,THETAR,PHIRH,PSIRH,NLAY,NLAYDUM
C
CCOMMON/LENGTH/ TLENG - TOTAL LENGTH OF MACHINE
C
C     ALENG(350) - BUFFER TO RECORD THE LENGTHS OF EACH ELEMENT
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
C
CCOMMON/PLT/OP CODE 300
CNPLOT - PLOT CONTROL - SEE MANUAL
CNCCUM - 0 - ACCUMULATE THE PLOT
C1 - DONT ACCUMULATE THE PLOT
CNGRAPH - 1,2,3,4,11,12,13,14 - SEE MANUAL FOR DESCRIPTION
CNCOL - NUMBER OF COLUMNS IN PLOT
CNLINE - NUMBER OF LINES IN PLOT
CFOR THE PLOT AXES:
CYPMAX - Y' MAXIMUM
CXPMIN - X' MINIMUM
CXPMAX - X' MAXIMUM
CXMIN - X MINIMUM
CXMAX - X MAXIMUM
CYMIN - Y MINIMUM
CYMAX - Y MAXIMUM
CYPMIN - Y' MINIMUM
CMXXPR(101,51) - X,X' PLOT MATRIX
CMYYPR(101,51) - Y,Y' PLOT MATRIX
CMXY(101,51) - X,Y PLOT MATRIX
CMALL - 0 - DO ALL THE PLOTS X,X'; Y,Y'; X,Y
C       1 - DO ONLY THAT CALLED FOR BY NGRAPH
C
      COMMON/PLT/
     1XMIN,XMAX,YMIN,YMAX,XPMIN,XPMAX,YPMIN,YPMAX,
     >DELMIN,DELMAX,DNUMIN,DNUMAX,DBMIN,DBMAX,
     2MXXPR,MYYPR,MXY,MALL,NPLOT,NCCUM,NGRAPH,NCOL,NLINE
C
CCOMMON/TRACE/OP CODE 300
CPART(350,6),DEL(350) - DATA FOR UP TO 350 PARTICLES
CNPART - NUMBER OF PARTICLES
CNCPART - NUMBER OF CURRENT PARTICLES
CNPRINT - PRINT CONTROL - SEE MANUAL
CNCTURN - NUMBER OF CURRENT TURN
CNPTOT - TOTAL NUMBER OF POSSIBLE PARTICLES
CMLOCAT - SEE MANUAL
CNTURN - NUMBER OF TURNS
C
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN,
     <  NPTOT,MLOCAT,NTURN
      DOUBLE PRECISION M(5,5)
      DIMENSION A(25),B(16),Q(4,4)
      EQUIVALENCE (M(1,1),A(1)), (Q(1,1),B(1))
      COMMON/TRI/WCO(15,6),GEN(5,4),PGEN(75,6),DIST,
     <A1(15),B1(15),A2(15),B2(15),XCOR(3,15),XPCOR(3,15),
     1AL1(15),AL2(15),MESH,NIT,NENER,NITX,NITS,NITM1,NANAL,NOPRT
c  middle holds flags for intermediate transfer matrix calculation
c    as part of operation MOVEMENT
c  interm=1	Calculate transfers at bends only
c  interm=2	Calculate transfers at quads only
c  interm=3	Calculate transfers at bends and quads
c        =4	At all elements
c        =5	At symmetry point (opposite IR)
c        =0	No calc of intermediate transfers
c  intprt	Print flag in subroutine transave that calcs transfers
c  iemitt =1	Calculate decoupled u v emittance, interm=1 or 3
c  idec   =1	Do Decoupled movement analysis
c  idec   =2	Calculate beam and error matrices
c  emit(2)    u,v emittances
	common /middle/emit(2),interm,intprt,iemitt,idec,nesave(2000)
      COMMON /MVT/ U(5,4)
      COMMON/CLSQ/ALSQ(15,2,4),IXY,NCOEF,NAPLT,JENER,LENER(15)
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/CBEAM/BSIG(6,6),BSIGF(6,6),MBPRT,nform
      COMMON/DETL/DENER(15),NH,NV,NVH,NHVP(105),MDPRT,NDENER,
     1NUXS(45),NUX(45),NUYS(45),NUY(45),NCO,NHNVHV,MULPRT,NSIG
      COMMON/GEOM/XCO,XPCO,YCO,YPCO,NCASE,NJOB,
     <            EPSX(10),EPSY(10),XI(10),YI(10),XG(300,10),
     <            XPG(300,10),YG(300,10),YPG(300,10),LCASE(10)
      COMMON/ERR/ERRVAL(7,50),NERELE(50),NERPAR(7,50),NERR,NEROPT,
     > NERRE,MERSEL(50),NERNGE(50),MERNGE(2,10,50),MERFLG
      COMMON/MIS/RMISA(7,50),MISELE(50),NMIS,ISEED,IXS,NOPT,
     > NMISE,MISSEL(50),NMRNGE(50),MSRNGE(2,10,50),MISFLG,MCHFLG
      COMMON/FITL/COEF(20,6),VALF(20),WGHT(20),RVAL(20),XM(20)
     >  ,EM(20),WV,NELF(20,6),NPAR(20,6),IND(20,6),NPVAR(20),NVAL(20)
     >  ,NSTEP,NVAR,NCOND,ISTART,NDIV,IFITM,IFITD
      COMMON/ANALC/COMPF,RNU0X,CETAX,CETAPX,CALPHX,CBETAX,
     1RMU1X,CHROMX,ALPH1X,BETA1X,
     1RMU0Y,RNU0Y,CETAY,CETAPY,CALPHY,CBETAY,
     1RMU1Y,CHROMY,ALPH1Y,BETA1Y,RMU0X,
     >COSX,ALX1,ALX2,VX1,VXP1,VX2,VXP2,
     >COSY,ALY1,ALY2,VY1,VYP1,VY2,VYP2,NSTABX,NSTABY,NSTAB,NWRNCP
      COMMON/MONIT/VALMON(12,4,3),MNAME(600,4),MONPOS(600),NMON
      COMMON/MONFIT/VALFA(12),WGHTA(12),ERRA(12),
     >AMULTA(12,6),ADDA(12,6),DELA(12),NPARA(12,6),NELFA(12,6),
     >NPVARA(12),INDA(12,6),VALR(12),
     >NMONA(12),NVALA(12),NVARA,NCONDA,IALFLG,MONFLG,MONLST,NOPTER,
     >IAFRST,ISDBEG,IMONSD,IMSBEG
      COMMON/CORR/CORVAL(600,4),ICRID(600),ICRPOS(600),ICRSET(600),
     >ICROPT(600),NCORR,NCURCR,ICRFLG,ICRCHK,ALMNEL,NPARC
      COMMON/ORBIT/SIZEX,SIZEY,RMSX,RMSY,RMSIX,RMSIY,
     >RTEMPX,RTEMPY,RMSPX(5),RMSPY(5),RPX,RPY,
     >RMAXX,RMAXY,RMINX,RMINY,MAXX,MAXY,MINX,MINY,PLENG,
     >IRNG,IRANGE(5),NPRORB,IORB,IREF,IPAGE,IPOINT
      COMMON/SYNC/ENOM,SYNDEL,ISYNFL,ISYNGO
	common /twiher/npnt,jfite(10),ipnt
      LOGICAL LOGPAR,MXXPR(101,51),MYYPR(101,51),MXY(101,51),LENER

caab ******************************************************************
caab miniinvoke is a 'switch'.It has value 1 if the operation mini
caab has been invoked,0 otherwise . It suspends some output in
caab the subroutine matrix in this case;
caab namely, the subroutines prmat and pranal
caab It can be found in mydimain,mymatrix, extdetaddelta,
caab mini,and myanal, as well as initbetas
caab for detaddelta, betas,ibeta_adr see the documentation.
caab such declarations of type should appear. however i have 
caab systematically not done so and conformed to the implicit
caab typing used in the rest of dimain
caab      integer miniinvoke,initbeta_count,ibeta_adr(2000)
caab      real detaddelta,betas(2000,2)
		
	common/minia/detaddelta,betas(2000,2),
     1               ibeta_adr(2000),initbeta_count,miniinvoke
C
C   SET UP THE DATA AND CONSTANTS
C
C *********** WARNING CODE 11 IS RESERVED INTERNALLY DO NOT USE CODE 11
C
      DATA KCHARS/'A','B','C','D','E','F','G','H','K','L','M','Q'
     >,'S','T','V'/
      DATA MFIT/'F','I','T',' '/
      DATA KCODE/12,14,7,4,15,0,10,1,8,6,5,2,3,9,13/
      DATA IEL/1/,ITOT/2500/
      DATA IH/'H'/,IV/'V'/,IB/'B'/,IP/'P'/,IBL/' '/
      DATA IBRKT/'('/,ISTAR/'*'/,IAT/'@'/
	data ionce/0/
cdlr     CALL ERRSET(207,300,1,1,1,0)
      NJOB=0
      N=1
      NORDER=2
      NOF=27
      KCOUNT=0
      NA=1
      PI=3.1415926535897932D0
      DATA NINE/'9'/
      TWOPI= PI * 2.0D0
      CRDEG = PI/180.0D0
      CMAGEN = 10.0D0/.299792458D0
      CLIGHT = 2.997924580D+08
C     ELECTRON MASS GIVEN IN GEV !!!
      EMASS = 0.5110041D-03
      ERAD = 2.8179380D-15
      ECHG = 1.6021892D-19
      NPTOT=350
      NPART=0
      NTURN=0
      MERFLG=0
      ISYNFL=0
      MISFLG=0
      ICRFLG=0
      MCHFLG=0
      DO 131 JB=1,6
  131 BSIG(JB,JB)=1.0D0
      DO 776 I=1,NPTOT
776   LOGPAR(I)=.TRUE.
C
C   OPEN THE INPUT AND OUTPUT FILES
C
      CALL SETUP
C
      WRITE(IOUT,99997)
99997 FORMAT(////////,18X
     >,'*****************************************************',//,18X
     >,'* DIMAT PROGRAM : LAST MODIFIED ON FEBRUARY 16 1984 *',//,18X
     >,'*****************************************************',///)
C  INPUT TITLE
C
      READ(IIN,9999)TITLE
      WRITE(IOUT,19998)TITLE
19998 FORMAT(///,10X,20A4,/,'1')
      WRITE(IOUT,19999)TITLE
9999  FORMAT(20A4)
19999 FORMAT(//,10X,20A4,//)
C
C   INPUT EXPULSION FACTOR
C
      NCHAR=0
      NDIM=5
      NDATA=5
      NIPR=0
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NIPR)
      EXPEL=DATA(1)
	itypel=data(2)	!>0 -print element list, >1 -print machine list
	igplot=data(3)
	idev=data(4)
	ndispl=data(5)
      WRITE(IOUT,10020)EXPEL,itypel,igplot,idev,ndispl
10020 FORMAT('  EXPULSION FACTOR FOR PARTICLES IS :',F6.2,3x,4i3/)
C
C   GET THE ALPHA CODE FOR THE ELEMENT
C
    5  NCHAR=4
      NDIM=0
      NDATA=1
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NIPR)
C
C   CHECK FOR END FLAG
C
      IF(ICHAR(1).EQ.NINE.AND.ICHAR(2).EQ.NINE) GO TO 99
C
C   DECODE THE CHARACTERS INTO THEIR CORRECT CODE
C
      DO 10 J=1,15
      IF(ICHAR(1).EQ.KCHARS(J)) GO TO 30
10    CONTINUE
      WRITE(IOUT,20)ICHAR(1)
      IF(ISO.NE.0)WRITE(ISOUT,20)ICHAR(1)
20    FORMAT(' INCORRECT START CODE :',5X,A1)
      CALL HALT
      STOP
C     ***********************
C
C   GET THE CODE OF THE ELEMENT AND THE MATRIX ADDRESS
C          CODE 12 HAS NO MATRIX
C
C  *********** WARNING CODE 11 IS RESERVED INTERNALLY
C
 30   KODE(NA)=KCODE(J)
      MADR(NA)=0
      IF(KODE(NA).EQ.12) GO TO 35
      MADR(NA) = N
      N=N+1
35    CONTINUE
C
C   GET THE NAME OF THE ELEMENT
C
      DO 40 I=1,4
      NAME(NA,I)=ICHAR(I)
40    CONTINUE
C
C   GET THE PARAMETERS
C
      NC=-1
      NDIM=400
      NIPR=0
      NCHAR=0
      CALL INPUT(ICHAR,NCHAR,PARM,NDIM,IEND,NC,NIPR)
      NAM=NAME(NA,1)
      IF((NAM.EQ.IH).OR.(NAM.EQ.IV).OR.(NAM.EQ.IB))GOTO 51
      if(itypel.ge.2)
     &	  WRITE(IOUT,10003)(NAME(NA,I),I=1,4),(PARM(J),J=1,NC)
10003 FORMAT(' ',4A1,7(F17.9),44(/,5X,7(F17.9)))
      GOTO 52
   51 if(itypel.ge.2)
     &	  WRITE(IOUT,11003)(NAME(NA,I),I=1,4),(PARM(J),J=1,NC)
11003 FORMAT(' ',4A1,2(F17.9),2(E17.9),3(F17.9),44(/,5X,7(F17.9)))
   52 XPEL(NA)=PARM(NC-1)
      YPEL(NA)=PARM(NC)
C
C   GET ADDRESS OF THE PARAMETERS
C
      IADR(NA)=IEL
C
C   PUT THE PARAMETERS IN THE BUFFER
C
      DO 50 J=1,NC
      ELDAT(IEL-1+J)=PARM(J)
50    CONTINUE
      NA=NA+1
      IF(NA.GT.350)GOTO6
      IEL=IEL+NC
      GO TO 5
    6 WRITE(IOUT,10999)
10999 FORMAT('  TOO MANY DISTINCT ELEMENTS IN ELEMENT LIST : 350 MAX.'
     >,/,'   REDUCE NUMBER OF ELEMENTS OR INCREASE DIMENSION OF ',/,
     >'  ARRAYS : AMAT,XPEL,YPEL,KODE,NAME,IADR,MADR AND CONSTANT IN',
     >/,'  STATEMENT : IF(NA.GT.350)GOTO6 IN PROGRAM MAIN'
     >,'AND N.LE.150 IN STATEMENT CONTAINING GOTO8765 IN PROMAT')
      STOP
C
C   THIS IS THE END OF THE ELEMENT DESCRIPTION SECTION
C
99    CONTINUE
      IADR(NA) = IEL
      N=0
      NA=NA-1
      IEL=IEL-1
C
C  GET LIST OF MACHINE COMPONENTS
C
      if(itypel.ge.1)WRITE(IOUT,10011)
10011 FORMAT(//,27H LIST OF MACHINE COMPONENTS,//)
      NELM=0
      NMON=0
      IEND=0
      NCHAR=4
      NFIT=0
      IFITE=0
      NDIM=0
      NPRINT=2
	if(itypel.lt.1)nprint=0
   55 NELM=NELM+1
      IF(NELM.LE.ITOT)GOTO 61
      WRITE(IOUT,62)
   62 FORMAT('  TO MANY MACHINE ELEMENTS ')
      CALL HALT
      STOP
  61  CALL INPUT(NNAME,NCHAR,OPLIST,NDIM,IEND,NOP,NPRINT)
      IF(NNAME(1).EQ.IBL)GOTO 57
C  CHECK FOR LETTER P INDICATING POSITION MONITOR
      IF(NNAME(1).EQ.IP)GOTO 63
C  CHECK IF NAME = FIT
      DO 59 IFF=1,4
      IF (NNAME(IFF).NE.MFIT(IFF))GO TO 60
   59 CONTINUE
      GOTO 56
   60 CALL ELID(NNAME,NELID)
      NORLST(NELM)=NELID
      IF(IEND.EQ.1)GOTO57
      GOTO 55
   56 NFIT=NFIT+1
      IF(NFIT.GT.10)GOTO 58
      IFITE=NELM-1
	jfite(nfit)=ifite
      NELM=IFITE
	npnt=nfit
      GOTO 55
   58 WRITE(IOUT,10012)
10012 FORMAT(' TOO MANY FIT POINTS, ONLY ONE RETAINED')
      GOTO 55
C  STORE MONITOR NAME AND POSITION DO NOT INCREMENT ELEMENT #
   63 NMON=NMON+1
      DO 64 INM=1,4
   64 MNAME(NMON,INM)=NNAME(INM)
      NELM=NELM-1
      MONPOS(NMON)=NELM
      IF(IEND.EQ.1)GOTO 57
      GOTO 55
   57 IEND = 0
C  SET WARNING ABOUT #S WHEN MONITORS ARE PRESENT
      IF(NMON.NE.0)WRITE(IOUT,10201)
10201 FORMAT(/,' ***** WARNING : MONITORS ARE PRESENT IN THE LIST OF',
     >' THE MACHINE. THEY ARE FLAGS ONLY!! AND DO NOT !!COUNT!! AS ',/
     >,' ELEMENTS IN THE ELEMENT NUMBER COUNT  **********',//)
       CALL LENG
      WRITE(IOUT,10111)TLENG
10111 FORMAT(//,' TOTAL LENGTH OF MACHINE IS:',F10.3,' METERS',/)
C
C     CALL THE RELEVENT ROUTINE TO CREATE THE MATRIX
C     AMAT(N,6,27) ACCORDING TO THE CODE "KODE"
C
      DO 120 ILK=1,NA
      CALL MATGEN(ILK)
120   CONTINUE
      IF(KCOUNT.EQ.0) GO TO 130
      WRITE(IOUT,140)KCOUNT
140   FORMAT(//' WARNING ',I4,' MATRICES COMPUTED FOR REAL KICKS'//)
      WRITE(IOUT,10200)
10200 FORMAT('1')
130   CONTINUE
      WRITE(IOUT,19999)TITLE
      miniinvoke=0	
C
C   READ AN OPERATION CODE
C
      WRITE(IOUT,10021)
10021  FORMAT(17H OPERATION LIST ,///)
99131 READ(IIN,9998)ITITOP
 9998 FORMAT(80A1)
      KCOM=0
      IC1=ITITOP(1)
      IF((IC1.EQ.IBRKT).OR.(IC1.EQ.ISTAR).OR.(IC1.EQ.IAT))KCOM=1
      IF(KCOM.EQ.1)WRITE(IOUT,9996)ITITOP
 9996 FORMAT('   ',80A1)
      IF(KCOM.EQ.1) GOTO 99131
      WRITE(IOUT,9997)ITITOP
 9997 FORMAT(/,'   ',80A1,//)
C
C     DETERMINE THE OPERATION CODE
C
      CALL OPTITL(ITITOP,KOD)
cdlr
	do idlr=1,4
	  noptype(idlr)=ititop(idlr)
	  end do
cdlr
      IKOD=(KOD+1)/100
      MDPRT=-2
      NANAL=0
      IREF=0
      NLAY=0
      IALFLG=0
      MONFLG=0
      IFITM=0
      IFITD=0

caab 20000 in goto added by aab. causes branch to mini subroutine

      GO TO (1000,2000,3000,4000,5000,6000,7000,8000
     >,9000,10000,11000,12000,13000,14000,15000,16000,17000
     >,18000,19000,20000),IKOD
      WRITE(IOUT,10010)
10010 FORMAT(24H ERROR IN OPERATION CODE)
      NOP=-1
      NCHAR=0
      NDIM=1600
      NIPR=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NIPR)
      GO TO 99000
 1000 IF(KOD.EQ.100)CALL FITMAT(IEND)
      IF(KOD.EQ.110)CALL FITLSQ(IEND)
      GO TO 99000
C              SUBPROGRAM TWISS ANALYSIS
2000  NOP=-1
      NCHAR=0
      NDIM=1600
      NIPR=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NIPR)
      NTURN=OPLIST(2)
      NOPRT=OPLIST(1)
      NPLOT=-2
      NPRINT=-2
      MLOCAT=0
      DO 3 I=1,NPTOT
 3    LOGPAR(I)=.TRUE.
      DO 214 ILE=1,15
  214 LENER(ILE)=.TRUE.
      NANAL=OPLIST(3)
      NITS=OPLIST(4)-.1
      NIT=ABS(OPLIST(4))+.1
      NITM1=NIT-1
      NENER=OPLIST(5)+.01
      IF(NENER.GT.15)GO TO 221
      NCOEF=OPLIST(6)
      IF(NCOEF.GT.9)GO TO 222
      GO TO 223
  221 WRITE(IOUT,10004)
      IF(ISO.NE.0)WRITE(ISOUT,10004)
      GO TO 99000
10004 FORMAT('******TOO MANY ENERGIES:OPERATION STOPPED******')
  222 WRITE(IOUT,10005)
      IF(ISO.NE.0)WRITE(ISOUT,10005)
10005 FORMAT('**TOO MANY COEFS REQUESTED:VALUE DEFAULTED TO 9***')
      NCOEF=9
  223 DIST=OPLIST(7)
      DO 42 I=1,NENER
	displace=dist
      DO 208 J=1,5
	xstart(j)=oplist(7+j)
  208 WCO(I,J)=OPLIST(7+J)
	en(i)=oplist(12+i)
   42 WCO(I,6)=OPLIST(12+I)
	interm=oplist(13+nener)
	intrm=0
	if(interm.lt.0)intrm=iabs(interm)
      do 209 j=1,intrm
  209	nesave(j)=oplist(13+nener+j)
	intprt=oplist(14+nener+intrm)
	iemitt=oplist(15+nener+intrm)
	idec=oplist(16+nener+intrm)
	if ((iemitt.eq.0).and.(emit(1).eq.0.).and.(emit(2).eq.0.)) then
	   emit(1)=oplist(17+nener+intrm)
	   emit(2)=oplist(18+nener+intrm)
	end if
	nplus=6
      NAPLT = OPLIST(13+nener+intrm+nplus)
      DELMIN = OPLIST(14+nener+intrm+nplus)
      DELMAX = OPLIST(15+nener+intrm+nplus)
      DNUMIN = OPLIST(16+nener+intrm+nplus)
      DNUMAX = OPLIST(17+nener+intrm+nplus)
      DBMIN = OPLIST(18+nener+intrm+nplus)
      DBMAX = OPLIST(19+nener+intrm+nplus)
      NCOL = OPLIST(20+nener+intrm+nplus)
      NLINE = OPLIST(21+nener+intrm+nplus)
      NITX=0
      CALL ENANAL
      NANAL=0
      GOTO 99000
C
C   PARTICLE TRACING OPERATION, GET PARAMETERS
C
3000  NOP=-1
      NCHAR=0
      NDIM=1600
      NIPR=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NIPR)
      NPLOT=OPLIST(1)+SIGN(0.02D0,OPLIST(1))
      NPRINT=OPLIST(2)+SIGN(0.02D0,OPLIST(2))
C
C   PLOTTING PARAMETERS
C
      NTENT = ABS(OPLIST(3))*6+5
      IF(NPRINT.LE.0) GO TO 3070
      NTENT = NTENT+2*OPLIST(NTENT)+1
 3070 IF(NPLOT.LT.0) GO TO 3050
C
C   SET UP PARAMETERS
C
      NGRAPH = OPLIST(NTENT)
      XMIN = OPLIST(NTENT+1)
      XMAX = OPLIST(NTENT+2)
      XPMIN = OPLIST(NTENT+3)
      XPMAX = OPLIST(NTENT+4)
      YMIN = OPLIST(NTENT+5)
      YMAX = OPLIST(NTENT+6)
      YPMIN = OPLIST(NTENT+7)
      YPMAX = OPLIST(NTENT+8)
      NCOL = OPLIST(NTENT+9)
      NLINE = OPLIST(NTENT+10)
      IF((NCOL.GT.0.AND.NCOL.LT.102). AND .
     +           (NLINE.GT.0.AND.NLINE.LT.52)) GO TO 3060
      WRITE(IOUT,10310)
10310 FORMAT(' ERROR IN NUMBER OF LINES OR COLUMNS: DEFAULT VALUES'
     +         ,'USED: 101,51')
      NCOL = 101
      NLINE = 51
      GO TO 3060
C
C   SET PARAMETERS FOR NO PLOTTING
C
 3050 XMIN = 0.0
      XMAX = 0.0
      XPMIN = 0.0
      XPMAX = 0.0
      YMIN = 0.0
      YMAX = 0.0
      YPMIN = 0.0
      YPMAX = 0.0
      NCOL = 0
      NLINE = 0
C
C   DETERMINE MODE OF PLOTTING
C
 3060 MALL = 1
      NCCUM = 1
      IF(NGRAPH.GT.10) NCCUM = 0
      IF(NGRAPH.GT.10) NGRAPH = NGRAPH-10
      IF(NGRAPH.EQ.4) MALL = 0
C
C   PRINTING PARAMETERS
C
      IF(NPRINT)3007,3007,3002
3002  I=ABS(OPLIST(3))+.01D0
      MLOCAT=OPLIST(5+I*6)
      IF(MLOCAT.EQ.0)GOTO 3007
      DO 3005 JM=1,MLOCAT
      INDJM=2*JM-1
      INDOP=INDJM+5+I*6
      NLIST(INDJM)=OPLIST(INDOP)
 3005 NLIST(INDJM+1)=OPLIST(INDOP+1)
3007  CONTINUE
C
C   NOPA - NUMBER OF PARTICLES ADDED
C
      NOPA=0
      IF(OPLIST(3))3010,3030,3020
C
C   NEGATIVE NPART, NPART PARTICLES ARE ADDED
C
3010  NOPA=ABS(OPLIST(3))
      NTURN=NTURN+OPLIST(4)+.02D0
C
C   GET PARTICLE DATA FOR NEW PARTICLES
C
      DO 315 I=1,NOPA
      I1=NPART+I
      I2=6*I-1
      PART(I1,1)=OPLIST(I2)
      PART(I1,2)=OPLIST(I2+1)
      PART(I1,3)=OPLIST(I2+2)
      PART(I1,4)=OPLIST(I2+3)
      PART(I1,5)=OPLIST(I2+4)
      PART(I1,6)=OPLIST(I2+5)
      DEL(I1)=OPLIST(I2+5)
315   CONTINUE
      NPART=NPART+NOPA
      NCPART=NCPART+NOPA
      GO TO 3040
C
C   POSITIVE NPART, OLD PARTICLES DELETED, NPART PARTICLES ADDED
C
3020  NPART=OPLIST(3)
      NCTURN=0
      NTURN=OPLIST(4)+0.02D0
      DO 3022 I=1,NPTOT
3022  LOGPAR(I)=.TRUE.
      NCPART=NPART
      DO 3025 I=1,NPART
      I2=6*I-1
      PART(I,1)=OPLIST(I2)
      PART(I,2)=OPLIST(I2+1)
      PART(I,3)=OPLIST(I2+2)
      PART(I,4)=OPLIST(I2+3)
      PART(I,5)=OPLIST(I2+4)
      PART(I,6)=OPLIST(I2+5)
      DEL(I)=OPLIST(I2+5)
3025  CONTINUE
      GO TO 3040
C
C   NPART=0, EXISTING PARTICLES KEPT, NONE ADDED
C
3030  CONTINUE
      NTURN=NTURN+OPLIST(4)+0.02D0
3040  CALL TRACKT
      IF(NCPART.NE.0) GO TO 99000
      WRITE(IOUT,10066)
      IF(ISO.NE.0)WRITE(ISOUT,10066)
10066 FORMAT('  WARNING--RUN STOPPED DUE TO LOSS OF PARTICLES')
      GO TO 99000
C
C     GET THE NUMBER OF VARIES TO BE DONE
C
4000  NOP=1
      NCHAR=0
      NDIM=1
      NIPR=1
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NOP,NIPR)
      NV = DATA(1)
C
C     VARY 'NV' PARAMETERS
C
      DO 4003 IV=1,NV
C
C     GET THE ELEMENT NAME AND TWO PARAMETERS
C
      NOP=1
      NCHAR=4
      NDIM=0
      NIPR=1
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NOP,NIPR)
C
C     MATCH THE NAME
C
      DO 4002 J=1,NA
      DO 4001 K=1,4
      IF (ICHAR(K).NE.NAME(J,K)) GO TO 4002
4001  CONTINUE
C
C     FOUND EQUAL NAMES
C
      NOP=2

      NCHAR=0
      NDIM=2
      NIPR=1
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NOP,NIPR)
      NVPAR = DATA(1)
      VARVAL = DATA(2)
      CALL VARY (J,NVPAR,VARVAL)
      GO TO 4003
4002  CONTINUE
C
C     ERROR COULDN'T FIND THIS ELEMENT
C
      WRITE(IOUT,4010) (ICHAR(K),K=1,4)
      IF(ISO.NE.0)WRITE(ISOUT,4010) (ICHAR(K),K=1,4)
4010  FORMAT(/,' COULDNT MATCH ELEMENT',2X,4A1,' IN OPERATION 400'/)
4003  CONTINUE
      GO TO 99000
C
C     OPERATION CODE:  500, 510 OR 520
C
5000  NOP = -1
      NCHAR=0
      NDIM=1600
      NIPR=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NIPR)
      IF(KOD.EQ.500) GO TO 5001
      IF(KOD.EQ.510) GO TO 5100
      IF(KOD.EQ.515) GO TO 5500
      IF(KOD.EQ.520) GO TO 5200
      WRITE(IOUT,10010)
      GO TO 99000
C
C   MATRIX COMPUTATION
C
5001  NORDER = OPLIST(1)
      NMAT=0
      IF(NORDER.LT.0)NMAT=1
      NORDER=ABS(OPLIST(1))
      MPRINT = OPLIST(2)
      MFPRNT = -2
	nelstrt=oplist(3)
	nelend=oplist(4)
      IF(MPRINT.LE.0) GO TO 5010
      MLOCAT=MPRINT
      DO 5005 JM=1,MPRINT
      INDJM=2*JM-1
      INDOP=INDJM+2+2
      NLIST(INDJM)=OPLIST(INDOP)
 5005 NLIST(INDJM+1)=OPLIST(INDOP+1)
5010  CALL MATRIX
      NMAT=0
      GO TO 99000
C
C   FUNCTION COMPUTATION
C
5100  STARTE = OPLIST(1)
      ENDE = OPLIST(2)
      DELTAE = OPLIST(3)
      NLUM = OPLIST(4)
      DNU = OPLIST(5)
      NINT = OPLIST(6)
      NBUNCH = OPLIST(7)
      IF(OPLIST(8).EQ.0.0D0)GOTO 5101
      BETAX = OPLIST(8)
      ALPHAX = OPLIST(9)
      ETAX = OPLIST(10)
      ETAPX = OPLIST(11)
      BETAY = OPLIST(12)
      ALPHAY = OPLIST(13)
      ETAY = OPLIST(14)
      ETAPY = OPLIST(15)
      GOTO 5102
 5101 BETAX = CBETAX
      ALPHAX = CALPHX
      ETAX = CETAX
      ETAPX = CETAPX
      BETAY = CBETAY
      ALPHAY = CALPHY
      ETAY = CETAY
      ETAPY = CETAPY
5102  WRITE(IOUT,5120)
5120  FORMAT(/,' ELEMENT #    BETAX     ALPHAX    BETAY     ALPHAY  ',
     <   '   ETAX     ETAPX      ETAY     ETAPY        NUX      NUY'
     <,'     LENGTH    ACC.LEN',/)
      WRITE(IOUT,5125)BETAX,ALPHAX,BETAY,ALPHAY,ETAX,ETAPX,ETAY,ETAPY
5125  FORMAT(/,11X,F10.3,F10.4,F10.3,F10.4,4F10.5)
      MFPRNT = OPLIST(16)
      MPRINT = MFPRNT
      NORDER = 1
      IF (MFPRNT.LE.0) GO TO 5110
      MLOCAT=MFPRNT
      DO 5105 JM=1,MFPRNT
      INDJM=2*JM-1
      INDOP=INDJM+16
      NLIST(INDJM)=OPLIST(INDOP)
 5105 NLIST(INDJM+1)=OPLIST(INDOP+1)
5110  CALL MATRIX
      GO TO 99000
C
C   HALFWAY POINT COMPUTATION
C
5200  STARTE = OPLIST(1)
      XHI=OPLIST(2)
      YHI=OPLIST(3)
      ZHI=OPLIST(4)
      THETAI=OPLIST(5)
      PHIHI=OPLIST(6)
      PSIHI=OPLIST(7)
      CONVH=OPLIST(8)
      MFPRNT = OPLIST(9)
      IF(MFPRNT.LE.0) GO TO 5210
      MLOCAT=MFPRNT
      DO 5205 IL=1,MFPRNT
      INDIL=2*IL-1
      INDOP=INDIL+9
      NLIST(INDIL)=OPLIST(INDOP)
 5205 NLIST(INDIL+1)=OPLIST(INDOP+1)
5210  CALL HWPNT
      GO TO 99000
 5500 BSIG(1,1)=OPLIST(1)
      BSIG(1,2)=OPLIST(2)
      BSIG(1,3)=OPLIST(3)
      BSIG(1,4)=OPLIST(4)
      BSIG(1,5)=OPLIST(5)
      BSIG(1,6)=OPLIST(6)
      BSIG(2,2)=OPLIST(7)
      BSIG(2,3)=OPLIST(8)
      BSIG(2,4)=OPLIST(9)
      BSIG(2,5)=OPLIST(10)
      BSIG(2,6)=OPLIST(11)
      BSIG(3,3)=OPLIST(12)
      BSIG(3,4)=OPLIST(13)
      BSIG(3,5)=OPLIST(14)
      BSIG(3,6)=OPLIST(15)
      BSIG(4,4)=OPLIST(16)
      BSIG(4,5)=OPLIST(17)
      BSIG(4,6)=OPLIST(18)
      BSIG(5,5)=OPLIST(19)
      BSIG(5,6)=OPLIST(20)
      BSIG(6,6)=OPLIST(21)
	nform=oplist(22)		!nform=1 then Bsig unormalized
	if(nform.eq.1)goto 5504
      DO 5501 IB=1,5
      JBB=IB+1
      DO 5501 JB=JBB,6
      BSIG(IB,JB)=BSIG(IB,JB)*BSIG(IB,IB)*BSIG(JB,JB)
 5501 BSIG(JB,IB)=BSIG(IB,JB)
      DO 5503 IB=1,6
 5503 BSIG(IB,IB)=BSIG(IB,IB)*BSIG(IB,IB)
 5504 MBPRT=OPLIST(23)
      MPRINT=MBPRT
      NORDER=1
      IF(MBPRT.LE.0)GOTO 5510
      MLOCAT=MBPRT
      DO 5502 JM=1,MBPRT
      INDJM=2*JM-1
      INDOP=INDJM+23
      NLIST(INDJM)=OPLIST(INDOP)
 5502 NLIST(INDJM+1)=OPLIST(INDOP+1)
 5510 IF(MBPRT.EQ.-2)GOTO 99000
      CALL MATRIX
      GOTO 99000
6000  CALL DETAIL(IEND)
      GO TO 99000
7000  CALL GEABER(IEND)
      GO TO 99000
8000  CALL LINABE(IEND)
      GOTO 99000
9000  CALL MISDAT(IEND)
      IEND=0
      GOTO 99000
10000 CALL ERRDAT(IEND)
      IEND=0
      GOTO 99000
11000 CALL SETMIS(IEND)
      GOTO 99000
12000 CALL SETERR(IEND)
      GOTO 99000
13000 CALL SEED(IEND)
      GOTO 99000
14000 CALL ALIGN(IEND)
      GOTO 99000
15000 CALL REFORB(IEND)
      GOTO 99000
16000 CALL CORDAT(IEND)
      IEND=0
      GOTO 99000
17000 CALL SETCOR(IEND)
      IEND=0
      GOTO 99000
18000 CALL SETSYN(IEND)
      IEND=0
      GOTO 99000
19000 CALL RTDUMP(IEND)
      GOTO 99000

caab code added by aab
20000 miniinvoke=1
      call mini
      goto 99000
		
99000 WRITE(IOUT,10200)
      NORDER=2
      NOF=27
      IF(IEND.LT.1) GO TO 130
      CALL HALT
      STOP
      END
      SUBROUTINE detloc
C     ***********************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON AMAT(350,6,27),NORLST(2500),XPEL(350),YPEL(350),
     1EXPEL,Nm,LOGPAR(350)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
c ppb
c This subroutine fills the array idetloc.
c idetloc: the location of the detectors in the lattice.The detectors 
c        are given in the order SIR,1w,2w,...,48w,49w,49e,48e,...2e,1e,SIR,NIR
c                      That is  SIR,1, 2, ...,48, 49, 50, 51, ...97,98,SIR,NIR
c           It is assumed that the lattice starts at the SIR
c           and goes through the east arc first.
c
c  Also contains the locations of the bends. These go into idetloc(101- )
c****************************************************************
	common/detdat/idetloc(200),sghold(8),htune,vtune

	indexj=1
	indexb=101

	do indexy=nelm,1,-1
	   nel =norlst(indexy)
	   if (indexy.eq.nelm) then 
	      nel1=norlst(1)
	   else 
	      nel1=norlst(indexy+1)
	   end if
	   if ((name(nel,1).eq.'F').and.(name(nel1,1).eq.'F').and.
     %         (name(nel,2).eq.'1').and.(name(nel1,2).eq.'1')) then
	    if((name(nel,3).eq.'4').and.(name(nel1,3).eq.'4').and.
     %         (name(nel,4).eq.'0').and.(name(nel1,4).eq.'0')) then
	      idetloc(100)=indexy
	    end if
	   end if
	   if ((name(nel,1).eq.name(nel1,1)).and.
     %         (name(nel,2).eq.name(nel1,2))) then
	    if((name(nel,3).eq.name(nel1,3)).and.
     %(name(nel,4).eq.name(nel1,4)).and.(name(nel,1).ne.'F')) then
	      idetloc(0) =indexy
	      idetloc(99)=indexy
	    end if
	   end if
	   if ((name(nel,1).eq.'E').and.(name(nel1,1).eq.'E').and.
     %         (name(nel,2).eq.'5').and.(name(nel1,2).eq.'5')) then
	    if((name(nel,3).eq.'0').and.(name(nel1,3).eq.'0').and.
     %         (name(nel,4).eq.'1').and.(name(nel1,4).eq.'1')) then
	      idetloc(0) =indexy
	      idetloc(99)=indexy
	    end if
	   end if

	   if ((name(nel,1).eq.'F').and.(name(nel1,1).eq.'F')) then
	      if (((name(nel,2).eq.'D').or.(name(nel,2).eq.'E')).and.
     %((name(nel1,2).eq.'D').or.(name(nel1,2).eq.'E'))) then
	         idetloc(indexj)=indexy
	         indexj=indexj+1
	         if ((indexj.eq.34).or.(indexj.eq.65)) indexj=indexj+1
	      end if
	   end if

	   if (name(nel,1).eq.'H') then
	      idetloc(indexb)=indexy
	      indexb=indexb+1
	   end if

	end do

	return
	end
      SUBROUTINE HALT
C     ***********************
	common /gplot/igplot,idev,ndispl
      RETURN
      END

C     ***********************
      SUBROUTINE FLEN2
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INPUTT/KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      IAD=IADR(N)
      AL=ELDAT(IAD)
      AK=ELDAT(IAD+1)
      if (al.le.0.) then
	ak =eldat(iad)
	aky=eldat(iad+1)
      end if
      N=MADR(N)
      DO 100 I=1,6
      DO 100 J=1,NOF
      AMAT(N,I,J)=0.0D0
      IF(I.EQ.J) AMAT(N,I,J)=1.0D0
  100 CONTINUE
      SQAK=SQRT(ABS(AK))
      ARGM=SQAK*AL
      CSIN=SIN(ARGM)
      CCOS=COS(ARGM)
      HSIN=SINH(ARGM)
      HCOS=COSH(ARGM)
      if(al.le.0.) then
         AMAT(N,1, 1)=1.0
         AMAT(N,1, 2)=0.0
         AMAT(N,2, 1)= ak
         AMAT(N,2, 2)=1.0
         AMAT(N,3, 3)=1.0
         AMAT(N,3, 4)=0.0
         AMAT(N,4, 3)= aky
         AMAT(N,4, 4)=1.0
	 return
      end if
      IF(AK)2,4,1
    1 A=CCOS
      B=CSIN
      C=HCOS
      D=HSIN
      E=-B
      F=D
      GOTO3
    2 A=HCOS
      B=HSIN
      C=CCOS
      D=CSIN
      E=B
      F=-D
    3 P=B/SQAK
      Q=D/SQAK
      AMAT(N,1, 1)=A
      AMAT(N,1, 2)=P
      AMAT(N,2, 1)=E*SQAK
      AMAT(N,2, 2)=A
      AMAT(N,3, 3)=C
      AMAT(N,3, 4)=Q
      AMAT(N,4, 3)=F*SQAK
      AMAT(N,4, 4)=C
      IF(NORDER.EQ.1)RETURN
      R=SQAK*0.5D0
      S=ARGM*0.5D0
      AMAT(N,1,12)=-E*S
      AMAT(N,1,17)=(P-A*AL)*0.5D0
      AMAT(N,2,12)= (A*ARGM+B)*R*ABS(AK)/AK
      AMAT(N,2,17)=-E*S
      AMAT(N,3,21)=-F*S
      AMAT(N,3,24)=(Q-C*AL)*0.5D0
      AMAT(N,4,21)=-(C*ARGM+D)*R*ABS(AK)/AK
      AMAT(N,4,24)=-F*S
C
C     PATH LENGTH
C
      AMAT(N,5,7) = (AK*AL+A*E*SQAK)/4.0D0
      AMAT(N,5,8) = E*B/2.0D0
      AMAT(N,5,13) = (AL+A*B/SQAK)/4.0D0
      AMAT(N,5,18) = (-AK*AL+F*C*SQAK)/4.0D0
      AMAT(N,5,19) = F*D/2.0D0
      AMAT(N,5,22) = (AL+C*D/SQAK)/4.0D0
      RETURN
4     AMAT(N,1,2) = AL
      AMAT(N,3,4) = AL
      IF(NORDER.EQ.1)RETURN
      AMAT(N,5,13) = AL/2.0D0
      AMAT(N,5,22) = AL/2.0D0
      RETURN
      END
      SUBROUTINE FFFCT(X,F)
C     ********************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/FITL/COEF(20,6),VALF(20),WGHT(20),RVAL(20),XM(20)
     >  ,EM(20),WV,NELF(20,6),NPAR(20,6),IND(20,6),NPVAR(20),NVAL(20)
     >  ,NSTEP,NVAR,NCOND,ISTART,NDIV,IFITM,IFITD
      COMMON/LAYOUT/XHI,YHI,ZHI,THETAI,PHIHI,PSIHI,CONVH,
     >SRH,XRH,YRH,ZRH,THETAR,PHIRH,PSIRH,NLAY,NLAYDUM
      DIMENSION X(1)
      DO 100 I=1,NVAR
      JF=NPVAR(I)
      VAL=ELDAT(IND(I,1))
      IF(VAL.EQ.XM(I))GOTO 100
      DO 200 J=1,JF
      ELDAT(IND(I,J))=XM(I)*COEF(I,J)
      CALL MATGEN(NELF(I,J))
  200 CONTINUE
  100 CONTINUE
      IF(IFITM.NE.1)GOTO 1
	norder=1
	nmat=0
	mprint=-1
	mfprint=-2
	call matrix
      BETAX = CBETAX
      ALPHAX = CALPHX
      ETAX = CETAX
      ETAPX = CETAPX
      BETAY = CBETAY
      ALPHAY = CALPHY
      ETAY = CETAY
      ETAPY = CETAPY
      CALL MATRIX
      CALL ANAL
    1 IF(IFITD.EQ.1)CALL DETAIL(IEND)
      IF(NLAY.EQ.1)CALL HWPNT
      CALL SETOUT
      CALL SQFCT(F)
      RETURN
      END
      SUBROUTINE SQFCT(F)
C     *************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/FITL/COEF(20,6),VALF(20),WGHT(20),RVAL(20),XM(20)
     >  ,EM(20),WV,NELF(20,6),NPAR(20,6),IND(20,6),NPVAR(20),NVAL(20)
     >  ,NSTEP,NVAR,NCOND,ISTART,NDIV,IFITM,IFITD
      COMMON/FOUT/OUTFL(300)
      F=0.0D0
	type 22
22	format(/)
	type 21,(outfl(nval(i)),i=1,ncond)
21	format(5e12.4)
	type 21,(valf(i),i=1,ncond)
      IF(ISTART.NE.0)GO TO 1
      DO 20 I=1,NCOND
      VAL0=OUTFL(NVAL(I))
	if(nval(i).ge.93.and.nval(i).le.96)outfl(nval(i))
     &	  =dmax1(outfl(nval(i)),valf(i))
   20 RVAL(I)=VAL0-(VAL0-VALF(I))/NDIV
      ISTART=1
    1 DO 10 I=1,NCOND
	if(nval(i).ge.93.and.nval(i).le.96)outfl(nval(i))
     &	  =dmax1(outfl(nval(i)),valf(i))
   10 F=F+((OUTFL(NVAL(I))-RVAL(I))*WGHT(I))**2
      F=F/WV
      F=SQRT(F)
	type *,' FIG ',f
      RETURN
      END
C     *************************
      SUBROUTINE ALIGN(IEND)
C     *************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/DETL/DENER(15),NH,NV,NVH,NHVP(105),MDPRT,NDENER,
     >NUXS(45),NUX(45),NUYS(45),NUY(45),NCO,NHNVHV,MULPRT,NSIG
      COMMON/BETAL/BETA0X,ALPH0X,BETA0Y,ALPH0Y,X0,XP0,Y0,YP0
     >,DX0,DXP0,DY0,DYP0,DEL0,XS(15),XPS(15),YS(15),YPS(15)
      COMMON/MONIT/VALMON(12,4,3),MNAME(600,4),MONPOS(600),NMON
      COMMON/MONFIT/VALFA(12),WGHTA(12),ERRA(12),
     >AMULTA(12,6),ADDA(12,6),DELA(12),NPARA(12,6),NELFA(12,6),
     >NPVARA(12),INDA(12,6),VALR(12),
     >NMONA(12),NVALA(12),NVARA,NCONDA,IALFLG,MONFLG,MONLST,NOPTER,
     >IAFRST,ISDBEG,IMONSD,IMSBEG
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/CORR/CORVAL(600,4),ICRID(600),ICRPOS(600),ICRSET(600),
     >ICROPT(600),NCORR,NCURCR,ICRFLG,ICRCHK,ALMNEL,NPARC
      COMMON/CORSET/DCX1,DCX2,DCXR1,DCXR2,DCY1,DCY2,DCYR1,DCYR2,
     >DCYP,DCDEL
      DIMENSION VALMAT(144),XA(12),EA(12)
      DIMENSION OPLIST(19),ICHAR(6)
      DIMENSION VAL0(12),DVAL(12),QVAL(12)
      DIMENSION LV(12),MV(12)
      DIMENSION ITCORR(4),IDIGIT(10)
      DATA IBLANK/' '/,ICHP/'P'/
      DATA IDIGIT/'0','1','2','3','4','5','6','7','8','9'/
      EXTERNAL FALCT
      DATA ITCORR/'C','O','R','R'/
C INITIALIZE ARRAYS
      IAFRST=100000
      DO 100 IAL=1,12
      DELA(IAL)=0.0D0
      VALFA(IAL)=0.0D0
      WGHTA(IAL)=0.0D0
      NVALA(IAL)=0
      NPVARA(IAL)=1
      DO 100 JAL=1,6
      AMULTA(IAL,JAL)=0.0D0
      ADDA(IAL,JAL)=0.0D0
      NELFA(IAL,JAL)=0
      NPARA(IAL,JAL)=0
      IF(JAL.EQ.1)AMULTA(IAL,JAL)=1.0D0
  100 CONTINUE
C  COLLECT INPUT DATA TO OPERATION
      IALFLG=1
      LOCCFL=0
      NDIM=19
      NCHAR=0
      NDATA=19
      NPRINT=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
      NSTEP=OPLIST(1)
      NIT=OPLIST(2)
      NVARA=OPLIST(3)
      NPARC=NVARA
      NCONDA=OPLIST(4)
      NFIT=OPLIST(5)
      NOPTER=OPLIST(6)
      BETA0X=OPLIST(7)
      ALPH0X=OPLIST(8)
      BETA0Y=OPLIST(9)
      ALPH0Y=OPLIST(10)
      X0=OPLIST(11)
      XP0=OPLIST(12)
      Y0=OPLIST(13)
      YP0=OPLIST(14)
      DX0=OPLIST(15)
      DXP0=OPLIST(16)
      DY0=OPLIST(17)
      DYP0=OPLIST(18)
      DEL0=0.0D0
      NH=1
      NV=1
      NVH=1
      NSIG=0
      NDENER=OPLIST(19)
      NDATA=NDENER
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
      DO 1 IAL=1,NDENER
      XS(IAL)=0.0D0
      XPS(IAL)=0.0D0
      YS(IAL)=0.0D0
      YPS(IAL)=0.0D0
    1 DENER(IAL)=OPLIST(IAL)
      DO 2 IVAR=1,NVARA
      NDATA=0
      NDIM=0
      NCHAR=4
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
      IF(LOCCFL.EQ.1)GOTO 22
      DO 20 ICH=1,4
      IF(ICHAR(ICH).NE.ITCORR(ICH))GOTO 21
   20 CONTINUE
      NPARC=IVAR-1
      LOCCFL=1
      ICRFLG=1
      NCHAR=6
      NDATA=0
      NDIM=0
      INITPS=0
      DO 300 IBL=1,6
  300 ICHAR(IBL)=IBLANK
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
      IF(ICHAR(1).EQ.ICHP)GOTO 301
      DO 302 ICH=1,6
      IF(ICHAR(ICH).EQ.IBLANK)GOTO 303
      DO 304 IDIG=1,10
      IF(ICHAR(ICH).EQ.IDIGIT(IDIG))INITPS=INITPS*10+IDIG-1
  304 CONTINUE
  302 CONTINUE
  303 GOTO 305
  301 CALL MONID(ICHAR,NID)
      INITPS=MONPOS(NID)
  305 NCHAR=4
      NDATA=0
      NDIM=0
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
   22 NCHAR=0
      NDATA=4
      NDIM=4
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
      CALL ELID(ICHAR,NELID)
      ICPOS=OPLIST(1)+INITPS
      IF(IAFRST.GT.ICPOS)IAFRST=ICPOS
      DO 23 ICORR=1,NCORR
      IF(ICPOS.LT.ICRPOS(ICORR))GOTO 24
      IF((NELID.EQ.ICRID(ICORR)).AND.(ICPOS.EQ.ICRPOS(ICORR)))GOTO 25
   23 CONTINUE
   24 WRITE(IOUT,10001)
10001 FORMAT(/,'  NO MATCH WAS FOUND FOR CORRECTOR ID AND POSITION',
     >' IN THE CORRECTOR LIST',/,' DEFINED IN THE CORRECTOR DEFINITION',
     >' OPERATION . RUN IS STOPPED',/)
      CALL HALT
      STOP
   25 ICRSET(ICORR)=1
      ICROPT(ICORR)=OPLIST(2)
      NELFA(IVAR,1)=ICORR
      NPARA(IVAR,1)=OPLIST(3)
      DELA(IVAR)=OPLIST(4)
      GOTO 2
   21 CALL ELID(ICHAR,NELID)
      NDATA=2
      NDIM=2
      NCHAR=0
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
C CHECK FOR LOCATION OF VARIED ELEMENT
      CALL POSCHK(NELID,IPOSCH)
C SET FIRST FLAG
      IF(IAFRST.GT.IPOSCH)IAFRST=IPOSCH
      NELFA(IVAR,1)=NELID
      NPARA(IVAR,1)=OPLIST(1)
      DELA(IVAR)=OPLIST(2)
    2 CONTINUE
      NDIM=4
      NCHAR=4
      NDATA=4
      DO 3 ICOND=1,NCONDA
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
      CALL MONID(ICHAR,NID)
C  PLACE THE MONITORS IN INCREASING ORDER OF POSITION
      IPL=ICOND
      IF(ICOND.EQ.1)GOTO 32
      ICM1=ICOND-1
      DO 31 ICC=1,ICM1
      IF(MONPOS(NID).LT.NMONA(ICC))GOTO 33
   31 CONTINUE
      GOTO 32
C MOVE REST OF LIST TO INSERT NEW MONITOR
   33 ISC=ICOND-ICC
      DO 34 ICSC=1,ISC
      IND=ICOND-ICSC
      INDP1=IND+1
      NMONA(INDP1)=NMONA(IND)
      NVALA(INDP1)=NVALA(IND)
      VALFA(INDP1)=VALFA(IND)
      WGHTA(INDP1)=WGHTA(IND)
   34 ERRA(INDP1)=ERRA(IND)
      IPL=ICC
C PLACE NEW MONITOR
   32 NMONA(IPL)=MONPOS(NID)
      NVALA(IPL)=OPLIST(1)
      ITEST=NVALA(IPL)-1
      IF(MOD(ITEST,4).GE.2)NSIG=1
      VALFA(IPL)=OPLIST(2)
      WGHTA(IPL)=OPLIST(3)
      ERRA(IPL)=OPLIST(4)
    3 CONTINUE
      MONLST=NMONA(NCONDA)
COLLECT INFORMATION ABOUT ASSOCIATED PARAMETERS
      NCHAR=0
      NDATA=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
      NASP=OPLIST(1)
      IF(NASP.EQ.0)GOTO 50
      DO 4 IASP=1,NASP
      NDATA=2
      NCHAR=4
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
      CALL ELID(ICHAR,NELID)
      IPAR=OPLIST(1)
CHECK IF NAME IS IN BASE LIST OF VARIED ELEMENTS
      DO 41 IEL=1,NVARA
      IF((NELID.EQ.NELFA(IEL,1)).AND.(IPAR.EQ.NPARA(IEL,1)))GO TO 42
   41 CONTINUE
      WRITE(IOUT,99990)ICHAR,NELID,IPAR,(NELFA(IN,1),IN=1,NVARA),
     >(NPARA(IN,1),IN=1,NVARA)
99990 FORMAT(/,' ELEMENT NAME AND PARAMETER # IS NOT IN BASE LIST',
     >' OF VARIED ELEMENTS',/,' ',4A1,26I6)
      CALL HALT
      STOP
   42 JPAS=IEL
      NPAS=OPLIST(2)+1
      NPVARA(JPAS)=NPAS
      DO 5 KPAS=2,NPAS
      NCHAR=4
      NDATA=3
      IF((IASP.EQ.NASP).AND.(KPAS.EQ.NPAS))NDATA=-1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
      CALL ELID(ICHAR,NELID)
C CHECK FOR LOCATION OF VARIED ELEMENT
      CALL POSCHK(NELID,IPOSCH)
C SET FIRST FLAG
      IF(IAFRST.GT.IPOSCH)IAFRST=IPOSCH
      NELFA(JPAS,KPAS)=NELID
      NPARA(JPAS,KPAS)=OPLIST(1)
      AMULTA(JPAS,KPAS)=OPLIST(2)
      ADDA(JPAS,KPAS)=OPLIST(3)
    5 CONTINUE
    4 CONTINUE
   50 CONTINUE
C SET UP INITIAL VALUES OF PARAMETERS AND COMPUTE ADDRESSES
      IF(NPARC.EQ.0)GOTO 80
      DO 6 IFLA=1,NPARC
      JFF=NPVARA(IFLA)
      DO 6 JFLA=1,JFF
      NELV=NELFA(IFLA,JFLA)
      INDA(IFLA,JFLA)=IADR(NELV)+NPARA(IFLA,JFLA)-1
    6 CONTINUE
      DO 200 IAA=1,NPARC
      VAL=ELDAT(INDA(IAA,1))
      JF=NPVARA(IAA)
      DO 210 JAA=1,JF
      ELDAT(INDA(IAA,JAA))=VAL*AMULTA(IAA,JAA)+ADDA(IAA,JAA)
      CALL MATGEN(NELFA(IAA,JAA))
  210 CONTINUE
  200 CONTINUE
   80 WRITE(IOUT,88884)(VALFA(IAA),IAA=1,NCONDA)
88884 FORMAT(/,'  THE REQUESTED VALUES ARE :',//,2X,2(5E16.7,/))
C COMPUTE INITIAL VALUES OF MONITOR READOUTS AND PLACE IN VAL0
      IALFLG=1
      CALL DETAIL(IEND)
      IALFLG=2
      IF(NSIG.EQ.1)GOTO 81
      NH=0
      NV=0
      NVH=0
   81 CALL DETAIL(IEND)
      DO 40 IAA=1,NCONDA
      JV=(NVALA(IAA)-1)/4 + 1
      IV=NVALA(IAA)-(JV-1)*4
   40 VAL0(IAA)=VALMON(IAA,IV,JV)
      WRITE(IOUT,88882)(VAL0(IAA),IAA=1,NCONDA)
88882 FORMAT(/,'  THE INITIAL VALUES ARE :',//,2X,2(6E16.7,/))
      NITT=NSTEP+NIT
      DO 9 IS=1,NITT
      NDIV=NSTEP-IS+1
      IF(NDIV.LT.1)NDIV=1
      DO 10 I =1,NCONDA
   10 VALR(I)=VAL0(I)-(VAL0(I)-VALFA(I))/NDIV
      IF(IS.LE.NSTEP)GOTO 14
      DO 12 I=1,NVARA
   12 DELA(I)=DELA(I)/5
   14 CONTINUE
      IF(NFIT.EQ.1)GOTO 90
      ESC=500
      ICON=1
      IPRINT=0
      MAXIT=3*IS*NIT
      DO 110 IFL=1,NVARA
      EA(IFL)=DELA(IFL)
      IF(IFL.LE.NPARC)GOTO 101
      XA(IFL)=CORVAL(NELFA(IFL,1),NPARA(IFL,1))
      GOTO 110
  101 XA(IFL)=ELDAT(INDA(IFL,1))
  110 CONTINUE
      CALL MINSUB(XA,EA,NVARA,F,ESC,IPRINT,ICON,MAXIT,FALCT)
      WRITE(IOUT,98899)IS,F
98899 FORMAT(' AFTER STEP ',I4,' THE FIT FUNCTION VALUE IS ',E14.6)
      DO 102 IFL=1,NVARA
      IF(IFL.LE.NPARC)GOTO 103
      CORVAL(NELFA(IFL,1),NPARA(IFL,1))=XA(IFL)
      GOTO 102
  103 ELDAT(INDA(IFL,1))=XA(IFL)
      JFL=NPVARA(IFL)
      DO 105 JAA=1,JFL
      ELDAT(INDA(IFL,JAA))=XA(IFL)*AMULTA(IFL,JAA)+ADDA(IFL,JAA)
  105 CALL MATGEN(NELFA(IFL,JAA))
  102 CONTINUE
      GOTO 7
   90 DO 74 I=1,NVARA
      IF(I.LE.NPARC)GOTO 27
      CORVAL(NELFA(I,1),NPARA(I,1))=CORVAL(NELFA(I,1),NPARA(I,1))+
     >DELA(I)
      GOTO 28
   27 VAL=ELDAT(INDA(I,1))+DELA(I)
      JF=NPVARA(I)
      DO 220 JAA=1,JF
      ELDAT(INDA(I,JAA))=VAL*AMULTA(I,JAA)+ADDA(I,JAA)
      CALL MATGEN(NELFA(I,JAA))
  220 CONTINUE
   28 CALL DETAIL(IEND)
      DO 75 IV=1,NCONDA
      JVV=(NVALA(IV)-1)/4 + 1
      IVV=NVALA(IV)-(JVV-1)*4
   75 VALMAT((IV-1)*NCONDA+I)=(VALMON(IV,IVV,JVV)-VAL0(IV))
     >/DELA(I)
      IF(I.LE.NPARC)GOTO 29
      CORVAL(NELFA(I,1),NPARA(I,1))=CORVAL(NELFA(I,1),NPARA(I,1))-
     >DELA(I)
      GOTO 74
   29 VAL=ELDAT(INDA(I,1))-DELA(I)
      JF=NPVARA(I)
      DO 230 JAA=1,JF
      ELDAT(INDA(I,JAA))=VAL*AMULTA(I,JAA)+ADDA(I,JAA)
      CALL MATGEN(NELFA(I,JAA))
  230 CONTINUE
   74 CONTINUE
      CALL DMINV(VALMAT,NVARA,D,LV,MV)
      DO 26 I=1,NVARA
   26 DVAL(I)=VALR(I)-VAL0(I)
      DO 7 I=1,NVARA
      QVAL(I)=0.0D0
      DO 8 J=1,NVARA
    8 QVAL(I)=QVAL(I)+VALMAT((I-1)*NVARA+J)*DVAL(J)
      IF(I.LE.NPARC)GOTO 70
      CORVAL(NELFA(I,1),NPARA(I,1))=CORVAL(NELFA(I,1),NPARA(I,1))+
     >QVAL(I)
      GOTO 7
   70 VAL = ELDAT(INDA(I,1))+QVAL(I)
      JF=NPVARA(I)
      DO 240 JAA=1,JF
      ELDAT(INDA(I,JAA))=VAL*AMULTA(I,JAA)+ADDA(I,JAA)
      CALL MATGEN(NELFA(I,JAA))
  240 CONTINUE
    7 CONTINUE
      CALL DETAIL(IEND)
      DO 11 I=1,NCONDA
      JAA=(NVALA(I)-1)/4 + 1
      IAA=NVALA(I)-(JAA-1)*4
   11 VAL0(I)=VALMON(I,IAA,JAA)
    9 CONTINUE
      WRITE(IOUT,88885)(VAL0(IAA),IAA=1,NCONDA)
88885 FORMAT(/,'  THE ACHIEVED VALUES ARE :',//,2X,2(6E16.7,/))
      IF(ISO.NE.0)WRITE(ISOUT,10011)
      WRITE(IOUT,10011)
10011 FORMAT(//,' THE FITTED PARAMETERS ARE : ')
      DO 60 IP=1,NVARA
      IF(IP.LE.NPARC)GOTO 71
      IF(IP.EQ.(NPARC+1))WRITE(IOUT,10012)
10012 FORMAT(/,'  CORRECTOR SETTINGS ',/)
      NCCOR=NELFA(IP,1)
      WRITE(IOUT,10013)NPARA(IP,1),NCCOR,ICRPOS(NCCOR),CORVAL(NCCOR,
     >NPARA(IP,1))
10013 FORMAT(' PARAM #',I5,' OF CORR #',I5,' AT POS :'
     <,I5,' IS:',E22.14)
      GOTO 60
   71 IAPF=NPVARA(IP)
      DO 61 IAP=1,IAPF
      NELV=NELFA(IP,IAP)
      WRITE(IOUT,10010)NPARA(IP,IAP),(NAME(NELV,J),J=1,4),
     > ELDAT(INDA(IP,IAP))
10010 FORMAT('  PARAMETER # ',I3,' OF ',4A1,' = ',E22.14)
   61 CONTINUE
   60 CONTINUE
      IALFLG=0
      MONFLG=0
      RETURN
      END
C     *************************
      SUBROUTINE ARBIT(IAD,NEL)
C     *************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/ARB/PARA(20)
      NP=IADR(NEL+1)-IAD
      IF(NP.GT.20)WRITE(IOUT,10000)
      IF(NP.GT.20)NP=20
      DO 1 IP=1,NP
    1 PARA(IP)=ELDAT(IAD+IP-1)
      RETURN
10000 FORMAT(/,'  NUMBER OF PARAMETERS IN ARBITRARY ELEMENT GREATER',
     >' THAN 20',/,'   ONLY THE FIRST 20 ARE KEPT, JOB PROCEEDS', /)
      END
C     ***********************
      SUBROUTINE BEAM
C     ***********************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON/CBEAM/BSIG(6,6),BSIGF(6,6),MBPRT,nform
      DO 1 I=1,6
      DO 1 J=I,6
      BSIGF(I,J)=0.0D0
      DO 1 K=1,6
      SL=0.0D0
      DO 2 L=1,6
    2 SL=SL+BSIG(K,L)*TEMP(J,L)
    1 BSIGF(I,J)=BSIGF(I,J)+TEMP(I,K)*SL
	if(nform.eq.1)return
      DO 3 I=1,6
    3 BSIGF(I,I)=SQRT(BSIGF(I,I))
      DO 4 I=1,5
      JB=I+1
      DO 4 J=JB,6
      BSIGF(I,J)=BSIGF(I,J)/(BSIGF(I,I)*BSIGF(J,J))
    4 BSIGF(J,I)=BSIGF(I,J)
      RETURN
      END
C     ***********************
      SUBROUTINE BEND
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON /INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/BND/IAD
      DIMENSION PARM(20)
C
C     SET UP THE PARAMETERS FOR ENTEX (ENTRANCE)
C
      H=(ELDAT(IAD+1)*CRDEG)/ELDAT(IAD)
      PARM(1) = H
      PARM(2) = ELDAT(IAD+2)
      PARM(3) = ELDAT(IAD+4)
      PARM(4) = 1.0D0
      PARM(5) = ELDAT(IAD+5)
      PARM(6) = ELDAT(IAD+6)
      PARM(7) = ELDAT(IAD+7)
C
C     CALL ENTEX (ENTRANCE)
C
      KODEPR = 11
      CALL ENTEX(PARM)
      CALL PROMAT
C
C     GET THE PARAMETERS FOR MAGT2
C
40    PARM(1) = ELDAT(IAD+1)
      PARM(2) = ELDAT(IAD)
      PARM(3) = ELDAT(IAD+2)
      PARM(4) = ELDAT(IAD+3)
C
C     CALL MAGT2
C
      KODEPR = 1
      CALL MAGT2(PARM)
      CALL PROMAT
C
C     GET THE PARAMETERS FOR ENTEX (EXIT)
C
      PARM(1) = H
      PARM(2) = ELDAT(IAD+2)
      PARM(3) = ELDAT(IAD+8)
      PARM(4) = -1.0D0
      PARM(5) = ELDAT(IAD+9)
      PARM(6) = ELDAT(IAD+10)
      PARM(7) = ELDAT(IAD+11)
C
C     CALL ENTEX (EXIT)
C
      KODEPR = 11
      CALL ENTEX(PARM)
      CALL PROMAT
C
C     PRINT THE MATRIX TO CHECK ITS OK
C
C     CALL PRMAT(TEMP,NMAT,0)
   50 RETURN
      END
C     ************************
      SUBROUTINE COMPL
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/V/VV(27),X1,X2,X3,X4,X5,X6
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      IF(ABS(X1).LT.1.0D-30)X1=0.0D0
      IF(ABS(X2).LT.1.0D-30)X2=0.0D0
      IF(ABS(X3).LT.1.0D-30)X3=0.0D0
      IF(ABS(X4).LT.1.0D-30)X4=0.0D0
      IF(ABS(X5).LT.1.0D-30)X5=0.0D0
      IF(ABS(X6).LT.1.0D-30)X6=0.0D0
      VV(1)=X1
      VV(2)=X2
      VV(3)=X3
      VV(4)=X4
      VV(5)=X5
      VV(6)=X6
      VV(7)=X1*X1
      VV(8)=X1*X2
      VV(9)=X1*X3
      VV(10)=X1*X4
      VV(11)=X1*X5
      VV(12)=X1*X6
      VV(13)=X2*X2
      VV(14)=X2*X3
      VV(15)=X2*X4
      VV(16)=X2*X5
      VV(17)=X2*X6
      VV(18)=X3*X3
      VV(19)=X3*X4
      VV(20)=X3*X5
      VV(21)=X3*X6
      VV(22)=X4*X4
      VV(23)=X4*X5
      VV(24)=X4*X6
      VV(25)=X5*X5
      VV(26)=X5*X6
      VV(27)=X6*X6
      RETURN
      END
C     *********************
      SUBROUTINE CORCHK(IE)
C     *********************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/CORR/CORVAL(600,4),ICRID(600),ICRPOS(600),ICRSET(600),
     >ICROPT(600),NCORR,NCURCR,ICRFLG,ICRCHK,ALMNEL,NPARC
      COMMON/CORSET/DCX1,DCX2,DCXR1,DCXR2,DCY1,DCY2,DCYR1,DCYR2,
     >DCYP,DCDEL
      COMMON/MISSET/DX,DXR,DY,DYR,DZ,DZR,DDEL,HLMNEL,I,IEP,MNEL
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
      ICRCHK=0
      DCX1=0.0D0
      DCX2=0.0D0
      DCXR1=0.0D0
      DCXR2=0.0D0
      DCY1=0.0D0
      DCY2=0.0D0
      DCYR1=0.0D0
      DCYR2=0.0D0
      DCYP=0.0D0
      DCDEL=0.0D0
      ALMNEL=ALENG(MNEL)
      DO 1 ICR=1,NCORR
      IF((ICRPOS(ICR).EQ.IE).AND.(ICRSET(ICR).EQ.1))GOTO 2
    1 CONTINUE
      RETURN
    2 NCURCR=ICR
      ICRCHK=1
      IOPT=ICROPT(ICR)
      IF(IOPT.GT.2)ICRCHK=2
      DCYP=CORVAL(NCURCR,3)
      DCDEL=CORVAL(NCURCR,4)
      IF(IOPT.GT.2)GOTO 30
      IF(IOPT.EQ.2)GOTO 20
      IF(IOPT.EQ.1)GOTO 10
      DCX1=CORVAL(NCURCR,1)
      DCX2=-DCX1
      DCY1=CORVAL(NCURCR,2)
      DCY2=-DCY1
      GO TO 100
   10 DCX1=CORVAL(NCURCR,1)
      DCX2=0.0D0
      DCYR1=-DCX1/(ALMNEL)
      DCYR2=-DCYR1
      DCY1=CORVAL(NCURCR,2)
      DCY2=0.0D0
      DCXR1=-DCY1/(ALMNEL)
      DCXR2=-DCXR1
      GOTO 100
   20 DCX1=0.0D0
      DCX2=CORVAL(NCURCR,1)
      DCYR1=DCX2/(ALMNEL)
      DCYR2=-DCYR1
      DCY1=0.0D0
      DCY2=CORVAL(NCURCR,2)
      DCXR1=DCY2/(ALMNEL)
      DCXR2=-DCXR1
      GOTO 100
   30 CONTINUE
  100 RETURN
      END
C     ***********************
      SUBROUTINE CORDAT(IEND)
C     ***********************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/CORR/CORVAL(600,4),ICRID(600),ICRPOS(600),ICRSET(600),
     >ICROPT(600),NCORR,NCURCR,ICRFLG,ICRCHK,ALMNEL,NPARC
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      DIMENSION ICHAR(4),OPLIST(200)
      DATA NINE/'9'/
      NCORR=0
    1 NOP = 0
      NCHAR=4
      INPRT=1
      NDIM=0
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,INPRT)
      IF((ICHAR(1).EQ.NINE).AND.(ICHAR(2).EQ.NINE))GO TO 99
      NOP = -1
      NCHAR=0
      INPRT=1
      NDIM=200
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,INPRT)
      CALL ELID(ICHAR,NELID)
      IF((2*(NOP/2)).EQ.NOP)GOTO 2
      WRITE(IOUT,10001)
10001 FORMAT('  EVEN NUMBER OF DATA NEEDED : RUN STOPPED ')
      CALL HALT
      STOP
    2 IRNGE=NOP/2
      DO 3 JRNGE=1,IRNGE
      IRBEG=OPLIST(2*JRNGE-1)-1
      IREND=OPLIST(2*JRNGE)
      ICRT=IREND-IRBEG
      DO 4 JCRT=1,ICRT
      IF(NORLST(IRBEG+JCRT).NE.NELID)GOTO 4
      NCORR=NCORR+1
      ICRID(NCORR)=NELID
      ICRPOS(NCORR)=IRBEG+JCRT
    4 CONTINUE
    3 CONTINUE
      GOTO 1
   99 NCUR=0
    7 NCUR=NCUR+1
      DO 5 IC=1,NCUR
      IF(ICRPOS(NCUR+1).LT.ICRPOS(IC))GOTO 6
    5 CONTINUE
    9 IF((NCUR+1).EQ.NCORR)GOTO 8
      GOTO 7
    6 IPOSAV=ICRPOS(NCUR+1)
      IDSAV=ICRID(NCUR+1)
      NDIS=NCUR-IC+1
      DO 10 ICC=1,NDIS
      ICRPOS(NCUR+2-ICC)=ICRPOS(NCUR+1-ICC)
      ICRID(NCUR+2-ICC)=ICRID(NCUR+1-ICC)
   10 CONTINUE
      ICRPOS(IC)=IPOSAV
      ICRID(IC)=IDSAV
      GOTO 9
    8 CONTINUE
      DO 12 INC=1,NCORR
      DO 12 JNC=1,4
      CORVAL(INC,JNC)=0.0D0
   12 CONTINUE
C     WRITE(IOUT,10002)(ICRPOS(IW),ICRID(IW),IW=1,NCORR)
10002 FORMAT('  ',2I6)
      RETURN
      END
C     *****************
      SUBROUTINE CRESET
C     *****************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/CORR/CORVAL(600,4),ICRID(600),ICRPOS(600),ICRSET(600),
     >ICROPT(600),NCORR,NCURCR,ICRFLG,ICRCHK,ALMNEL,NPARC
      COMMON/CORSET/DCX1,DCX2,DCXR1,DCXR2,DCY1,DCY2,DCYR1,DCYR2,
     >DCYP,DCDEL
      COMMON/MISSET/DX,DXR,DY,DYR,DZ,DZR,DDEL,HLMNEL,I,IEP,MNEL
        COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN
     +  ,NPTOT,MLOCAT,NTURN
      X=PART(I,1)
      XP=PART(I,2)
      Y=PART(I,3)
      YP=PART(I,4)
      AL=PART(I,5)
      DELTA=PART(I,6)
      DELTA=DELTA-DCDEL
      X=X+DCX2
      XP=XP+DCYR2
      Y=Y+DCY2
      YP=YP+DCXR2+(DCYP/(1.0D0+DELTA))
      PART(I,1)=X
      PART(I,2)=XP
      PART(I,3)=Y
      PART(I,4)=YP
      PART(I,5)=AL
      PART(I,6)=DELTA
      RETURN
      END
C     ***************
      SUBROUTINE CSET
C     ***************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/CORR/CORVAL(600,4),ICRID(600),ICRPOS(600),ICRSET(600),
     >ICROPT(600),NCORR,NCURCR,ICRFLG,ICRCHK,ALMNEL,NPARC
      COMMON/CORSET/DCX1,DCX2,DCXR1,DCXR2,DCY1,DCY2,DCYR1,DCYR2,
     >DCYP,DCDEL
      COMMON/MISSET/DX,DXR,DY,DYR,DZ,DZR,DDEL,HLMNEL,I,IEP,MNEL
        COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN
     +  ,NPTOT,MLOCAT,NTURN
      X=PART(I,1)
      XP=PART(I,2)
      Y=PART(I,3)
      YP=PART(I,4)
      AL=PART(I,5)
      DELTA=PART(I,6)
      X=X+DCX1
      XP=XP+DCYR1
      Y=Y+DCY1
      YP=YP+DCXR1+(DCYP/(1.0D0+DELTA))
      DELTA=DELTA+DCDEL
      PART(I,1)=X
      PART(I,2)=XP
      PART(I,3)=Y
      PART(I,4)=YP
      PART(I,5)=AL
      PART(I,6)=DELTA
      RETURN
      END
C     ***********************
      SUBROUTINE DETAIL(IEND)
C     ***********************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION OPLIST(200)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/PLT/
     1XMIN,XMAX,YMIN,YMAX,XPMIN,XPMAX,YPMIN,YPMAX,
     >DELMIN,DELMAX,DNUMIN,DNUMAX,DBMIN,DBMAX,
     2MXXPR,MYYPR,MXY,MALL,NPLOT,NCCUM,NGRAPH,NCOL,NLINE
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      LOGICAL LOGPAR,MXXPR(101,51),MYYPR(101,51),MXY(101,51)
      COMMON/DETL/DENER(15),NH,NV,NVH,NHVP(105),MDPRT,NDENER,
     >NUXS(45),NUX(45),NUYS(45),NUY(45),NCO,NHNVHV,MULPRT,NSIG
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN,
     <  NPTOT,MLOCAT,NTURN
      COMMON/BETAL/BETA0X,ALPH0X,BETA0Y,ALPH0Y,X0,XP0,Y0,YP0
     >,DX0,DXP0,DY0,DYP0,DEL0,XS(15),XPS(15),YS(15),YPS(15)
      COMMON/CBEAM/BSIG(6,6),BSIGF(6,6),MBPRT,nform
      COMMON/FITL/COEF(20,6),VALF(20),WGHT(20),RVAL(20),XM(20)
     >  ,EM(20),WV,NELF(20,6),NPAR(20,6),IND(20,6),NPVAR(20),NVAL(20)
     >  ,NSTEP,NVAR,NCOND,ISTART,NDIV,IFITM,IFITD
      COMMON/MONFIT/VALFA(12),WGHTA(12),ERRA(12),
     >AMULTA(12,6),ADDA(12,6),DELA(12),NPARA(12,6),NELFA(12,6),
     >NPVARA(12),INDA(12,6),VALR(12),
     >NMONA(12),NVALA(12),NVARA,NCONDA,IALFLG,MONFLG,MONLST,NOPTER,
     >IAFRST,ISDBEG,IMONSD,IMSBEG
      DO 11 IL=1,NPTOT
   11 LOGPAR(IL)=.TRUE.
      DO  10 IN=1,45
      NUXS(IN)=0
      NUX(IN)=0
      NUYS(IN)=0
   10 NUY(IN)=0
      IF(IFITD.EQ.1)GOTO 3
      IF(IALFLG.NE.0)GOTO3
      NOP = -1
      NCHAR=0
      INPRT=1
      NDIM=200
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,INPRT)
      NH = OPLIST(1)
      NV = OPLIST(2)
      NVH = OPLIST(3)
      X0 = OPLIST(4)
      XP0 = OPLIST(5)
      Y0 = OPLIST(6)
      YP0 = OPLIST(7)
      DX0 = OPLIST(8)
      DXP0 = OPLIST(9)
      DY0 = OPLIST(10)
      DYP0 = OPLIST(11)
      BETA0X = OPLIST(12)
      ALPH0X = OPLIST(13)
      BETA0Y = OPLIST(14)
      ALPH0Y = OPLIST(15)
      NDENER = OPLIST(16)
      NCO=OPLIST(17)
      IF(NCO.GT.6)NCO=6
      IF(NCO.GT.NDENER)NCO=NDENER
      DEL0=0.0D0
      DO 1 INE = 1, NDENER
      XS(INE)=0.0D0
      XPS(INE)=0.0D0
      YS(INE)=0.0D0
      YPS(INE)=0.0D0
    1 DENER(INE) = OPLIST(INE + 17)
      MDPRT = OPLIST(NDENER + 18)
      IF(MDPRT .LE. 0) GO TO 3
      DO 2 IMD = 1, MDPRT
      INDD = 2*IMD-1
      MLOCAT = MDPRT
      INDOP = INDD + NDENER + 18
      NLIST(INDD) = OPLIST(INDOP)
    2 NLIST(INDD+1) = OPLIST(INDOP + 1)
    3 NPLOT = -1
      NPRINT = -2
      NTURN = 1
      NCTURN=0
      MULPRT=5
      NHNVHV=0
      IF((NH.EQ.0).AND.(NV.EQ.0).AND.(NVH.EQ.0))NHNVHV=1
      IF(NHNVHV.EQ.1)MULPRT=1
      NPART = NDENER*MULPRT
      NCPART=NPART
      DO 4 IEN = 1,NDENER
      INDP=(IEN-1)*MULPRT+1
      PART(INDP,1)=X0+XS(IEN)
      PART(INDP,2)=XP0+XPS(IEN)
      PART(INDP,3)=Y0+YS(IEN)
      PART(INDP,4)=YP0+YPS(IEN)
      PART(INDP,6)=DENER(IEN)+DEL0
      IF(NHNVHV.EQ.1)GOTO4
      INDP=INDP+1
      PART(INDP,1)=X0+XS(IEN)+DX0
      PART(INDP,2)=XP0+XPS(IEN)
      PART(INDP,3)=Y0+YS(IEN)
      PART(INDP,4)=YP0+YPS(IEN)
      PART(INDP,6)=DENER(IEN)+DEL0
      INDP=INDP+1
      PART(INDP,1)=X0+XS(IEN)
      PART(INDP,2)=XP0+XPS(IEN)+DXP0
      PART(INDP,3)=Y0+YS(IEN)
      PART(INDP,4)=YP0+YPS(IEN)
      PART(INDP,6)=DENER(IEN)+DEL0
      INDP=INDP+1
      PART(INDP,1)=X0+XS(IEN)
      PART(INDP,2)=XP0+XPS(IEN)
      PART(INDP,3)=Y0+YS(IEN)+DY0
      PART(INDP,4)=YP0+YPS(IEN)
      PART(INDP,6)=DENER(IEN)+DEL0
      INDP=INDP+1
      PART(INDP,1)=X0+XS(IEN)
      PART(INDP,2)=XP0+XPS(IEN)
      PART(INDP,3)=Y0+YS(IEN)
      PART(INDP,4)=YP0+YPS(IEN)+DYP0
      PART(INDP,6)=DENER(IEN)+DEL0
    4 CONTINUE
      DO 5 INP=1,NPART
    5 PART(INP,5)=0.0D0
      CALL TRACKT
      IF(NCPART.EQ.0)GOTO6
      RETURN
    6 WRITE(IOUT,99999)
99999 FORMAT(/,'  ALL PARTICLE WERE LOST SO JOB IS ABORTED',/)
      CALL HALT
      STOP
      END
C      ***********************
      SUBROUTINE DETLPR(IE, ILIST)
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION BETAX(15),ALPHAX(15),BETAY(15),ALPHAY(15),ANUX(15),
     <ANUY(15),R(6,6,15),BSIGL(4,4,15),XO(15),XPO(15),YO(15),YPO(15),
     >XCOEF(6),XPCOEF(6),YCOEF(6),YPCOEF(6),
     >PHIX(15),PHIY(15),BSIGS(4,4,15)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/DETL/DENER(15),NH,NV,NVH,NHVP(105),MDPRT,NDENER,
     1NUXS(45),NUX(45),NUYS(45),NUY(45),NCO,NHNVHV,MULPRT,NSIG
      COMMON/BETAL/BETA0X,ALPH0X,BETA0Y,ALPH0Y,X0,XP0,Y0,YP0
     >,DX0,DXP0,DY0,DYP0,DEL0,XS(15),XPS(15),YS(15),YPS(15)
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN,
     <  NPTOT,MLOCAT,NTURN
      COMMON/CBEAM/BSIG(6,6),BSIGF(6,6),MBPRT,nform
      COMMON/FITL/COEF(20,6),VALF(20),WGHT(20),RVAL(20),XM(20)
     >  ,EM(20),WV,NELF(20,6),NPAR(20,6),IND(20,6),NPVAR(20),NVAL(20)
     >  ,NSTEP,NVAR,NCOND,ISTART,NDIV,IFITM,IFITD
      COMMON/FITD/AVEBX,AVEAX,AVEBY,AVEAY,AVENUX,AVENUY,
     >AVER11,AVER12,AVER21,AVER22,AVER33,AVER34,AVER43,AVER44
      COMMON/MONIT/VALMON(12,4,3),MNAME(600,4),MONPOS(600),NMON
      COMMON/MONFIT/VALFA(12),WGHTA(12),ERRA(12),
     >AMULTA(12,6),ADDA(12,6),DELA(12),NPARA(12,6),NELFA(12,6),
     >NPVARA(12),INDA(12,6),VALR(12),
     >NMONA(12),NVALA(12),NVARA,NCONDA,IALFLG,MONFLG,MONLST,NOPTER,
     >IAFRST,ISDBEG,IMONSD,IMSBEG
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      EREF=0.01D0
      NEL=NORLST(IE)
      IF((MDPRT.NE.-2).AND.(IALFLG.EQ.0))
     >WRITE(IOUT,10042)IE,(NAME(NEL,IN),IN=1,4)
10042 FORMAT(/,'   AFTER ELEMENT ',2X,I4,'(',4A1,')',/)
      GAMM0X=(1.0D0+ALPH0X*ALPH0X)/BETA0X
      GAMM0Y=(1.0D0+ALPH0Y*ALPH0Y)/BETA0Y
      DO 1 IEN = 1, NDENER
      INDEN=(IEN-1)*MULPRT+1
      XO(IEN)=PART(INDEN,1)
      XPO(IEN)=PART(INDEN,2)
      YO(IEN)=PART(INDEN,3)
      YPO(IEN)=PART(INDEN,4)
      IF(NHNVHV.EQ.1)GOTO100
      INDEN=INDEN+1
      R(1,1,IEN)=(PART(INDEN,1)-XO(IEN))/DX0
      R(2,1,IEN)=(PART(INDEN,2)-XPO(IEN))/DXP0
      R(3,1,IEN)=(PART(INDEN,3)-YO(IEN))/DY0
      R(4,1,IEN)=(PART(INDEN,4)-YPO(IEN))/DYP0
      INDEN=INDEN+1
      R(1,2,IEN)=(PART(INDEN,1)-XO(IEN))/DX0
      R(2,2,IEN)=(PART(INDEN,2)-XPO(IEN))/DXP0
      R(3,2,IEN)=(PART(INDEN,3)-YO(IEN))/DY0
      R(4,2,IEN)=(PART(INDEN,4)-YPO(IEN))/DYP0
      INDEN=INDEN+1
      R(1,3,IEN)=(PART(INDEN,1)-XO(IEN))/DX0
      R(2,3,IEN)=(PART(INDEN,2)-XPO(IEN))/DXP0
      R(3,3,IEN)=(PART(INDEN,3)-YO(IEN))/DY0
      R(4,3,IEN)=(PART(INDEN,4)-YPO(IEN))/DYP0
      INDEN=INDEN+1
      R(1,4,IEN)=(PART(INDEN,1)-XO(IEN))/DX0
      R(2,4,IEN)=(PART(INDEN,2)-XPO(IEN))/DXP0
      R(3,4,IEN)=(PART(INDEN,3)-YO(IEN))/DY0
      R(4,4,IEN)=(PART(INDEN,4)-YPO(IEN))/DYP0
  100 IF(NH.EQ.0)GOTO 2
      CX=R(1,1,IEN)
      SX=R(1,2,IEN)
      CPX=R(2,1,IEN)
      SPX=R(2,2,IEN)
      BETAX(IEN)=CX*CX*BETA0X-2.0D0*CX*SX*ALPH0X+SX*SX*GAMM0X
      ALPHAX(IEN)=-CPX*CX*BETA0X+(1.0D0+2.0D0*SX*CPX)*
     >ALPH0X-SX*SPX*GAMM0X
      AMU=ATAN2(SX,(CX*BETA0X-SX*ALPH0X))
      ANUX(IEN)=AMU/TWOPI
      IF(ANUX(IEN).LT.0.0D0)GOTO 10
      NUXS(IEN)=0
   11 ANUX(IEN)=ANUX(IEN)+NUX(IEN)
      INUX0=ANUX(1)+0.5D0
      INUX1=ANUX(IEN)+0.5D0
      ANUX(IEN)=ANUX(IEN)+INUX0-INUX1
      PHIX(IEN)=ANUX(IEN)*360.0D0
      GOTO 2
   10 IF(NUXS(IEN).NE.0)GOTO 11
      NUX(IEN)=NUX(IEN)+1
      NUXS(IEN)=1
      GOTO 11
    2 IF(NV.EQ.0)GOTO 3
      CY=R(3,3,IEN)
      SY=R(3,4,IEN)
      CPY=R(4,3,IEN)
      SPY=R(4,4,IEN)
      BETAY(IEN)=CY*CY*BETA0Y-2.0D0*CY*SY*ALPH0Y+SY*SY*GAMM0Y
      ALPHAY(IEN)=-CPY*CY*BETA0Y+(1.0D0+2.0D0*SY*CPY)*
     >ALPH0Y-SY*SPY*GAMM0Y
      AMU=ATAN2(SY,(CY*BETA0Y-SY*ALPH0Y))
      ANUY(IEN)=AMU/TWOPI
      IF(ANUY(IEN).LT.0.0D0)GOTO 20
      NUYS(IEN)=0
   21 ANUY(IEN)=ANUY(IEN)+NUY(IEN)
      INUY0=ANUY(1)+0.5D0
      INUY1=ANUY(IEN)+0.5D0
      ANUY(IEN)=ANUY(IEN)+INUY0-INUY1
      PHIY(IEN)=ANUY(IEN)*360.0D0
      GOTO 3
   20 IF(NUYS(IEN).NE.0)GOTO 21
      NUY(IEN)=NUY(IEN)+1
      NUYS(IEN)=1
      GOTO 11
    3 IF(NVH.EQ.0)GOTO 35
      IF(IALFLG.GT.1)GOTO 61
      DO 62 IBS=1,4
      DO 62 JBS=1,4
   62 BSIGS(IBS,JBS,IEN)=BSIG(IBS,JBS)
   61 DO 31 IB=1,4
      DO 31 JB=1,4
      BSIGL(IB,JB,IEN)=0.0D0
      DO 31 KB=1,4
      SL=0.0D0
      DO 32 LB=1,4
   32 SL=SL+BSIGS(KB,LB,IEN)*R(JB,LB,IEN)
   31 BSIGL(IB,JB,IEN)=BSIGL(IB,JB,IEN)+R(IB,KB,IEN)*SL
      IF(IALFLG.NE.1)GOTO 64

      DO 65 IBS=1,4
      DO 65 JBS=1,4
   65 BSIGS(IBS,JBS,IEN)=BSIGL(IBS,JBS,IEN)
   64 DO 33 IB=1,4
   33 BSIGL(IB,IB,IEN)=SQRT(BSIGL(IB,IB,IEN))
      DO 34 IB=1,3
      JB=IB+1
      DO 34 JBB=JB,4
      BSIGL(IB,JBB,IEN)=BSIGL(IB,JBB,IEN)/(BSIGL(IB,IB,IEN)*
     >BSIGL(JBB,JBB,IEN))
   34 BSIGL(JBB,IB,IEN)=BSIGL(IB,JBB,IEN)
   35 IF(IALFLG.EQ.0) GOTO 1
      DO 36 IM=1,NCONDA
      IF(IE.NE.NMONA(IM))GOTO 36
      FACTER=0.0D0
      IF(NOPTER.EQ.0)GOTO 51
   50 FACT=GAUSS(IMONSD)
      IF(FACT.GT.2.0D0)GOTO 50
      FACTER=FACT*ERRA(IM)
   51 VALMON(IM,1,IEN)=XO(IEN)+FACTER
      VALMON(IM,2,IEN)=YO(IEN)+FACTER
      VALMON(IM,3,IEN)=BSIGL(1,1,IEN)+FACTER
      VALMON(IM,4,IEN)=BSIGL(3,3,IEN)+FACTER
C     WRITE(IOUT,10002)IE,IM,(VALMON(IM,IV,IEN),IV=1,4)
10002 FORMAT(/,2I6,4E12.4)
   36 CONTINUE
    1 CONTINUE
      IF(IALFLG.NE.1)GOTO200
      DO 1000 ISD=1,NDENER
      XS(ISD)=XO(ISD)
      XPS(ISD)=XPO(ISD)
      YS(ISD)=YO(ISD)
      YPS(ISD)=YPO(ISD)
 1000 CONTINUE
      DEL0=PART(1,6)
      BETA0X=BETAX(1)
      ALPH0X=ALPHAX(1)
      BETA0Y=BETAY(1)
      ALPH0Y=ALPHAY(1)
  200 IF(MDPRT.EQ.-2)GOTO 40
      IF(IALFLG.NE.0)GOTO 40
      WRITE(IOUT,20000)
20000 FORMAT(//,' CENTROID COORDINATES',/)
      WRITE(IOUT,20020)
20020 FORMAT(/,2X,'ENERGY(DP/P)',5X,'X(M)',8X,'XP(RAD)',9X,'Y(M)',
     >8X,'YP(RAD)',/)
      WRITE(IOUT,20001)(DENER(IEN),XO(IEN),XPO(IEN),YO(IEN),
     >YPO(IEN),IEN=1,NDENER)
20001 FORMAT(/,(2X,5(E13.5)))
      IF(NCO.EQ.0)GOTO 301
      REF=1.0D-02
      CALL POLLSQ(DENER,XO,NDENER,NCO,XCOEF,REF)
      CALL POLLSQ(DENER,XPO,NDENER,NCO,XPCOEF,REF)
      CALL POLLSQ(DENER,YO,NDENER,NCO,YCOEF,REF)
      CALL POLLSQ(DENER,YPO,NDENER,NCO,YPCOEF,REF)
      WRITE(IOUT,30001)REF
30001 FORMAT(/,' TAYLOR EXPANSION COEFFICIENTS FOR REFERENCE ',
     >'MOMENTUM:',E10.3,//,
     >'   #         X             XP             Y             YP',//)
      DO 300 ICO=1,NCO
      ICOM1=ICO-1
  300 WRITE(IOUT,30002)ICOM1,XCOEF(ICO),XPCOEF(ICO),YCOEF(ICO),
     >YPCOEF(ICO)
30002 FORMAT(I4,4E14.5)
  301 IF((NH.EQ.0).AND.(NV.EQ.0).AND.(NVH.EQ.0))GOTO 40
      WRITE(IOUT,20010)
20010 FORMAT(//,' TRANSFER MATRICES ELEMENTS ',/)
      WRITE(IOUT,20021)
20021 FORMAT(/,2X,'ENERGY(DP/P)',5X,'R11',10X,'R12',10X,'R13',10X,
     >'R14',/)
      WRITE(IOUT,20011)(DENER(IEN),(R(1,JM,IEN),JM=1,4),IEN=1,NDENER)
20011 FORMAT(/,(2X,5(E13.5)))
      WRITE(IOUT,20022)
20022 FORMAT(/,2X,'ENERGY(DP/P)',5X,'R21',10X,'R22',10X,'R23',10X,
     >'R24',/)
      WRITE(IOUT,20011)(DENER(IEN),(R(2,JM,IEN),JM=1,4),IEN=1,NDENER)
      WRITE(IOUT,20023)
20023 FORMAT(/,2X,'ENERGY(DP/P)',5X,'R31',10X,'R32',10X,'R33',10X,
     >'R34',/)
      WRITE(IOUT,20011)(DENER(IEN),(R(3,JM,IEN),JM=1,4),IEN=1,NDENER)
      WRITE(IOUT,20024)
20024 FORMAT(/,2X,'ENERGY(DP/P)',5X,'R41',10X,'R42',10X,'R43',10X,
     >'R44',/)
      WRITE(IOUT,20011)(DENER(IEN),(R(4,JM,IEN),JM=1,4),IEN=1,NDENER)
cdlr
	call fttwiss(r)
cdlr
      IF(NH.EQ.0)GOTO 41
      WRITE(IOUT,20002)
20002 FORMAT(//,' HORIZONTAL FUNCTION VALUES',/)
      WRITE(IOUT,20025)
20025 FORMAT(/,2X,'ENERGY(DP/P)',4X,'BETAX',7X,'ALPHAX',9X,'NUX',
     >8X,'PHIX',/)
      WRITE(IOUT,20003)(DENER(IEN),BETAX(IEN),ALPHAX(IEN),
     >ANUX(IEN),PHIX(IEN),IEN=1,NDENER)
20003 FORMAT(/,(2X,5(E13.5)))
   41 IF(NV.EQ.0)GOTO 42
      WRITE(IOUT,20004)
20004 FORMAT(//,' VERTICAL FUNCTION VALUES',/)
      WRITE(IOUT,20026)
20026 FORMAT(/,2X,'ENERGY(DP/P)',4X,'BETAY',7X,'ALPHAY',9X,'NUY',
     >8X,'PHIY',/)
      WRITE(IOUT,20003)(DENER(IEN),BETAY(IEN),ALPHAY(IEN),
     >ANUY(IEN),PHIY(IEN),IEN=1,NDENER)
   42 IF(NVH.EQ.0)GOTO 40
      WRITE(IOUT,20005)
20005 FORMAT(//,' BEAM MATRIX VALUES ',/)
      WRITE(IOUT,20027)
20027 FORMAT(/,2X,'ENERGY(DP/P)',4X,'SIGX',8X,'SIGXP',9X,'R12',
     >9X,'SIGY',8X,'SIGYP',9X,'R34',/)
      WRITE(IOUT,20006)(DENER(IEN),BSIGL(1,1,IEN),BSIGL(2,2,IEN),
     >BSIGL(1,2,IEN),BSIGL(3,3,IEN),BSIGL(4,4,IEN),BSIGL(3,4,IEN),
     >IEN=1,NDENER)
20006 FORMAT(/,(2X,7(E13.5)))
      WRITE(IOUT,20028)
20028 FORMAT(/,2X,'ENERGY(DP/P)',5X,'R13',10X,'R14',10X,'R23',
     >10X,'R24',/)
      WRITE(IOUT,20007)(DENER(IEN),BSIGL(1,3,IEN),BSIGL(1,4,IEN),
     >BSIGL(2,3,IEN),BSIGL(2,4,IEN),IEN=1,NDENER)
20007 FORMAT(/,(2X,5(E13.5)))
   40 RETURN
      END
C     ************************
      SUBROUTINE DMINV(A,N,D,L,M)
C     ***********************
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      DIMENSION A(1),L(1),M(1)
      DOUBLE PRECISION A,D,BIGA,HOLD
      D=1.0D0
      NK=-N
      DO80 K=1,N
      NK=NK+N
      L(K)=K
      M(K)=K
      KK=NK+K
      BIGA=A(KK)
      DO20 J=K,N
      IZ=N*(J-1)
      DO 20 I=K,N
      IJ=IZ+I
   10 IF(ABS(BIGA)-ABS(A(IJ))) 15,20,20
   15 BIGA=A(IJ)
      L(K)=I
      M(K)=J
   20 CONTINUE
      J=L(K)
      IF(J-K) 35,35,25
   25 KI=K-N
      DO 30 I=1,N
      KI=KI+N
      HOLD=-A(KI)
      JI=KI-K+J
      A(KI)=A(JI)
   30 A(JI) =HOLD
   35 I=M(K)
      IF(I-K) 45,45,38
   38 JP=N*(I-1)
      DO40 J=1,N
      JK=NK+J
      JI=JP+J
      HOLD=-A(JK)
      A(JK)=A(JI)
   40 A(JI) =HOLD
   45 IF(BIGA) 48,46,48
   46 D=0.0D0
      RETURN
   48 DO55 I=1,N
      IF(I-K) 50,55,50
   50 IK=NK+I
      A(IK)=A(IK)/(-BIGA)
   55 CONTINUE
      DO 65 I=1,N
      IK=NK+I
      HOLD=A(IK)
      IJ=I-N
      DO 65 J=1,N
      IJ=IJ+N
      IF(I-K) 60,65,60
   60 IF(J-K) 62,65,62
   62 KJ=IJ-I+K
      A(IJ)=HOLD*A(KJ)+A(IJ)
   65 CONTINUE
      KJ=K-N
      DO 75 J=1,N
      KJ=KJ+N
      IF(J-K) 70,75,70
   70 A(KJ)=A(KJ)/BIGA
   75 CONTINUE
      D=D*BIGA
      A(KK)=1.0D0/BIGA
   80 CONTINUE
      K=N
  100 K=(K-1)
      IF(K) 150,150,105
  105 I=L(K)
      IF(I-K) 120,120,108
  108 JQ=N*(K-1)
      JR=N*(I-1)
      DO 110 J=1,N
      JK=JQ+J
      HOLD=A(JK)
      JI=JR+J
      A(JK)=-A(JI)
  110 A(JI) =HOLD
  120 J=M(K)
      IF(J-K) 100,100,125
  125 KI=K-N
      DO 130 I=1,N
      KI=KI+N
      HOLD=A(KI)
      JI=KI-K+J
      A(KI)=-A(JI)
  130 A(JI) =HOLD
      GO TO 100
  150 RETURN
      END
C     ********************
      SUBROUTINE DRIFT
C     ************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INPUTT/KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/PRODCT/KODEPR,NEL,NOF
      IAD=IADR(N)
      N=MADR(N)
      AL=ELDAT(IAD)
      DO 100 I=1,6
      DO 100 J=1,NOF
      AMAT(N,I,J)=0.0D0
      IF(I.EQ.J) AMAT(N,I,J)=1.0D0
  100 CONTINUE
      AMAT(N,1,2)=AL
      AMAT(N,3,4)=AL
      IF(NORDER.EQ.1)RETURN
      AMAT(N,5,13)=AL/2.0D0
      AMAT(N,5,22)=AL/2.0D0
      RETURN
      END
C     ***********************
C     ..................................................................
C
C        SUBROUTINE DSIMQ
C
C        PURPOSE
C           OBTAIN SOLUTION OF A SET OF SIMULTANEOUS LINEAR EQUATIONS,
C           AX=B
C
C        USAGE
C           CALL DSIMQ(A,B,N,KS)
C
C        DESCRIPTION OF PARAMETERS
C           A - MATRIX OF COEFFICIENTS STORED COLUMNWISE.  THESE ARE
C               DESTROYED IN THE COMPUTATION.  THE SIZE OF MATRIX A IS
C               N BY N.
C           B - VECTOR OF ORIGINAL CONSTANTS (LENGTH N). THESE ARE
C               REPLACED BY FINAL SOLUTION VALUES, VECTOR X.
C           N - NUMBER OF EQUATIONS AND VARIABLES. N MUST BE .GT. ONE.
C           KS - OUTPUT DIGIT
C                0 FOR A NORMAL SOLUTION
C                1 FOR A SINGULAR SET OF EQUATIONS
C
C        REMARKS
C           MATRIX A MUST BE GENERAL.
C           IF MATRIX IS SINGULAR , SOLUTION VALUES ARE MEANINGLESS.
C           AN ALTERNATIVE SOLUTION MAY BE OBTAINED BY USING MATRIX
C           INVERSION (MINV) AND MATRIX PRODUCT (GMPRD).
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           NONE
C
C        METHOD
C           METHOD OF SOLUTION IS BY ELIMINATION USING LARGEST PIVOTAL
C           DIVISOR. EACH STAGE OF ELIMINATION CONSISTS OF INTERCHANGING
C           ROWS WHEN NECESSARY TO AVOID DIVISION BY ZERO OR SMALL
C           ELEMENTS.
C           THE FORWARD SOLUTION TO OBTAIN VARIABLE N IS DONE IN
C           N STAGES. THE BACK SOLUTION FOR THE OTHER VARIABLES IS
C           CALCULATED BY SUCCESSIVE SUBSTITUTIONS. FINAL SOLUTION
C           VALUES ARE DEVELOPED IN VECTOR B, WITH VARIABLE 1 IN B(1),
C           VARIABLE 2 IN B(2),........, VARIABLE N IN B(N).
C           IF NO PIVOT CAN BE FOUND EXCEEDING A TOLERANCE OF 0.0,
C           THE MATRIX IS CONSIDERED SINGULAR AND KS IS SET TO 1. THIS
C           TOLERANCE CAN BE MODIFIED BY REPLACING THE FIRST STATEMENT.
C
C     ..................................................................
C
      SUBROUTINE DSIMQ(A,B,N,KS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(1),B(1)
C
C        FORWARD SOLUTION
C
      TOL=0.0
      KS=0
      JJ=-N
      DO 65 J=1,N
      JY=J+1
      JJ=JJ+N+1
      BIGA=0
      IT=JJ-J
      DO 30 I=J,N
C
C        SEARCH FOR MAXIMUM COEFFICIENT IN COLUMN
C
      IJ=IT+I
      IF(ABS(BIGA)-ABS(A(IJ))) 20,30,30
   20 BIGA=A(IJ)
      IMAX=I
   30 CONTINUE
C
C        TEST FOR PIVOT LESS THAN TOLERANCE (SINGULAR MATRIX)
C
      IF(ABS(BIGA)-TOL) 35,35,40
   35 KS=1
      RETURN
C
C        INTERCHANGE ROWS IF NECESSARY
C
   40 I1=J+N*(J-2)
      IT=IMAX-J
      DO 50 K=J,N
      I1=I1+N
      I2=I1+IT
      SAVE=A(I1)
      A(I1)=A(I2)
      A(I2)=SAVE
C
C        DIVIDE EQUATION BY LEADING COEFFICIENT
C
   50 A(I1)=A(I1)/BIGA
      SAVE=B(IMAX)
      B(IMAX)=B(J)
      B(J)=SAVE/BIGA
C
C        ELIMINATE NEXT VARIABLE
C
      IF(J-N) 55,70,55
   55 IQS=N*(J-1)
      DO 65 IX=JY,N
      IXJ=IQS+IX
      IT=J-IX
      DO 60 JX=JY,N
      IXJX=N*(JX-1)+IX
      JJX=IXJX+IT
   60 A(IXJX)=A(IXJX)-(A(IXJ)*A(JJX))
   65 B(IX)=B(IX)-(B(J)*A(IXJ))
C
C        BACK SOLUTION
C
   70 NY=N-1
      IT=N*N
      DO 80 J=1,NY
      IA=IT-J
      IB=N-J
      IC=N
      DO 80 K=1,J
      B(IB)=B(IB)-A(IA)*B(IC)
      IA=IA-N
   80 IC=IC-1
      RETURN
      END
      SUBROUTINE SETOUT
C     ******************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/FOUT/OUTFL(300)
      COMMON/CBEAM/BSIG(6,6),BSIGF(6,6),MBPRT,nform
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON/ANALC/COMPF,RNU0X,CETAX,CETAPX,CALPHX,CBETAX,
     1RMU1X,CHROMX,ALPH1X,BETA1X,
     1RMU0Y,RNU0Y,CETAY,CETAPY,CALPHY,CBETAY,
     1RMU1Y,CHROMY,ALPH1Y,BETA1Y,RMU0X,
     >COSX,ALX1,ALX2,VX1,VXP1,VX2,VXP2,
     >COSY,ALY1,ALY2,VY1,VYP1,VY2,VYP2,NSTABX,NSTABY,NSTAB,NWRNCP
      COMMON/TWF/BETAOX,ALPHOX,ETAOX,ETAPOX,ANUX,
     >            BETAOY,ALPHOY,ETAOY,ETAPOY,ANUY,IE
      COMMON/FITD/AVEBX,AVEAX,AVEBY,AVEAY,AVENUX,AVENUY,
     >AVER11,AVER12,AVER21,AVER22,AVER33,AVER34,AVER43,AVER44
      COMMON/LAYOUT/XHI,YHI,ZHI,THETAI,PHIHI,PSIHI,CONVH,
     >SRH,XRH,YRH,ZRH,THETAR,PHIRH,PSIRH,NLAY,NLAYDUM
 	common /twiher/mpnt,jfite(10),ipnt
	common /bmax/bvarc,bharc,bvir,bhir,ir1,ir2,ir3,ir4
      DIMENSION RELAY2(10),RELAY1(20),RELAY3(162)
      DIMENSION RELAY4(6),RELAY5(8),RELAY6(8)
      EQUIVALENCE(RELAY4(1),AVEBX)
      EQUIVALENCE(RELAY5(1),AVER11)
      EQUIVALENCE(RELAY6(1),SRH)
      EQUIVALENCE(COMPF,RELAY1(1))
      EQUIVALENCE(RELAY2(1),BETAOX)
      EQUIVALENCE(TEMP(1,1),RELAY3(1))
      IF((IE.EQ.IFITE).AND.(IE.NE.0))GOTO 4
      DO 1 I=1,10
      OUTFL(I+20)=RELAY2(I)
    1 CONTINUE
      DO 2 I=1,20
      OUTFL(I)=RELAY1(I)
    2 CONTINUE
      DO 3 I = 1,162
      OUTFL(I+100)=RELAY3(I)
    3 CONTINUE
c      IBS=1
c      DO 6 IB=1,6
c      DO 6 JB=IB,6
c      OUTFL(40+IBS)=BSIGF(IB,JB)
c    6 IBS=IBS+1
c      DO 8 IR=1,6
c      OUTFL(92+IR)=RELAY4(IR)
	outfl(93)=bvarc
	outfl(94)=bharc
	outfl(95)=bvir
	outfl(96)=bhir
    8 CONTINUE
      DO 9 IR=1,8
      OUTFL(270+IR)=RELAY5(IR)
    9 CONTINUE
      DO 10 IR=1,8
      OUTFL(280+IR)=RELAY6(IR)
   10 CONTINUE
      RETURN
    4 DO 5 I=1,mpnt
      ip=(ipnt-1)*10
    5 OUTFL(I+30+ip)=RELAY2(I)
c      IBS=1
c      DO 7 IB=1,6
c      DO 7 JB=IB,6
c      OUTFL(70+IBS)=BSIGF(IB,JB)
c    7 IBS=IBS+1
      RETURN
      END
C     *******************
      SUBROUTINE ELID(ICHAR,NELID)
C     *******************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      DIMENSION ICHAR(1)
      I=0
    1 I=I+1
      IF(I.GT.NA)GOTO 2
      IF(ICHAR(1).NE.NAME(I,1))GOTO 1
      IF(ICHAR(2).NE.NAME(I,2))GOTO 1
      IF(ICHAR(3).NE.NAME(I,3))GOTO 1
      IF(ICHAR(4).NE.NAME(I,4))GOTO 1
      NELID = I
      RETURN
    2 WRITE(IOUT,10000)ICHAR
      IF (ISO.NE.0)WRITE(ISOUT,10000)
10000 FORMAT(/,' ELEMENT NAME DID NOT MATCH MACHINE ELEMENT LIST',/,
     >' ',4A1)
      CALL HALT
      STOP
      END
C     *******************
      SUBROUTINE ENANAL
C     *******************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION L(5),M1(5),L4(4),M14(4)
      DOUBLE PRECISION M(5,5)
      DIMENSION A(25),B(16),F(4),X(4),V(5,4),Q(4,4),SAVEU(75,4)
      DIMENSION DAT(4,5)
      EQUIVALENCE (M(1,1),A(1)), (Q(1,1),B(1))
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN,
     <  NPTOT,MLOCAT,NTURN
      COMMON/TRI/WCO(15,6),GEN(5,4),PGEN(75,6),DIST,
     <A1(15),B1(15),A2(15),B2(15),XCOR(3,15),XPCOR(3,15),
     1AL1(15),AL2(15),MESH,NIT,NENER,NITX,NITS,NITM1,NANAL,NOPRT
        common/analc/compf,rnu0x,cetax,cetapx,calphx,cbetax,
     1	rmu1x,chromx,alph1x,beta1x,
     1	rmu0y,rnu0y,cetay,cetapy,calphy,cbetay,
     1	rmu1y,chromy,alph1y,beta1y,rmu0x,
     1	cosx,alx1,alx2,vx1,vxp1,vx2,vxp2,
     1	cosy,aly1,aly2,vy1,vyp1,vy2,vyp2,nstabx,nstaby,nstab,nwrncp
	common /middle/emit(2),interm,intprt,iemitt,idec,nesave(2000)
	common /alph/ab,halpha(15),valpha(15),detyspot(15),detyspotmax,
     &         detxspotmax,scspotmax
      COMMON /MVT/ U(5,4)
	common /detx/detx(5,15),dety(5,15),sc(5,15),dethv(5,15),detintmax
      COMMON/CLSQ/ALSQ(15,2,4),IXY,NCOEF,NAPLT,JENER,LENER(15)
      LOGICAL LOGPAR,LENER
	data minipri/0/
      DATA DAT/ 1.0D0, 0.0D0, 1.0D0, 0.0D0, 0.309017D0, 0.951057D0,
     1 0.309017D0, 0.951057D0, -0.809017D0, 0.587785D0, -0.809016D0,
     2 -0.587785D0, -0.809017D0, -0.587785D0, 0.309017D0, -0.951056D0,
     3 0.309017D0, -0.951056D0, -0.809017D0, 0.587785D0/
	data idum/0/
        data ifirst/0/
        dimension g(4)
	dimension distxy(6,4)
        if(ifirst.eq.0)then
            g(1)=dsqrt(1.d0)
            g(2)=1.d0/dsqrt(1.d0)
            g(3)=dsqrt(0.015d0)
            g(4)=1.d0/dsqrt(0.015d0)
            type 11113
11113      format(1x,' distxxyy for first iteration ?')
           read(5,11114)(distxy(1,i),i=1,4)
           type 11115
11115      format(1x,' distxxyy for second iteration ?')
           read(5,11114)(distxy(2,i),i=1,4)
           type 11117
11117      format(1x,' distxxyy for third iteration ?')
           read(5,11114)(distxy(3,i),i=1,4)
           type 11119
11119      format(1x,' distxxyy for fourth iteration ?')
           read(5,11114)(distxy(4,i),i=1,4)
           type 11121
11121      format(1x,' distxxyy for fifth iteration ?')
           read(5,11114)(distxy(5,i),i=1,4)
           type 11123
11123      format(1x,' distxxyy for sixth iteration ?')
           read(5,11114)(distxy(6,i),i=1,4)
11114      format(4f)
           ifirst=1
           type 11124,((distxy(j,i),i=1,4),j=1,6)
           write(13,11124)((distxy(j,i),i=1,4),j=1,6)
11124      format(1x,4f9.6)
           endif
	detyspotmax=1.
        detxspotmax=1.
        scspotmax=1.
C TO SET UP GEN
  200 DO 201 I=1,5
      DO 202 J=1,4
  202 GEN(I,J)=DISTxy(nitx+1,j)*g(j)*DAT(J,I)
  201 CONTINUE
C TO GENERATE PARTICLES.
      DO 203 I=1,5
      DO 204 N=1,NENER
      IND=I+N+N+N+N+N-5
      DO 205 J=1,4
  205 PGEN(IND,J)=WCO(N,J)+GEN(I,J)
      PGEN(IND,6)=WCO(N,6)
  204 PGEN(IND,5)=WCO(N,5)
  203 CONTINUE
C TO PREPARE FOR TRACKING PARTICLES.
      NPART=5*NENER
      NCPART = NPART
      DO 206 I = 1, NPART
      DO 207 J=1,6
  207 PART(I,J)=PGEN(I,J)
  206 CONTINUE
	if(minipri.eq.0)goto 209
       IF (NITS.LT.0) GO TO 209
      WRITE (IOUT,210)
  210 FORMAT ('-', 'INITIAL POSITIONS OF PARTICLES ', /)
      DO 211 I=1,NPART
  211 WRITE (IOUT,212) I, (PART(I,K),K=1,6)
  212 FORMAT(I4,6(E14.5))
  209 NCTURN=0
  215 CALL TRACKT
      DO 216 IP=1,NENER
      DO 216 IL=1,5
      ILP=(IP-1)*5+IL
      IF(.NOT.LOGPAR(ILP))LENER(IP)=.FALSE.
  216 IF(.NOT.LENER(IP))LOGPAR(ILP)=.FALSE.
      DO 218 IL=1,NENER
      IF(LENER(IL))GO TO 220
  218 CONTINUE
      WRITE(IOUT,48)
   48 FORMAT(' OPERATION STOPPED DUE TO LOSS OF PARTICLES ')
      STOP
  220 CONTINUE
C TO FIND THE CLOSED ORBIT.
  260 DO 270 J=1,NENER
      IF(.NOT.LENER(J))GO TO 270
      IND5=J+J+J+J+J
      IND4=IND5-1
      IND3=IND4-1
      IND2=IND3-1
      IND1=IND2-1
      DO 271 I=1,4
      IND=I+1
      M(1,IND)=PGEN(IND1,I)
      M(2,IND)=PGEN(IND2,I)
      M(3,IND)=PGEN(IND3,I)
      M(4,IND)=PGEN(IND4,I)
      M(5,IND)=PGEN(IND5,I)
      V(1,I)=PART(IND1,I)
      V(2,I)=PART(IND2,I)
      V(3,I)=PART(IND3,I)
      V(4,I)=PART(IND4,I)
  271 V(5,I)=PART(IND5,I)
      DO 275 I=1,5
  275 M(I,1)=1
      CALL DMINV(A,5,D,L,M1)
      DO 277 I=1,5
      DO 278 N=1,4
      U(I,N)=0.0D0
      DO 279 K=1,5
  279 U(I,N)=U(I,N)+M(I,K)*V(K,N)
  278 CONTINUE
  277 CONTINUE
c  268 WRITE (IOUT,276) PGEN(IND1,6)
c  276 FORMAT(//,10X,33H-----     THE ANALYSIS FOR ENERGY,E17.5,
c     *10H     -----,/)
c      WRITE (IOUT,281)
c  281 FORMAT('-', 'THE TRANSFER MATRIX IS ')
c      DO 283 I=1,4
c      WRITE (IOUT,282) (U(N,I),N=2,5)
c  282 FORMAT ('-',4(E15.5))
c  283 CONTINUE
269	continue
C TO FIND THE DETERMINANT.
      DET=((U(4,3)*U(5,4)-U(5,3)*U(4,4))*(U(2,1)*U(3,2)-U(2,2)*U(3,1)))
     1+ ((U(4,2)*U(5,4)-U(5,2)*U(4,4)) * (U(2,3)*U(3,1)-U(2,1)*U(3,3)))
     1+ ((U(4,2)*U(5,3)-U(5,2)*U(4,3)) * (U(2,1)*U(3,4)-U(2,4)*U(3,1)))
     1+ ((U(4,1)*U(5,4)-U(5,1)*U(4,4)) * (U(2,2)*U(3,3)-U(2,3)*U(3,2)))
     1+ ((U(4,1)*U(5,3)-U(5,1)*U(4,3)) * (U(2,4)*U(3,2)-U(2,2)*U(3,4)))
     1+ ((U(4,1)*U(5,2)-U(5,1)*U(4,2)) * (U(2,3)*U(3,4)-U(2,4)*U(3,3)))
      if(minipri.ne.0.or.(abs(det)-1.0d0).gt.0.5d0)WRITE(IOUT,284) DET
      IF((ABS(DET)-1.0D0).GT.0.5D0)STOP
	detx(1+nitx,j)=u(2,1)*u(3,2)-u(3,1)*u(2,2)
	dety(1+nitx,j)=u(4,3)*u(5,4)-u(5,3)*u(4,4)
	sc(1+nitx,j)=u(4,1)**2+u(5,1)**2+u(4,2)**2+u(5,2)**2+
     &	  u(2,3)**2+u(3,3)**2+u(2,4)**2+u(3,4)**2
	dethv(1+nitx,j)=det
  284 FORMAT ('-','THE DETERMINANT IS: ',E20.10)
      IF(NITX.LT.NIT) GO TO 265
c	if(minipri.eq.0)goto 269
  268	continue
  262 DO 285 I=1,4
      DO 286 K=1,4
  286 Q(I,K)=-(U(K+1,I))
      Q(I,I)=1.D0+Q(I,I)
  285 X(I)=U(1,I)
      CALL DMINV(B,4,D,L4,M14)
      DO 289 I=1,4
      F(I)=0.0D0
      DO 287 K=1,4
  287 F(I)=F(I)+Q(I,K)*X(K)
  289 WCO(J,I)=F(I)
      GO TO 261
C THE ROUTINE TO SAVE THE MATRIX U.
  265 DO 266 I=1,5
      IND=I+IND1-1
      DO 267 K=1,4
  267 SAVEU(IND,K)=U(I,K)
  266 CONTINUE
      IF(NITS.LT.0.AND.NITX.LT.NITM1) GO TO 262
      GO TO 268
  261 CONTINUE
      IF (NITS.LT.0.AND.NITX.LT.NITM1) GO TO 270
	if(minipri.eq.0)goto 270
      WRITE (IOUT,288) (F(I),I=1,4)
  288 FORMAT ('-','THE CLOSED ORBIT IS',/,20X,'XCO=',E15.5,8X,'X"CO=',
     1E15.5,/,20X, 'ZCO=',E15.5,8X,'Z"CO=',E15.5)
 270  CONTINUE
      NITX=NITX+1
      IF(NITX.LT.NIT) GO TO 251
      IF(NOPRT.NE.NTURN) GO TO 350
C THE MOVEMENT ANALYSIS OF THE DATA.
  351 IF (NANAL.EQ.0) RETURN
	if(minipri.eq.0)goto 69
      WRITE(IOUT,20001)
20001 FORMAT(///,30(1H ),27(1H*),/,30(1H ),
     127H*    MOVEMENT ANALYSIS    *,/,30(1H ),27(1H*),/)
69	continue
  230 DO 231 J=1,NENER
      JENER=J
      IF(.NOT.LENER(J))GO TO 231
      DO 232 K=1,5
      IND=K+J+J+J+J+J-5
      DO 233 I=1,4
  233 U(K,I)=SAVEU(IND,I)
  232 CONTINUE
      ALSQ(J,1,3)=WCO(J,1)
      ALSQ(J,1,4)=WCO(J,2)
      ALSQ(J,2,3)=WCO(J,3)
      ALSQ(J,2,4)=WCO(J,4)
	if(minipri.eq.0)goto 769
      WRITE(IOUT,239) WCO(J,6)
  239 FORMAT(/(10X,16H-----     ENERGY  ,E17.5,10H     -----,/))
C TO FIND THE HORIZONTAL MOVEMENT.
      WRITE (IOUT,234)
  234 FORMAT('-',30X,'HORIZONTAL MOVEMENT')
769	continue
      IXY=1
      CALL MOVMT
	halpha(j)=ab
C TO FIND THE VERTICAL MOVEMENT
	if(minipri.eq.0)goto 869
      WRITE(IOUT,235)
  235 FORMAT('-',31X,'VERTICAL MOVEMENT')
869	continue
      DO 236 I=2,3
      IND=I+2
      DO 237 K=1,2
  237 U(I,K)=U(IND,K+2)
  236 CONTINUE
      IXY=2
      CALL MOVMT
	valpha(j)=ab
  231 CONTINUE
      IF(NANAL.GT.1)CALL RES
c      CALL LSQ
      IF(NAPLT.EQ.1) CALL PLOTEN
      RETURN
c  251 DIST=DIST*0.3D0
  251 DIST=DIST*0.1D0
      GO TO 200
  296 DO 297 JICO=1,6
  297 PART(ICO,JICO)=0.0D0
      GO TO 298
  350 DO 298 ICO=1,NENER
      IF(.NOT.LENER(ICO)) GO TO 296
      DO 290 J=1,6
  290 PART(ICO,J) = WCO(ICO,J)
  298 CONTINUE
      NPRINT =NOPRT
      NPART=NENER
      NCPART = NPART
	if(minipri.eq.0)goto 969
      WRITE(IOUT,213)
 213  FORMAT(//,30(1H ),36(1H*),/,30(1H ),
     >36H*    DETAILED CLOSED ORBIT DATA    *,/,30(1H )
     >,36(1H*),/)
969	continue
      NCTURN=0
      CALL TRACKT
      GO TO 351
      END
C     ***********************
      SUBROUTINE ENTEX(PARM)
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON /INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/PRODCT/KODEPR,NEL,NOF
      DIMENSION PARM(20)
C
C     CLEAR AMAT(N,6,27)
C
      DO 100 I=1,6
      DO 100 J=1,NOF
      AMAT(N,I,J)=0.0D0
100   CONTINUE
      PARM(3)=PARM(3)*CRDEG
      TAN1=TAN(PARM(3))
      TAN2=TAN1*TAN1
      SEC=1.0D0/COS(PARM(3))
      AN=PARM(2)
      H=PARM(1)
      S=PARM(4)
      SIN1=SIN(PARM(3))
      SIN2=SIN1*SIN1
      CFOCL=2.0D0*PARM(7)*H*PARM(6)*SEC*(1.0D0+SIN2)
      AMAT(N,1,1) = 1.0D0
      AMAT(N,2,1) = H*TAN1
      AMAT(N,2,2) = 1.0D0
      AMAT(N,3,3) = 1.0D0
      AMAT(N,4,3)=-H*TAN(PARM(3)-CFOCL)
      AMAT(N,4,4) = 1.0D0
      AMAT(N,5,5) = 1.0D0
      AMAT(N,6,6)=1.0D0
      IF(NORDER.EQ.1)RETURN
      SEC2=SEC*SEC
      SEC3=SEC2*SEC
      H2=H*H
      HO2=H/2.0D0
      ENTC=(H*PARM(5)*SEC3)/2.0D0
      AMAT(N,1,7) = -S*HO2*TAN2
      AMAT(N,1,18) = S*HO2*SEC2
      AMAT(N,2,7)=ENTC-H2*(AN-(S-1)*TAN2/4)*TAN1
      AMAT(N,2,8) = S*TAN2*H
      AMAT(N,2,12) = -H*TAN1
      AMAT(N,2,18)=H2*(AN+(S+1)*(TAN2+1)/4 + S*TAN2/2) *TAN1 - ENTC
      AMAT(N,2,19) = -S*H*TAN2
      AMAT(N,3,9) = S*TAN2*H
      AMAT(N,4,9)=-2.0D0*ENTC+H2*(2*AN-(S-1)*SEC2/2)*TAN1
      AMAT(N,4,10) = -S*TAN2*H
      AMAT(N,4,14) = -S*H*SEC2
      AMAT(N,4,21) = H*TAN1
      RETURN
      END
C     *****************
      SUBROUTINE ERESET
C     *****************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)

      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/ERSAV/SAV(7),SAVMAT(6,27),IERSET,IER,IDE
      COMMON/ERR/ERRVAL(7,50),NERELE(50),NERPAR(7,50),NERR,NEROPT,
     > NERRE,MERSEL(50),NERNGE(50),MERNGE(2,10,50),MERFLG
      COMMON/MISSET/DX,DXR,DY,DYR,DZ,DZR,DDEL,HLMNEL,I,IEP,MNEL
      IF(IERSET.EQ.0)RETURN
      IAD=IADR(MNEL)
      N=MADR(MNEL)
C     WRITE(IOUT,88888)MNEL,N
88888 FORMAT(/,' IN ERESET MNEL AND N =',2I5)
      DO 1 ID=1,7
      NPAR=NERPAR(ID,IDE)
      IF(NPAR.EQ.0)GOTO 2
      ELDAT(IAD+NPAR-1)=SAV(ID)
    1 CONTINUE
    2 CONTINUE
C     WRITE(IOUT,99000)(((AMAT(N,IM,JM)),JM=1,27),IM=1,6)
99000 FORMAT(/,6(3(9E14.5,/),/))
      DO 3 IMAT=1,6
      DO 3 JMAT=1,27
      AMAT(N,IMAT,JMAT)=SAVMAT(IMAT,JMAT)
    3 CONTINUE
C     WRITE(IOUT,99000)(((AMAT(N,IM,JM)),JM=1,27),IM=1,6)
      IERSET=0
      RETURN
      END
C     ***********************
      SUBROUTINE ERRDAT(IEND)
C     ********************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/ERR/ERRVAL(7,50),NERELE(50),NERPAR(7,50),NERR,NEROPT,
     > NERRE,MERSEL(50),NERNGE(50),MERNGE(2,10,50),MERFLG
      DIMENSION ICHAR(4),DATA(14)
      DATA NINE/'9'/
C INITIALIZE TO 0 ALL ARRAYS DEFINED IN THIS ROUTINE
      DO 3 INER=1,50
      NERELE(INER)=0
      DO 3 JNER=1,7
      NERPAR(JNER,INER)=0
    3 ERRVAL(JNER,INER)=0.0D0
      NPRINT=1
      IEND=0
      NERR=0
    2 NCHAR=4
      NDATA=0
      NDIM=0
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
      IF((ICHAR(1).EQ.NINE).AND.(ICHAR(2).EQ.NINE))GOTO 99
      CALL ELID(ICHAR,NELID)
      NERR=NERR+1
      NERELE(NERR)=NELID
      NCHAR=0
      NDIM=14
      NDATA=-1
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
      DO 1 ID=1,NDATA
      NERPAR(ID,NERR)=DATA(2*ID-1)
    1 ERRVAL(ID,NERR)=DATA(2*ID)
C     WRITE(IOUT,99998)
99998 FORMAT(' IN ERRDAT NERPAR =')
C     WRITE(IOUT,99997)((NERPAR(I,J),J=1,50),I=1,7)
99997 FORMAT(7(5(10I10,/)/))
      GOTO 2
   99 RETURN
      END
C     ***************
      SUBROUTINE ESET
C     ***************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/ERSAV/SAV(7),SAVMAT(6,27),IERSET,IER,IDE
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/ERR/ERRVAL(7,50),NERELE(50),NERPAR(7,50),NERR,NEROPT,
     > NERRE,MERSEL(50),NERNGE(50),MERNGE(2,10,50),MERFLG
      COMMON/MISSET/DX,DXR,DY,DYR,DZ,DZR,DDEL,HLMNEL,I,IEP,MNEL
      COMMON/MIS/RMISA(7,50),MISELE(50),NMIS,ISEED,IXS,NOPT,
     > NMISE,MISSEL(50),NMRNGE(50),MSRNGE(2,10,50),MISFLG,MCHFLG
      DO 1 IER=1,NERRE
      IDE=MERSEL(IER)
      IF(MNEL.EQ.NERELE(IDE))GOTO 2
    1 CONTINUE
      RETURN
    2 NFRNGE=NERNGE(IER)
      IF(NFRNGE.EQ.0)GOTO 4
      IF(NFRNGE.LT.0)RETURN
C     WRITE(IOUT,99001)IEP,IER,MNEL
99001 FORMAT(/,' IN ESET IEP IER MNEL =',3I5)
      DO 3 IERN=1,NFRNGE
      IF((IEP.GE.MERNGE(1,IERN,IER)).AND.(IEP.LE.MERNGE(2,IERN,IER)))
     > GOTO 4
    3 CONTINUE
      RETURN
    4 IERSET=1
      IAD=IADR(MNEL)
      N=MADR(MNEL)
      DO 7 ID=1,7
C     WRITE(IOUT,88887)ID,IDE
88887 FORMAT(' IN LOOP 7 IN ESET ID,IDE=',2I4)
      NPAR=NERPAR(ID,IDE)
C     WRITE(IOUT,88885)NPAR,ID,IDE
88885 FORMAT('  IN LOOP 7 IN ESET NPAR,ID,IDE=',3I10)
      IF(NPAR.EQ.0)GOTO 8
      SAV(ID)=ELDAT(IAD+NPAR-1)
      IGOTO=NEROPT+1
      GOTO(100,101,102,103),IGOTO
      WRITE(IOUT,99998)
99998 FORMAT(/,'  ERROR IN OPTION NUMBER FOR RANDOM GENERATION',/)
      STOP
  100 FACT=1.0D0
      GOTO 200
  101 UR=URAND(IXS)
      FACT=1.0D0
      IF(UR.LT.0.5D0)FACT=-1.0D0
      GOTO200
  102 FACT=SQRT(3.0D0)*2.0D0*(URAND(IXS)-0.5D0)
      GOTO 200
  103 FACT=GAUSS(IXS)
      IF(FACT.GT.2.0D0)GOTO 103
  200 ELDAT(IAD+NPAR-1)=ELDAT(IAD+NPAR-1)+FACT*ERRVAL(ID,IDE)
C     WRITE(IOUT,88886)ID,IDE,IAD,NPAR
88886 FORMAT(' AT END LOOP 7 IN ESET ID,IDE,IAD,NPAR=',4I4)
    7 CONTINUE
    8 DO 9 IMAT=1,6
      DO 9 JMAT=1,27
      SAVMAT(IMAT,JMAT)=AMAT(N,IMAT,JMAT)
    9 CONTINUE
C     WRITE(IOUT,88888)MNEL,N
88888 FORMAT(/,' IN ESET MNEL AND N =',2I5)
C     WRITE(IOUT,99003)(((AMAT(N,IM,JM)),JM=1,27),IM=1,6)
99003 FORMAT(/,6(3(9E12.5,/),//))
C     WRITE(IOUT,99000)MNEL
99000 FORMAT(/,' MATRIX OF ELEMENT ',I5,'IS MODIFIED')
      CALL MATGEN(MNEL)
C     WRITE(IOUT,99003)(((AMAT(N,IM,JM)),JM=1,27),IM=1,6)
      RETURN
      END
C     ***********************
      SUBROUTINE FALCT(X,F)
C     ********************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/CORR/CORVAL(600,4),ICRID(600),ICRPOS(600),ICRSET(600),
     >ICROPT(600),NCORR,NCURCR,ICRFLG,ICRCHK,ALMNEL,NPARC
      COMMON/MONIT/VALMON(12,4,3),MNAME(600,4),MONPOS(600),NMON
      COMMON/MONFIT/VALFA(12),WGHTA(12),ERRA(12),
     >AMULTA(12,6),ADDA(12,6),DELA(12),NPARA(12,6),NELFA(12,6),
     >NPVARA(12),INDA(12,6),VALR(12),
     >NMONA(12),NVALA(12),NVARA,NCONDA,IALFLG,MONFLG,MONLST,NOPTER,
     >IAFRST,ISDBEG,IMONSD,IMSBEG
      DIMENSION VAL0(12),X(1)
      DO 102 IFL=1,NVARA
      IF(IFL.LE.NPARC)GOTO 103
      CORVAL(NELFA(IFL,1),NPARA(IFL,1))=X(IFL)
      GOTO 102
  103 ELDAT(INDA(IFL,1))=X(IFL)
      JFL=NPVARA(IFL)
      DO 105 JAA=1,JFL
      ELDAT(INDA(IFL,JAA))=X(IFL)*AMULTA(IFL,JAA)+ADDA(IFL,JAA)
  105 CALL MATGEN(NELFA(IFL,JAA))
  102 CONTINUE
      CALL DETAIL(IEND)
      DO 200 IFL=1,NCONDA
      JAA=(NVALA(IFL)-1)/4+1
      IAA=NVALA(IFL)-(JAA-1)*4
  200 VAL0(IFL)=VALMON(IFL,IAA,JAA)
      SW=0.0D0
      F=0.0D0
      DO 201 IFL=1,NCONDA
      F=F+((VALR(IFL)-VAL0(IFL))*WGHTA(IFL))**2
  201 SW=SW+WGHTA(IFL)**2
      F=SQRT(F/SW)
      RETURN
      END
C     **********************
      SUBROUTINE FITLSQ(IEND)
C     ***********************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      DIMENSION OPLIST(12),ICHAR(4),DEL(20)
      COMMON/FITL/COEF(20,6),VALF(20),WGHT(20),RVAL(20),XM(20)
     >  ,EM(20),WV,NELF(20,6),NPAR(20,6),IND(20,6),NPVAR(20),NVAL(20)
     >  ,NSTEP,NVAR,NCOND,ISTART,NDIV,IFITM,IFITD
      COMMON/FOUT/OUTFL(300)
      COMMON/ANALC/COMPF,RNU0X,CETAX,CETAPX,CALPHX,CBETAX,
     1RMU1X,CHROMX,ALPH1X,BETA1X,
     1RMU0Y,RNU0Y,CETAY,CETAPY,CALPHY,CBETAY,
     1RMU1Y,CHROMY,ALPH1Y,BETA1Y,RMU0X,
     >COSX,ALX1,ALX2,VX1,VXP1,VX2,VXP2,
     >COSY,ALY1,ALY2,VY1,VYP1,VY2,VYP2,NSTABX,NSTABY,NSTAB,NWRNCP
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/FUNC/BETAX,ALPHAX,ETAX,ETAPX,BETAY,ALPHAY,ETAY,ETAPY,
     <  STARTE,ENDE,DELTAE,DNU,MFPRNT,KOD,NLUM,NINT,NBUNCH
      COMMON/LAYOUT/XHI,YHI,ZHI,THETAI,PHIHI,PSIHI,CONVH,
     >SRH,XRH,YRH,ZRH,THETAR,PHIRH,PSIRH,NLAY,NLAYDUM
	common /bmax/bvarc,bharc,bvir,bhir,ir1,ir2,ir3,ir4
      EXTERNAL FFFCT
      MPRINT=-2
      ISTART=0
      WV=0.0D0
      NORDER=1
      DO 100 I=1,20
      DEL(I)=0.0D0
      VALF(I)=0.0D0
      WGHT(I)=0.0D0
      NVAL(I)=0
      NPVAR(I)=1
      DO 100 J=1,6
      COEF(I,J)=0.0D0
      IF(J.EQ.1)COEF(I,J)=1.0D0
      NELF(I,J)=0
      NPAR(I,J)=0
  100 CONTINUE
      NDIM=12
      NCHAR=0
      NOP=12
      NPRINT=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NPRINT)
      NSTEP=OPLIST(1)
      NIT=OPLIST(2)
      NVAR=OPLIST(3)
      NCOND=OPLIST(4)
      IF(OPLIST(5).EQ.0.0D0)GOTO 5101
      BETAX=OPLIST(5)
      ALPHAX=OPLIST(6)
      ETAX=OPLIST(7)
      ETAPX=OPLIST(8)
      BETAY=OPLIST(9)
      ALPHAY=OPLIST(10)
      ETAY=OPLIST(11)
      ETAPY=OPLIST(12)
      GOTO 5102
 5101 BETAX = CBETAX
      ALPHAX = CALPHX
      ETAX = CETAX
      ETAPX = CETAPX
      BETAY = CBETAY
      ALPHAY = CALPHY
      ETAY = CETAY
      ETAPY = CETAPY
5102  NOP=2
      NCHAR=4
      DO 1 IVAR=1,NVAR
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NPRINT)
      CALL ELID(ICHAR,NELID)
      NELF(IVAR,1)=NELID
      NPAR(IVAR,1)=OPLIST(1)
      DEL(IVAR)=OPLIST(2)
    1 CONTINUE
      NCHAR=0
      NOP=3
      DO 2 ICOND=1,NCOND
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NPRINT)
      NVAL(ICOND)=OPLIST(1)
      VALF(ICOND)=OPLIST(2)
      WGHT(ICOND)=OPLIST(3)
      WV=WV+WGHT(ICOND)**2
      NVA=NVAL(ICOND)
      IF(NVA.LE.92)IFITM=1
c      IF((NVA.GE.93).AND.(NVA.LE.98))IFITD=1
      IF((NVA.GE.271).AND.(NVA.LE.278))IFITD=1
      IF((NVA.GE.281).AND.(NVA.LE.288))NLAY=1
      IF((NVA.GE.7).AND.(NVA.LE.10))NORDER=2
      IF((NVA.GE.17).AND.(NVA.LE.20))NORDER=2
      IF(IFITD.EQ.1)NORDER=2
      IF((NVA.GE.271).AND.(NVA.LE.288))GOTO 2
      IF(NVA.LT.110)GOTO 2
      IFITM=1
      IVA=NVA/100
      JVAL= NVA-100*IVA
      JVA=JVAL/10
      KVA=JVAL-10*JVA
      IF(KVA.EQ.0)GOTO 10
      NORDER=2
c      NVAL(ICOND)=100+6*(7*JVA-JVA*(JVA-1)/2+KVA-1) + IVA
      NVAL(ICOND)=100+6*(7*JVA-JVA*(JVA-1)/2+KVA-2) + IVA
      GOTO2
   10 NVAL(ICOND)=6*(JVA-1)+IVA+100
    2 CONTINUE
      NOP=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NPRINT)
      NASP=OPLIST(1)
      IF (NASP.EQ.0)GOTO 50
      NOP=2
      DO 3 IASP=1,NASP
      NCHAR=4
      NOP=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NPRINT)
      CALL ELID(ICHAR,NELID)
      DO 31 IEL=1,NVAR
      IF(NELID.EQ.NELF(IEL,1))GOTO 32
   31 CONTINUE
      WRITE(IOUT,99990)
99990 FORMAT('  ELEMENT NAME NOT PRESENT IN BASE ELEMENT LIST ')
      CALL HALT
      STOP
   32 JPAS=IEL
      NPAS=OPLIST(1)+1
      NPVAR(JPAS)=NPAS
      DO 4 KPAS=2,NPAS
      NCHAR=4
      NOP=2
      IF((IASP.EQ.NASP).AND.(KPAS.EQ.NPAS))NOP=-1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NPRINT)
      CALL ELID(ICHAR,NELID)
      NELF(JPAS,KPAS)=NELID
      NPAR(JPAS,KPAS)=OPLIST(1)
      COEF(JPAS,KPAS)=OPLIST(2)
    4 CONTINUE
    3 CONTINUE
  50  DO 5 IFL=1,NVAR
      JFF=NPVAR(IFL)
      DO 5 JFL=1,JFF
      NELV=NELF(IFL,JFL)
      IND(IFL,JFL)=IADR(NELV)+NPAR(IFL,JFL)-1
    5 CONTINUE
      DO 200 I=1,NVAR
      VAL=ELDAT(IND(I,1))
      XM(I)=VAL
      EM(I)=DEL(I)
      JF=NPVAR(I)
      IF (NORDER.EQ.1)NOF=6
      IF (NORDER.EQ.2)NOF=27
      DO 210 J=1,JF
      ELDAT(IND(I,J))=VAL*COEF(I,J)
      CALL MATGEN(NELF(I,J))
  210 CONTINUE
  200 CONTINUE
      ESC=500
      ICON=1
      IPRINT=0
	type 10023
10023	format(' Element numbers at boundaries to IRs ? ',$)
	accept *,ir1,ir2,ir3,ir4
      NTSTEP=NSTEP+NIT
      NM1=NSTEP-1
      NDIV=3
      CALL FFFCT(XM,F)
      WRITE(IOUT,10020)
10020 FORMAT(/,' THE REQUESTED FINAL VALUES ARE : ')
      WRITE(IOUT,10002)(VALF(I),I=1,NCOND)
      WRITE(IOUT,10021)
10021 FORMAT('  THE INITIAL VALUES ARE : ')
      WRITE(IOUT,10002)(OUTFL(NVAL(I)),I=1,NCOND)
      WRITE(IOUT,10022)F
10022 FORMAT(' THE INITIAL VALUE OF FIT FUNCTION IS ',E14.5)
      DO 400 IS=1,NTSTEP
      IF(IS.EQ.2)NDIV=2
      IF(IS.LE.NM1)GOTO 1001
      NDIV=1
      DO 1000 II=1,NVAR
 1000 EM(II)=EM(II)*0.1D0
 1001 CONTINUE
      ISTART=0
      MAXIT=3*IS*NIT
      CALL MINSUB(XM,EM,NVAR,F,ESC,IPRINT,ICON,MAXIT,FFFCT)
      IF(IS.EQ.NTSTEP)NORDER=2
      IF(IS.EQ.NTSTEP)NOF=27
      DO 300 I=1,NVAR
      VAL=XM(I)
      JF=NPVAR(I)
      DO 310 J=1,JF
      ELDAT(IND(I,J))=VAL*COEF(I,J)
      CALL MATGEN(NELF(I,J))
  310 CONTINUE
  300 CONTINUE
      WRITE(IOUT,10001)IS
10001 FORMAT(/,' REQUESTED VALUES AT STEP :',I5)
      WRITE(IOUT,10002)(RVAL(I),I=1,NCOND)
10002 FORMAT(/,4(5E22.14,/),/)
      WRITE(IOUT,10003)
10003 FORMAT(/,' ACHIEVED VALUES ')
      WRITE(IOUT,10002)(OUTFL(NVAL(I)),I=1,NCOND)
      WRITE(IOUT,10004)
      IF(ISO.NE.0)WRITE(ISOUT,10004)
10004 FORMAT(/,'  FITTED PARAMETERS VALUES ')
      DO 60 IFL=1,NVAR
      JFF=NPVAR(IFL)
      DO 60 J=1,JFF
      NELV=NELF(IFL,J)
      WRITE(IOUT,10010)NPAR(IFL,J),(NAME(NELV,I),I=1,4)
     >  ,ELDAT(IND(IFL,J))
      IF(ISO.NE.0)WRITE(ISOUT,10010)NPAR(IFL,J),(NAME(NELV,I),I=1,4)
     >  ,ELDAT(IND(IFL,J))
10010 FORMAT('  PARAMETER # ',I3,' OF ',4A1,' = ',E22.14)
   60 CONTINUE
      WRITE(IOUT,10005) F
      IF(ISO.NE.0)WRITE(ISOUT,10005) F
10005 FORMAT(/,'  THE FIT FUNCTION VALUE IS :',E14.5,/)
  400 CONTINUE
      IFITD=0
      IFITM=0
      CALL LENG
      RETURN
      END
C     ***********************
      SUBROUTINE FITMAT(IEND)
C     ***********************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/ANALC/COMPF,RNU0X,CETAX,CETAPX,CALPHX,CBETAX,
     1RMU1X,CHROMX,ALPH1X,BETA1X,
     1RMU0Y,RNU0Y,CETAY,CETAPY,CALPHY,CBETAY,
     1RMU1Y,CHROMY,ALPH1Y,BETA1Y,RMU0X,
     >COSX,ALX1,ALX2,VX1,VXP1,VX2,VXP2,
     >COSY,ALY1,ALY2,VY1,VYP1,VY2,VYP2,NSTABX,NSTABY,NSTAB,NWRNCP
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
	common /mat1/temp1(6,27),iflag1,nelstrt,nelend
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON/LAYOUT/XHI,YHI,ZHI,THETAI,PHIHI,PSIHI,CONVH,
     >SRH,XRH,YRH,ZRH,THETAR,PHIRH,PSIRH,NLAY,NLAYDUM
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/PRODCT/KODEPR,NEL,NOF
      DIMENSION VALMAT(1000),VALF(100),DEL(100),DVAL(100),QVAL(100),
     >VALR(100),VAL0(100),NPVAR(100),
     >NELFM(100,25),NVAL(100),IND(100,25),NPAR(100,25),
     >LV(100),MV(100)
      DIMENSION AMULT(100,25),ADD(100,25)
c      DIMENSION VALMAT(100),VALF(10),DEL(10),DVAL(10),QVAL(10),
c     >VALR(10),VAL0(10),NPVAR(10),
c     >NELFM(10,6),NVAL(10),IND(10,6),NPAR(10,6),
c     >LV(10),MV(10)
c      DIMENSION AMULT(10,6),ADD(10,6)
      DIMENSION OPLIST(20),ICHAR(4)
      DIMENSION OUTP1(20),OUTP2(8)
      EQUIVALENCE (OUTP1(1),COMPF),(OUTP2(1),SRH)
	data nfitting/0/
	if(nfitting.ne.0)goto 101
	type 102
102	format(' Matrix multiplication or Tracking , (1 or 2) ? ',$)
	accept *,nfitting
101	continue 
c	DO 100 IFT=1,10
      DO 100 IFT=1,100
      DEL(IFT)=0.0D0
      VALF(IFT)=0.0D0
      NVAL(IFT)=0
      NPVAR(IFT)=1
c      DO 100 JFT=1,6
	do 100 jft=1,25 
      AMULT(IFT,JFT)=0.0D0
      ADD(IFT,JFT)=0.0D0
      NELFM(IFT,JFT)=0
      NPAR(IFT,JFT)=0
      IF(JFT.EQ.1)AMULT(IFT,JFT)=1.0D0
  100 CONTINUE
      MPRINT=-2
      NORDER=1
      NDIM=20
      NOF=6
      NCHAR=0
      NOP=3
      NPRINT=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NPRINT)
      NSTEP=OPLIST(1)
      NIT=OPLIST(2)
      NVAR=OPLIST(3)
      NOP=2
      NCHAR=4
      DO 1 IVAR=1,NVAR
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NPRINT)
      CALL ELID(ICHAR,NELID)
      NELFM(IVAR,1)=NELID
      NPAR(IVAR,1)=OPLIST(1)
      DEL(IVAR)=OPLIST(2)
    1 CONTINUE
c      NOP=2*NVAR
	nop=2 
      NCHAR=0
	do 3 ivar=1,nvar 
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NPRINT)
c      DO 3 IVAR=1,NVAR
c      NVA=OPLIST(2*IVAR-1)
	nva=oplist(1) 
      NVAL(IVAR)=NVA
      IF((NVA.GE.7).AND.(NVA.LE.10))NORDER=2
      IF((NVA.GE.17).AND.(NVA.LE.20))NORDER=2
      IF(NVA.GT.20)NLAY=1
c      VALF(IVAR)=OPLIST(2*IVAR)
	valf(ivar)=oplist(2) 
   3  CONTINUE
COLLECT INFORMATION ABOUT ASSOCIATED PARAMETERS
      NCHAR=0
      NDATA=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
      NASP=OPLIST(1)
      IF(NASP.EQ.0)GOTO 55
      DO 104 IASP=1,NASP
      NDATA=2
      NCHAR=4
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
      CALL ELID(ICHAR,NELID)
      IPAR=OPLIST(1)
CHECK IF NAME IS IN BASE LIST OF VARIED ELEMENTS
      DO 143 IEL=1,NVAR
      IF((NELID.EQ.NELFM(IEL,1)).AND.(IPAR.EQ.NPAR(IEL,1)))GO TO 144
  143 CONTINUE
      WRITE(IOUT,99990)ICHAR,NELID,IPAR,(NELFM(IN,1),IN=1,NVAR),
     >(NPAR(IN,1),IN=1,NVAR)
99990 FORMAT(/,' ELEMENT NAME AND PARAMETER # IS NOT IN BASE LIST',
     >' OF VARIED ELEMENTS',/,' ',4A1,26I6)
      CALL HALT
      STOP
  144 JPAS=IEL
      NPAS=OPLIST(2)+1
      NPVAR(JPAS)=NPAS
      DO 105 KPAS=2,NPAS
      NCHAR=4
      NDATA=3
      IF((IASP.EQ.NASP).AND.(KPAS.EQ.NPAS))NDATA=-1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NPRINT)
      CALL ELID(ICHAR,NELID)
      NELFM(JPAS,KPAS)=NELID
      NPAR(JPAS,KPAS)=OPLIST(1)
      AMULT(JPAS,KPAS)=OPLIST(2)
      ADD(JPAS,KPAS)=OPLIST(3)
  105 CONTINUE
  104 CONTINUE
   55 IF(NORDER.EQ.2)NOF=27
      IF(NLAY.EQ.1)CALL HWPNT
      IF(NLAY.EQ.1)GOTO 110
      if(nfitting.eq.1)CALL MATRIX
c      if(nfitting.eq.1)CALL ANAL
      IF(NSTABX.EQ.1.OR.NSTABY.EQ.1) write(iout,99998)
c      IF(NSTABX.EQ.1.OR.NSTABY.EQ.1) GOTO 50
  110 DO 40 I=1,NVAR
      JFF=NPVAR(I)
      DO 140 JFT=1,JFF
      NELV=NELFM(I,JFT)
  140 IND(I,JFT)=IADR(NELV)+NPAR(I,JFT)-1
      NVA=NVAL(I)
      IF(NVA.LE.20)OUTPUT=OUTP1(NVA)
      IF(NVA.GE.21)OUTPUT=OUTP2(NVA-20)
   40 VAL0(I)=OUTPUT
	type 9991
9991	format(' output ')
	type 9992,(outp1(nval(i)),i=1,nvar)
9992	format(6e11.4)
      DO 141 IFT=1,NVAR
      VAL=ELDAT(IND(IFT,1))
      JFF=NPVAR(IFT)
      DO 141 JFT=1,JFF
c      ELDAT(IND(IFT,JFT))=VAL*AMULT(IFT,JFT)+ADD(IFT,JFT)
  141 CALL MATGEN(NELFM(IFT,JFT))
      NITT=NSTEP+NIT
      DO 9 IS=1,NITT
      NDIV=NSTEP-IS+1
      IF(NDIV.LT.1)NDIV=1
      DO 10 I =1,NVAR
   10 VALR(I)=VAL0(I)-(VAL0(I)-VALF(I))/NDIV
      IF(IS.GT.NSTEP) THEN
	 DO 12 I=1,NVAR
   12    DEL(I)=DEL(I)/5
      END IF
   14 DO 4 I=1,NVAR
      VAL=ELDAT(IND(I,1))+DEL(I)
      JFF=NPVAR(I)
      DO 41 JFT=1,JFF
c      ELDAT(IND(I,JFT))=VAL*AMULT(I,JFT)+ADD(I,JFT)
	eldat(ind(i,jft))=eldat(ind(i,jft))+amult(i,jft)*del(i)
	type 941,i,jft,nelfm(i,jft),eldat(ind(i,jft))
 941	format(' i, jft, nelfm, eldat ',3i,e13.4) 
   41 CALL MATGEN(NELFM(I,JFT))
      IF(NLAY.EQ.1)CALL HWPNT
      IF(NLAY.EQ.1)GOTO 120
      if(nfitting.eq.1)CALL MATRIX
c      if(nfitting.eq.1)CALL ANAL
      IF(NSTABX.EQ.1.OR.NSTABY.EQ.1) write(iout,99998)
c      IF(NSTABX.EQ.1.OR.NSTABY.EQ.1) GOTO 50
  120 DO 5 IV=1,NVAR
      NVA=NVAL(IV)
      IF(NVA.LE.20)OUTPUT=OUTP1(NVA)
      IF(NVA.GE.21)OUTPUT=OUTP2(NVA-20)
    5 VALMAT((IV-1)*NVAR+I)=(OUTPUT-VAL0(IV))/DEL(I)
	type  9991
	type 9992,(outp1(nval(iv)),iv=1,nvar)
      VAL=ELDAT(IND(I,1))-DEL(I)
      DO 42 JFT=1,JFF
c      ELDAT(IND(I,JFT))=VAL*AMULT(I,JFT)+ADD(I,JFT)
 	eldat(ind(i,jft))=eldat(ind(i,jft))-amult(i,jft)*del(i)
   42 CALL MATGEN(NELFM(I,JFT))
    4 CONTINUE
      CALL DMINV(VALMAT,NVAR,D,LV,MV)
      IF(IS.EQ.NITT)NORDER=2
      IF(IS.EQ.NITT)NOF=27
      DO 6 I=1,NVAR
    6 DVAL(I)=VALR(I)-VAL0(I)
      DO 7 I=1,NVAR
      QVAL(I)=0.0D0
      DO 8 J=1,NVAR
    8 QVAL(I)=QVAL(I)+VALMAT((I-1)*NVAR+J)*DVAL(J)
      VAL = ELDAT(IND(I,1))+QVAL(I)
      JFF=NPVAR(I)
      DO 43 JFT=1,JFF
c      ELDAT(IND(I,JFT))=VAL*AMULT(I,JFT)+ADD(I,JFT)
	eldat(ind(i,jft))=eldat(ind(i,jft))+amult(i,jft)*qval(i) 
	type 941,i,jft,nelfm(i,jft),eldat(ind(i,jft))
   43 CALL MATGEN(NELFM(I,JFT))
    7 CONTINUE
      IF(NLAY.EQ.1)CALL HWPNT
      IF(NLAY.EQ.1)GOTO 130
      if(nfitting.eq.1)CALL MATRIX
c      if(nfitting.eq.1)CALL ANAL
	ivt=1
	if(is.eq.nitt)ivt=2	
	if(nfitting.eq.2)call trakfit(ivt)
      IF(NSTABX.EQ.1.OR.NSTABY.EQ.1) write(iout,99998)
c      IF(NSTABX.EQ.1.OR.NSTABY.EQ.1) GOTO 50
  130 DO 11 I=1,NVAR
      NVA=NVAL(I)
      IF(NVA.LE.20)OUTPUT=OUTP1(NVA)
      IF(NVA.GE.21)OUTPUT=OUTP2(NVA-20)
   11 VAL0(I)=OUTPUT
    9 CONTINUE
	OPEN(UNIT=35,STATUS='UNKNOWN')
	OPEN(UNIT=36,STATUS='UNKNOWN')
      IF(ISO.NE.0)WRITE(ISOUT,10011)
      WRITE(IOUT,10011)
10011 FORMAT(//,' THE FITTED PARAMETERS ARE : ')
      DO 60 IP=1,NVAR
      JFF=NPVAR(IP)
      DO 60 JFT=1,JFF
      NELV=NELFM(IP,JFT)
	WRITE(35,20010)(NAME(NELV,I),I=1,4),NPAR(IP,JFT),ELDAT(IND(IP,JFT))
20010	FORMAT(2X,4A1,I2,E22.14)
	IADDRESS=IND(IP,JFT)-NPAR(IP,JFT)+1
	WRITE(36,20011)(NAME(NELV,I),I=2,4),ELDAT(IADDRESS),ELDAT(IND(IP,JFT))
20011	FORMAT(1X,3A1,',',F8.6,',',F10.6)	
      WRITE(IOUT,10010)NPAR(IP,JFT),(NAME(NELV,J),J=1,4),
     >ELDAT(IND(IP,JFT))
      IF(ISO.NE.0)
     > WRITE(ISOUT,10010)NPAR(IP,JFT),(NAME(NELV,J),J=1,4)
     >,ELDAT(IND(IP,JFT))
10010 FORMAT('  PARAMETER # ',I3,' OF ',4A1,' = ',E22.14)
   60 CONTINUE
	CLOSE(UNIT=35)
	CLOSE(UNIT=36)
      IF(NLAY.EQ.1)CALL HWPNT
      IF(NLAY.EQ.1)GOTO 131
      CALL PRANAL(NORDER)
  131 RETURN
   50 WRITE (IOUT,99998)
      IF(ISO.NE.0)WRITE(ISOUT,99998)
99998 FORMAT('   UNSTABLE MOTION ENCOUNTERED DURING FIT',
     >' COMPUTATION ',/,'  JOB HALTED ')
      CALL HALT
      STOP
      END
C     ***********************
      SUBROUTINE GABAN
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/GEOM/XCO,XPCO,YCO,YPCO,NCASE,NJOB,
     <            EPSX(10),EPSY(10),XI(10),YI(10),XG(300,10),
     <            XPG(300,10),YG(300,10),YPG(300,10),LCASE(10)
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN,
     <  NPTOT,MLOCAT,NTURN
      DIMENSION A(9),B(3),EPSCX(300),EPSCY(300),AMUX(300),AMUY(300)
      LOGICAL LCASE
      DO 1 NC = 1, NCASE
      IF(LCASE(NC))GOTO20
      WRITE(IOUT,10012) EPSX(NC), EPSY(NC)
10012 FORMAT(/,'  CASE OF EPSX =',E10.3,'  EPSY =',E10.3,/,
     <'  NOT ANALYSED BECAUSE OF LOST PARTICLES  ',/)
      GO TO 1
   20 WRITE(IOUT,10010)EPSX(NC),EPSY(NC)
10010 FORMAT(/,'  VALUES FOR NOMINAL EPSX =',E10.3,/,
     >'     AND FOR NOMINAL EPSY =',E10.3,//)
      IPLOTX=0
      IPLOTY=0
      IFLGX=0
      IFLGY=0
      BETAVX=1.0D0
      BETAVY=1.0D0
      GAMAVX=1.0D0
      GAMAVY=1.0D0
      ALPAVX=1.0D0
      ALPAVY=1.0D0
      IF(EPSX(NC).EQ.0.0D0)GOTO10
      SUMX1 = 0.0D0
      SUMX2 = 0.0D0
      SUMX3 = 0.0D0
      SUMX4 = 0.0D0
      SUMX5 = 0.0D0
      SUMX6 = 0.0D0
      SUMX7 = 0.0D0
      SUMX8 = 0.0D0
      SUMY1 = 0.0D0
      SUMY2 = 0.0D0
      SUMY3 = 0.0D0
      SUMY4 = 0.0D0
      SUMY5 = 0.0D0
      SUMY6 = 0.0D0
      SUMY7 = 0.0D0
      SUMY8 = 0.0D0
      DO 2 NT = 1, NTURN
      X = XG(NT,NC)
      XP = XPG(NT,NC)
      Y = YG(NT,NC)
      YP = YPG(NT,NC)
      X2 = X*X
      Y2 = Y*Y
      XP2 = XP*XP
      YP2 = YP*YP
      X3 = X2*X
      Y3 = Y2*Y
      XP3 = XP2*XP
      YP3 = YP2*YP
      X4 = X3*X
      Y4 = Y3*Y
      XP4 = XP3*XP
      YP4 = YP3*YP
      SUMX1 = SUMX1 + X4
      SUMY1 = SUMY1 + Y4
      SUMX2 = SUMX2 + X3*XP
      SUMY2 = SUMY2 + Y3*YP
      SUMX3 = SUMX3 + X2*XP2
      SUMY3 = SUMY3 + Y2*YP2
      SUMX4 = SUMX4 + X*XP3
      SUMY4 = SUMY4 + Y*YP3
      SUMX5 = SUMX5 + XP4
      SUMY5 = SUMY5 + YP4
      SUMX6 = SUMX6 + X2
      SUMY6 = SUMY6 + Y2
      SUMX7 = SUMX7 + X*XP
      SUMY7 = SUMY7 + Y*YP
      SUMX8 = SUMX8 + XP2
      SUMY8 = SUMY8 + YP2
    2 CONTINUE
      A(1) = SUMX1
      A(2) = SUMX3
      A(3) = SUMX2
      A(4) = SUMX3
      A(5) = SUMX5
      A(6) = SUMX4
      A(7) = SUMX2
      A(8) = SUMX4
      A(9) = SUMX3
      B(1) = SUMX6
      B(2) = SUMX8
      B(3) = SUMX7
      CALL DSIMQ(A,B,3,KS)
      CX = B(1)
      BX = B(2)
      AX = B(3)
      ARG=BX*CX-(AX*AX)/4.0D0
      IF(ARG.LT.0.0D0)GOTO 30
      EPSAVX = 1.0D0/(SQRT(ARG))
      BETAVX = BX*EPSAVX
      ALPAVX = AX*EPSAVX/2.0D0
      GAMAVX = (1.0D0 + ALPAVX*ALPAVX)/BETAVX
      GOTO 10
   30 WRITE(IOUT,99999)
99999 FORMAT(/,'  ELLIPSE COULD NOT BE FITTED TO X DATA ',/)
      IFLGX=0
   10 IF(EPSY(NC).EQ.0.0D0)GOTO 50
      A(1) = SUMY1
      A(2) = SUMY3
      A(3) = SUMY2
      A(4) = SUMY3
      A(5) = SUMY5
      A(6) = SUMY4
      A(7) = SUMY2
      A(8) = SUMY4
      A(9) = SUMY3
      B(1) = SUMY6
      B(2) = SUMY8
      B(3) = SUMY7
      CALL DSIMQ(A,B,3,KS)
      CY = B(1)
      BY = B(2)
      AY = B(3)
      ARG=BY*CY-(AY*AY)/4.0D0
      IF(ARG.LT.0.0D0)GOTO 11
      EPSAVY = 1.0D0/(SQRT(ARG))
      BETAVY = BY*EPSAVY
      ALPAVY = AY*EPSAVY/2.0D0
      GAMAVY = (1.0D0 + ALPAVY*ALPAVY)/BETAVY
      GOTO 50
   11 WRITE(IOUT,99998)
99998 FORMAT(/,'  ELLIPSE COULD NOT BE FITTED TO Y DATA ',/)
      IFLGY=0
   50 DO 3 NT = 1, NTURN
      EPSCX(NT) = GAMAVX*XG(NT,NC)*XG(NT,NC) + BETAVX*XPG(NT,NC)
     < *XPG(NT,NC)  + 2.0D0*ALPAVX*XG(NT,NC)*XPG(NT,NC)
      EPSCY(NT) = GAMAVY*YG(NT,NC)*YG(NT,NC) + BETAVY*YPG(NT,NC)
     < *YPG(NT,NC)  + 2.0D0*ALPAVY*YG(NT,NC)*YPG(NT,NC)
      IF (NT .EQ. 1) GO TO 3
      XIN = XG(NT - 1,NC)
      XPIN = XPG(NT-1,NC)
      XO=XG(NT,NC)
      XPO=XPG(NT,NC)
      ANUM = XO*XPIN-XPO*XIN
      DENOM=XO*(GAMAVX*XIN+ALPAVX*XPIN)+XPO*(BETAVX*XPIN+ALPAVX*XIN)
      AMUX(NT) = ATAN2(ANUM, DENOM)
      IF(AMUX(NT).LT.0.0D0)AMUX(NT)=AMUX(NT)+TWOPI
      AMUX(NT)=AMUX(NT)/TWOPI
      YIN=YG(NT-1,NC)
      YPIN=YPG(NT-1,NC)
      YO=YG(NT,NC)
      YPO=YPG(NT,NC)
      ANUM = YO*YPIN-YPO*YIN
      DENOM =YO*(GAMAVY*YIN+ALPAVY*YPIN)+YPO*(BETAVY*YPIN+ALPAVY*YIN)
      AMUY(NT) = ATAN2(ANUM, DENOM)
      IF(AMUY(NT).LT.0.0D0)AMUY(NT)=AMUY(NT)+TWOPI
      AMUY(NT)=AMUY(NT)/TWOPI
    3 CONTINUE
      WRITE(IOUT,10011)
10011 FORMAT('  AVERAGE :   BETAX',7X,'ALPHAX',6X,'EPSX',8X,'BETAY',
     <7X,'ALPHAY',6X,'EPSY',/)
      WRITE (IOUT, 10001) BETAVX,ALPAVX,EPSAVX,
     >                    BETAVY,ALPAVY,EPSAVY
10001 FORMAT (9X,6E12.3 )
      EXMAX = 0.0D0
      EYMAX = 0.0D0
      SUMX = 0.0D0
      SUMY = 0.0D0
      EXMIN = 1.0D32
      EYMIN = 1.0D32
      DO 4 NT = 1, NTURN
      IF(EPSCX(NT) .GT. EXMAX)EXMAX = EPSCX(NT)
      IF(EPSCX(NT) .LT. EXMIN)EXMIN = EPSCX(NT)
      IF(EPSCY(NT) .GT. EYMAX)EYMAX = EPSCY(NT)
      IF(EPSCY(NT) .LT. EYMIN)EYMIN = EPSCY(NT)
      IF (NT .EQ. 1) GO TO 4
      SUMX = SUMX + AMUX(NT)
      SUMY = SUMY + AMUY(NT)
    4 CONTINUE
      AVNUX = SUMX/(NTURN - 1)
      AVNUY = SUMY/(NTURN - 1)
      SUMX = 0.0D0
      SUMY = 0.0D0
      DO 5 NT =2, NTURN
      SUMX = SUMX + (AMUX(NT)-AVNUX)**2
      SUMY = SUMY + (AMUY(NT)-AVNUY)**2
    5 CONTINUE
      SIGNUX = SQRT(SUMX/(NTURN - 1))
      SIGNUY = SQRT(SUMY/(NTURN - 1))
      DEX = EXMAX - EXMIN
      DEY = EYMAX - EYMIN
      WRITE(IOUT, 10003)EXMAX, EXMIN, DEX, EYMAX, EYMIN, DEY
10003 FORMAT(/,'   EPSXMAX   EPSXMIN   DELEPSX   EPSYMAX ',
     <'   EPSYMIN   DELEPSY',/,' ',6E10.3,/)
      DEEPSX=DEX/EPSAVX
      DEEPSY=DEY/EPSAVY
      WRITE(IOUT,10006)DEEPSX,DEEPSY
10006 FORMAT(/,'DELEPSX/EPSX   DELEPSY/EPSY ',/,2E10.3,/)
      WRITE(IOUT, 10004) AVNUX, SIGNUX, AVNUY, SIGNUY
10004 FORMAT(/,'   AVENUX    SIGNUX    AVENUY    SIGNUY',/,
     <' ',4E10.3,/)
      XMIN = SQRT(BETAVX*EXMIN)
      XMAX = SQRT(BETAVX*EXMAX)
      YMIN = SQRT(BETAVY*EYMIN)
      YMAX = SQRT(BETAVY*EYMAX)
      CANOM = XI(NC)*YI(NC)
      CAMIN = XMIN*YMIN
      CAMAX = XMAX*YMAX
      IF(CAMIN.NE.0.0D0)CARAT=CAMAX/CAMIN
      WRITE(IOUT, 10005)CANOM,CAMAX,CAMIN,CARAT
10005 FORMAT(/,'  CROSS SECTIONAL AREAS',//,10X,'  NOMINAL',5X,
     <'  MAXIMUM',5X,'  MINIMUM',5X,'   MAX/MIN',//,10X,4(E10.3,2X),/)
    1 CONTINUE
      RETURN
      END
C     *************************
      FUNCTION GAUSS(IX)
C     *************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      G=0
      DO 1 I=1,12
    1 G = G+URAND(IX)
      GAUSS = G - 6
      RETURN
      END
C     ***********************
      SUBROUTINE GEABER(IEND)
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON/PLT/
     1XMIN,XMAX,YMIN,YMAX,XPMIN,XPMAX,YPMIN,YPMAX,
     >DELMIN,DELMAX,DNUMIN,DNUMAX,DBMIN,DBMAX,
     2MXXPR,MYYPR,MXY,MALL,NPLOT,NCCUM,NGRAPH,NCOL,NLINE
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN,
     <  NPTOT,MLOCAT,NTURN
      COMMON/GEOM/XCO,XPCO,YCO,YPCO,NCASE,NJOB,
     <            EPSX(10),EPSY(10),XI(10),YI(10),XG(300,10),
     <            XPG(300,10),YG(300,10),YPG(300,10),LCASE(10)
      LOGICAL LOGPAR,MXXPR(101,51),MYYPR(101,51),MXY(101,51)
      LOGICAL LCASE
      DIMENSION OPLIST(300), ICHAR(6)
      NORDER = 2
      NCHAR = 0
      NOP = -1
      DO 11 IL = 1,10
  11  LCASE(IL) = .TRUE.
      DO 10 IP = 1, NPTOT
   10 LOGPAR(IP) = .TRUE.
      NDIM=300
      NIPR=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NIPR)
      BETAX = OPLIST(1)
      ALPHAX = OPLIST(2)
      BETAY = OPLIST(3)
      ALPHAY = OPLIST(4)
      XCO = OPLIST(5)
      XPCO = OPLIST(6)
      YCO = OPLIST(7)
      YPCO = OPLIST(8)
      DELTA = OPLIST(9)
      NCASE = OPLIST(10)
      IF(NCASE .LE. 10) GO TO 6
      NCASE = 10
      WRITE (ISOUT,10000)
10000 FORMAT ('  TOO MANY CASES REQUESTED:DEFAULT MAX 10 ARE READ ')
    6 NTURN = OPLIST(11)
      NJOB = OPLIST(12)
      NPLOT = OPLIST(13)
      NPRINT = OPLIST(14)
      MLOCAT=0
      EPSXM = 0.0D0
      EPSYM = 0.0D0
      DO 1 NC = 1, NCASE
      IND = (NC-1)*2 + 15
      EPSX(NC) = OPLIST(IND)*1.0D-06
      EPSY(NC) = OPLIST(IND + 1)*1.0D-06
      IF(EPSX(NC) .GT. EPSXM)EPSXM = EPSX(NC)
      IF(EPSY(NC) .GT. EPSYM)EPSYM = EPSY(NC)
    1 CONTINUE
      NPART = NJOB*NCASE
      NCPART=NPART
      DO 2 NP = 1, NPART
      DO 3 IP = 1, 5
    3 PART(NP, IP) = 0.0D0
      PART(NP, 6) = DELTA
      DEL(NP)=DELTA
    2 CONTINUE
      NCP = 1
      DO 4 INP = 1, NCASE
      XI(INP) = SQRT(BETAX*EPSX(INP))
      PART(NCP, 1) = XCO + SQRT(BETAX*EPSX(INP))
      PART(NCP, 2) = XPCO - ALPHAX*SQRT(EPSX(INP)/BETAX)
      IF (NJOB .EQ. 2) NCP = NCP + 1
      YI(INP) = SQRT(BETAY*EPSY(INP))
      PART(NCP, 3) = YCO + SQRT(BETAY*EPSY(INP))
      PART(NCP, 4) = YPCO - ALPHAY*SQRT(EPSY(INP)/BETAY)
      NCP = NCP + 1
    4 CONTINUE
      IF(NPLOT .EQ. -1) GO TO 5
      XMAX = SQRT(EPSXM*BETAX)*1.5D0
      XMIN = -XMAX
      XMAX=XMAX+XCO
      XMIN=XMIN+XCO
      YMAX = SQRT(EPSYM*BETAY)*1.5D0
      YMIN = -YMAX
      YMAX=YMAX+YCO
      YMIN=YMIN+YCO
      GAMMAX = (1.0D0 + ALPHAX*ALPHAX)/BETAX
      GAMMAY = (1.0D0 + ALPHAY*ALPHAY)/BETAY
      NCCUM =0
      NGRAPH = 4
      MALL = 0
      NCOL = 71
      NLINE = 51
      XPMAX = SQRT(EPSXM*GAMMAX)*1.5D0
      XPMIN = -XPMAX
      XPMAX=XPMAX+XPCO
      XPMIN=XPMIN+XPCO
      YPMAX = SQRT(EPSYM*GAMMAY)*1.5D0
      YPMIN = -YPMAX
      YPMAX=YPMAX+YPCO
      YPMIN=YPMIN+YPCO
    5 NCTURN = 0
      CALL TRACKT
      IPART = 1
      DO 12 IC = 1, NCASE
      DO 12 IJ = 1, NJOB
      IF(.NOT.LOGPAR(IPART))LCASE(IC) = .FALSE.
      IPART = IPART + 1
   12 CONTINUE
      CALL GABAN
      NJOB = 0
      RETURN
      END
C     ***********************
      SUBROUTINE GENRAL
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/INPUTT/KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      IAD = IADR(N)
C
C     GET NUMBER OF PARAMETERS
C
      NUM = IADR(N+1)-IAD-2
      IF(NUM/2*2.EQ.NUM) GO TO 10
      WRITE(IOUT,5) NUM
      IF(ISO.NE.0)WRITE(ISOUT,5) NUM
5     FORMAT(/,' ERROR IN GENERAL MATRIX PARAMETERS ',I5,
     +'  SHOULD BE A MULTIPLE OF TWO',/)
      CALL HALT
      STOP
10    N = MADR(N)
C
C     CLEAR AMAT(N,6,27)
C
      DO 20 I=1,6
      DO 20 J=1,27
      AMAT(N,I,J) = 0.0D0
      IF(I.EQ.J) AMAT(N,I,J) = 1.0D0
20    CONTINUE
C
C     SET UP AMAT (N,6,27)
C
      DO 50 IP = 1,NUM,2
      NIND=ELDAT(IAD+IP-1)
      I=NIND/100
      JIND=NIND-I*100
      J=JIND/10
      K=JIND-J*10
      VALUE=ELDAT(IAD+IP)
C
C     CHECK 'K' IS VALID AND IF THIS A SECOND OR FIRST
C        ORDER TERM
C
      IF (K.EQ.0) GO TO 40
      IF (K.GE.J) GO TO 30
      WRITE(IOUT,25) J,K
      IF(ISO.NE.0)WRITE(ISOUT,25) J,K
25    FORMAT(/,' ERROR IN DEFINING GENERAL MATRIX, K<J',2I5,/)
      CALL HALT
      STOP
30    J = K+(13-J)*J/2
40    AMAT(N,I,J) = VALUE
50    CONTINUE
      RETURN
      END
C     ***********************
      SUBROUTINE HBEND
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/BND/IAD
C
C     GET ADDRESS OF THE PARAMETERS AND THE MATRIX
C
      IAD = IADR(N)
      N = MADR(N)
C
C     CLEAR AMAT(N,6,27)
C
      DO 100 I=1,6
      DO 100 J=1,27
      AMAT(N,I,J)=0.0D0
 100  CONTINUE
C
C     SET UP THE IDENTITY MATRIX IN TEMP
C
      DO 10 IX = 1,6
      DO 10 IY = 1,27
      TEMP(IX,IY)=0.0D0
      IF(IX.EQ.IY) TEMP(IX,IY) = 1.0D0
10    CONTINUE
      CALL BEND
C
C     PUT TEMP INTO AMAT(N,6,27)
C
      DO 20 IX=1,6
      DO 20 IY=1,27
  20  AMAT(N,IX,IY) = TEMP(IX,IY)
      RETURN
      END
C     ***********************
      SUBROUTINE HEXA2
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/INPUTT/KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      IAD = IADR(N)
      DIST=ELDAT(IAD)
      AK=ELDAT(IAD+1)
      N = MADR(N)
      DO 100 I=1,6
      DO 100 J=1,NOF
      AMAT(N,I,J)=0.0
  100 CONTINUE
      DO 101 I=1,6
      AMAT(N,I,I)=1.0
  101 CONTINUE
      AMAT(N,1, 2)=DIST
      AMAT(N,3, 4)= DIST
      IF(NORDER.EQ.1)RETURN
      AKL1=AK*DIST
      AKL2=AKL1*DIST
      AKL3=AKL2*DIST
      AKL4=AKL3*DIST
      AMAT(N,1, 7)=-AKL2/2.0
      AMAT(N,1, 8)=-AKL3/3.0
      AMAT(N,1,13)=-AKL4/12.0
      AMAT(N,1,18)= AKL2/2.0
      AMAT(N,1,19)= AKL3/3.0
      AMAT(N,1,22)= AKL4/12.0
      AMAT(N,2, 7)=-AKL1
      AMAT(N,2, 8)=-AKL2
      AMAT(N,2,13)=-AKL3/3.0
      AMAT(N,2,18)= AKL1
      AMAT(N,2,19)= AKL2
      AMAT(N,2,22)= AKL3/3.0
      AMAT(N,3, 9)= AKL2
      AMAT(N,3, 10)= AKL3/3.0
      AMAT(N,3,14)= AKL3/3.0
      AMAT(N,3,15)= AKL4/6.0
      AMAT(N,4, 9)= AKL1*2.0
      AMAT(N,4, 10)= AKL2
      AMAT(N,4,14)= AKL2
      AMAT(N,4,15)= AKL3*2.0/3.0
C
C     PATH LENGTH
C
      AMAT(N,5,13) = DIST/2.0D0
      AMAT(N,5,22) = DIST/2.0D0
      RETURN
      END
C     *************************
      SUBROUTINE HWPNT
C     *************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON/FUNC/BETAX,ALPHAX,ETAX,ETAPX,BETAY,ALPHAY,ETAY,ETAPY,
     <  STARTE,ENDE,DELTAE,DNU,MFPRNT,KOD,NLUM,NINT,NBUNCH
      COMMON/LAYOUT/XHI,YHI,ZHI,THETAI,PHIHI,PSIHI,CONVH,
     >SRH,XRH,YRH,ZRH,THETAR,PHIRH,PSIRH,NLAY,NLAYDUM
      DIMENSION R(3),U(3,3),S(3),NUNITS(6,7)
      DATA NUNITS/'M','E','T','E','R','S','C','M',' ',' ',' ',' '
     >,'M','M',' ',' ',' ',' ','M','I','C','R','O','N'
     >,'Y','A','R','D','S',' ','F','E','E','T',' ',' '
     >,'I','N','C','H','E','S'/
      DATA ILL/'L'/,ILR/'R'/

C
C   SET COORDINATES AND ANGLE INITIALLY TO ZERO
C
      IF(NLAY.EQ.0)WRITE(IOUT,88880)STARTE
88880 FORMAT(//,'         VALUES ARE FOR ENERGY :',E12.3,' GEV',/)
      XH=XHI*CONVH
      YH=YHI*CONVH
      ZH=ZHI*CONVH
      THETAH=THETAI*CRDEG
      PHIH=PHIHI*CRDEG
      PSIH=PSIHI*CRDEG
      CT=COS(THETAH)
      ST=SIN(THETAH)
      CF=COS(PHIH)
      SF=SIN(PHIH)
      CPS=COS(PSIH)
      SPS=SIN(PSIH)
      IF(NLAY.GE.1)GOTO 2000
C
C   SECTION FOR PRINTING OUT THE DATA ON THE MAGNETS
C
      BRHO = CMAGEN*STARTE
      DO 4 IJK=1,NA
      KODIJK = KODE(IJK)
      IF(KODIJK.EQ.1)GOTO1
      IF(KODIJK.EQ.2)GOTO 2
      IF(KODIJK.EQ.3)GOTO3
      IF(KODIJK.EQ.13)GO TO 1
      IF(KODIJK.EQ.14)GO TO 1
      IF(KODIJK.EQ.4) GOTO 40
      IF (KODIJK.EQ.15) GOTO 15
C
C KODE IS NOT IN 1-4 NOR IN 13-15 , IGNORE ELEMENT
C
      GO TO 4
C
C   BEND COMPUTATION
C
    1 IPAR = IADR(IJK)
      D2 = ELDAT(IPAR+13)
      ALPHA = ELDAT(IPAR+1)
      RHO = ELDAT(IPAR) / (ELDAT(IPAR+1)*CRDEG)
      ALENTH = ELDAT(IPAR)
      FIELDN = ELDAT(IPAR+2)
      FIELDB = ELDAT(IPAR+3)
      ENTANG = ELDAT(IPAR+4)
      EXANG  = ELDAT(IPAR+8)
      ENTCUR = ELDAT(IPAR+5)
      EXCUR  = ELDAT(IPAR+9)
      AINDCT = BRHO/RHO
      WRITE(IOUT,10)(NAME(IJK,I),I=1,4),D2,ALPHA,RHO,ALENTH,AINDCT,
     <FIELDN,FIELDB,ENTANG,ENTCUR,EXANG,EXCUR

   10 FORMAT(/,' ELEMENT:',4A1,/,10X,
     > 'GAP=',F13.8,7X,'  BENDING ANGLE=',F13.8,'(DEG)','  BENDING ',
     > 'RADIUS=',F17.8,'(M.)',/,
     > 10X,'LENGTH=',E15.7,'(M)',' INDUCTION=',F13.8,'(KG)',/,
     > 10X,7X,'FIELD INDEX N=',F13.4,7X,'FIELD INDEX BETA=',F13.4,/,
     > 10X,'ENTRANCE ANGLE=',F12.8,'(DEG)',
     > 1X,'ENTRANCE CURVATURE=',F17.9,'(/M)',/,
     > 10X,'EXIT ANGLE =',F12.8,'(DEG)',
     > 4X,'EXIT CURVATURE=',F17.9,'(/M)')
      GO TO 4
C
C   QUADRUPOLE
C
    2 IPAR = IADR(IJK)
      APTURE = SQRT(ELDAT(IPAR+2)*ELDAT(IPAR+3))
      ALENTH = ELDAT(IPAR)
      STRGTH = ELDAT(IPAR+1)
      IF(ALENTH.EQ.0.0D0.OR.STRGTH.EQ.0.0D0) GO TO 4
      AK = SQRT(ABS(STRGTH))
      THETA = AK*ALENTH
      IF(AK.GE.0.0D0)FOCAL = 1.0D0/(AK*SIN(THETA))
      IF(AK.LT.0.0D0)FOCAL = -1.0D0/(AK*SINH(THETA))
      AINDCT = STRGTH*BRHO*APTURE
      AINT = STRGTH*ALENTH
      WRITE(IOUT,20)(NAME(IJK,I),I=1,4),APTURE,ALENTH,STRGTH,FOCAL,
     > AINDCT,AINT
   20 FORMAT(/,' ELEMENT:',4A1,/,10X,
     > 'APERTURE=',F13.8,'(M)',5X,'  LENGTH=',F13.8,'(M)',12X,
     > '  STRENGTH=',F13.8,'(/M**2)',/,10X,
     > 'FOCAL LENGTH=',E15.7,'(M)',' POLE TIP INDUCTION=',F13.8,
     > '(KG)','  INTEGRATED STRENGTH=',F13.8,'(/M)')
      GO TO 4
C
C   SEXTUPOLE
C
    3 IPAR = IADR(IJK)
      APTURE = SQRT(ELDAT(IPAR+2)*ELDAT(IPAR+3))
      ALENTH = ELDAT(IPAR)
      STRGTH = ELDAT(IPAR+1)
      AINDCT = STRGTH*BRHO*APTURE*APTURE
      AINT = STRGTH*ALENTH
      WRITE(IOUT,30)(NAME(IJK,I),I=1,4),APTURE,ALENTH,STRGTH,AINDCT,
     > AINT
   30 FORMAT(/,' ELEMENT:',4A1,/,10X,
     > 'APERTURE=',F13.8,'(M)',11X,'  LENGTH=',F13.8,'(M.)',
     > '  STRENGTH=',F13.8,'(/M**3)',/,10X,
     > 'POLE TIP INDUCTION=',F13.8,'(KG)','  INTEGRATED STRENGTH=',
     > F13.8,'(/M**2)')
      GOTO 4
C
C    QUADRUPOLE-SEXTUPOLE ELEMENT CODE D OR 4
C
   40 IPAR = IADR(IJK)
      APTURE= SQRT(ELDAT(IPAR+3)*ELDAT(IPAR+4))
      ALENTH=ELDAT(IPAR)
      QSTR=ELDAT(IPAR+1)
      SSTR=ELDAT(IPAR+2)
      QIND=QSTR*BRHO*APTURE
      SIND=SSTR*BRHO*APTURE*APTURE
      QINT=QIND*ALENTH
      SINT=SIND*ALENTH
      WRITE(IOUT,41)(NAME(IJK,I),I=1,4),APTURE,ALENTH,
     > QSTR,QIND,QINT,SSTR,SIND,SINT
   41 FORMAT(/,'  ELEMENT :',4A1,/,10X,'  APERTURE =',F13.8,'(M)',
     >5X,' LENGTH =',F13.8,'(M)',/,30X,'QUADRUPOLE COMPONENT',/,
     >10X,' STRENGTH =',F13.8,'(/M**2)',10X,'POLETIP INDUCTION =',
     >F13.8,'(KG)',/,10X,'INTEGRATED STRENGTH =',F13.8,'(/M)',/,
     >30X,'SEXTUPOLE COMPONENT',/,
     >10X,' STRENGTH =',F13.8,'(/M**3)',10X,'POLETIP INDUCTION =',
     >F13.8,'(KG)',/,10X,'INTEGRATED STRENGTH =',F13.8,'(/M**2)',/)
   15 CONTINUE
    4 CONTINUE
C
C   START THE LOOP TO GET THE HALFWAY POINT
C
 2000 R(1)=ZH
      R(2)=XH
      R(3)=YH
      U(1,1)=CT*CF
      U(1,2)=ST*CF
      U(1,3)=SF
      U(2,1)=-CT*SF*SPS - ST*CPS
      U(2,2)=-ST*SF*SPS + CT*CPS
      U(2,3)=SPS*CF
      U(3,1)=-CT*SF*CPS + ST*SPS
      U(3,2)=-ST*SF*CPS - CT*SPS
      U(3,3)=CF*CPS
      ILIST=1
      IU=0
      IF(ABS(CONVH-1.0D0).LT.1.0D-03)IU=1
      IF(ABS(CONVH-1.0D-02).LT.1.0D-05)IU=2
      IF(ABS(CONVH-1.0D-03).LT.1.0D-06)IU=3
      IF(ABS(CONVH-1.0D-06).LT.1.0D-09)IU=4
      IF(ABS(CONVH-0.9144D0).LT.1.0D-03)IU=5
      IF(ABS(CONVH-0.3048D0).LT.1.0D-03)IU=6
      IF(ABS(CONVH-2.54D-02).LT.1.0D-05)IU=7
      IF(NLAY.EQ.0)WRITE(IOUT,88888)
88888 FORMAT(//, ' THE SXYZ COORDINATES,AZIMUTH,ELEVATION AND ROLL',
     >' ANGLES ARE :',//,'  #   NAME ',6X,'S',12X,'X',10X,'Y',12X,'Z',
     >8X,'THETA',9X,'PHI',8X,'PSI',9X,'ALPHA',/)
      IF(IU.EQ.0) GOTO 20000
      IF(NLAY.EQ.0)WRITE(IOUT,90003)(NUNITS(IIU,IU),IIU=1,6)
90003 FORMAT(' THE LENGTHS ARE MEASURED IN ',6A1,' ,THE ANGLES IN',
     >' DEGREES')
      GOTO 20001
20000 IF(NLAY.EQ.0)WRITE(IOUT,88887)
88887 FORMAT(' ***SPECIAL UNITS ARE USED FOR THE LENGTHS!!!!****')
20001 DO 1000 IE=1,NELM
      IBEND=0
      NEL=NORLST(IE)
      KOD=KODE(NEL)
      IAT=IADR(NEL)
      IF(KOD.EQ.1.OR.KOD.EQ.13.OR.KOD.EQ.14)IBEND=1
      ALEN=0.0D0
      IF(KOD.EQ.0.OR.KOD.EQ.2.OR.KOD.EQ.3.OR.KOD.EQ.4.OR.KOD.EQ.15.OR.
     >IBEND.EQ.1)ALEN=ELDAT(IAT)
      IF(KOD.EQ.8)GOTO 800
      IF(IBEND.EQ.1)GOTO 500
      DO 101 IR=1,3
  101 R(IR)=R(IR) + U(1,IR)*ALEN
      GOTO 1100
  500 ARG=ELDAT(IAT+1)*CRDEG
      DC=COS(ARG)
      DS=SIN(ARG)
      OMC=1.0D0-DC
      RHO=ALEN/ARG
      IF(KOD.EQ.1)GOTO 200
      IF(KOD.EQ.13)GOTO 300
      IF(KOD.EQ.14)GOTO 400
  200 DO 201 IR=1,3
      R(IR)=R(IR)-RHO*(OMC*U(2,IR)
     <-DS*U(1,IR))
      U(3,IR)=U(3,IR)
      S(IR)=U(1,IR)*DC-U(2,IR)*DS
      U(2,IR)=U(2,IR)*DC+U(1,IR)*DS
  201 U(1,IR)=S(IR)
      GOTO 1100
  300 DO 301 IR=1,3
      R(IR)=R(IR)+RHO*(OMC*U(3,IR)
     <+DS*U(1,IR))
      U(2,IR)=U(2,IR)
      S(IR)=U(1,IR)*DC+U(3,IR)*DS
      U(3,IR)=U(3,IR)*DC-U(1,IR)*DS
  301 U(1,IR)=S(IR)
      GO TO 1100
  400 GOTO 1100
  800 ALEN=ELDAT(IAT+7)
      ARG=ELDAT(IAT+6)*CRDEG
      DC=COS(ARG)
      DS=SIN(ARG)
      DO 801 IR=1,3
      V2=U(2,IR)*DC+U(3,IR)*DS
      V3=-U(2,IR)*DS+U(3,IR)*DC
      U(2,IR)=V2
      U(3,IR)=V3
      R(IR)=R(IR)+U(1,IR)*ALEN
  801 CONTINUE
      GOTO 1100
 1100 IF (MFPRNT.LT.0)GOTO 1000
      IF((MFPRNT.EQ.0).AND.(IE.NE.NELM))GOTO 1200
      CALL PRTTST(IE,ILIST,IPRT)
      IF(IPRT.EQ.1)GOTO 1200
 1000 CONTINUE
 1001 IE=IE-1
 1200 XRH=R(2)/CONVH
      YRH=R(3)/CONVH
      ZRH=R(1)/CONVH
C     WRITE(IOUT,90001)U(2,2),U(2,3),U(2,1)
C     WRITE(IOUT,90002)U(3,2),U(3,3),U(3,1)
C     WRITE(IOUT,90002)U(1,2),U(1,3),U(1,1)
90001 FORMAT(/,' THE COMPONENTS OF THE UNIT VECTORS ALONG THE LOCAL',
     >' COORDINATES IN THE REFERENCE COORDINATES ARE :',//,3F15.5,//)
90002 FORMAT(3F15.5)
      DENOM=SQRT(U(1,2)**2+U(1,1)**2)
      THETAR=ATAN2(U(1,2),U(1,1))
      PHIRH=ATAN2(U(1,3),DENOM)
      PSIRH=ATAN2(U(2,3),U(3,3))
      THETAR=THETAR/CRDEG
      PHIRH=PHIRH/CRDEG
      PSIRH=PSIRH/CRDEG
      ALPHAR=PSIRH
      ILP=ILR
      IF((PSIRH.GT.90.0D0).AND.(PSIRH.LE.180.0D0))GOTO 601
      IF((PSIRH.GE.-180.0D0).AND.(PSIRH.LT.-90.0D0))GOTO 602
      GOTO 603
  601 ILP=ILL
      ALPHAR=-(180.0D0-PSIRH)
      GOTO 603
  602 ILP=ILL
      ALPHAR=(180.0D0+PSIRH)
  603 SRH=ACLENG(IE)/CONVH
      IF(NLAY.EQ.0)WRITE(IOUT,90004)IE,(NAME(NORLST(IE),IN),IN=1,4)
     >,SRH,XRH,YRH,ZRH,THETAR,PHIRH,PSIRH,ALPHAR,ILP
90004 FORMAT(I5,X,4A1,8F12.5,A4)
      IF(IE.LT.NELM)GO TO 1001
      RETURN
      END
C      ***********************
      SUBROUTINE INPUT(ICHAR,NCHAR,ARRAY,NDIM,IEND,NE,NPRINT)
C     ***********************
C    THIS ROUTINE READS VALUES AND PUTS THEM INTO 'ARRAY' WHICH HAS
C      A DIMENSION OF NDIM
C    A COMMA SEPARATES ARRAYS; A SEMICOLON INDICATES THE END OF THE DATA
C   WHEN A SEMICOLON IS FOUND THE FLAG 'IEND' IS ASSIGNED THE VALUE OF 1
C   IF NE IS A POSITIVE VARIABLE OR CONSTANT, THEN NE ELEMENTS OF DATA
C         ARE READ INTO THE GIVEN ARRAY
C    IF NE IS NEGATIVE, IT MUST BE A VARIABLE AND WILL BE RETURNED WITH
C          THE NUMBER OF ELEMENTS THAT HAVE BEEN READ INTO THE ARRAY
      DIMENSION IDIGIT(10)
      DOUBLE PRECISION ARRAY,TEMP
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      DIMENSION ARRAY(1),ICHAR(1)
      INTEGER CARD(72),TABLE(9,8),P
      INTEGER DIGIT
      DATA TABLE/1,0,60,0,60,0,0,60,' ',4,4,5,5*0,'.',
     1  2,4*0,7,2*0,'+',12,4*0,47,2*0,'-',90,0,70,0,70,2*0,70,',',
     2  99,0,80,0,80,2*0,80,';',2*0,6,0,6,3*0,'E',3*23,2*35,3*58,0/
      DATA P/0/
      DATA IDIGIT/'0','1','2','3','4','5','6','7','8','9'/
      DATA IAA/'A'/,IZ/'Z'/,IBLANK/' '/,ICOM/','/,ISCOL/';'/
      DATA IBRKT/'('/,ISTAR/'*'/,IAT/'@'/
C  INITIALIZE:
      IA=0
      ICOUNT=0
      M=1
      IF(P.NE.0) GO TO 410
11    READ(IIN,99) CARD
      KCOM=0
      IC1=CARD(1)
      IF((IC1.EQ.IBRKT).OR.(IC1.EQ.ISTAR).OR.(IC1.EQ.IAT))KCOM=1
      IF(KCOM.EQ.1)WRITE(IOUT,300)CARD
      IF(KCOM.EQ.1)GOTO 11
      IF(NPRINT.EQ.1)WRITE(IOUT,300)CARD
      IF(NPRINT.EQ.2)WRITE(IOUT,301)NELM,CARD
  301 FORMAT(' ',I5,' ',72A1)
      P=0
  410 IF(NCHAR.EQ.0) GO TO 18
400   P=P+1
      IF(P.GT.72) GO TO 11
C
C  ACCEPT INITIAL CHARACTER A-Z AND 0-9 BUT NOTHING ELSE
C
      IF(CARD(P).EQ.ICOM) GO TO 411
      IF(CARD(P).GE.IAA.AND.CARD(P).LE.IZ) GO TO 230
      IF(CARD(P).GE.IDIGIT(1).AND.CARD(P).LE.IDIGIT(10))GOTO230
      IF(CARD(P).LE.IAA.AND.CARD(P).GE.IZ) GO TO 230
      IF(CARD(P).LE.IDIGIT(1).AND.CARD(P).GE.IDIGIT(10))GOTO230
      GO TO 400
  411 IEND=1
      NELM=NELM-1
      ICHAR(1)=IBLANK
      RETURN
230   IEPOS=P+NCHAR-1
      IF(IEPOS.GT.72)IEPOS=72
      DO 240 JJ=P,IEPOS
      L=JJ
      IF(NCHAR.LE.6.AND.CARD(L).EQ.IBLANK) GO TO 250
      IF(CARD(JJ).NE.ICOM) GO TO 235
      IEND=1
      GO TO 250
235   ICHAR(M)=CARD(JJ)
      M=M+1
      ICOUNT=ICOUNT+1
240   CONTINUE
      IEPOS=IEPOS-1
      GO TO 270
250   II=JJ-P+1
  251 ICHAR(II)=IBLANK
      IEPOS=IEPOS-1
      ICOUNT=ICOUNT+1
      II=II+1
      IF(II.LE.NCHAR)GOTO251
  270 P=IEPOS+1
      NCHAR=ICOUNT
      IF(NDIM.NE.0.AND.P.NE.72) GO TO 18
      RETURN
18    I=1
      IXSIGN=1
      NCHECK=0
      MSIGN=1
      IX=0
      NIX = 0
      IY = 0
      NIY = 0
      KOD = 0
       M=0
       IEXP=0
      GO TO 8
C  FIND CHARACTER IN TABLE:
2     IF(I.EQ.0)GOTO 5
8     P=P+1
      J=1
      IF(P.GT.72) GO TO 11
3     IF(CARD(P).NE.TABLE(9,J)) GO TO 7
4     N=TABLE(I,J)/10
      IF(TABLE(I,J).EQ.99) GO TO 100
      I=TABLE(I,J)-N*10
      IF(N.LT.1.OR.N.GT.9) GO TO 2
      GO TO (10,20,30,40,50,60,70,80,90),N
      GO TO 2
7     J=J+1
      IF(J.LT.8) GO TO 3
      DO 700 IJK=1,10
      IF(CARD(P).EQ.IDIGIT(IJK)) GO TO 701
700   CONTINUE
      GO TO 5
701   DIGIT=IJK-1
      GO TO 4
C  BUILD NUMBER
10    IXSIGN=-1
      GO TO 2
30    KOD = 30
20    NIX = NIX + 1
      IF (NIX.GT.16) GO TO 2
      IF (KOD.EQ.0) GO TO 32
      IEXP = IEXP + 1
32    IF (NIX.GT.8) GO TO 22
      IX = 10*IX + DIGIT
      GO TO 2
22    IY = 10*IY + DIGIT
      NIY = NIY + 1
      GO TO 2
40    MSIGN=-1
      GO TO 2
50    M=10*M+DIGIT
      IF(M.GT.50)GO TO 5
      GO TO 2
60    NCHECK=NCHECK+1
70    NCHECK=NCHECK+1
80    NCHECK=NCHECK+1
      IA=IA+1
      IF (IA.GT.NDIM) GO TO 200
      ARRAY(IA)=IXSIGN*(IX*10.0D0**NIY+IY)/10.D0**IEXP*10.D0**(MSIGN*M)
      IF (IA.EQ.NE) GOTO 90
      IF(NCHECK.EQ.3) GO TO 18
      IF(NE.GT.0) GO TO 66
75    IF(NCHECK.EQ.2) GO TO 90
100   IEND=1
90    NE=IA
      IF(CARD(P).EQ.ISCOL)IEND=1
      IF(P.EQ.72)GOTO 91
      IF(CARD(P+1).EQ.ISCOL)IEND=1
   91 RETURN
66    WRITE(IOUT,96) NE
      IF(ISO.NE.0)WRITE(ISOUT,96) NE
96    FORMAT(10H   ERROR--,I3,24H ELEMENTS WERE NOT FOUND)
      CALL HALT
      STOP
99    FORMAT(72A1)
5     WRITE(IOUT,98) IA
      IF(ISO.NE.0)WRITE(ISOUT,98) IA
98    FORMAT(42H   IMPROPER NUMBER FORMAT IN DATA ELEMENT ,I3)
      CALL HALT
      STOP
 200  WRITE(IOUT,201) IA,NDIM
      IF(ISO.NE.0)WRITE(ISOUT,201) IA,NDIM
 201  FORMAT(I5,36H ELEMENTS READ IN: EXEEDS ARRAY SIZE,I5)
  300 FORMAT(' ',72A1)
      CALL HALT
      STOP
      END
C     ***********************
      SUBROUTINE KICK
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/INPUTT/KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/PRODCT/KODEPR,NEL,NOF
      IAD=IADR(N)
      N=MADR(N)
      DO 520 I=1,6
      IF(ELDAT(IAD+I-1).NE.0.0D0) GO TO 524
520   CONTINUE
521   ARG=ELDAT(IAD+6)* CRDEG
      AL=ELDAT(IAD+7)
      SIN1=SIN(ARG)
      COS1=COS(ARG)
      DO 522 I=1,6
      DO 523 J=1,NOF
 523  AMAT(N,I,J)=0.0D0
 522  AMAT(N,I,I)=COS1
      AMAT(N,1,3)=SIN1
      AMAT(N,2,4)=SIN1
      AMAT(N,3,1)=-SIN1
      AMAT(N,4,2)=-SIN1
      AMAT(N,5,5)=1.0D0
      AMAT(N,6,6)=1.0D0
      AMAT(N,1,2)=AL*COS1
      AMAT(N,1,4)=AL*SIN1
      AMAT(N,3,2)=-SIN1*AL
      AMAT(N,3,4)=COS1*AL
      RETURN
  524 KCOUNT=KCOUNT+1
      GOTO 521
      END
C     ***********************
      SUBROUTINE LABAN(INC,INDF,INDG,DELTA)
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/PLT/
     1XMIN,XMAX,YMIN,YMAX,XPMIN,XPMAX,YPMIN,YPMAX,
     >DELMIN,DELMAX,DNUMIN,DNUMAX,DBMIN,DBMAX,
     2MXXPR,MYYPR,MXY,MALL,NPLOT,NCCUM,NGRAPH,NCOL,NLINE
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN,
     <  NPTOT,MLOCAT,NTURN
      COMMON/GEOM/XCO,XPCO,YCO,YPCO,NCASE,NJOB,
     <            EPSX(10),EPSY(10),XI(10),YI(10),XG(300,10),
     <            XPG(300,10),YG(300,10),YPG(300,10),LCASE(10)
      COMMON/LINE/BETAXF(10),ALPHXF(10),BETAYF(10),ALPHYF(10),
     >XCOF(10),XPCOF(10),YCOF(10),YPCOF(10)
      COMMON/FUNC/BETAX,ALPHAX,ETAX,ETAPX,BETAY,ALPHAY,ETAY,ETAPY,
     <  STARTE,ENDE,DELTAE,DNU,MFPRNT,KOD,NLUM,NINT,NBUNCH
      COMMON/ANALC/COMPF,RNU0X,CETAX,CETAPX,CALPHX,CBETAX,
     1RMU1X,CHROMX,ALPH1X,BETA1X,
     1RMU0Y,RNU0Y,CETAY,CETAPY,CALPHY,CBETAY,
     1RMU1Y,CHROMY,ALPH1Y,BETA1Y,RMU0X,
     >COSX,ALX1,ALX2,VX1,VXP1,VX2,VXP2,
     >COSY,ALY1,ALY2,VY1,VYP1,VY2,VYP2,NSTABX,NSTABY,NSTAB,NWRNCP
      LOGICAL LOGPAR,MXXPR(101,51),MYYPR(101,51),MXY(101,51)
      DIMENSION A(9),B(3),EPSCX(300),EPSCY(300)
      DIMENSION NTITL1(7),NTITL2(7)
      LOGICAL LCASE
      DATA NTITL1/'    ','HORI','ZONT','AL P','HASE',' SPA','CE  '/
      DATA NTITL2/'    ','VERT','ICAL',' PHA','SE S','PACE','    '/
      IF(LCASE(INC))GOTO 120
      WRITE(IOUT,10012) EPSX(INC), EPSY(INC)
10012 FORMAT(/,'  CASE OF EPSX =',E10.3,'  EPSY =',E10.3,/,
     <'  NOT ANALYSED BECAUSE OF LOST PARTICLES  ',/)
      GO TO 1
  120 WRITE(IOUT,10010)EPSX(INC),EPSY(INC)
10010 FORMAT(/,30X,'  VALUES FOR NOMINAL EPSX =',E10.3,/,
     >30X,'     AND FOR NOMINAL EPSY =',E10.3,//)
      WRITE(IOUT,10020)BETAXF(INDF),ALPHXF(INDF),BETAYF(INDF),
     > ALPHYF(INDF),XCOF(INDF),XPCOF(INDF),YCOF(INDF),YPCOF(INDF)
10020 FORMAT(/,10X,'FUNCTION VALUES AT END OF BEAM LINE ARE ',//,
     >10X,'   BETAX =',E12.5,'  ALPHAX =',E12.5,'  BETAY =',E12.5,
     >'  ALPHAY =',E12.5,/,10X,'   XCOF  =',E12.5,'  XPCOF  =',
     >E12.5,'  YCOF  =',E12.5,'YPCOF  =',E12.5,//)
      IPLOTX=0
      IPLOTY=0
      IFLGX=0
      IFLGY=0
      BETAVX=1.0D0
      BETAVY=1.0D0
      GAMAVX=1.0D0
      GAMAVY=1.0D0
      ALPAVX=1.0D0
      ALPAVY=1.0D0
      SUMX1 = 0.0D0
      SUMX2 = 0.0D0
      SUMX3 = 0.0D0
      SUMX4 = 0.0D0
      SUMX5 = 0.0D0
      SUMX6 = 0.0D0
      SUMX7 = 0.0D0
      SUMX8 = 0.0D0
      SUMY1 = 0.0D0
      SUMY2 = 0.0D0
      SUMY3 = 0.0D0
      SUMY4 = 0.0D0
      SUMY5 = 0.0D0
      SUMY6 = 0.0D0
      SUMY7 = 0.0D0
      SUMY8 = 0.0D0
      NPRM1=NPART-1
      DO 2 NT = 1, NPRM1
      X = XG(NT,INDG)
      XP = XPG(NT,INDG)
      Y = YG(NT,INDG)
      YP = YPG(NT,INDG)
      IF(ABS(X).LT.1.0D-16)X=0.0D0
      IF(ABS(XP).LT.1.0D-16)XP=0.0D0
      IF(ABS(Y).LT.1.0D-16)Y=0.0D0
      IF(ABS(YP).LT.1.0D-16)YP=0.0D0
      X2 = X*X
      Y2 = Y*Y
      XP2 = XP*XP
      YP2 = YP*YP
      IF(ABS(X2).LT.1.0D-16)X2=0.0D0
      IF(ABS(XP2).LT.1.0D-16)XP2=0.0D0
      IF(ABS(Y2).LT.1.0D-16)Y2=0.0D0
      IF(ABS(YP2).LT.1.0D-16)YP2=0.0D0
      X3 = X2*X
      Y3 = Y2*Y
      XP3 = XP2*XP
      YP3 = YP2*YP
      X4 = X3*X
      Y4 = Y3*Y
      XP4 = XP3*XP
      YP4 = YP3*YP
      SUMX1 = SUMX1 + X4
      SUMY1 = SUMY1 + Y4
      SUMX2 = SUMX2 + X3*XP
      SUMY2 = SUMY2 + Y3*YP
      SUMX3 = SUMX3 + X2*XP2
      SUMY3 = SUMY3 + Y2*YP2
      SUMX4 = SUMX4 + X*XP3
      SUMY4 = SUMY4 + Y*YP3
      SUMX5 = SUMX5 + XP4
      SUMY5 = SUMY5 + YP4
      SUMX6 = SUMX6 + X2
      SUMY6 = SUMY6 + Y2
      SUMX7 = SUMX7 + X*XP
      SUMY7 = SUMY7 + Y*YP
      SUMX8 = SUMX8 + XP2
      SUMY8 = SUMY8 + YP2
    2 CONTINUE
      EPSAVX=1.0D0
      EPSAVY=1.0D0
      IF(EPSX(INC).EQ.0.0D0)GOTO 10
      IFLGX=1
      IPLOTX=1
      A(1) = SUMX1
      A(2) = SUMX3
      A(3) = SUMX2
      A(4) = SUMX3
      A(5) = SUMX5
      A(6) = SUMX4
      A(7) = SUMX2
      A(8) = SUMX4
      A(9) = SUMX3
      B(1) = SUMX6
      B(2) = SUMX8
      B(3) = SUMX7
      CALL DSIMQ(A,B,3,KS)
      CX = B(1)
      BX = B(2)
      AX = B(3)
      ARG=BX*CX-(AX*AX)/4.0D0
      IF(ARG.LT.0.0D0) GOTO 30
      EPSAVX = 1.0D0/(SQRT(ARG))
      BETAVX = BX*EPSAVX
      ALPAVX = AX*EPSAVX/2.0D0
      GAMAVX = (1.0D0 + ALPAVX*ALPAVX)/BETAVX
      GOTO 10
   30 WRITE(IOUT,99999)
99999 FORMAT(/,' ELLIPSE COULD NOT BE FITTED TO X DATA',/)
      IFLGX=0
   10 IF(EPSY(INC).EQ.0.0D0)GOTO11
      IFLGY=1
      IPLOTY=1
      A(1) = SUMY1
      A(2) = SUMY3
      A(3) = SUMY2
      A(4) = SUMY3
      A(5) = SUMY5
      A(6) = SUMY4
      A(7) = SUMY2
      A(8) = SUMY4
      A(9) = SUMY3
      B(1) = SUMY6
      B(2) = SUMY8
      B(3) = SUMY7
      CALL DSIMQ(A,B,3,KS)
      CY = B(1)
      BY = B(2)
      AY = B(3)
      ARG=BY*CY-(AY*AY)/4.0D0
      IF(ARG.LT.0.0D0)GOTO 31
      EPSAVY = 1.0D0/(SQRT(BY*CY-(AY*AY)/4.0D0))
      BETAVY = BY*EPSAVY
      ALPAVY = AY*EPSAVY/2.0D0
      GAMAVY = (1.0D0 + ALPAVY*ALPAVY)/BETAVY
      GOTO 11
   31 WRITE(IOUT,99998)
99998 FORMAT(/,' ELLIPSE COULD NOT BE FITTED TO Y DATA',/)
      IFLGY=0
   11 DO 3 NT = 1, NPRM1
      X = XG(NT,INDG)
      XP = XPG(NT,INDG)
      Y = YG(NT,INDG)
      YP = YPG(NT,INDG)
      IF(ABS(X).LT.1.0D-16)X=0.0D0
      IF(ABS(XP).LT.1.0D-16)XP=0.0D0
      IF(ABS(Y).LT.1.0D-16)Y=0.0D0
      IF(ABS(YP).LT.1.0D-16)YP=0.0D0
      EPSCX(NT) = GAMAVX*X*X + BETAVX*XP
     < *XP  + 2.0D0*ALPAVX*X*XP
      EPSCY(NT) = GAMAVY*Y*Y + BETAVY*YP
     < *YP + 2.0D0*ALPAVY*Y*YP
    3 CONTINUE
      EXMAX = 0.0D0
      EYMAX = 0.0D0
      SUMX = 0.0D0
      SUMY = 0.0D0
      EXMIN = 1.0D32
      EYMIN = 1.0D32
      DO 4 NT = 1, NPRM1
      IF(EPSCX(NT) .GT. EXMAX)EXMAX = EPSCX(NT)
      IF(EPSCX(NT) .LT. EXMIN)EXMIN = EPSCX(NT)
      IF(EPSCY(NT) .GT. EYMAX)EYMAX = EPSCY(NT)
      IF(EPSCY(NT) .LT. EYMIN)EYMIN = EPSCY(NT)
    4 CONTINUE
      DEX = EXMAX - EXMIN
      DEY = EYMAX - EYMIN
      DEEPSX=DEX/EPSAVX
      DEEPSY=DEY/EPSAVY
      XMIN = SQRT(BETAVX*EXMIN)
      XMAX = SQRT(BETAVX*EXMAX)
      YMIN = SQRT(BETAVY*EYMIN)
      YMAX = SQRT(BETAVY*EYMAX)
      CAMIN = XMIN*YMIN
      CAMAX = XMAX*YMAX
      IF(CAMIN.NE.0.0D0)CARAT=CAMAX/CAMIN
      IF((IFLGX.EQ.0).AND.(IFLGY.EQ.0))GOTO 40
      IF(IFLGX.EQ.0)GOTO 50
      IF(IFLGY.EQ.0)GOTO 60
      GOTO 70
   40 WRITE(IOUT,99997)
99997 FORMAT(/,'  PLOTS ONLY ARE PROVIDED ',/)
      GOTO 41
   70 WRITE(IOUT,10011)
10011 FORMAT('  AVERAGE :   BETAX',7X,'ALPHAX',6X,'EPSX',8X,'BETAY',
     <7X,'ALPHAY',6X,'EPSY',/)
      WRITE (IOUT, 10001) BETAVX,ALPAVX,EPSAVX,
     >                    BETAVY,ALPAVY,EPSAVY
10001 FORMAT (9X,6E12.3 )
      WRITE(IOUT, 10003)EXMAX, EXMIN, DEX, EYMAX, EYMIN, DEY
10003 FORMAT(/,'   EPSXMAX   EPSXMIN   DELEPSX   EPSYMAX ',
     <'   EPSYMIN   DELEPSY',/,' ',6E10.3,/)
      WRITE(IOUT,10006)DEEPSX,DEEPSY
10006 FORMAT(/,'  DELEPSX/EPSX   DELEPSY/EPSY ',/,2E10.3,/)
      WRITE(IOUT, 10005)CAMAX,CAMIN,CARAT
10005 FORMAT(/,'  CROSS SECTIONAL AREAS',//,10X,
     <'  MAXIMUM',5X,'  MINIMUM',5X,'   MAX/MIN',//,10X,4(E10.3,2X),/)
      GOTO 41
   50 WRITE(IOUT,50011)
50011 FORMAT('  AVERAGE :   BETAY',
     <7X,'ALPHAY',6X,'EPSY',/)
      WRITE (IOUT, 50001)
     >                    BETAVY,ALPAVY,EPSAVY
50001 FORMAT (9X,3E12.3 )
      WRITE(IOUT, 50003) EYMAX, EYMIN, DEY
50003 FORMAT(/,'   EPSYMAX ',
     <'   EPSYMIN   DELEPSY',/,' ',3E10.3,/)
      WRITE(IOUT,50006)DEEPSY
50006 FORMAT(/,'  DELEPSY/EPSY ',/,E10.3,/)
      GOTO 41
   60 WRITE(IOUT,60011)
60011 FORMAT('  AVERAGE :   BETAX',7X,'ALPHAX',6X,'EPSX',8X,
     </)

      WRITE (IOUT, 60001) BETAVX,ALPAVX,EPSAVX
60001 FORMAT (9X,3E12.3 )
      WRITE(IOUT, 60003)EXMAX, EXMIN, DEX
60003 FORMAT(/,'   EPSXMAX   EPSXMIN   DELEPSX'
     <,/,' ',3E10.3,/)
      WRITE(IOUT,60006)DEEPSX
60006 FORMAT(/,' DELEPSX/EPSX ',/,E10.3,/)
   41 IF(NPLOT .EQ. -1) GO TO 1
      XMAX = SQRT(EPSX(INC)*BETAXF(INDF))*1.5D0
      XMIN = -XMAX
      YMAX = SQRT(EPSY(INC)*BETAYF(INDF))*1.5D0
      YMIN = -YMAX
      GAMMFX = (1.0D0 + ALPHXF(INDF)*ALPHXF(INDF))/BETAXF(INDF)
      GAMMFY = (1.0D0 + ALPHYF(INDF)*ALPHYF(INDF))/BETAYF(INDF)
      NZERO = 0
      NCHAR = 39
      IF(DELTA.GT.0.0D0)NCHAR=36
      IF(DELTA.LT.0.0D0)NCHAR=38
      NCCUM =1
      NGRAPH = 4
      MALL = 0
      NCOL = 71
      NLINE = 51
      XPMAX = SQRT(EPSX(INC)*GAMMFX)*1.5D0
      XPMIN = -XPMAX
      YPMAX = SQRT(EPSY(INC)*GAMMFY)*1.5D0
      YPMIN = -YPMAX
      XMAX=XMAX+XCOF(INDG)
      XMIN=XMIN+XCOF(INDG)
      XPMAX=XPMAX+XPCOF(INDG)
      XPMIN=XPMIN+XPCOF(INDG)
      YMAX=YMAX+YCOF(INDG)
      YMIN=YMIN+YCOF(INDG)
      YPMAX=YPMAX+YPCOF(INDG)
      YPMIN=YPMIN+YPCOF(INDG)
      WRITE(IOUT,10021)
10021 FORMAT(///,'  THE FOLLOWING PLOTS ARE CENTERED AROUND THE ',
     >'CHOSEN ORBIT ')
      WRITE(IOUT,10022)
      IF(IPlOTX.EQ.1)CALL PPLOT(PART(1,1),PART(1,2)
     >,NPART,XMAX,XMIN,XPMAX,XPMIN,
     > NCCUM,NZERO,NCHAR,NCOL,NLINE,NTITL1,MXXPR,LOGPAR)
      IF(IPLOTY.EQ.1)CALL PPLOT(PART(1,3),PART(1,4)
     >,NPART,YMAX,YMIN,YPMAX,YPMIN,
     > NCCUM,NZERO,NCHAR,NCOL,NLINE,NTITL2,MYYPR,LOGPAR)
      WRITE(IOUT,10022)
10022 FORMAT('1')
    1 CONTINUE
      RETURN
      END
C     *****************
      SUBROUTINE LENG
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
C
C     STORE LENGTH OF EACH MACHINE ELEMENT
C
      DO 1 IE = 1,NA
      NGT=KODE(IE)+1
CDLR      GO TO (400,401,400,400,400,400,400,409,408,409,409,
CDLR     >409,409,400,400,400,409),NGT
      GO TO (400,401,400,400,400,409,400,409,408,409,409,
     >409,409,400,400,400,409),NGT
  409 ALENG(IE)=0.0D0
      GO TO   1
  400 ALENG(IE)=ELDAT(IADR(IE))
      GO TO   1
  401 ALENG(IE)=ELDAT(IADR(IE))
      GO TO   1
  408 ALENG(IE)=ELDAT(IADR(IE)+7)
      GO TO   1
    1 CONTINUE
C
C     COMPUTE LENGTH OF MACHINE
C
      TLENG=0.0D0
      NGT=NORLST(1)
      ACLENG(1)=ALENG(NGT)
      DO 90 IL=2,NELM
      NGT=NORLST(IL)
  90  ACLENG(IL)=ACLENG(IL-1)+ALENG(NGT)
      TLENG=ACLENG(NELM)
      RETURN
      END
C     ***********************
      SUBROUTINE LINABE(IEND)
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/PLT/
     1XMIN,XMAX,YMIN,YMAX,XPMIN,XPMAX,YPMIN,YPMAX,
     >DELMIN,DELMAX,DNUMIN,DNUMAX,DBMIN,DBMAX,
     2MXXPR,MYYPR,MXY,MALL,NPLOT,NCCUM,NGRAPH,NCOL,NLINE
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN,
     <  NPTOT,MLOCAT,NTURN
      COMMON/GEOM/XCO,XPCO,YCO,YPCO,NCASE,NJOB,
     <            EPSX(10),EPSY(10),XI(10),YI(10),XG(300,10),
     <            XPG(300,10),YG(300,10),YPG(300,10),LCASE(10)
      COMMON/LINE/BETAXF(10),ALPHXF(10),BETAYF(10),ALPHYF(10),
     >XCOF(10),XPCOF(10),YCOF(10),YPCOF(10)
      COMMON/FUNC/BETAX,ALPHAX,ETAX,ETAPX,BETAY,ALPHAY,ETAY,ETAPY,
     <  STARTE,ENDE,DELTAE,DNU,MFPRNT,KOD,NLUM,NINT,NBUNCH
      COMMON/ANALC/COMPF,RNU0X,CETAX,CETAPX,CALPHX,CBETAX,
     1RMU1X,CHROMX,ALPH1X,BETA1X,
     1RMU0Y,RNU0Y,CETAY,CETAPY,CALPHY,CBETAY,
     1RMU1Y,CHROMY,ALPH1Y,BETA1Y,RMU0X,
     >COSX,ALX1,ALX2,VX1,VXP1,VX2,VXP2,
     >COSY,ALY1,ALY2,VY1,VYP1,VY2,VYP2,NSTABX,NSTABY,NSTAB,NWRNCP
      LOGICAL LOGPAR,MXXPR(101,51),MYYPR(101,51),MXY(101,51)
      LOGICAL LCASE
      DIMENSION OPLIST(300), ICHAR(6)
      NORDER = 2
      NCHAR = 0
      NOP = -1
      DO 11 IL = 1,10
  11  LCASE(IL) = .TRUE.
      DO 10 IP = 1, NPTOT
   10 LOGPAR(IP) = .TRUE.
      NDIM=300
      NIPR=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NIPR)
      BETAX = OPLIST(1)
      ALPHAX = OPLIST(2)
      BETAY = OPLIST(3)
      ALPHAY = OPLIST(4)
      GAMMAX = (1.0D0+ALPHAX*ALPHAX)/BETAX
      GAMMAY = (1.0D0+ALPHAY*ALPHAY)/BETAY
      XCO = OPLIST(5)
      XPCO = OPLIST(6)
      YCO = OPLIST(7)
      YPCO = OPLIST(8)
      DELTA = OPLIST(9)
      NCASE = OPLIST(10)
      IF(NCASE .LE. 10) GO TO 6
      NCASE = 10
      WRITE (ISOUT,10000)
10000 FORMAT ('  TOO MANY CASES REQUESTED:DEFAULT MAX 10 ARE READ ')
    6 NGPART = OPLIST(11)
      NCOUP= OPLIST(12)
      NGPLOT = OPLIST(13)
      NGPRNT = OPLIST(14)
      MLOCAT= OPLIST(15)
      IF(MLOCAT.EQ.0)GOTO 7
      DO 4 IML=1,MLOCAT
      INDIM = 2*IML -1
      INDOP = INDIML + 15
      NLIST(INDIM) = OPLIST(INDOP)
    4 NLIST(INDIM+1) = OPLIST(INDOP+1)
    7 EPSXM = 0.0D0
      EPSYM = 0.0D0
      DO 1 NC = 1, NCASE
      IND = (NC-1)*2 + 16 + 2*MLOCAT
      EPSX(NC) = OPLIST(IND)*1.0D-06
      EPSY(NC) = OPLIST(IND + 1)*1.0D-06
      IF(EPSX(NC) .GT. EPSXM)EPSXM = EPSX(NC)
      IF(EPSY(NC) .GT. EPSYM)EPSYM = EPSY(NC)
    1 CONTINUE
      DO 2 NP = 1, NGPART
      DO 3 IP = 1, 5
    3 PART(NP, IP) = 0.0D0
      PART(NP, 6) = DELTA
      DEL(NP)=DELTA
    2 CONTINUE
      NPART = 5
      NCPART = NPART
      PART(1,1) = XCO
      PART(1,2) = XPCO
      PART(1,3) = YCO
      PART(1,4) = YPCO
      PART(2,1) = XCO + 1.0D-06
      PART(2,2) = XPCO
      PART(2,3) = YCO
      PART(2,4) = YPCO
      PART(3,1) = XCO
      PART(3,2) = XPCO + 1.0D-06
      PART(3,3) = YCO
      PART(3,4) = YPCO
      PART(4,1) = XCO
      PART(4,2) = XPCO
      PART(4,3) = YCO + 1.0D-06
      PART(4,4) = YPCO
      PART(5,1) = XCO
      PART(5,2) = XPCO
      PART(5,3) = YCO
      PART(5,4) = YPCO + 1.0D-06
      NPLOT = -1
      NPRINT = -2
      NTURN = 1
      NCTURN = 0
C     WRITE(IOUT,77777)MDPRT
77777 FORMAT(' IN LINABE',I6)
      CALL TRACKT
      INDF=MLOCAT*2+1
      XCOF(INDF) = PART(1,1)
      XPCOF(INDF) = PART(1,2)
      YCOF(INDF) = PART(1,3)
      YPCOF(INDF) = PART(1,4)
      CX = (PART(2,1)-PART(1,1))*1.0D06
      CPX = (PART(2,2)-PART(1,2))*1.0D06
      SX = (PART(3,1)-PART(1,1))*1.0D06
      SPX = (PART(3,2)-PART(1,2))*1.0D06
      CY = (PART(4,3)-PART(1,3))*1.0D06
      CPY = (PART(4,4)-PART(1,4))*1.0D06
      SY = (PART(5,3)-PART(1,3))*1.0D06
      SPY = (PART(5,4)-PART(1,4))*1.0D06
      BETAXF(INDF) = CX*CX*BETAX-2.0D0*CX*SX*ALPHAX+SX*SX*GAMMAX
      ALPHXF(INDF) = -CPX*CX*BETAX+(1.0D0+2.0D0*SX*CPX)*ALPHAX
     >-SX*SPX*GAMMAX
      BETAYF(INDF) = CY*CY*BETAY-2.0D0*CY*SY*ALPHAY+SY*SY*GAMMAY
      ALPHYF(INDF) = -CPY*CY*BETAY+(1.0D0+2.0D0*SY*CPY)*ALPHAY
     >-SY*SPY*GAMMAY
      NPART = NGPART
      NPM1=NPART-1
      DO 20 INC=1,NCASE
      NPLOT = -1
      NPRINT = NGPRNT
      X0I=SQRT(BETAX*EPSX(INC))
      XP0I=-ALPHAX*SQRT(EPSX(INC)/BETAX)
      Y0I=SQRT(BETAY*EPSY(INC))
      YP0I=-ALPHAY*SQRT(EPSY(INC)/BETAY)
      DO 21 INP=1,NPM1
      COS1 = COS((INP-1)*TWOPI/NPM1)
      SIN1 = SIN((INP-1)*TWOPI/NPM1)
      XIL=X0I*(COS1+ALPHAX*SIN1)+XP0I*BETAX*SIN1
      XPIL=-X0I*GAMMAX*SIN1+XP0I*(COS1-ALPHAX*SIN1)
      YIL=Y0I*(COS1+ALPHAY*SIN1)+YP0I*BETAY*SIN1
      YPIL=-Y0I*GAMMAY*SIN1+YP0I*(COS1-ALPHAY*SIN1)
      PART(INP,1)=XCO+XIL
      PART(INP,2)=XPCO+XPIL
      PART(INP,3)=YCO+YIL
      PART(INP,4)=YPCO+YPIL
      PART(INP,5)=0.0D0
      PART(INP,6)=DELTA
   21 CONTINUE
      PART(NPART,1)=XCO
      PART(NPART,2)=XPCO
      PART(NPART,3)=YCO
      PART(NPART,4)=YPCO
      PART(NPART,5)=0.0D0
      PART(NPART,6)=DELTA
      NCPART=NPART
      NCTURN = 0
      CALL TRACKT
      NPLOT=NGPLOT
      DO 22 INP=1,NPART
      IF(.NOT.LOGPAR(INP))GOTO 23
      INDG=MLOCAT*2+1
      XG(INP,INDG)=PART(INP,1)-XCOF(INDG)
      XPG(INP,INDG)=PART(INP,2)-XPCOF(INDG)
      YG(INP,INDG)=PART(INP,3)-YCOF(INDG)
      YPG(INP,INDG)=PART(INP,4)-YPCOF(INDG)
   22 CONTINUE
      GOTO 24
   23 LCASE(INC)=.FALSE.
   24 CALL LABAN(INC,INDF,INDG,DELTA)
   20 CONTINUE
      RETURN
      END
C     *****************
      SUBROUTINE LSQ
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/TRI/WCO(15,6),GEN(5,4),PGEN(75,6),DIST,
     <A1(15),B1(15),A2(15),B2(15),XCOR(3,15),XPCOR(3,15),
     1AL1(15),AL2(15),MESH,NIT,NENER,NITX,NITS,NITM1,NANAL,NOPRT
      COMMON/CLSQ/ALSQ(15,2,4),IXY,NCOEF,NAPLT,JENER,LENER(15)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      DIMENSION  AL(100),B(10),R(10,2,4),LL(10),ML(10),AMAX(2,4)
      LOGICAL LENER
      REF=1.0D-02
      IF((NENER.LT.NCOEF).OR.(NCOEF.EQ.0)) GO TO 1000
      IT=0
      DO 1 IE=1,NENER
    1 IF(LENER(IE))IT=IT+1
      IF(IT.LT.NCOEF) GO TO 1000
      DO 10 JXY=1,2
      DO 10 JNB=1,4
      DO 20 I=1,10
      B(I)=0.0
      R(I,JXY,JNB)=0.0
      DO 20 J=1,10
   20 AL((I-1)*10+J)=0.0
      DO 30 IE=1,NENER
      IF(.NOT.LENER(IE)) GO TO 30
      ENVAL=WCO(IE,6)/REF
      DO 40 IA=1,NCOEF
      DO 50 JA=IA,NCOEF
      IF(JA.NE.1) GO TO 49
      AL((IA-1)*NCOEF+JA)=AL((IA-1)*NCOEF+JA)+1.0
      GO TO 50
  49  AL((IA-1)*NCOEF+JA)=AL((IA-1)*NCOEF+JA)+ENVAL**(IA+JA-2)
   50 AL((JA-1)*NCOEF+IA)=AL((IA-1)*NCOEF+JA)
      IF(IA.NE.1) GO TO 39
      B(IA)=B(IA)+ALSQ(IE,JXY,JNB)
      GO TO 40
   39 B(IA)=B(IA)+ALSQ(IE,JXY,JNB)*ENVAL**(IA-1)
   40 CONTINUE
   30 CONTINUE
      CALL DMINV(AL,NCOEF,D,LL,ML)
      DO 60 IA=1,NCOEF
      DO 60 JA=1,NCOEF
   60 R(IA,JXY,JNB)=R(IA,JXY,JNB)+AL((IA-1)*NCOEF+JA)*B(JA)
   10 CONTINUE
      WRITE(IOUT,20003)REF
      IF(ISO.NE.0)WRITE(ISOUT,20003)REF
20003 FORMAT(/,'   THE REFERENCE ENERGY IS : ',E10.2,/)
      WRITE(IOUT,20000)
      IF(ISO.NE.0)WRITE(ISOUT,20000)
20000 FORMAT(//,'         EXPANSION COEFFICIENTS FOR ',//,
     >11X,'NUX',12X,'NUY',11X,'BETAX',10X,'BETAY',//)
      DO 61 I=1,NCOEF
      IM1=I-1
      WRITE(IOUT,20001)IM1,((R(I,J,K),J=1,2),K=1,2)
      IF(ISO.NE.0)WRITE(ISOUT,20001)I,((R(I,J,K),J=1,2),K=1,2)
   61 CONTINUE
20001 FORMAT(I5,4E15.5)
      WRITE(IOUT,20002)
      IF(ISO.NE.0)WRITE(ISOUT,20002)
20002 FORMAT(//,'         EXPANSION COEFFICIENTS FOR ',//,
     >10X,'ETAX',11X,'ETAY',10X,'ETAPX',10X,'ETAPY',//)
      DO 62 I=1,NCOEF
      IM1=I-1
      WRITE(IOUT,20001)IM1,((R(I,J,K),J=1,2),K=3,4)
      IF(ISO.NE.0)WRITE(ISOUT,20001)I,((R(I,J,K),J=1,2),K=3,4)
   62 CONTINUE
      DO 31 K=1,4
      DO 32 J=1,2
      AMAX(J,K)=0.0
      DO 33 IE=1,NENER
      IF(.NOT.LENER(IE)) GO TO 33
      XE=WCO(IE,6)/REF
      VAL=0.0
      DO 34 I=1,NCOEF
   34 VAL =VAL*XE + R(NCOEF+1-I,J,K)
      ERR=ABS(VAL-ALSQ(IE,J,K))
      IF(ERR.GT.AMAX(J,K)) AMAX(J,K)=ERR
   33 CONTINUE
   32 CONTINUE
   31 CONTINUE
      WRITE(IOUT,30000) AMAX
30000 FORMAT(//,' MAXIMUM ABSOLUTE ERRORS ',//,2(4E15.6,/),//)
      RETURN
 1000 WRITE(IOUT,10000)
10000 FORMAT(47H   LEAST SQUARE FIT NOT DONE,LESS THAN FIVE PTS   )
      RETURN
      END
C     ***********************
      SUBROUTINE LUMIN
C     *****************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/FUNC/BETAX,ALPHAX,ETAX,ETAPX,BETAY,ALPHAY,ETAY,ETAPY,
     <  STARTE,ENDE,DELTAE,DNU,MFPRNT,KOD,NLUM,NINT,NBUNCH
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
      COMMON/LUM/ UO,TAUX,ALPHX,ALPHY,TAUY,
     <  ALPHE,TAUE,SIGE,SIGX,EPSX,
     <SIGY,EPSY,SIGXT,SIGYT,ENERGY,TAUREV
      SIGXT2=SIGXT*SIGXT
      SIGYT2=SIGYT*SIGYT
      BRAT=BETAY/BETAX
      SIGX2=SIGX*SIGX
      SIGY2=SIGY*SIGY
      SIGE2=SIGE*SIGE
      TAURAT=TAUX/TAUY
      DENOM=SIGX2-SIGY2*TAURAT
      DENOM=DENOM-(ETAX*ETAX*BRAT-(ETAY*ETAY)/BRAT)*SIGE2
      COUP=(SIGXT2*BRAT-SIGYT2/BRAT)/DENOM
    1 A=SQRT(COUP)
      GAMMA=(ENERGY/EMASS)
      SIGNX2=(SIGX2+COUP*TAURAT*SIGY2/BRAT)/(1.0D0+COUP)
      SIGNY2=(SIGY2+COUP*SIGX2*BRAT/TAURAT)/(1.0D0+COUP)
      SIGNX=SQRT(SIGNX2)
      SIGNY=SQRT(SIGNY2)
      SIGTX=SQRT(SIGNX2+ETAX*ETAX*SIGE2)
      SIGTY=SQRT(SIGNY2+ETAY*ETAY*SIGE2)
      SIGT=SIGTX+SIGTY
      ANPBN=2.0D0*PI*GAMMA*SIGTX*SIGT*DNU/(ERAD*BETAX)
      AIBEAM=ECHG*ANPBN*NBUNCH/TAUREV
      DENOM=(2.0D0*ERAD*BETAX*SIGTY*TAUREV*1.0D04)
      ALUM=GAMMA*NBUNCH*ANPBN*SIGT*DNU/DENOM
      IF(COUP.EQ.1.0D0) GOTO 2
      WRITE(IOUT,10002)A,SIGNX,SIGNY,SIGTX,SIGTY,ANPBN,AIBEAM,ALUM
      COUP= 1.0D0
      GOTO 1
   2  WRITE(IOUT,10003)A,SIGNX,SIGNY,SIGTX,SIGTY
10002 FORMAT('          VALUES FOR OPTIMUM COUPLING : ',F6.3,
     < //,' SIGX = ',E11.4,' (M)',10X,' SIGY = ',E11.4,' (M)'
     < /,' SIGXT = ',E11.4,' (M)',10X,'SIGYT = ',E11.4,' (M)',/,
     < ' # OF PARTICLES/BUNCH = ',E11.4,5X,' INTENSITY/BEAM = ',
     < E11.4,' AMP ',/
     < ' LUMINOSITY = ',E11.4,' (CM(-2)SEC(-1)) ')
10003 FORMAT(/,'          VALUES FOR MAXIMUM COUPLING : ',F6.3,
     < //,' SIGX = ',E11.4,' (M)',10X,' SIGY = ',E11.4,' (M)'
     < /,' SIGXT = ',E11.4,' (M)',10X,'SIGYT = ',E11.4,' (M)')
      RETURN
      END


C      ***********************
      SUBROUTINE MAGT2(PARM)
C     ***********************
C
C **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
C                OTHERWIZE DECLARED *********
C
      IMPLICIT DOUBLE PRECISION(A-Z)
      INTEGER KODE,NAME,IADR,MADR,KCOUNT,NA
      INTEGER NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,NLIST
      INTEGER IIN,IOUT,ISOUT,ISO,NORLST
      INTEGER N,I,J
      LOGICAL LOGPAR
      EQUIVALENCE (COSR,CX,SPX),(COSV,CY,SPY),(DPX,SINEPR)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      DIMENSION PARM(20)
C
C     CLEAR AMAT(N,6,27)
C
      DO 99 I=1,6
      DO 99 J=1,27
      AMAT(N,I,J) = 0.0D0
99    CONTINUE
      DEFAND=PARM(1)
      AL=PARM(2)
      FIELDN=PARM(3)
      BETA=PARM(4)
      DEFANG=DEFAND*CRDEG
      H=DEFANG/AL
      RAD=1.0D0/H
      H2=H*H
      H3=H2*H
      H4=H3*H
      H5=H4*H
      H6=H5*H
      KX2=(1.0D0-FIELDN)*H2
      KY2=FIELDN*H2
      KX=SQRT(ABS(KX2))
      KY=SQRT(ABS(KY2))
      ARGX=KX*AL
      SINX=SIN(ARGX)
      COSX=COS(ARGX)
      SHX=SINH(ARGX)
      CHX=COSH(ARGX)
      KX4=KX2*KX2
      KX6=KX4*KX2
      ARGY=KY*AL
      SINY=SIN(ARGY)
      COSY=COS(ARGY)
      SHY=SINH(ARGY)
      CHY=COSH(ARGY)
      KY3=KY2*KY
      KY4=KY2*KY2
      TARGX=ARGX+ARGX
      SIN2X=SIN(TARGX)
      COS2X=COS(TARGX)
      SH2X=SINH(TARGX)
      CH2X=COSH(TARGX)
      KX3=KX*KX2
      KX5=KX3*KX2
      KX7=KX5*KX2
      TARGY=ARGY+ARGY
      SIN2Y=SIN(TARGY)
      COS2Y=COS(TARGY)
      SH2Y=SINH(TARGY)
      CH2Y=COSH(TARGY)
      AL2=AL*AL
      AL3=AL2*AL
      AL4=AL3*AL
      AL5=AL4*AL
      AL6=AL5*AL
      AL7=AL6*AL
      C=1.0D0/(KX2-4.0D0*KY2)
      IF (KX2) 1,2,3
    1 CX=COSH(KX*AL)
      SX=SINH(KX*AL)/KX
      DX=H*(1.0D0-CX)/KX2
      J1XL=(ARGX-SHX)/KX3
      J2XL=(1.0D0-CHX+.5D0*ARGX*SHX)/KX4
      J3XL=.5D0*(SHX-ARGX*CHX)/KX3
      J4XL=(.5D0*ARGX-2.0D0*SHX/3.0D0+SH2X/12.0D0)/KX5
      J5XL=(.25D0-CHX/3.0D0+CH2X/12.0D0)/KX4
      J10XL=(ARGX-1.5D0*SHX+.5D0*ARGX*CHX)/KX5
      J11XL=(-2.0D0*ARGX+3.0D0*SHX-ARGX*CHX)/KX5
      J12XL=(4.0D0*ARGX-5.5D0*SHX+1.5D0*ARGX*CHX)/KX3
      J13XL=(.75D0-2.0D0*CHX/3.0D0-CH2X/12.0D0+.5D0*ARGX*SHX)
     <  /KX6
      J14XL=(1.5D0-4.0D0*CHX/3.0D0-CH2X/6.0D0+ARGX*SHX)/KX6
      J15XL=(-1.75D0+4.0D0*CHX/3.0D0+5.0D0*CH2X/12.0D0-1.5D0*ARGX*SHX)
     <  /KX4
      J16XL=(1.5D0*ARGX-7.0D0*SHX/3.0D0-SH2X/12.0D0+ARGX*CHX)/
     <  KX7
      J17XL=(-1.75D0*ARGX+17.0D0*SHX/6.0D0+5.0D0*SH2X/24.0D0-1.5D0
     <  *ARGX*CHX)/KX5
      J1L=(.5D0*ARGX-.25D0*SH2X)/KX3
      J2L=(.5D0*ARGX+.25D0*SH2X)/KX
      J3L=.25D0*(1.0D0-CH2X)/KX2
      IF(KY2) 345,346,347
345   J7XL=.5*(ARGX-SHX+KX2*C*(SHX-.5*KX*SH2Y/KY))/(KX3*KY2)
      J9XL=C*((CHX-1)/KX2+(1.0D0-CH2Y)/(4.0D0*KY2))
      GO TO 4
346   J7XL=(2.0D0*(SINX-ARGX)/KX3+AL3/3.0D0)/KX2
      J9XL=AL2/(2.0D0*KX2)+(CHX-1.0D0)/KX4
      GO TO 4
347   J7XL=.5D0*(ARGX-SHX+KX2*C*(SHX-.5D0*KX*SIN2Y/KY))/(KX3*KY2)
      J9XL=C*((CHX-1.0D0)/KX2+(1.0D0-COS2Y)/(4.0D0*KY2))
      GO TO 4
2     CX=1
      SX=AL
      DX=H*AL*AL/2.0D0
      J1XL=AL3/6.0D0
      J2XL=AL4/24.0D0
      J3XL=AL3/6.0D0
      J4XL=AL5/60.0D0
      J5XL=AL4/24.0D0
      J7XL=(AL3/12.0D0-AL/(8.0D0*KY2)-SIN2Y/(16.0D0*KY3))/KY2
      J10XL=-AL5/24.0D0
      J11XL=-AL5/60.0D0
      J12XL=AL3/6.0D0
      J9XL=AL2/(8.0D0*KY2)-(1.0D0-COS2Y)/(16.0D0*KY4)
      J13XL=AL6/240.0D0
      J14XL=AL6/1080.0D0
      J15XL=AL4/12.0D0
      J16XL=AL7/840.0D0
      J17XL=AL5/60.0D0
      J1L=AL3/3.0D0
      J2L=AL
      J3L=AL2/2.0D0
      GO TO 4
    3 CX=COS(KX*AL)
      SX=SIN(KX*AL)/KX
      DX=H*(1.0D0-CX)/KX2
      J1XL=(ARGX-SINX)/KX3
      J2XL=(1.0D0-COSX-.5D0*ARGX*SINX)/KX4
      J3XL=.5D0*(SINX-ARGX*COSX)/KX3
      J4XL=(.5D0*ARGX-2.0D0*SINX/3.0D0+SIN2X/12.0D0)/KX5
      J5XL=(.25D0-COSX/3.0D0+COS2X/12.0D0)/KX4
      J10XL=(ARGX-1.5D0*SINX+.5D0*ARGX*COSX)/KX5
      J11XL=(-2.0D0*ARGX+3.0D0*SINX-ARGX*COSX)/KX5
      J12XL=(4.0D0*ARGX-5.5D0*SINX+1.5D0*ARGX*COSX)/KX3
      J13XL=(.75D0-2.0D0*COSX/3.0D0-COS2X/12.0D0-.5D0*ARGX*SINX)
     <  /KX6
      J14XL=(1.5D0-4.0D0*COSX/3.0D0-COS2X/6.0D0-ARGX*SINX)/KX6
      J15XL=(-1.75D0+4.0D0*COSX/3.0D0+5.0D0*COS2X/12.0D0+1.5D0*ARGX
     <  *SINX)/KX4
      J16XL=(1.5D0*ARGX-7.0D0*SINX/3.0D0-SIN2X/12.0D0+ARGX*COSX)/
     <  KX7
      J17XL=(-1.75D0*ARGX+17.0D0*SINX/6.0D0+5.0D0*SIN2X/24.0D0-1.5D0
     <  *ARGX*COSX)/KX5
      J1L=(.5D0*ARGX-.25D0*SIN2X)/KX3
      J2L=(.5D0*ARGX+.25D0*SIN2X)/KX
      J3L=.25D0*(1.0D0-COS2X)/KX2
      IF(KY2) 234,244,245
234   J7XL=.5D0*(ARGX-SINX+KX2*C*(SINX-.5D0*KX*SH2Y/KY))/(KX3*KY2)
      J9XL=C*((COSX-1.0D0)/KX2+(1.0D0-CH2Y)/(4.0D0*KY2))
      GO TO 4
244   J7XL=(2.0D0*(SINX-ARGX)/KX3+AL3/3.0D0)/KX2
      J9XL=AL2/(2.0D0*KX2)+(COSX-1.0D0)/KX4
      GO TO 4
245   J7XL=.5D0*(ARGX-SINX+KX2*C*(SINX-.5D0*KX*SIN2Y/KY))/(KX3*KY2)
      J9XL=C*((COSX-1.0D0)/KX2+(1.0D0-COS2Y)/(4.0D0*KY2))
    4 CPX=-KX2*SX
      SPX=CX
      DPX=H*SX
      IF (KY2) 5,6,7
    5 CY=COSH(KY*AL)
      SY=SINH(KY*AL)/KY
      J4L=(.5D0*ARGY-.25D0*SH2Y)/KY3
      J5L=(.5D0*ARGY+.25D0*SH2Y)/KY
      J6L=.25D0*(1.0D0-CH2Y)/KY2
      GO TO 8
6     CY=1.0D0
      SY=AL
      J4L=AL3/3.0D0
      J5L=AL
      J6L=AL2/2.0D0
      GO TO 8
    7 CY=COS(KY*AL)
      SY=SIN(KY*AL)/KY
      J4L=(.5D0*ARGY-.25D0*SIN2Y)/KY3
      J5L=(.5D0*ARGY+.25D0*SIN2Y)/KY
      J6L=.25D0*(1.0D0-COS2Y)/KY2
    8 CPY=-KY2*SY
      SPY=CY
      SY2=SY*SY
      A=2.0D0*FIELDN-1.0D0-BETA
      B=(2.0D0-FIELDN)
      BN1=2.0D0*FIELDN-1.0D0-BETA
      BN2=2.5D0*FIELDN-BETA-1.5D0
      BN3=2.0D0*BETA-FIELDN
      I10=DX/H
      I11=0.5D0*AL*SX
      I111=1.0D0*(SX**2+DX*RAD)/3.0D0
      I112=SX*DX*RAD/3.0D0
      I133=DX/H-(KY2/(KX2-4.0D0*KY2))*(SY2-2.0D0*DX*RAD)
      I134=C*(SY*CY-SX)
      I144=(SY2-2.0D0*DX*RAD)*C
      I20=SX
      I21=(SX+AL*CX)/2.0D0
      I22=I11
      I211=SX*(1.0D0+2.0D0*CX)/3.0D0
      I212=(2.0D0*SX**2-DX/H)/3.0D0
      I222=2.0D0*SX*DX*RAD/3.0D0
      I233=SX-2.0D0*KY2*(SY*CY-SX)*C
      I234=(KX2*DX*RAD-2.0D0*KY2*SY2)*C
      I244=2.0D0*C*(SY*CY-SX)
      I33=0.5D0*AL*SY
      IF(KY2.EQ.0.0D0) GO TO 9
      I34=0.5*(SY-AL*CY)/KY2
      GO TO 10
    9 I34=AL3/6.0D0
   10 I313=C*(KX2*CY*DX*RAD-2.0D0*SX*SY*KY2)
      I314=(2.0D0*SX*CY-SY*(1.0D0+CX))*C
      I324=C*(2.0D0*CY*DX*RAD-SX*SY)
      I43=0.5D0*(SY+AL*CY)
      I44=I33
      I413=C*((KX2-2.0D0*KY2)*SX*CY-KY2*SY*(1.0D0+CX))
      I414=C*((KX2-2.0D0*KY2)*SX*SY-CY*(1.0D0-CX))
      I424=C*(CY*SX-CX*SY-2.0D0*KY2*SY*DX*RAD)
      IF (KX.EQ.0.0D0) GO TO 20
      I12=(SX-AL*CX)*0.5D0/KX2
      I27=(DX*RAD-.5*AL*SX)/KX2
      I116=(0.5D0*AL*SX-(SX**2+DX/H)/3.0D0)*H/KX2
      I122=(2.0D0*DX/H-SX**2)/3.0D0/KX2
      I126=H*(SX+2.0D0*SX*CX-3.0D0*AL*CX)/6.0D0/KX2**2
      I166=H2*(4.0D0*DX*RAD/3.0D0+SX**2/3.0D0-AL*SX)/KX2**2
      I216=H*(AL*CX/2.0D0+SX/6.0D0-2.0D0*SX*CX/3.0D0)/KX2
      I226=H*(0.5D0*AL*SX-2.0D0*SX**2/3.0D0+DX*RAD/3.0D0)/KX2
      I266=H2*(SX/3.0D0+2.0D0*SX*CX/3.0D0-AL*CX)/KX2**2
      I323=C*(2.0D0*KY2*SY*(1.0D0+CX)/KX2-SX*CY)+SY/KX2
      I336=H*(0.5D0*AL*SY-C*(CY*(1.0D0-CX)-2.0D0*KY2*SX*SY))/KX2
      I346=H*(I34-C*(2.0D0*SX*CY-SY*(1.0D0+CX)))/KX2
      I423=C*(2.0D0*KY2*CY*(1.0D0+CX)/KX2-CX*CY-KY2*SX*SY)+CY/KX2
      I436=H*(0.5D0*AL*CY+0.5D0*SY+C*(KY2*SY*(1.0D0+CX)
     >-(KX2-2.0D0*KY2)*SX*CY))/KX2
      I446=H*(AL*SY*0.5D0-C*((KX2-2.0D0*KY2)*SX*SY-CY*(1.0D0-CX)))/KX2
      GO TO 21
20    I12=AL3/6.0D0

      I27=AL4/12.0D0
      I116=H*AL4/24.0D0
      I122=AL4/12.0D0
      I126=H*AL5/40.0D0
      I166=H2*AL2/120.0D0
      I216=H*AL3/6.0D0
      I226=H*AL4/8.0D0
      I266=H2*AL5/20.0D0
      I323=AL2*SY/4.0D0
      I336=H*AL*(AL2*SY/12.0D0+(AL*CY-SY)/(KY2*8.0D0))
      I346=H*AL2*(SY/(KY2*8.0D0)-AL*CY/(KY2*12.0D0))
      I423=(AL2*CY+AL*SY)/4.0D0
      I436=H*AL2*(SY/8.0D0+CY*AL/12.0D0)
      I446=H*AL*(AL2*SY/12.0D0+(SY-AL*CY)/(KY2*8.0D0))
21    AMAT(N,1, 1)=CX
      I26=I12*H
      AMAT(N,1, 2)=SX
      AMAT(N,1, 3)=0.0D0
      AMAT(N,1, 4)=0.0D0
      AMAT(N,1, 6)=DX
      AMAT(N,1, 7)=A*H3*I111+0.5D0*KX2**2*I122*H
      AMAT(N,1, 8)=2.0D0*A*H3*I112-KX2*H*I112+H*SX
      AMAT(N,1, 9)=0.0D0
      AMAT(N,1,10)=0.0D0
      AMAT(N,1,12)=B*H2*I11+2.0D0*A*H3*I116-KX2*H2*I122
      AMAT(N,1,13)=A*H3*I122+0.5D0*H*I111
      AMAT(N,1,14)=0.0D0
      AMAT(N,1,15)=0.0D0
      AMAT(N,1,17)=B*H2*I12+2.0D0*A*H3*I126+H2*I112
      AMAT(N,1,18)=BETA*H3*I133-0.5D0*KY2*H*I10
      AMAT(N,1,19)=2.0D0*BETA*H3*I134
      AMAT(N,1,21)=0.0D0
      AMAT(N,1,22)=BETA*H3*I144-0.5D0*H*I10
      AMAT(N,1,24)=0.0D0
      AMAT(N,1,27)=B*H2*H*I27+A*H3*I166+0.5D0*H3*I122-
     1           H*I10
      AMAT(N,2, 1)=CPX
      AMAT(N,2, 2)=SPX
      AMAT(N,2, 3)=0.0D0
      AMAT(N,2, 4)=0.0D0
      AMAT(N,2, 6)=DPX
      AMAT(N,2, 7)=A*H3*I211+0.5D0*KX2**2*H*I222-H*CX*CPX
      AMAT(N,2, 8)=H*SPX+2.0D0*A*H3*I212-KX2*H*I212-H*(CX*SPX+CPX*SX)
      AMAT(N,2, 9)=0.0D0
      AMAT(N,2,10)=0.0D0
      AMAT(N,2,12)=B*H2*I21+2.0D0*A*H3*I216-KX2*H2*I222-H*
     >(CX*DPX+CPX*DX)
      AMAT(N,2,13)=A*H3*I222+0.5D0*H*I211-H*SX*SPX
      AMAT(N,2,14)=0.0D0
      AMAT(N,2,15)=0.0D0
      AMAT(N,2,17)=B*H2*I22+2.0D0*A*H3*I226+H2*I212-H*(SX*DPX+SPX*DX)
      AMAT(N,2,18)=BETA*H3*I233-0.5D0*KY2*H*I20
      AMAT(N,2,19)=2.0D0*BETA*H3*I234
      AMAT(N,2,21)=0.0D0
      AMAT(N,2,22)=BETA*H3*I244-0.5D0*H*I20
      AMAT(N,2,24)=0.0D0
      AMAT(N,2,27)=B*H2*I26+A*H3*I266+0.5D0*H3*I222-H*DX*DPX-H*I20
C
C     VALUE OF "B" IS CHANGED.
C
      B=BETA-FIELDN
      AMAT(N,3, 1)=0.0D0
      AMAT(N,3, 2)=0.0D0
      AMAT(N,3, 3)=CY
      AMAT(N,3, 4)=SY
      AMAT(N,3, 6)=0.0D0
      AMAT(N,3, 7)=0.0D0
      AMAT(N,3, 8)=0.0D0
      AMAT(N,3,9)=2.0D0*B*H3*I313+KX2*KY2*H*I324
      AMAT(N,3,10)=H*SY+2.0D0*B*H3*I314-KX2*H*I323
      AMAT(N,3,12)=0.0D0
      AMAT(N,3,13)=0.0D0
      AMAT(N,3,14)=2.0D0*B*H3*I323-KY2*H*I314
      AMAT(N,3,15)=2.0D0*B*H3*I324+H*I313
      AMAT(N,3,17)=0.0D0
      AMAT(N,3,18)=0.0D0
      AMAT(N,3,19)=0.0D0
      AMAT(N,3,21)=KY2*I33+2.0D0*B*H3*I336-KY2*H2*I324
      AMAT(N,3,22)=0.0D0
      AMAT(N,3,24)=KY2*I34+2.0D0*B*H3*I346+H2*I323
      AMAT(N,3,27)=0.0D0
      AMAT(N,4, 1)=0.0D0
      AMAT(N,4, 2)=0.0D0
      AMAT(N,4, 3)=CPY
      AMAT(N,4, 4)=SPY
      AMAT(N,4, 6)=0.0D0
      AMAT(N,4, 7)=0.0D0
      AMAT(N,4, 8)=0.0D0
      AMAT(N,4, 9)=2.0D0*B*H3*I413+KX2*KY2*H*I424-H*CX*CPY
      AMAT(N,4,10)=H*SPY+2.0D0*H3*B*I414-KX2*H*I423-H*CX*SPY
      AMAT(N,4,12)=0.0D0
      AMAT(N,4,13)=0.0D0
      AMAT(N,4,14)=2.0D0*B*H3*I423-KY2*H*I414-H*SX*CPY
      AMAT(N,4,15)=2.0D0*B*H3*I424+H*I413-H*SX*SPY
      AMAT(N,4,17)=0.0D0
      AMAT(N,4,18)=0.0D0
      AMAT(N,4,19)=0.0D0
      AMAT(N,4,21)=KY2*I43+2.0D0*B*H3*I436-KY2*H2*I424-H*DX*CPY
      AMAT(N,4,22)=0.0D0
      AMAT(N,4,24)=KY2*I44+2.0D0*B*H3*I446+H2*I423-H*DX*SPY
      AMAT(N,4,27)=0.0D0
      AMAT(N,5,1)=H*SX
      AMAT(N,5,2)=DX
      AMAT(N,5,6)=H2*J1XL
      AMAT(N,5,7)=H4*(BN1*J1XL-BN2*KX2*J4XL)+.5D0*KX4*J1L
      AMAT(N,5,8)=H4*2.0D0*BN2*J5XL-KX2*J3L+H*DX
      AMAT(N,5,12)=H5*J11XL+H3*J12XL+H*KX2*J3XL
     <   +H5*2.0D0*BN2*J4XL+2.0D0*BETA*H5*J10XL-H*KX2*J1L
      AMAT(N,5,13)=.5D0*(H2*J1XL+H4*2.0D0*BN2*J4XL+J2L)
      AMAT(N,5,17)=-2.0D0*BETA*H5*J13XL+H5*J14XL+H3*J15XL+H*KX2*
     <  J2XL+H*J3L
      AMAT(N,5,18)=.5D0*(H4*(BN3*J1XL-2.0D0*BETA*KY2*J7XL)+KY4*J4L)
      AMAT(N,5,19)=2.0D0*BETA*H4*J9XL-KY2*J6L
      AMAT(N,5,22)=BETA*H4*J7XL-.5D0*(H2*J1XL-J5L)
      AMAT(N,5,27)=(1.0D0-BETA)*H6*J16XL+H4*J17XL-H2*J3XL+.5D0*H2*J1L
      DO 100 J=1,27
      AMAT(N,6, J)=0.0D0
  100 CONTINUE
      AMAT(N,5,5) = 1.0D0
      AMAT(N,6, 6)=1.0D0
      RETURN
      END
C   *****************************
      SUBROUTINE MATGEN(ILK)
C   *****************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      N = ILK
      NGT=KODE(ILK)+1
C
C  ******* WARNING CODE 11 IS RESERVED INTERNALLY
C
      GO TO (100,101,102,103,104,105,106,107,108,109,110,111
     +,112,113,114,115,116),NGT
  111 GOTO 120
  116 GOTO 120
100   CALL DRIFT
      GOTO 120
101   CALL HBEND
      GO TO 120
102   CALL FLEN2
      GO TO 120
103   CALL HEXA2
      GO TO 120
104   CALL QUASEX
      GOTO 120
105   CALL MULTIM
      GOTO 120
106   CALL ROTQUA(ilk)
      GO TO 120
107   GO TO 120
108   CALL KICK
      GO TO 120
109   CALL TWISS
      GO TO 120
110   CALL GENRAL
      GO TO 120
115   CALL SOLQUA
      GOTO 120
112   GOTO 120
113   CALL VBEND
      GOTO 120
114   GOTO 120
  120 RETURN
      END
C   *****************************
      SUBROUTINE MATRIX
C   *****************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
	common /mat1/temp1(6,27),iflag1,nelstrt,nelend
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
	common /gplot/igplot,idev,ndispl
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/FOUT/OUTFL(300)
      COMMON/FUNC/BETAX,ALPHAX,ETAX,ETAPX,BETAY,ALPHAY,ETAY,ETAPY,
     <  STARTE,ENDE,DELTAE,DNU,MFPRNT,KOD,NLUM,NINT,NBUNCH
      COMMON/TWF/BETAOX,ALPHOX,ETAOX,ETAPOX,ANUX,
     >            BETAOY,ALPHOY,ETAOY,ETAPOY,ANUY,IE
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
      COMMON/LUM/ UO,TAUX,ALPHX,ALPHY,TAUY,
     <  ALPHE,TAUE,SIGE,SIGX,EPSX,
     <SIGY,EPSY,SIGXT,SIGYT,ENERGY,TAUREV
      COMMON/CBEAM/BSIG(6,6),BSIGF(6,6),MBPRT,nform
	common /bmax/bvarc,bharc,bvir,bhir,ir1,ir2,ir3,ir4
 	common /twiher/npnt,jfite(10),ipnt
caab see dimain for an explanation of miniinvoke etc      
	common/minia/detaddelta,betas(2000,2),
     1               ibeta_adr(2000),initbeta_count,miniinvoke

	iflag1=0	
      IFUN=0
      IFITF=0
      IBEAM=0
      IMAT=0
      NOF=27
      IF(NORDER.EQ.1)NOF=6
      NUX = 0
      NUXS = 0
      NUY = 0
      NUYS = 0
      IF(KOD.EQ.500)IMAT=1
      IF(KOD.EQ.510)IFUN=1
      IF(KOD.EQ.110)IFITF=1
      IF(KOD.EQ.515)IBEAM=1
c  set beta max to zero
	bvarc=0.0
	bharc=0.0
	bvir=0.0
	bhir=0.0
C
C   SET INTEGRALS INITIALLY TO ZERO
C
      IF(IFUN.EQ.0)GOTO 11
      AI1X=0.0D0
      AI2X=0.0D0
      AI3X=0.0D0
      AI4X=0.0D0
      AI5X=0.0D0
      AI1Y=0.0D0
      AI2Y=0.0D0
      AI3Y=0.0D0
      AI4Y=0.0D0
      AI5Y=0.0D0
C
C     SET TEMP TO IDENTITY
C
   11 DO 10 IX=1,6
      DO 10 IY=1,27
	temp1(ix,iy)=0.0d0
      TEMP(IX,IY)=0.0D0
	if(ix.eq.iy)temp1(ix,iy)=1.0d0
      IF(IX.EQ.IY) TEMP(IX,IY)=1.0D0
10    CONTINUE
C
C     PROCESS EACH MACHINE ELEMENT FOR MATRIX PRODUCT EXCEPT CODE 12
C
      ILIST = 1
      JLIST=1
      KLIST=2
      DO 1000 IE=1,NELM
      IF (NMAT.NE.1)GOTO 2000
      IF(IE.NE.NLIST(JLIST))GOTO 2000
      NEL1=NORLST(IE)
      IE1=IE
      JLIST=JLIST+2
      DO 2001 IX=1,6
      DO 2001 IY=1,27
	temp1(ix,iy)=0.0d0
      TEMP(IX,IY)=0.0D0
	if(ix.eq.iy)temp1(ix,iy)=1.0d0
      IF(IX.EQ.IY)TEMP(IX,IY)=1.0D0
 2001 CONTINUE
 2000 NEL=NORLST(IE)
      N=MADR(NEL)
      NT=KODE(NEL)
      KODEPR = KODE(NEL)
      IF(NT.EQ.12) GOTO 101
      CALL PROMAT
C
C
  101 IF(IFUN.EQ.1)GOTO 12
      IF(IFITF.EQ.1.AND.NT.EQ.2)GOTO12
	do 102 i=1,npnt
  102	if(ie.eq.jfite(i))goto 103
        ifite=0
	goto 104
  103	ifite=jfite(i)
	ipnt=i
  104 IF(IFITF.EQ.1.AND.(IE.EQ.IFITE.OR.IE.EQ.NELM))GOTO 12
      GOTO 840
   12 ANUX = ATAN2(TEMP(1,2),TEMP(1,1)*BETAX-TEMP(1,2)*ALPHAX)
      ANUX = ANUX/TWOPI
      IF (ANUX.LT.0.0) GO TO 810
      NUXS = 0
805   ANUX = ANUX+NUX
      GO TO 820
810   IF (NUXS.NE.0) GO TO 805
      NUX = NUX+1
      NUXS = 1
      GO TO 805
820   ANUY = ATAN2(TEMP(3,4),TEMP(3,3)*BETAY-TEMP(3,4)*ALPHAY)
      ANUY = ANUY/TWOPI
      IF (ANUY.LT.0.0) GO TO 830
      NUYS = 0
825   ANUY = ANUY+NUY
      GO TO 860
830   IF (NUYS.NE.0) GO TO 825
      NUY = NUY+1
      NUYS = 1
      GO TO 825
C
860   GAMMAX = (1.0D0+ALPHAX*ALPHAX)/BETAX
      GAMMAY = (1.0D0+ALPHAY*ALPHAY)/BETAY
      XM1112 = TEMP(1,1)*TEMP(1,2)
      XM2111 = TEMP(2,1)*TEMP(1,1)
      XM1221 = TEMP(1,2)*TEMP(2,1)
      XM1222 = TEMP(1,2)*TEMP(2,2)
      BETAOX = TEMP(1,1)*TEMP(1,1)*BETAX-2.0D0*XM1112*ALPHAX+
     <     TEMP(1,2)*TEMP(1,2)*GAMMAX
      ALPHOX = -XM2111*BETAX+(1.0D0+2.0D0*XM1221)*ALPHAX-
     <     XM1222*GAMMAX
      ETAOX = TEMP(1,1)*ETAX+TEMP(1,2)*ETAPX+TEMP(1,6)
     &	  +temp(1,3)*etay+temp(1,4)*etapy
      ETAPOX = TEMP(2,1)*ETAX+TEMP(2,2)*ETAPX+TEMP(2,6)
     &    +temp(2,3)*etay+temp(2,4)*etapy
      AMUX = ANUX*TWOPI
C
      YM1112 = TEMP(3,3)*TEMP(3,4)
      YM2111 = TEMP(4,3)*TEMP(3,3)
      YM1221 = TEMP(3,4)*TEMP(4,3)
      YM1222 = TEMP(3,4)*TEMP(4,4)
      BETAOY = TEMP(3,3)*TEMP(3,3)*BETAY-2.0D0*YM1112*ALPHAY+
     <     TEMP(3,4)*TEMP(3,4)*GAMMAY
      ALPHOY = -YM2111*BETAY+(1.0D0+2.0D0*YM1221)*ALPHAY-
     <     YM1222*GAMMAY
      ETAOY = TEMP(3,3)*ETAY+TEMP(3,4)*ETAPY+TEMP(3,6)
     &    +temp(3,1)*etax+temp(3,2)*etapx
      ETAPOY = TEMP(4,3)*ETAY+TEMP(4,4)*ETAPY+TEMP(4,6)
     &    +temp(4,1)*etax+temp(4,2)*etapx
      AMUY = ANUY*TWOPI
	HS=(ETAOX**2+(BETAOX*ETAPOX+ALPHOX*ETAOX)**2)/BETAOX
	xx=BETAOX
	yy=BETAOY
	if(igplot.eq.0)goto 5011
        if(ie.eq.0)zz=0.0
	if(ie.ne.0)zz=acleng(ie)
5011	if(ie.lt.ir1.or.(ie.gt.ir2.and.ie.lt.ir3).or.ie.gt.ir4)goto 5001
	bvarc=dmax1(bvarc,betaoy)
	bharc=dmax1(bharc,betaox)
	goto 5002
5001	bvir=dmax1(bvir,betaoy)
	bhir=dmax1(bhir,betaox)
5002  IF(NT.NE.2)GOTO 500
      IAD=IADR(NEL)
      AL=ELDAT(IAD)
      ST=ELDAT(IAD+1)
      ALST=AL*ST/(2.0D0*TWOPI)
  500 IF(IFITF.NE.1)GOTO 300
c      IF((IE.EQ.IFITE).OR.(IE.EQ.NELM))CALL BEAM
      IF(IE.EQ.IFITE)CALL SETOUT
  300 IF(IFUN.EQ.0)GOTO 840
      IF(NLUM.EQ.0)GOTO 840
C
C
C   IS THE NEXT ELEMENT A BEND
C
C
      NEXT=IE+1
      NEXTEL=NORLST(NEXT)
      IF(NEXT.GT.NELM) GO TO 840
      KODN=KODE(NEXTEL)
      IBEND=0
      IF(KODN.EQ.1)IBEND=1
      IF(KODN.EQ.13)IBEND=1
      IF(KODN.EQ.14)IBEND=1
      IF(IBEND.EQ.0)GOTO 840
C
C   GET THE PARAMETERS
C
      IAT=IADR(NEXTEL)
      ANG=ELDAT(IAT+1)*CRDEG
      AL=ELDAT(IAT)
      RAD=AL/ANG
      FIELDN=ELDAT(IAT+2)
      PHI1=ELDAT(IAT+4)*CRDEG
      PHI2=ELDAT(IAT+8)*CRDEG
      RAD2=RAD*RAD
      RAD3=RAD2*RAD
      AK2=(1.0D0-FIELDN)/RAD2
      AK=SQRT(ABS(AK2))
      ARG=AK*AL
      AL2=AL*AL
      ARG2=AK2*AL*AL
      ARG3=ARG2*ARG
      ARG4=ARG2*ARG2
      ARG5=ARG3*ARG2
      IF(AK2)1,2,3
1     C=COSH(ARG)
      S=SINH(ARG)
      GO TO 4
2     C=1.0D0
      S=0.0D0
      F1=1.0D0
      F2=.5D0
      F3=1.0D0/6.0D0
      F4=1.0D0/3.0D0
      F5=1.0D0/60.0D0
      GO TO 5
3     C=COS(ARG)
      S=SIN(ARG)
4     F1=S/ARG
      F2=(1.0D0-C)/ARG2
      F3=(ARG-S)/ARG3
      F4=(ARG-S*C)/ARG3
      F5=(3.0D0*ARG-4.0D0*S+S*C)/ARG5
C
C   FIND THE VALUES THAT CONTRIBUTE TO THE INTEGRALS
C
    5 IF(KODN.EQ.13)GOTO 870
      ETAP1=ETAPOX+ETAOX*TAN(PHI1)/RAD
      AVETA=ETAOX*F1+ETAP1*AL*F2+AL2*F3/RAD
      ETA2=ETAOX*C+ETAP1*S*AL/ARG+(AL2*(1.0D0-C))/(RAD*ARG2)
      AVEFOR=FIELDN*AVETA/RAD3+(ETAOX*TAN(PHI1)+ETA2*TAN(PHI2))/
     <  (2.0D0*AL*RAD2)
      ALPHA1=ALPHOX-BETAOX*TAN(PHI1)/RAD
      GAMMA=(1.0D0+ALPHOX*ALPHOX)/BETAOX
      T1=GAMMA*ETAOX*ETAOX
      T2=2.0D0*ALPHA1*ETAOX*ETAP1
      T3=BETAOX*ETAP1*ETAP1
      T4=-(GAMMA*ETAOX+ALPHA1*ETAP1)*F3*AL
      T5=(ALPHA1*ETAOX+BETAOX*ETAP1)*F2
      T45=2.0D0*AL*(T4+T5)/RAD
      T6=GAMMA*F5*AL2/2.0D0
      T7=ALPHOX*F2*F2*AL
      T8=BETAOX*F4/2.0D0
      T678=AL2*(T6-T7+T8)/RAD2
      HAV=T1+T2+T3+T45+T678
C
C   COMPUTE THE INTEGRALS
C
      AI1X=AI1X+AL*AVETA/RAD
      AI2X=AI2X+AL/RAD2
      AI3X=AI3X+AL/(ABS(RAD))**3
      AI4X=AI4X+(AL*AVETA/RAD3-2.0D0*AL*AVEFOR)
      AI5X=AI5X+AL*HAV/(ABS(RAD))**3
      GO TO 840
  870 ETAP1=ETAPOY+ETAOY*TAN(PHI1)/RAD
      AVETA=ETAOY*F1+ETAP1*AL*F2+AL2*F3/RAD
      ETA2=ETAOY*C+ETAP1*S*AL/ARG+(AL2*(1.0D0-C))/(RAD*ARG2)
      AVEFOR=FIELDN*AVETA/RAD3+(ETAOY*TAN(PHI1)+ETA2*TAN(PHI2))/
     <  (2.0D0*AL*RAD2)
      ALPHA1=ALPHOY-BETAOY*TAN(PHI1)/RAD
      GAMMA=(1.0D0+ALPHOY*ALPHOY)/BETAOY
      T1=GAMMA*ETAOY*ETAOY
      T2=2.0D0*ALPHA1*ETAOY*ETAP1
      T3=BETAOY*ETAP1*ETAP1
      T4=-(GAMMA*ETAOY+ALPHA1*ETAP1)*F3*AL
      T5=(ALPHA1*ETAOY+BETAOY*ETAP1)*F2
      T45=2.0D0*AL*(T4+T5)/RAD
      T6=GAMMA*F5*AL2/2.0D0
      T7=ALPHOY*F2*F2*AL
      T8=BETAOY*F4/2.0D0
      T678=AL2*(T6-T7+T8)/RAD2
      HAV=T1+T2+T3+T45+T678
C
C   COMPUTE THE INTEGRALS
C
      AI1Y=AI1Y+AL*AVETA/RAD
      AI2Y=AI2Y+AL/RAD2
      AI3Y=AI3Y+AL/(ABS(RAD))**3
      AI4Y=AI4Y+(AL*AVETA/RAD3-2.0D0*AL*AVEFOR)
      AI5Y=AI5Y+AL*HAV/(ABS(RAD))**3
      GO TO 840
C
C
caab i've changed the label 840 to the line i've added
caab it branches to 99999 only if both miniinvoke and ifun are 1
caab ie. only if initbetas is in operation
caab 99999 sits  harmlessly in the middle  somewhere and does nothing
caab unless initbeta has been called

840   if ((miniinvoke.eq.1).and.(ifun.eq.1)) goto 99999	
      IF(MPRINT.EQ.-2)GOTO 1000
      IF(MPRINT.EQ.-1.AND.IE.NE.NELM)GOTO 1000
      IF(MPRINT.EQ.0)GO TO 900
      IF (NMAT .NE. 1)GO TO 2100
      IF (IE.NE.NLIST(KLIST))GO TO 1000
      NEL2=NORLST(IE)
      IE2=IE
      KLIST=KLIST+2
      WRITE(IOUT,22222)(NAME(NEL1,IN),IN=1,4),IE1,
     <(NAME(NEL2,IN),IN=1,4),IE2
22222 FORMAT(///,'  BETWEEN  ',4A1, '  ELEMENT # ',I4,'  AND ',4A1,
     >'  ELEMENT # ',I4,/)

caab no output here if mini is in operation  
      if (miniinvoke.ne.1)CALL PRMAT(TEMP,NMAT,NORDER)

      GO TO 1000
 2100 IF(IE.EQ.NELM)GOTO 900
      CALL PRTTST(IE,ILIST,IPRT)
      IF(IPRT.NE.1) GOTO 1000
  900 IF(IMAT.EQ.0)GOTO 910
      WRITE(IOUT,8888)(NAME(NEL,IN),IN=1,4),IE
8888  FORMAT(////,'  AFTER :',4A1,' ELEMENT #:',I4,/)
      if (miniinvoke.ne.1)CALL PRMAT(TEMP,NMAT,NORDER)
      IF(IE.NE.NELM)GOTO 910
      CALL ANAL
caab no output here if mini is in operation  
      if (miniinvoke.ne.1)CALL PRANAL(NORDER)

c	call tunesplit

caab here assignment is done to the array betas if the element
caab represents a sextupole
caab betas(#,1) is beta-x,betas(#,2) is beta-y of the #'th sextupole
caab i_beta_adr(#) tells us where the strength of this sextupole is in eldat.
caab the order of sextupoles here in betas is different from d1!
caab so if you  use these, beware

99999 if ((ifun.eq.1).and.(miniinvoke.eq.1)) then
	if (name(norlst(ie),1).eq.'S') then
		initbeta_count=initbeta_count+1
		betas(initbeta_count,1)=betaox
		betas(initbeta_count,2)=betaoy
		ibeta_adr(initbeta_count)=iadr(norlst(ie))+1
	endif
      endif
			
910   IF((IFUN.EQ.0).OR.(MPRINT.EQ.-2))GOTO 950
      WRITE(IOUT,880)(NAME(NEL,IN),IN=1,4),IE,BETAOX,ALPHOX,BETAOY,
     <ALPHOY,ETAOX,ETAPOX,ETAOY,HS,ANUX,ANUY,ALENG(NEL),ACLENG(IE)
880   FORMAT(X,4A1,I5,X,F10.3,F10.4,F10.3,F10.4,6F10.5,F9.3,F11.3)
 950  IF(IBEAM.EQ.0)GOTO 1000
      WRITE(IOUT,9999)(NAME(NEL,IN),IN=1,4),IE,
     >((BSIGF(I,J),J=I,6),I=1,6)
 9999 FORMAT(//,' AFTER :',4A1,' ELEMENT #:',I4,' THE BEAM MATRIX IS :'
     >//,' ',6E12.4,/,' ',12X,5E12.4,/,' ',24X,4E12.4,/,' ',36X,
     >3E12.4,/,' ',48X,2E12.4,/,' ',60X,E12.4,/)
1000  CONTINUE
      IF(IFUN.EQ.0)RETURN
      IF(KOD.EQ.110)RETURN
      AI1=AI1X+AI1Y
      AI2=AI2X+AI2Y
      AI3=AI3X+AI3Y
      AI4=AI4X+AI4Y
       AI5=AI5X+AI5Y
C
C
      IF(miniinvoke.eq.1.or.NLUM.EQ.0)GOTO 5000
      WRITE(IOUT,1100)AI1X,AI2X,AI3X,AI4X,AI5X
 1100 FORMAT(/,'   SYNCHROTRON INTEGRALS ARE  ',//,
     >3X,'INTEGRAL X1=',E18.11,13X,'INTEGRAL X2=',E18.11,/,
     <       3X,'INTEGRAL X3=',E18.11,13X,'INTEGRAL X4=',E18.11,/,
     <       3X,'INTEGRAL X5=',E18.11,/)
      WRITE(IOUT,1101)AI1Y,AI2Y,AI3Y,AI4Y,AI5Y
1101  FORMAT(/,3X,'INTEGRAL Y1=',E18.11,13X,'INTEGRAL Y2=',E18.11,/,
     <       3X,'INTEGRAL Y3=',E18.11,13X,'INTEGRAL Y4=',E18.11,/,
     <       3X,'INTEGRAL Y5=',E18.11,/)
5000  COMPAC = AI1/TLENG
      IF(ABS(AI2).LT.1.0E-30)RETURN
      AJX = 1.0D0-(AI4X/AI2)
      AJY = 1.0D0-(AI4Y/AI2)
      AJE = 2.0D0+(AI4/AI2)
      TAUREV = NINT*TLENG/CLIGHT
      FREV = 1.0D0/TAUREV
      ENERGY = STARTE
C
C   OUTPUT THE RESULTS
C
      if(miniinvoke.eq.1)goto 5003
      WRITE(IOUT,10001)
10001 FORMAT(//,10X,' LUMINOSITY RESULTS FOR OPTIMUM AND '
     < 'MAXIMUM COUPLING ONLY ',//)
      TOTLEN=NINT*TLENG
      WRITE(IOUT,10002)TOTLEN,NINT,NBUNCH,DNU
10002 FORMAT(' TOTAL LENGTH = ',F11.3,' (M)   # INTERACTION PTS = '
     <,I3,/,' # BUNCHES = ',I3,10X,' DNU FOR OPTIMUM = ',F6.3)
      WRITE(IOUT,734)COMPAC,AJX,AJY,AJE,TAUREV,FREV
      IF(ISO.NE.0)WRITE(ISOUT,734)COMPAC,AJX,AJY,AJE,TAUREV,FREV
734   FORMAT(/,' MOMENTUM COMPACTION=',E15.7,3X,'JX=',F8.5,3X,
     < 'JY=',F8.5,3X,
     <  'JE=',F8.5,/,' TAUREV=',E15.7,'(SEC)',3X,'FREV=',E15.7,
     <  '(HZ)'/)
 5003 continue
733   ALPH = 7.039346E-06*ENERGY**3*FREV*NINT
      UO = 1.4078692E-02*ENERGY**4*AI2*NINT
      ALPHX = ALPH*(AI2-AI4X)
      TAUX = 1.0D0/ALPHX
      ALPHY = ALPH*(AI2-AI4Y)
      TAUY = 1.0D0/ALPHY
      ALPHE = ALPH*(2.0D0*AI2+AI4)
      TAUE = 1.0D0/ALPHE
      SIG = 1.211335E-03*ENERGY
      SIGE = SIG*SQRT(AI3/(2.0D0*AI2+AI4))
      EPSX = ABS(AI5X/(AI2-AI4X))*SIG**2
      SIGX = SQRT(EPSX*BETAX)
      EPSY = ABS(AI5Y/(AI2-AI4Y))*SIG**2
      SIGY = SQRT(EPSY*BETAY)
      SIGXT=SQRT(SIGX**2+(ETAX*SIGE)**2)
      SIGYT=SQRT(SIGY**2+(ETAY*SIGE)**2)
      if(miniinvoke.ne.1)then
         WRITE(IOUT,735)ENERGY,UO,ALPHX,ALPHY,ALPHE,
     <  TAUX,TAUY,TAUE,SIGE,EPSX,SIGX,
     <SIGXT,EPSY,SIGY,SIGYT
      IF(ISO.NE.0)WRITE(ISOUT,735)ENERGY,UO,ALPHX
     <,ALPHY,ALPHE,
     <  TAUX,TAUY,TAUE,SIGE,EPSX,SIGX,
     <SIGXT,EPSY,SIGY,SIGYT
735   FORMAT(//,20X,' ENERGY = ',F8.4,'(GEV)',//,' ENERGY LOSS =',
     < E13.5,'(MEV/REV)'
     < ,/,' AX=',E13.5,'(/SEC)'5X,'AY=',E13.5,'(/SEC)',5X,'AE=',
     <  E13.5,'(/SEC)',/,' TAUX=',E13.5,'(SEC)',4X,'TAUY=',E13.5,'(SEC)'
     <  4X,'TAUE=',E13.5,'(SEC)',/,' SIGE=',E13.5,/,
     <  ' EPSX=',E13.5,'(M-RAD)',2X,'SIGX=',E13.5,'(M.)',5X,
     <'SIGXT=',E13.5,'(M.)',/,
     <  ' EPSY=',E13.5,'(M-RAD)',2X,'SIGY=',E13.5,'(M.)',5X,
     <'SIGYT=',E13.5,'(M.)',/)
      endif
      IF(NLUM.EQ.2) CALL LUMIN
      ENERGY = ENERGY+DELTAE
      IF(ENERGY.LE.ENDE) GO TO 733
      RETURN
      END
C     *********************************************************
      SUBROUTINE MINSUB (X,E,N,F,ESCALE,IPRINT,ICON,MAXIT,FMIN)
C     *********************************************************
C
C###### 24/08/72 LAST LIBRARY UPDATE
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      DIMENSION W(460)
      DIMENSION X(1),E(1)
      EXTERNAL FMIN
      DDMAG=0.1*ESCALE
      SCER=0.05/ESCALE
      JJ=N*N+N
      JJJ=JJ+N
      K=N+1
      NFCC=1
      IND=1
      INN=1
      DO 40 I=1,N
      DO 30 J=1,N
      W(K)=0.
      IF (I-J) 20,10,20
   10 W(K)=ABS(E(I))
      W(I)=ESCALE
   20 K=K+1
   30 CONTINUE
   40 CONTINUE
      ITERC=1
      ISGRAD=2
      CALL FMIN(X,F)
      FKEEP=ABS(F)+ABS(F)
   50 ITONE=1
      FP=F
      SUM=0.
      IXP=JJ
      DO 60 I=1,N
      IXP=IXP+1
      W(IXP)=X(I)
   60 CONTINUE
      IDIRN=N+1
      ILINE=1
   70 DMAX=W(ILINE)
      DACC=DMAX*SCER
      DMAG=DMIN1(DDMAG,0.1*DMAX)
      DMAG=DMAX1(DMAG,20.*DACC)
      DDMAX=10.*DMAG
      GO TO (80,80,310),ITONE
   80 DL=0.
      D=DMAG
      FPREV=F
      IS=5
      FA=F
      DA=DL
   90 DD=D-DL
      DL=D
  100 K=IDIRN
      DO 110 I=1,N
      X(I)=X(I)+DD*W(K)
      K=K+1
  110 CONTINUE
      CALL FMIN(X,F)
C
      NFCC=NFCC+1
      GO TO (320,290,270,240,120,550),IS
  120 IF (F-FA) 160,130,170
  130 IF (ABS(D)-DMAX) 140,140,150
  140 D=D+D
      GO TO 90
  150 WRITE(IOUT,950)
      GO TO 920
  160 FB=F
      DB=D
      GO TO 180
  170 FB=FA
      DB=DA
      FA=F
      DA=D
  180 GO TO (200,190),ISGRAD
  190 D=DB+DB-DA
      IS=1
      GO TO 90
  200 D=0.5*(DA+DB-(FA-FB)/(DA-DB))
      IS=4
      IF ((DA-D)*(D-DB)) 210,90,90
  210 IS=1
      IF (ABS(D-DB)-DDMAX) 90,90,220
  220 D=DB+SIGN(DDMAX,DB-DA)
      IS=1
      DDMAX=DDMAX+DDMAX
      DDMAG=DDMAG+DDMAG
      IF (DDMAX-DMAX) 90,90,230
  230 DDMAX=DMAX
      GO TO 90
  240 IF (F-FA) 250,190,190
  250 FC=FB
      DC=DB
  260 FB=F
      DB=D
      GO TO 330
  270 IF (F-FB) 250,250,280
  280 FA=F
      DA=D
      GO TO 330
  290 IF (F-FB) 300,320,320
  300 FA=FB
      DA=DB
      GO TO 260
  310 DL=1.
      DDMAX=5.
      FA=FP
      DA=-1.
      FB=FHOLD
      DB=0.

      D=1.
  320 FC=F
      DC=D
  330 A=(DB-DC)*(FA-FC)
      B=(DC-DA)*(FB-FC)
      IF ((A+B)*(DA-DC)) 340,340,350
  340 FA=FB
      DA=DB
      FB=FC
      DB=DC
      GO TO 220
  350 D=0.5*(A*(DB+DC)+B*(DA+DC))/(A+B)
      DI=DB
      FI=FB
      IF (FB-FC) 370,370,360
  360 DI=DC
      FI=FC
  370 GO TO (390,390,380),ITONE
  380 ITONE=2
      GO TO 410
  390 IF (ABS(D-DI)-DACC) 450,450,400
  400 IF (ABS(D-DI)-0.03*ABS(D)) 450,450,410
  410 IF ((DA-DC)*(DC-D)) 430,420,420
  420 FA=FB
      DA=DB
      FB=FC
      DB=DC
      GO TO 210
  430 IS=2
      IF ((DB-D)*(D-DC)) 440,90,90
  440 IS=3
      GO TO 90
  450 F=FI
      D=DI-DL
      DD=SQRT((DC-DB)*(DC-DA)*(DA-DB)/(A+B))
      DO 460 I=1,N
      X(I)=X(I)+D*W(IDIRN)
      W(IDIRN)=DD*W(IDIRN)
      IDIRN=IDIRN+1
  460 CONTINUE
      W(ILINE)=W(ILINE)/DD
      ILINE=ILINE+1
      IF (IPRINT-1) 480,470,480
  470 WRITE(IOUT,960) ITERC,NFCC,F,(X(I),I=1,N)
      GO TO (480,710),IPRINT
  480 GO TO (490,690),ITONE
  490 IF (FPREV-F-SUM) 510,500,500
  500 SUM=FPREV-F
      JIL=ILINE
  510 IF (IDIRN-JJ) 70,70,520
  520 GO TO (530,700),IND
  530 FHOLD=F
      IS=6
      IXP=JJ
      DO 540 I=1,N
      IXP=IXP+1
      W(IXP)=X(I)-W(IXP)
  540 CONTINUE
      DD=1.
      GO TO 100
  550 GO TO (560,580),IND
  560 IF (FP-F) 660,660,570
  570 D=2.*(FP+F-2.*FHOLD)/(FP-F)**2
      IF (D*(FP-FHOLD-SUM)**2-SUM) 580,660,660
  580 J=JIL*N+1
      IF (J-JJ) 590,590,620
  590 DO 600 I=J,JJ
      K=I-N
      W(K)=W(I)
  600 CONTINUE
      DO 610 I=JIL,N
      W(I-1)=W(I)
  610 CONTINUE
  620 IDIRN=IDIRN-N
      ITONE=3
      K=IDIRN
      IXP=JJ
      AAA=0.
      DO 650 I=1,N
      IXP=IXP+1
      W(K)=W(IXP)
      IF (AAA-ABS(W(K)/E(I))) 630,640,640
  630 AAA=ABS(W(K)/E(I))
  640 K=K+1
  650 CONTINUE
      DDMAG=1.
      W(N)=ESCALE/AAA
      ILINE=N
      GO TO 70
  660 IXP=JJ
      AAA=0.
      F=FHOLD
      DO 680 I=1,N
      IXP=IXP+1
      X(I)=X(I)-W(IXP)
      IF (AAA*ABS(E(I))-ABS(W(IXP))) 670,680,680
  670 AAA=ABS(W(IXP)/E(I))
  680 CONTINUE
      GO TO 700
  690 AAA=AAA*(1.+DI)
      GO TO (700,910),IND
  700 IF (IPRINT-2) 710,470,470
  710 GO TO (720,790),IND
  720 IF (AAA-0.1) 730,730,770
  730 GO TO (920,740),ICON
  740 IND=2
      GO TO (750,850),INN
  750 INN=2
      K=JJJ
      DO 760 I=1,N
      K=K+1
      W(K)=X(I)
      X(I)=X(I)+10.*E(I)
  760 CONTINUE
      FKEEP=F
      CALL FMIN(X,F)
      NFCC=NFCC+1
      DDMAG=0.
      GO TO 810
  770 IF (F-FP) 800,780,780
  780 WRITE(IOUT,980)
      GO TO 920
  790 IND=1
  800 DDMAG=0.4*SQRT(FP-F)
      ISGRAD=1
  810 ITERC=ITERC+1
      IF (ITERC-MAXIT) 50,50,820
  820 WRITE(IOUT,990) MAXIT
      IF (F-FKEEP) 920,920,830
  830 F=FKEEP
      DO 840 I=1,N
      JJJ=JJJ+1
      X(I)=W(JJJ)
  840 CONTINUE
      GO TO 920
  850 JIL=1
      FP=FKEEP
      IF (F-FKEEP) 870,780,860
  860 JIL=2
      FP=F
      F=FKEEP
  870 IXP=JJ
      DO 900 I=1,N
      IXP=IXP+1
      K=IXP+N
      GO TO (880,890),JIL
  880 W(IXP)=W(K)
      GO TO 900
  890 W(IXP)=X(I)
      X(I)=W(K)
  900 CONTINUE
      JIL=2
      GO TO 530
  910 IF (AAA-0.1) 920,920,930
  920 RETURN
  930 INN=1
      GO TO 800
C
C                  COMING OUT
C
C
C
C
  950 FORMAT(5X,'  MINSUB MAXIMUM CHANGE DOES NOT ALTER FUNCTION')
  960 FORMAT (/1X,9HITERATION,I5,I15,16H FUNCTION VALUES,
     110X,3HF =,E21.14/(5E24.14))
  980 FORMAT(5X,' MINSUB ACCURACY LIMITED BY ERRORS IN F')
  990 FORMAT(I5,'  ITERATIONS COMPLETED BY MINSUB ')
      END
C     *****************
      SUBROUTINE MISCHK
C     *****************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
      COMMON/MIS/RMISA(7,50),MISELE(50),NMIS,ISEED,IXS,NOPT,
     > NMISE,MISSEL(50),NMRNGE(50),MSRNGE(2,10,50),MISFLG,MCHFLG
      COMMON/MISSET/DX,DXR,DY,DYR,DZ,DZR,DDEL,HLMNEL,I,IEP,MNEL
      MCHFLG=0
      DO 1 IEL=1,NMISE
      IF(MNEL.EQ.MISELE(MISSEL(IEL)))GOTO 2
    1 CONTINUE
      RETURN
    2 NMR=NMRNGE(IEL)
      HLMNEL=ALENG(MNEL)*0.5D0
      IF(NMR.EQ.0) GOTO 4
      IF(NMR.EQ.-1) RETURN
      DO 3 IMR=1,NMR
      IF((IEP.GE.MSRNGE(1,IMR,IEL)).AND.
     >(IEP.LE.MSRNGE(2,IMR,IEL)))GOTO4
    3 CONTINUE
      RETURN
    4 IGOTO=NOPT+1
      GOTO(100,101,102,103),IGOTO
      WRITE(IOUT,99999)
99999 FORMAT(/,'    ERROR IN OPTION NUMBER')
      STOP
  100 DX=RMISA(1,MISSEL(IEL))
      DXR=RMISA(2,MISSEL(IEL))
      DY=RMISA(3,MISSEL(IEL))
      DYR=RMISA(4,MISSEL(IEL))
      DZ=RMISA(5,MISSEL(IEL))
      DZR=RMISA(6,MISSEL(IEL))
      DDEL=RMISA(7,MISSEL(IEL))
      GOTO 10
  101 ISIGN=1
      UR=URAND(IXS)
      IF(UR.LT.0.5D0)ISIGN=-1
      DX=ISIGN*RMISA(1,MISSEL(IEL))
      UR=URAND(IXS)
      IF(UR.GE.0.5D0)ISIGN=1
      DXR=ISIGN*RMISA(2,MISSEL(IEL))
      UR=URAND(IXS)
      IF(UR.LT.0.5D0)ISIGN=-1
      DY=ISIGN*RMISA(3,MISSEL(IEL))
      UR=URAND(IXS)
      IF(UR.GE.0.5D0)ISIGN=1
      DYR=ISIGN*RMISA(4,MISSEL(IEL))
      UR=URAND(IXS)
      IF(UR.LT.0.5D0)ISIGN=-1
      DZ=ISIGN*RMISA(5,MISSEL(IEL))
      UR=URAND(IXS)
      IF(UR.GE.0.5D0)ISIGN=1
      DZR=ISIGN*RMISA(6,MISSEL(IEL))
      UR=URAND(IXS)
      IF(UR.LT.0.5D0)ISIGN=-1
      DDEL=ISIGN*RMISA(7,MISSEL(IEL))
      GOTO 10
  102 SQR3T2=SQRT(3.0D0)*2.0D0
      FACT=SQR3T2*(URAND(IXS)-0.5D0)
      DX=FACT*RMISA(1,MISSEL(IEL))
      FACT=SQR3T2*(URAND(IXS)-0.5D0)
      DXR=FACT*RMISA(2,MISSEL(IEL))
      FACT=SQR3T2*(URAND(IXS)-0.5D0)
      DY=FACT*RMISA(3,MISSEL(IEL))
      FACT=SQR3T2*(URAND(IXS)-0.5D0)
      DYR=FACT*RMISA(4,MISSEL(IEL))
      FACT=SQR3T2*(URAND(IXS)-0.5D0)
      DZ=FACT*RMISA(5,MISSEL(IEL))
      FACT=SQR3T2*(URAND(IXS)-0.5D0)
      DZR=FACT*RMISA(6,MISSEL(IEL))
      FACT=SQR3T2*(URAND(IXS)-0.5D0)
      DDEL=FACT*RMISA(7,MISSEL(IEL))
      GOTO 10
  103 FACT=GAUSS(IXS)
      IF (FACT.GT.2.0D0)GOTO 103
      DX=FACT*RMISA(1,MISSEL(IEL))
  113 FACT=GAUSS(IXS)
      IF (FACT.GT.2.0D0)GOTO 113
      DXR=FACT*RMISA(2,MISSEL(IEL))
  123 FACT=GAUSS(IXS)
      IF (FACT.GT.2.0D0)GOTO 123
      DY=FACT*RMISA(3,MISSEL(IEL))
  133 FACT=GAUSS(IXS)
      IF (FACT.GT.2.0D0)GOTO 133
      DYR=FACT*RMISA(4,MISSEL(IEL))
  143 FACT=GAUSS(IXS)
      IF (FACT.GT.2.0D0)GOTO 143
      DZ=FACT*RMISA(5,MISSEL(IEL))
  153 FACT=GAUSS(IXS)
      IF (FACT.GT.2.0D0)GOTO 153
      DZR=FACT*RMISA(6,MISSEL(IEL))
  163 FACT=GAUSS(IXS)
      IF (FACT.GT.2.0D0)GOTO 163
      DDEL=FACT*RMISA(7,MISSEL(IEL))
   10 CONTINUE
      MCHFLG=1
C     IF(DDEL.NE.0.0D0)WRITE(IOUT,99995)DX,DXR,DY,DYR,DZ,DZR,DDEL
99995 FORMAT(/,' IN MISCHK',7E12.4)
      RETURN
      END
C     ***********************
      SUBROUTINE MISDAT(IEND)
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/MIS/RMISA(7,50),MISELE(50),NMIS,ISEED,IXS,NOPT,
     > NMISE,MISSEL(50),NMRNGE(50),MSRNGE(2,10,50),MISFLG,MCHFLG
      DIMENSION ICHAR(4),DATA(7)
      DATA NINE/'9'/
      NPRINT=1
      IEND=0
      NMIS=0
    2 NCHAR=4
      NDATA=0
      NDIM=0
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
      IF((ICHAR(1).EQ.NINE).AND.(ICHAR(2).EQ.NINE))GOTO 99
      CALL ELID(ICHAR,NELID)
      NMIS=NMIS+1
      MISELE(NMIS)=NELID
      NCHAR=0
      NDIM=7
      NDATA=7
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
      DO 1 ID=1,NDATA
    1 RMISA(ID,NMIS)=DATA(ID)
      GOTO 2
   99 CONTINUE
      RETURN
      END
C     ***********************
      SUBROUTINE MONCHK(IE)
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/MONIT/VALMON(12,4,3),MNAME(600,4),MONPOS(600),NMON
      COMMON/MONFIT/VALFA(12),WGHTA(12),ERRA(12),
     >AMULTA(12,6),ADDA(12,6),DELA(12),NPARA(12,6),NELFA(12,6),
     >NPVARA(12),INDA(12,6),VALR(12),
     >NMONA(12),NVALA(12),NVARA,NCONDA,IALFLG,MONFLG,MONLST,NOPTER,
     >IAFRST,ISDBEG,IMONSD,IMSBEG
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      MONFLG=0
      DO 1 IM=1,NCONDA
      IF(IE.EQ.NMONA(IM))GOTO 2
    1 CONTINUE
      RETURN
    2 MONFLG=1
      IF(NMONA(IM).EQ.MONLST)MONFLG=2
C     WRITE(6,10)MONFLG,IM,NMONA(IM),MONLST
   10 FORMAT('  IN MONCHK',4I6)
      RETURN
      END
C     ***********************
      SUBROUTINE MONID(ICHAR,NID)
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/MONIT/VALMON(12,4,3),MNAME(600,4),MONPOS(600),NMON
      COMMON/MONFIT/VALFA(12),WGHTA(12),ERRA(12),
     >AMULTA(12,6),ADDA(12,6),DELA(12),NPARA(12,6),NELFA(12,6),
     >NPVARA(12),INDA(12,6),VALR(12),
     >NMONA(12),NVALA(12),NVARA,NCONDA,IALFLG,MONFLG,MONLST,NOPTER,
     >IAFRST,ISDBEG,IMONSD,IMSBEG
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      DIMENSION ICHAR(1)
      DO 1 IM=1,NMON
      IF(ICHAR(1).NE.MNAME(IM,1))GOTO 1
      IF(ICHAR(2).NE.MNAME(IM,2))GOTO 1
      IF(ICHAR(3).NE.MNAME(IM,3))GOTO 1
      IF(ICHAR(4).NE.MNAME(IM,4))GOTO 1
      NID=IM
      RETURN
    1 CONTINUE
      WRITE(IOUT,10000)
      IF (ISO.NE.0)WRITE(ISOUT,10000)
10000 FORMAT(/,' MONITOR NAME DID NOT MATCH MONITOR IN MACHINE LIST',/)
      CALL HALT
      STOP
      END
C     ***********************
      SUBROUTINE MOVMT
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
	common /alph/a,halpha(15),valpha(15),detyspot(15),detyspotmax,
     &         detxspotmax,scspotmax
      COMMON /MVT/ U(5,4)
      COMMON/CLSQ/ALSQ(15,2,4),IXY,NCOEF,NAPLT,JENER,LENER(15)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/TRI/WCO(15,6),GEN(5,4),PGEN(75,6),DIST,
     <A1(15),B1(15),A2(15),B2(15),XCOR(3,15),XPCOR(3,15),
     1AL1(15),AL2(15),MESH,NIT,NENER,NITX,NITS,NITM1,NANAL,NOPRT
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      LOGICAL  LENER
	data minipri/0/
      C1=(U(2,1)+U(3,2))/2.0D0
      if(minipri.ne.0)WRITE (IOUT,1) C1
    1 FORMAT('-','THE COS(MU) IS ', E20.10)
      IF(ABS(C1).GT.1.0D0) GO TO 4
      IF(C1.EQ.1.0D0) GO TO 8
      S=SQRT(1.0D0-C1*C1)
      S=SIGN(S,U(3,1))
      AM1=ATAN2(S,C1)
      IF(AM1.LT.0.0D0) AM1=TWOPI+AM1
      B=U(3,1)/S
      A=(U(3,2)-U(2,1))/(2.0D0*S)
      A=-A
      AN1=AM1/TWOPI
      if(minipri.ne.0)WRITE(IOUT,10) AM1,AN1
   10 FORMAT('-', 3X, 'MU = ', E17.10, 3X, 'NU = ',E17.10)
      if(minipri.ne.0)WRITE(IOUT,20) A,B
   20 FORMAT('-',3X, 'A = ', E17.10, 3X, 'B = ', E17.10)
      ALSQ(JENER,IXY,1)=AN1
      ALSQ(JENER,IXY,2)=B
      RETURN
    4 WRITE (IOUT,30)
   30 FORMAT('-', 3X, 'MOVEMENT IS UNSTABLE.')
	WRITE (6,30)
	WRITE (13,30)
	write(6,*)' movmt jener ixy ',jener,ixy
	if(1.lt.2)STOP
      RAL1=C1+SQRT(C1*C1-1.0D0)
      RAL2=C1-SQRT(C1*C1-1.0D0)
      A12=U(3,1)
      A11=U(2,1)
      VP1=A11-RAL1
      DENOM=SQRT(A12*A12+VP1*VP1)
      V1=-A12/DENOM
      VP1=VP1/DENOM
      VP2=A11-RAL2
      DENOM=SQRT(A12*A12+VP2*VP2)
      V2=-A12/DENOM
      VP2=VP2/DENOM
      WRITE(IOUT,10003)C1,RAL1,V1,VP1,RAL2,V2,VP2
10003 FORMAT(/,20X,'  HALF-TRACE =   ',E21.14,/,
     >3X,' EIGENVALUE1 =  ',E21.14,/,5X,'  WITH EIGENVECTOR : ',/,
     >10X,'  X =  ',E21.14,5X,'  XP =  ',E21.14,/,
     >3X,' EIGENVALUE2 =  ',E21.14,/,5X,'  WITH EIGENVECTOR : ',/,
     >10X,'  X =  ',E21.14,5X,'  XP =  ',E21.14,/)
      LENER(JENER)=.FALSE.
      IF(RAL2.GT.1.0D0)GO TO 100
      AL1(JENER)=RAL1
      AL2(JENER)=RAL2
      A1(JENER)=V1
      B1(JENER)=VP1
      A2(JENER)=V2
      B2(JENER)=VP2
      RETURN
  100 A1(JENER)=V2
      B1(JENER)=VP2
      A2(JENER)=V1
      B2(JENER)=VP1
      AL1(JENER)=RAL2
      AL2(JENER)=RAL1
      RETURN
    8 IF (U(3,1).NE.0.0D0) GO TO 4
      IF (U(2,2).NE.0.0D0) GO TO 4
      WRITE (IOUT,40)
   40 FORMAT('-', 3X, 'TRANSFER MATRIX IS THE IDENTITY.')
      RETURN
      END
C     *****************
      SUBROUTINE MRESET
C     *****************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/MISSET/DX,DXR,DY,DYR,DZ,DZR,DDEL,HLMNEL,I,IEP,MNEL
        COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN
     +  ,NPTOT,MLOCAT,NTURN
      COMMON/CORR/CORVAL(600,4),ICRID(600),ICRPOS(600),ICRSET(600),
     >ICROPT(600),NCORR,NCURCR,ICRFLG,ICRCHK,ALMNEL,NPARC
      X=PART(I,1)
      XP=PART(I,2)
      Y=PART(I,3)
      YP=PART(I,4)
      AL=PART(I,5)
      DELTA=PART(I,6)
      C=COS(-DZR)
      S=SIN(-DZR)
      XS=X*C+Y*S
      Y =-X*S+Y*C
      X=XS
      XPS=XP*C+YP*S
      YP=-XP*S+YP*C
      XP=XPS
      X=X-XP*DZ
      Y=Y-YP*DZ
      Y=Y-DY-DXR*HLMNEL
      YP=YP-DXR
      X=X-DX-DYR*HLMNEL
      XP=XP-DYR
      DELTA=DELTA-DDEL
      PART(I,1)=X
      PART(I,2)=XP
      PART(I,3)=Y
      PART(I,4)=YP
      PART(I,5)=AL
      PART(I,6)=DELTA
C     IF(DELTA.NE.0.0D0)WRITE(IOUT,99999)I,DX,DXR,DY,DYR,DZ,DZR,DDEL,
C    >DELTA
C99999 FORMAT(/,' IN MRESET',I4,8E12.4)
      RETURN
      END
C     ***************
      SUBROUTINE MSET
C     ***************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/MISSET/DX,DXR,DY,DYR,DZ,DZR,DDEL,HLMNEL,I,IEP,MNEL
        COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN
     +  ,NPTOT,MLOCAT,NTURN
      COMMON/CORR/CORVAL(600,4),ICRID(600),ICRPOS(600),ICRSET(600),
     >ICROPT(600),NCORR,NCURCR,ICRFLG,ICRCHK,ALMNEL,NPARC
      X=PART(I,1)
      XP=PART(I,2)
      Y=PART(I,3)
      YP=PART(I,4)
      AL=PART(I,5)
      DELTA=PART(I,6)
      X=X+DX-DYR*HLMNEL
      XP=XP+DYR
      Y=Y+DY-DXR*HLMNEL
      YP=YP+DXR
      DELTA=DELTA+DDEL
      X=X+XP*DZ
      Y=Y+YP*DZ
      C=COS(DZR)
      S=SIN(DZR)
      XS=X*C+Y*S
      Y =-X*S+Y*C
      X=XS
      XPS=XP*C+YP*S
      YP=-XP*S+YP*C
      XP=XPS
      PART(I,1)=X
      PART(I,2)=XP
      PART(I,3)=Y
      PART(I,4)=YP
      PART(I,5)=AL
      PART(I,6)=DELTA
      RETURN
      END
C     ***********************
      SUBROUTINE MULTIM
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      IAD=IADR(N)
      FACT1=1.0D06
      FACT2=1.0D-06
      NQ=0
      AKQ=0.0D0
      NS=0
      AKS=0.0D0
      SF=ELDAT(IAD)
      FACT1=FACT1*SF
      NP=ELDAT(IAD+1)
      DO 1 IM=1,NP
      NI=ELDAT(IAD+2+(IM-1)*3)
      IF(NI.EQ.2)GOTO 2
      IF(NI.EQ.3)GOTO 3
    1 CONTINUE
      GOTO 4
    2 NQ=1
      AKQ=ELDAT(IAD+3+(IM-1)*3)*FACT1
      GOTO 4
    3 NS=1
      AKS=ELDAT(IAD+3+(IM-1)*3)*FACT1
    4 CALL QSX(FACT2,AKQ,AKS)
      RETURN
      END
C     ***********************
      SUBROUTINE MULTIT(IAD)
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/MULT/SF,AN(20),BN(20),NP,N(20)
      SF=ELDAT(IAD)
      NP=ELDAT(IAD+1)
      DO 1 IM=1,NP
      N(IM)=ELDAT(IAD+2+(IM-1)*3)
      AN(IM)=ELDAT(IAD+3+(IM-1)*3)
    1 BN(IM)=ELDAT(IAD+4+(IM-1)*3)
      RETURN
      END
C     ***********************
      SUBROUTINE MULTTR(X1,X2,X3,X4,X5,X6)
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/MULT/SF,AN(20),BN(20),NP,N(20)
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      BMX=0.0D0
      BMY=0.0D0
      EFACT=1.0D0/(1.0D0+X6)
      R=SQRT(X1*X1+X3*X3)
      IF(R.LT.1.0D-20)RETURN
      PHI=ATAN2(X3,X1)
      DO 1 IM=1,NP
      NM1=N(IM)-1
      TEST=-50.0D0/NM1
      RNM1=0.0D0
      IF(R.GT.10**TEST)RNM1=R**NM1
      ARG=NM1*PHI
      SIN1=SIN(ARG)
      COS1=COS(ARG)
      ARG2=BN(IM)*CRDEG
      C=AN(IM)*COS(ARG2)
      D=AN(IM)*SIN(ARG2)
      BMX=BMX-RNM1*(C*SIN1+D*COS1)
    1 BMY=BMY+RNM1*(D*SIN1+C*COS1)
      BMX=BMX*SF
      BMY=BMY*SF
      X2=X2-BMY*EFACT
      X4=X4-BMX*EFACT
      RETURN
      END
C     **********************************************************
      SUBROUTINE PPLOT(A,B,NPART,XMAX,XMIN,YMAX,YMIN,NCCUM,NZERO,
     1 NCHAR,NCOL,NLINE,NTITLE,APLOT,LOGPAR)
C     **********************************************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      DIMENSION X(350),Y(350),NTITLE(7),A(1),B(1)
       LOGICAL APLOT(101,51),APRINT(42)
      LOGICAL LOGPAR(1)
      DATA APRINT/'1','2','3','4','5','6','7','8','9','A','B','C','D',
     1'E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T',
     2'U','V','W','X','Y','Z','+','.','-','*','!','=',' '/
       DO 340 I=1,NPART
      X(I)=A(I)
340    Y(I)=B(I)
      NCH=NCHAR
      DX = (XMAX-XMIN)/(NCOL - 1)
      DY = (YMAX - YMIN)/(NLINE - 1)
      IF(NZERO.NE.0)GO TO 1
      DO 2 J= 1,51
         DO 2 I=1,101
      APLOT(I,J) = APRINT(42)
    2 CONTINUE
      NORX = 1
      NORY = NLINE
      NF = NORX+NCOL-1
      DO 3 I = NORX,NF,5
      APLOT(I,NORY) = APRINT(40)
    3 APLOT(I,NORY-NLINE+1) = APRINT(40)
      NI = NORY-NLINE+1
      DO 4 J = NI,NORY,5
      APLOT(NORX,J) =APRINT(38)
    4 APLOT(NORX + NCOL -1,J) = APRINT(38)
      APLOT(NORX,NORY) = APRINT(36)
      APLOT(NORX,NORY - NLINE + 1) = APRINT(36)
      APLOT(NORX + NCOL - 1,NORY) = APRINT(36)
      APLOT(NORX + NCOL - 1,NORY - NLINE + 1) = APRINT(36)
    1 DO 5 I = 1,NPART

      IF(.NOT.LOGPAR(I)) GO TO 5
      IF ((X(I)-XMIN)*(X(I)-XMAX).GT.0) GO TO 5
      IX=((X(I)-XMIN)/DX) +0.5 + NORX
      IF ((Y(I)-YMIN)*(Y(I)-YMAX).GT.0) GO TO 5
      IY=NORY - (((Y(I) - YMIN)/DY) - 0.5)
      IF(NCHAR.EQ.0)NCH=(MOD(I-1,35)+1)
      APLOT(IX,IY) = APRINT(NCH)
    5 CONTINUE
      IF(NCCUM. EQ.0) GO TO 7
      WRITE(IOUT,1002) NTITLE
1002   FORMAT('-',40X,7A4,//)
      WRITE(IOUT,1003) YMAX,(APLOT(I,NORY-NLINE + 1) , I = NORX,NCOL)
 1003 FORMAT(' ',E10.3,'   ',111A1)
      NI = NORY-NLINE+2
      NF = NORY - 1
      DO 6 J = NI,NF
    6 WRITE(IOUT,1004) (APLOT(I,J) ,I = NORX,NCOL)
 1004 FORMAT('              ',111A1)
      WRITE(IOUT,1005) YMIN,(APLOT(I,NORY),I=NORX,NCOL)
 1005 FORMAT(' ',E10.3,'   ',111A1)
      NFO=NCOL/10
      GOTO(11,12,13,14,15,16,17,18,19,20),NFO
   11 WRITE(IOUT,20011)XMIN,XMAX
20011 FORMAT(10X,E10.3,5X,E10.3)
      GOTO 9
   12 WRITE(IOUT,20012)XMIN,XMAX
20012 FORMAT(10X,E10.3,10X,E10.3)
      GOTO 9
   13 WRITE(IOUT,20013)XMIN,XMAX
20013 FORMAT(10X,E10.3,20X,E10.3)
      GOTO 9
   14 WRITE(IOUT,20014)XMIN,XMAX
20014 FORMAT(10X,E10.3,30X,E10.3)
      GOTO 9
   15 WRITE(IOUT,20015)XMIN,XMAX
20015 FORMAT(10X,E10.3,40X,E10.3)
      GOTO 9
   16 WRITE(IOUT,20016)XMIN,XMAX
20016 FORMAT(10X,E10.3,50X,E10.3)
      GOTO 9
   17 WRITE(IOUT,20017)XMIN,XMAX
20017 FORMAT(10X,E10.3,60X,E10.3)
      GOTO 9
   18 WRITE(IOUT,20018)XMIN,XMAX
20018 FORMAT(10X,E10.3,70X,E10.3)
      GOTO 9
   19 WRITE(IOUT,20019)XMIN,XMAX
20019 FORMAT(10X,E10.3,80X,E10.3)
      GOTO 9
   20 WRITE(IOUT,20020)XMIN,XMAX
20020 FORMAT(10X,E10.3,90X,E10.3)
      GOTO 9
    9 WRITE(IOUT,1001)
 1001 FORMAT('1')
    7 RETURN
      END
C     ********************
      SUBROUTINE PLOTEN
C     ********************
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/PLT/
     1XMIN,XMAX,YMIN,YMAX,XPMIN,XPMAX,YPMIN,YPMAX,
     >DELMIN,DELMAX,DNUMIN,DNUMAX,DBMIN,DBMAX,
     2MXXPR,MYYPR,MXY,MALL,NPLOT,NCCUM,NGRAPH,NCOL,NLINE
      COMMON/CLSQ/ALSQ(15,2,4),IXY,NCOEF,NAPLT,JENER,LENER(15)
      COMMON/TRI/WCO(15,6),GEN(5,4),PGEN(75,6),DIST,
     <A1(15),B1(15),A2(15),B2(15),XCOR(3,15),XPCOR(3,15),
     1AL1(15),AL2(15),MESH,NIT,NENER,NITX,NITS,NITM1,NANAL,NOPRT
      DIMENSION A(15),B(15)
      LOGICAL APLOT(101,51),LENER
      LOGICAL MXXPR(101,51),MYYPR(101,51),MXY(101,51)
      DIMENSION NTITL1(7),NTITL2(7)
      DATA NTITL1/'    ','DNU ','PLOT',' VER','SUS ','ENER','GY  '/
      DATA NTITL2/'DBET','A/BE','TA  ',' VER','SUS ','ENER','GY  '/
      WRITE(IOUT,1001)
 1001 FORMAT('1')
      DO 1 K=1,2
      DO 2 IXY = 1,2
      DO 3 JENER = 1,NENER
      A(JENER) = WCO(JENER,6)
      B(JENER) = ALSQ(JENER,IXY,K) - ALSQ(1,IXY,K)
      IF(K.EQ.2)B(JENER)=B(JENER)/ALSQ(1,IXY,K)
    3 CONTINUE
      NCHAR=32+IXY
      IF(IXY.EQ.1.AND.K.EQ.1)CALL PPLOT(A,B,NENER,DELMAX,DELMIN,DNUMAX
     >,DNUMIN,0,0,NCHAR,NCOL,NLINE,NTITL1,APLOT,LENER)
      IF(IXY.EQ.1.AND.K.EQ.2)CALL PPLOT(A,B,NENER,DELMAX,DELMIN,DBMAX
     >,DBMIN,0,0,NCHAR,NCOL,NLINE,NTITL2,APLOT,LENER)
      IF(IXY.EQ.2.AND.K.EQ.1)CALL PPLOT(A,B,NENER,DELMAX,DELMIN,DNUMAX
     >,DNUMIN,1,1,NCHAR,NCOL,NLINE,NTITL1,APLOT,LENER)
      IF(IXY.EQ.2.AND.K.EQ.2)CALL PPLOT(A,B,NENER,DELMAX,DELMIN,DBMAX
     >,DBMIN,1,1,NCHAR,NCOL,NLINE,NTITL2,APLOT,LENER)
    2 CONTINUE
    1 CONTINUE
      RETURN
      END
C     ********************************************
      SUBROUTINE PLOTO(X,IORB,SIZE,IL,ICHAR,IPAGE)
C     ********************************************
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      DIMENSION IPLOT(120,11),X(1),IL(1)
      DATA IM/'-'/,IBL/' '/
      DO 1 IZ=1,120
      IPLOT(IZ,1)=IM
      IPLOT(IZ,11)=IM
      DO 1 JZ=2,10
    1 IPLOT(IZ,JZ)=IBL
      DO 2 IO=1,IORB
      IX=((X(IO)+SIZE)/(2.0D0*SIZE))*10.0D0+0.5D0
      IF(IX.LT.0)IX=0
      IF(IX.GT.10)IX=10
      IX=IX+1
      IPLOT(IO,IX)=ICHAR
    2 IPLOT(IO,6)=IL(IO)
      WRITE(IOUT,10001)SIZE,(IPLOT(JPL,11),JPL=1,IORB)
10001 FORMAT(/,E11.3,120A1)
      DO 3 IPL=2,10
      IRPL=12-IPL
    3 WRITE(IOUT,10002)(IPLOT(JPL,IRPL),JPL=1,IORB)
10002 FORMAT(11X,120A1)
      SIZEM=-SIZE
      WRITE(IOUT,10001)SIZEM,(IPLOT(JPL,1),JPL=1,IORB)
      IPAGE=IPAGE+1
      IF(IPAGE.NE.4)RETURN
      WRITE(IOUT,10000)
10000 FORMAT('1')
      IPAGE=0
      RETURN
      END
C*********************
      SUBROUTINE PLOTPR(IE,NZERO)
C*********************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN
     +  ,NPTOT,MLOCAT,NTURN
      COMMON/PLT/
     1XMIN,XMAX,YMIN,YMAX,XPMIN,XPMAX,YPMIN,YPMAX,
     >DELMIN,DELMAX,DNUMIN,DNUMAX,DBMIN,DBMAX,
     2MXXPR,MYYPR,MXY,MALL,NPLOT,NCCUM,NGRAPH,NCOL,NLINE
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      LOGICAL MXXPR(101,51),MYYPR(101,51),MXY(101,51),LOGPAR
      DIMENSION NTITL1(7),NTITL2(7),NTITL3(7)
      DATA NTITL1/'    ','HORI','ZONT','AL P','HASE',' SPA','CE  '/
      DATA NTITL2/'    ','VERT','ICAL',' PHA','SE S','PACE','    '/
      DATA NTITL3/'    ','PHYS','ICAL',' PHA','SE S','PACE','    '/
C
C
      NCHAR = 0
      NEL = NORLST(IE)
      IF(NCCUM.EQ.0.OR.NPRINT.EQ.0) GO TO 5
      WRITE(IOUT,1001)
 1001 FORMAT('1')
      WRITE(IOUT,19876)IE,(NAME(NEL,IZ),IZ=1,4),NCTURN
19876 FORMAT(' PLOTS OF PARTICLE POSITIONS AFTER ELEMENT',2X,
     *  I4,'(',4A1,')',2X,'DURING TURN',I6,/)
    5 IF(NGRAPH.NE.1.AND.MALL.EQ.1) GO TO 10
C
C   X-X PRIME PLOT
C
      CALL PPLOT(PART(1,1),PART(1,2),NPART,XMAX,XMIN,XPMAX,XPMIN,
     *      NCCUM,NZERO,NCHAR,NCOL,NLINE,NTITL1,MXXPR,LOGPAR)
      IF(MALL.EQ.0) GO TO 11
      RETURN
   10 IF(NGRAPH.NE.2) GO TO 20
C
C   Y-Y PRIME PLOT
C
   11 CALL PPLOT(PART(1,3),PART(1,4),NPART,YMAX,YMIN,YPMAX,YPMIN,
     *      NCCUM,NZERO,NCHAR,NCOL,NLINE,NTITL2,MYYPR,LOGPAR)
      IF(MALL.EQ.0) GO TO 21
      RETURN
   20 IF(NGRAPH.NE.3) GO TO 30
C
C   X-Y PLOT
C
   21 CALL PPLOT(PART(1,1),PART(1,3),NPART,XMAX,XMIN,YMAX,YMIN,
     *      NCCUM,NZERO,NCHAR,NCOL,NLINE,NTITL3,MXY,LOGPAR)
      RETURN
C
C   ERROR
C
   30 WRITE(IOUT,8431)NGRAPH
      IF(ISO.NE.0)WRITE(ISOUT,8431)NGRAPH
 8431 FORMAT(' ERROR NGRAPH VALUE',I6)
      CALL HALT
      STOP
      END
C     *******************************
      SUBROUTINE PLPORB(IE,NEL,NELM)
C     *******************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
      COMMON/ORBIT/SIZEX,SIZEY,RMSX,RMSY,RMSIX,RMSIY,
     >RTEMPX,RTEMPY,RMSPX(5),RMSPY(5),RPX,RPY,
     >RMAXX,RMAXY,RMINX,RMINY,MAXX,MAXY,MINX,MINY,PLENG,
     >IRNG,IRANGE(5),NPRORB,IORB,IREF,IPAGE,IPOINT
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN,
     <  NPTOT,MLOCAT,NTURN
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      DIMENSION X(120),Y(120),IPL(120)
      DATA IX/'X'/,IY/'Y'/,IK/'K'/
      CLENG=ALENG(NORLST(IE))
      XPAR=PART(1,1)
      YPAR=PART(1,3)
      IF(NAME(NEL,1).NE.IK)GOTO 10
      IAD=IADR(NEL)
      XPAR=XPAR-ELDAT(IAD)
      YPAR=YPAR-ELDAT(IAD+2)
   10 CONTINUE
      IF(XPAR.LE.RMAXX)GOTO 40
      RMAXX=XPAR
      MAXX=IE
   40 IF(XPAR.GE.RMINX)GOTO 50
      RMINX=XPAR
      MINX=IE
   50 IF(YPAR.LE.RMAXY)GOTO 60
      RMAXY=YPAR
      MAXY=IE
   60 IF(YPAR.GE.RMINY)GOTO 70
      RMINY=YPAR
      MINY=IE
   70 RMSX=RMSX+XPAR**2
      RMSY=RMSY+YPAR**2
      RMSIX=RMSIX+0.5D0*CLENG*(XPAR**2+RPX)
      RMSIY=RMSIY+0.5D0*CLENG*(YPAR**2+RPY)
      RPX=XPAR**2
      RPY=YPAR**2
      IF(IE.NE.IRANGE(IRNG))GOTO 30
      RMSPX(IRNG)=(RMSIX-RTEMPX)/(ACLENG(IE)-PLENG)
      RMSPY(IRNG)=(RMSIY-RTEMPY)/(ACLENG(IE)-PLENG)
      RTEMPX=RMSIX
      RTEMPY=RMSIY
      PLENG=ACLENG(IE)
      IRNG=IRNG+1
   30 IPOINT=IPOINT+1
      IF(NPRORB.EQ.2)GOTO 200
      WRITE(IOUT,1)IE,(NAME(NEL,IN),IN=1,4),XPAR,YPAR
    1 FORMAT(I6,X,4A1,3X,2E16.5)
      RETURN
 200  IORB=IORB+1
      IPL(IORB)=NAME(NEL,1)
      X(IORB)=XPAR
      Y(IORB)=YPAR
      IF((IORB.EQ.120).OR.(IE.EQ.NELM))GOTO 3
      RETURN
    3 CALL PLOTO(X,IORB,SIZEX,IPL,IX,IPAGE)
      CALL PLOTO(Y,IORB,SIZEY,IPL,IY,IPAGE)
      IORB=0
      RETURN
      END
C     **********************************
      SUBROUTINE POLLSQ(X,Y,NE,NC,B,REF)
C     **********************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      DIMENSION X(1),Y(1),B(1),A(36)
      DO 10 IC=1,NC
      B(IC)=0.0D0
      DO 10 JC=1,NC
   10 A((IC-1)*NC+JC)=0.0D0
      DO 1 IE=1,NE
      DO 2 IC=1,NC
      DO 3 JC=IC,NC
      IF(JC.NE.1)GOTO 4
      A((IC-1)*NC+JC)=A((IC-1)*NC+JC)+1.0D0
      GOTO 3
    4 A((IC-1)*NC+JC)=A((IC-1)*NC+JC)+(X(IE)/REF)**(IC+JC-2)
    3 A((JC-1)*NC+IC)=A((IC-1)*NC+JC)
      IF(IC.NE.1)GOTO 5
      B(IC)=B(IC)+Y(IE)
      GOTO 2
    5 B(IC)=B(IC)+Y(IE)*(X(IE)/REF)**(IC-1)
    2 CONTINUE
    1 CONTINUE
      CALL DSIMQ(A,B,NC,KS)
      RETURN
      END
C     *******************************
      SUBROUTINE POSCHK(NELID,IPOSCH)
C     *******************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      DO 1 IELP=1,NELM
      IF(NELID.EQ.NORLST(IELP))GOTO 2
    1 CONTINUE
      WRITE(IOUT,10000)
10000 FORMAT(/,'  THIS ELEMENT IS NOT IN THE MACHINE LIST ',/)
      CALL HALT
      STOP
    2 IPOSCH=IELP
      RETURN
      END
C     ***********************
      SUBROUTINE PRANAL (NORDER)
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/ANALC/COMPF,RNU0X,CETAX,CETAPX,CALPHX,CBETAX,
     1RMU1X,CHROMX,ALPH1X,BETA1X,
     1RMU0Y,RNU0Y,CETAY,CETAPY,CALPHY,CBETAY,
     1RMU1Y,CHROMY,ALPH1Y,BETA1Y,RMU0X,
     >COSX,ALX1,ALX2,VX1,VXP1,VX2,VXP2,
     >COSY,ALY1,ALY2,VY1,VYP1,VY2,VYP2,NSTABX,NSTABY,NSTAB,NWRNCP
      IF(NWRNCP.EQ.1)WRITE(IOUT,10005)
      IF((NWRNCP.EQ.1).AND.(ISO.NE.0))WRITE(ISOUT,10005)
      IF(NSTAB.EQ.1) GOTO 5
10005 FORMAT(/,'  **** WARNING : X-Y COUPLING NOT NEGLIGIBLE'
     > ' FOLLOWING ANALYSIS MAY BE MEANINGLESS ****',//)
      WRITE(IOUT,580)
      IF(ISO.NE.0)WRITE(ISOUT,580)
 580  FORMAT(//,'    HORIZONTAL MOVEMENT ANALYSIS',/)
      WRITE(IOUT,500)COMPF
      IF(ABS(ABS(COSX)-1.0D0).LT.1.0D-06)WRITE(IOUT,88881)
88881 FORMAT(/,' ******** WARNING : NEAR +-UNIT MATRIX FOLLOWING',
     >' ANALYSIS MAY BE MEANINGLESS!!!*******',/)
  500 FORMAT(/,'   COMPACTION FACTOR =',E14.7,/)
      IF(ISO.NE.0)WRITE(ISOUT,500)COMPF
      IF(NSTABX.GE.1) GO TO 1
      WRITE(IOUT,581)COSX,RNU0X,CETAX,CETAPX,CALPHX,CBETAX
      IF(ISO.NE.0)WRITE(ISOUT,581)COSX,RNU0X,CETAX,CETAPX,CALPHX
     <,CBETAX
      IF (NORDER.EQ.1) GO TO 3
      WRITE(IOUT,583) RMU1X,CHROMX,ALPH1X,BETA1X
      IF(ISO.NE.0)WRITE(ISOUT,583) RMU1X,CHROMX,ALPH1X,BETA1X
 581  FORMAT(3X,'COS(MU)=',E21.14,9X,'NU =',E21.14,/,
     >3X,'ETA =',E21.14,12X,'ETAP =',E21.14,/,
     1 3X,'ALPHA =',E21.14,10X,'BETA =',E21.14,/)
583   FORMAT
     1(3X,'DMU /DELTA=',E21.14,6X,'CHROMATICITY   =',E21.14,/,
     2 3X,'DALPHA /DDELTA=',E21.14,2X,'DBETA/DDELTA=',E21.14,/)
    3 WRITE(IOUT,582)
      IF(ISO.NE.0)WRITE(ISOUT,582)
 582  FORMAT(//,'    VERTICAL MOVEMENT ANALYSIS',/)
      IF(NSTABY.GE.1) GO TO 2
      IF(ABS(ABS(COSY)-1.0D0).LT.1.0D-06)WRITE(IOUT,88881)
      WRITE(IOUT,581)COSY,RNU0Y,CETAY,CETAPY,CALPHY,CBETAY
      IF(ISO.NE.0)WRITE(ISOUT,581)COSY,RNU0Y,CETAY,CETAPY,CALPHY
     <,CBETAY
      IF (NORDER.EQ.1) GO TO 4
      WRITE(IOUT,583) RMU1Y,CHROMY,ALPH1Y,BETA1Y
      IF(ISO.NE.0)WRITE(ISOUT,583) RMU1Y,CHROMY,ALPH1Y,BETA1Y
    4 RETURN
    1 WRITE(IOUT,10001)
      IF(ISO.NE.0)WRITE(ISOUT,10001)
10001 FORMAT('   MOVEMENT IS UNSTABLE  ')
      WRITE(IOUT,10003)COSX,ALX1,VX1,VXP1,ALX2,VX2,VXP2
10003 FORMAT(/,20X,'  HALF-TRACE =   ',E21.14,/,
     >3X,' EIGENVALUE1 =  ',E21.14,/,5X,'  WITH EIGENVECTOR : ',/,
     >10X,'  X =  ',E21.14,5X,'  XP =  ',E21.14,/,
     >3X,' EIGENVALUE2 =  ',E21.14,/,5X,'  WITH EIGENVECTOR : ',/,
     >10X,'  X =  ',E21.14,5X,'  XP =  ',E21.14,/)
      GOTO 3
    2 WRITE(IOUT,10001)
      IF(ISO.NE.0)WRITE(ISOUT,10001)
      WRITE(IOUT,10004)COSY,ALY1,VY1,VYP1,ALY2,VY2,VYP2
10004 FORMAT(/,20X,'  HALF-TRACE =   ',E21.14,/,
     >3X,' EIGENVALUE1 = ',E21.14,/,5X,'  WITH EIGENVECTOR : ',/,
     >10X,'  Y =  ',E21.14,5X,'  YP =  ',E21.14,/,
     >3X,' EIGENVALUE2 = ',E21.14,/,5X,'  WITH EIGENVECTOR : ',/,
     >10X,'  Y =  ',E21.14,5X,'  YP =  ',E21.14,/)
      GOTO 4
    5 WRITE(IOUT,10002)
      IF(ISO.NE.0)WRITE(ISOUT,10002)
10002 FORMAT(//,'    MOVEMENT ANALYSIS NOT PERFORMED  ',//)
      GOTO 4
      END
C     *********************
      SUBROUTINE PRMAT(TEMP,NMAT,NORDER)
C     *********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
	common /mat1/temp1(6,27),iflag1,nelstrt,nelend
      DIMENSION TEMP(6,27)
      DIMENSION AM(3),IND(3),INDEX(27)
      DATA INDEX/10,20,30,40,50,60,11,12,13,14,15,16,22,23,24,25,26,
     <33,34,35,36,44,45,46,55,56,66/
      IF(NMAT.EQ.1)GO TO 100
      WRITE(IOUT,598)
 598  FORMAT(///,30(1H ),
     *     30(1H*),/,30(1H ),30H*   TRANSFORMATION  MATRIX   * ,
     * /,30(1H ),30(1H*),/)
      WRITE(IOUT,543)
  543 FORMAT(/,'          FIRST ORDER MATRIX')
      WRITE(IOUT,597)((TEMP(I,J),J=1,6),I=1,6)
      WRITE(IOUT,597)((TEMP1(I,J),J=1,6),I=1,6)
  597 FORMAT(' ',6(/,'-',6(E15.7)))
      IF(NORDER.EQ.1)RETURN
      WRITE (IOUT,544)
  544 FORMAT(/,'               SECOND ORDER TERMS',/)
      DO 560 I=1,5
      WRITE(IOUT,590)(TEMP(I,J),J=7,12)
      WRITE(IOUT,590)(TEMP1(I,J),J=7,12)
  590 FORMAT('  ',6E15.7)
      WRITE(IOUT,591)(TEMP(I,J),J=13,17)
      WRITE(IOUT,591)(TEMP1(I,J),J=13,17)
  591 FORMAT(' ',16X,5E15.7)
      WRITE(IOUT,592)(TEMP(I,J),J=18,21)
      WRITE(IOUT,592)(TEMP1(I,J),J=18,21)
  592 FORMAT(' ',31X,4E15.7)
      WRITE(IOUT,593)(TEMP(I,J),J=22,24)
      WRITE(IOUT,593)(TEMP1(I,J),J=22,24)
  593 FORMAT(' ',46X,3E15.7)
      WRITE(IOUT,5930)(TEMP(I,J),J=25,26)
      WRITE(IOUT,5930)(TEMP1(I,J),J=25,26)
 5930 FORMAT(' ',61X,2E15.7)
      WRITE(IOUT,594)TEMP(I,27)
      WRITE(IOUT,594)TEMP1(I,27)
  594 FORMAT(' ',76X,E15.7)
560   CONTINUE
      RETURN
  100 DO 101 IM=1,6
      IPM = 0
      DO 102 JM=1,27
      IF(TEMP(IM,JM).EQ.0.0D0) GO TO 102
      IPM = IPM + 1
      AM(IPM) = TEMP(IM,JM)
      IND(IPM) = IM*100+INDEX(JM)
      IF (IPM.NE.3) GO TO 102
      WRITE(IOUT,10001)(IND(IW),AM(IW), IW=1,3)
10001 FORMAT(' ',3(I4,E18.10))
      IPM = 0
  102 CONTINUE
      IF(IPM.EQ.0) GO TO 101
      WRITE(IOUT,10001)(IND(IW),AM(IW), IW=1,IPM)
  101 CONTINUE
      RETURN
      END
C     *************************
      SUBROUTINE PROMAT
C     ************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
	dimension trans1(27,27)
      DIMENSION TRANS(27,27)
      DIMENSION INDEL(6,18),INDOR2(13,6,8),INDORD(13,6,18)
      DIMENSION INDOR1(13,6,10)
      EQUIVALENCE (INDOR1(1,1,1),INDORD(1,1,1))
      EQUIVALENCE(INDOR2(1,1,1),INDORD(1,1,11))
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
	common /mat1/temp1(6,27),iflag1,nelstrt,nelend
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/TWF/BETAOX,ALPHOX,ETAOX,ETAPOX,ANUX,
     >            BETAOY,ALPHOY,ETAOY,ETAPOY,ANUY,IE
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      DATA INDEL/2,1,2,1,3,1,
     <12,12,8,8,13,1,4,4,4,4,7,1,8,7,6,5,3,1,10,10,8,8,7,1,
     <6*0,6*0,4,2,4,2,1,1, 4,2,
     <4,2,1,1,2,2,2,2,1,1,6*0,3,7,2,6,1,1,
     <6*0,  8,8,12,12,13,1, 6*0, 8,8,8,8,11,1,6*0,6*0/
      DATA INDOR1/1,2,11*0, 2,12*0, 3,4,11*0, 4,12*0, 5,13,22,10*0,
     +  6,12*0, 1,2,6,7,8,12,13,17,18,19,22,27,0,
     <  1,2,6,7,8,12,13,17,18,19,22,27,0,
     <  3,4,9,10,14,15,21,24,5*0, 3,4,9,10,14,15,21,24,5*0,
     <  1,2,5,6,7,8,12,13,17,18,19,22,27, 6,12*0,
     <  1,2,12,17,9*0, 1,2,12,17,9*0, 3,4,21,24,9*0, 3,4,21,24,9*0,
     <  5,7,8,13,18,19,22,6*0, 6,12*0, 1,2,7,8,13,18,19,22,5*0,
     <  2,7,8,13,18,19,22,6*0, 3,4,9,10,14,15,7*0, 4,9,10,14,15,8*0,
     <5,13,22,10*0,6,12*0, 1,2,7,8,12,13,17,18,19,22,3*0,
     <1,2,7,8,12,13,17,18,19,22,3*0,3,4,9,10,14,15,21,24,5*0,
     <3,4,9,10,14,15,21,24,5*0,5,7,8,13,18,19,22,6*0,6,12*0,
     <78*0,78*0,1,2,3,4,9*0,2,4,11*0,1,2,3,4,9*0,
     <2,4,11*0, 5,12*0,6,12*0,
     <  1,2,3,4,9*0, 2,4,11*0,
     <  1,2,3,4,9*0, 2,4,11*0, 5,12*0, 6,12*0, 1,2,11*0, 1,2,11*0,
     <  3,4,11*0, 3,4,11*0, 5,12*0, 6,12*0/
       DATA INDOR2/78*0, 1,7,18,10*0,
     <  1,2,7,8,12,18,19,6*0, 3,9,11*0, 3,4,9,10,14,21,7*0,
     <  5,12*0, 6,12*0,78*0,
     <1,2,9,10,12,14,15,17,5*0,  1,2,9,10,12,14,15,17,5*0,
     <3,4,6,7,8,13,18,19,21,22,24,27,0,
     <3,4,6,7,8,13,18,19,21,22,24,27,0,
     <3,4,5,6,7,8,13,18,19,21,22,24,27, 6,12*0,
     <78*0,1,2,3,4,12,17,21,24,5*0,1,2,3,4,12,17,21,24,5*0,
     >1,2,3,4,12,17,21,24,5*0,1,2,3,4,12,17,21,24,5*0,
     >5,7,8,9,10,13,14,15,18,19,22,2*0,6,12*0,
     >78*0,78*0/
	data ifirst/0/
	if(ifirst.ne.0)goto 104
	type 103
103	format(' Start and end element for intermediate transfer matrix ',$)
	accept *,nelstrt,nelend
	ifirst=1
 104	continue
 	if(ie.eq.nelstrt)iflag1=1
	if(ie.eq.nelend)iflag1=2
      IIND = KODEPR
      IF(NORDER.EQ.2)NOF=27
  541 DO 507 I=1,6
      DO 507 J=1,NOF
	if(iflag1.eq.1)trans1(i,j)=temp1(i,j)
 507  TRANS(I,J)=TEMP(I,J)
      IF (NORDER.EQ.1) GO TO 520
C   FIND TRANS--THE 27X27 MATRIX FOR MACHINE TO PRESENT ELEMENT
      DO 508 I=1,5
      DO 508 K=I, 6
      COEF=7*I-I*(I+1)/2+K
      DO 508 J=1, 6
	if(iflag1.eq.1)trans1(coef,j)=0
      TRANS(COEF,J)=0
      DO 508 L1=J, 6
	if(iflag1.eq.1)tranc1=trans1(i,j)*trans1(k,l1)
      TRANC=TRANS(I,J)*TRANS(K,L1)
	if(j.ne.l1.and.iflag1.eq.1)tranc1=tranc1+trans1(i,l1)*trans1(k,j)
      IF (J.NE.L1) TRANC=TRANC+TRANS(I,L1)*TRANS(K,J)
	if(iflag1.eq.1)trans1(coef,7*j-j*(j+1)/2+l1)=tranc1
      TRANS(COEF,7*J-J*(J+1)/2+L1) = TRANC
 508  CONTINUE
      DO 510 I=1, NOF
	if(iflag1.eq.1)trans1(27,i)=0
 510  TRANS(27,I)=0
	if(iflag1.eq.1)trans1(27,27)=1
      TRANS(27,27)=1
520   IF(IIND.EQ.10) GO TO 550
      IF(IIND.EQ.5)GOTO 600
      IIND = IIND+1
C
C     PROCESS ALL CODES EXCEPT 10 AND 5
C
      DO 512 IM=1,6
      DO 512 I=1,NOF
	if(iflag1.eq.1)temp1(im,i)=0.0d0
      TEMP(IM,I) = 0.0D0
      JMF = INDEL(IM,IIND)
      IF(IIND.EQ.7)JMF=27
      DO 513 JM=1,JMF
      IJM = INDORD(JM,IM,IIND)
      IF(IIND.EQ.7)IJM=JM
      IF(NORDER.EQ.1.AND.IJM.GT.6) GO TO 512
      IF(IM.LT.1.OR.I.LT.1.OR.N.LT.1.OR.IJM.LT.1) GO TO 9876
      IF(IM.LE.6.AND.I.LE.27.AND.N.LE.350.AND.IJM.LE.27) GO TO 8765
9876  WRITE(IOUT,567)IIND,INDEL(IM,IIND),JMF,INDORD(JM,IM,IIND),
     <  IJM,IM,I,N
567   FORMAT(/,' IIND  INDEL  JMF  INDORD  IJM    IM   I     N   ',/
     <  ' ',I5,2X,I5,1X,I5,2X,I5,4(1X,I5))
      CALL HALT
      STOP
8765  TEMP(IM,I) = TEMP(IM,I)+AMAT(N,IM,IJM)*TRANS(IJM,I)
	if(iflag1.eq.1)
     &	  temp1(im,i)=temp1(im,i)+amat(n,im,ijm)*trans1(ijm,i)
513   CONTINUE
512   CONTINUE
      GO TO 590
C
C  PROCESS CODE 5
C
  600 DO 601 IM=1,6
      DO 601 JM=1,NOF
	if(iflag1.eq.1)temp1(im,jm)=0.0d0
      TEMP(IM,JM)=0.0D0
      DO 602 KM=1,NOF
	if(iflag1.eq.1)
     &	  temp1(im,jm)=temp1(im,jm)+amat(n,im,km)*trans1(km,jm)
  602 TEMP(IM,JM)=TEMP(IM,JM)+AMAT(N,IM,KM)*TRANS(KM,JM)
  601 CONTINUE
      GOTO 590
C
C     PROCESS CODE 10 : GENERAL MATRIX
C
  550 DO 560 IM=1,6
      DO 560 I=1,NOF
      TEMP(IM,I)=0.0D0
	if(iflag1.eq.1)temp1(im,i)=0.0d0
      DO 561 JM=1,NOF
      AMIJ=AMAT(N,IM,JM)
      IF(AMIJ.EQ.0.0D0)GOTO 561
	if(iflag1.eq.1)
     &	  temp1(im,i)=temp1(im,i)+amij*trans1(jm,i)
      TEMP(IM,I)=TEMP(IM,I)+AMIJ*TRANS(JM,I)
561   CONTINUE
560   CONTINUE
590   RETURN
      END
C     *************************
      SUBROUTINE PRTTST(IELEM,ILIST,IPRT)
C     *************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN,
     <  NPTOT,MLOCAT,NTURN
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      IPRT=0
      IF((MLOCAT.EQ.0).AND.(IELEM.EQ.NELM))IPRT=1
      IF(ILIST.GT.2*MLOCAT)GOTO 1
      LIMLO=NLIST(ILIST)
      LIMUP=NLIST(ILIST+1)
C     WRITE(6,99999)IELEM,ILIST,LIMLO,LIMUP,MLOCAT
99999 FORMAT(' PRTTST ',5I6)
      IF(IELEM.GE.LIMLO.AND.IELEM.LE.LIMUP)IPRT=1
      IF(IELEM.NE.LIMUP)GOTO 1
      ILIST=ILIST+2
    1 IF((NCTURN.EQ.NTURN).AND.(IELEM.EQ.NELM))IPRT=0
      RETURN
      END
C     ***********************
      SUBROUTINE QUASEX
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INPUTT/KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      IAD=IADR(N)
      AL =ELDAT(IAD)
      AKQ2=ELDAT(IAD+1)
      AKS2=ELDAT(IAD+2)
      CALL QSX(AL,AKQ2,AKS2)
      RETURN
      END
C     ****************************
      SUBROUTINE QSX(AL,AKQ2,AKS2)
C     ****************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/PRODCT/KODEPR,NEL,NOF
      DO 100 I=1,6
      DO 100 J=1,NOF
      AMAT(N,I,J)=0.0D0
      IF(I.EQ.J) AMAT(N,I,J)=1.0D0
  100 CONTINUE
      AKQ=SQRT(ABS(AKQ2))
      ARG=AKQ*AL
      CSIN=SIN(ARG)
      CCOS=COS(ARG)
      HSIN=SINH(ARG)
      HCOS=COSH(ARG)
      IF(AKQ2.NE.0.0D0)GOTO 1
      AMAT(N,1,2)=AL
      AMAT(N,3,4)=AL
      IF(NORDER.EQ.1)RETURN
      AMAT(N,5,13)=AL/2.0D0
      AMAT(N,5,22)=AL/2.0D0
      IF(AKS2.EQ.0.0D0)RETURN
      AKL1=AKS2*AL
      AKL2=AKL1*AL
      AKL3=AKL2*AL
      AKL4=AKL3*AL
      AMAT(N,1, 7)=-AKL2/2.0D0
      AMAT(N,1, 8)=-AKL3/3.0D0
      AMAT(N,1,13)=-AKL4/12.0D0
      AMAT(N,1,18)= AKL2/2.0D0
      AMAT(N,1,19)= AKL3/3.0D0
      AMAT(N,1,22)= AKL4/12.0D0
      AMAT(N,2, 7)=-AKL1
      AMAT(N,2, 8)=-AKL2
      AMAT(N,2,13)=-AKL3/3.0D0
      AMAT(N,2,18)= AKL1
      AMAT(N,2,19)= AKL2
      AMAT(N,2,22)= AKL3/3.0D0
      AMAT(N,3, 9)= AKL2
      AMAT(N,3, 10)= AKL3/3.0D0
      AMAT(N,3,14)= AKL3/3.0D0
      AMAT(N,3,15)= AKL4/6.0D0
      AMAT(N,4, 9)= AKL1*2.0D0
      AMAT(N,4, 10)= AKL2
      AMAT(N,4,14)= AKL2
      AMAT(N,4,15)= AKL3*2.0D0/3.0D0
      RETURN
    1 IF(AKQ2.LT.0.0D0)GOTO 2
      SSOK=CSIN/AKQ
      SC=CCOS

      BSOK=HSIN/AKQ
      BC=HCOS
      GOTO 3
    2 SSOK=HSIN/AKQ
      SC=HCOS
      BSOK=CSIN/AKQ
      BC=CCOS
    3 AMAT(N,1,1)=SC
      AMAT(N,1,2)=SSOK
      AMAT(N,2,1)=-AKQ2*SSOK
      AMAT(N,2,2)=SC
      AMAT(N,3,3)=BC
      AMAT(N,3,4)=BSOK
      AMAT(N,4,3)=AKQ2*BSOK
      AMAT(N,4,4)=BC
      IF(NORDER.EQ.1) RETURN
      AMAT(N,1,7)=-AKS2*(SSOK*SSOK+(1.0D0-SC)/AKQ2)/3.0D0
      AMAT(N,1,8)=-2.0D0*AKS2*(SSOK*(1.0D0-SC)/AKQ2)/3.0D0
      AMAT(N,1,12)=AL*AKQ2*SSOK/2.0D0
      AMAT(N,1,13)=-AKS2*(2.0D0*(1.0D0-SC)/AKQ2-SSOK*SSOK)/(3.0D0*AKQ2)
      AMAT(N,1,17)=(SSOK-AL*SC)/2.0D0
      AMAT(N,1,18)=AKS2*(BSOK*BSOK+3.0D0*(1.0D0-SC)/AKQ2)/5.0D0
      AMAT(N,1,19)=2.0D0*AKS2*(BSOK*BC-SSOK)/(5.0D0*AKQ2)
      AMAT(N,1,22)=AKS2*(BSOK*BSOK-2.0D0*(1.0D0-SC)/AKQ2)/(5.0D0*AKQ2)
      AMAT(N,2,7)=-AKS2*(2.0D0*SSOK*SC+SSOK)/3.0D0
      AMAT(N,2,8)=-2.0D0*AKS2*(SC*(1.0D0-SC)/AKQ2+SSOK*SSOK)/3.0D0
      AMAT(N,2,12)=AKQ2*(SSOK+AL*SC)/2.0D0
      AMAT(N,2,13)=-AKS2*(2.0D0*SSOK-2.0D0*SSOK*SC)/(3.0D0*AKQ2)
      AMAT(N,2,17)=AMAT(N,1,12)
      AMAT(N,2,18)=AKS2*(2.0D0*BSOK*BC+3.0D0*SSOK)/5.0D0
      AMAT(N,2,19)=2.0D0*AKS2*(BC*BC+BSOK*BSOK*AKQ2-SC)/(5.0D0*AKQ2)
      AMAT(N,2,22)=2.0D0*AKS2*(BSOK*BC-SSOK)/(5.0D0*AKQ2)
      AMAT(N,3,9)=2.0D0*AKS2*(BC*(1.0D0-SC)/AKQ2+
     >                2.0D0*SSOK*BSOK)/5.0D0
      AMAT(N,3,10)=2.0D0*AKS2*(2.0D0*SSOK*BC-BSOK*(1.0D0+SC))
     >  /(5.0D0*AKQ2)
      AMAT(N,3,14)=2.0D0*AKS2*(3.0D0*BSOK-2.0D0*BSOK*SC-
     >    SSOK*BC)/(5.0D0*AKQ2)
      AMAT(N,3,15)=2.0D0*AKS2*(2.0D0*BC*(1.0D0-SC)/AKQ2-
     >     SSOK*BSOK)/(5.0D0*AKQ2)
      AMAT(N,3,21)=-AL*AKQ2*BSOK/2.0D0
      AMAT(N,3,24)=(BSOK-AL*BC)/2.0D0
      AMAT(N,4,9)=2.0D0*AKS2*(BSOK*(1.0D0-SC)+BC*SSOK+
     >  2.0D0*SC*BSOK+2.0D0*SSOK*BC)/5.0D0
      AMAT(N,4,10)=2.0D0*AKS2*(2.0D0*SC*BC+2.0D0*SSOK*BSOK*AKQ2-
     >   BC*(1.0D0+SC)+BSOK*SSOK*AKQ2)/(5.0D0*AKQ2)
      AMAT(N,4,14)=2.0D0*AKS2*(3.0D0*BC-2.0D0*BC*SC
     > +2.0D0*BSOK*SSOK*AKQ2-SC*BC-SSOK*BSOK*AKQ2)/(5.0D0*AKQ2)
      AMAT(N,4,15)=2.0D0*AKS2*(2.0D0*BSOK*(1.0D0-SC)+
     >  2.0D0*BC*SSOK-SC*BSOK-SSOK*BC)/(5.00*AKQ2)
      AMAT(N,4,21)=-AKQ2*(BSOK+AL*BC)/2.0D0
      AMAT(N,4,24)=AMAT(N,3,21)
      AMAT(N,5,7)=AKQ2*(AL-SC*SSOK)/4.0D0
      AMAT(N,5,8)=-AKQ2*SSOK*SSOK/2.0D0
      AMAT(N,5,13)=(AL+SC*SSOK)/4.0D0
      AMAT(N,5,18)=-AKQ2*(AL-BC*BSOK)/4.0D0
      AMAT(N,5,19)=AKQ2*(BSOK*BSOK)/2.0D0
      AMAT(N,5,22)=(AL+BC*BSOK)/4.0D0
      RETURN
      END
C     *************************
      SUBROUTINE REFORB(IEND)
C     ******************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
      COMMON/ORBIT/SIZEX,SIZEY,RMSX,RMSY,RMSIX,RMSIY,
     >RTEMPX,RTEMPY,RMSPX(5),RMSPY(5),RPX,RPY,
     >RMAXX,RMAXY,RMINX,RMINY,MAXX,MAXY,MINX,MINY,PLENG,
     >IRNG,IRANGE(5),NPRORB,IORB,IREF,IPAGE,IPOINT
      COMMON/DETL/DENER(15),NH,NV,NVH,NHVP(105),MDPRT,NDENER,
     1NUXS(45),NUX(45),NUYS(45),NUY(45),NCO,NHNVHV,MULPRT,NSIG
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN,
     <  NPTOT,MLOCAT,NTURN
      COMMON/PLT/
     1XMIN,XMAX,YMIN,YMAX,XPMIN,XPMAX,YPMIN,YPMAX,
     >DELMIN,DELMAX,DNUMIN,DNUMAX,DBMIN,DBMAX,
     2MXXPR,MYYPR,MXY,MALL,NPLOT,NCCUM,NGRAPH,NCOL,NLINE
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      LOGICAL MXXPR(101,51),MYYPR(101,51),MXY(101,51)
      DIMENSION OPLIST(10)
      LOGICAL LOGPAR
      DO 500 ILO=1,NPTOT
  500 LOGPAR(ILO)=.TRUE.
      NINP=1
      DO 10 IR=1,5
      RMSPX(IR)=0.0D0
      RMSPY(IR)=0.0D0
   10 IRANGE(IR)=0
      RMAXX=0.0D0
      RMINX=0.0D0
      RMAXY=0.0D0
      RMINY=0.0D0
      NDATA=10
      NDIM=10
      NCHAR=0
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NINP)
      NPRORB=OPLIST(1)
      SIZEX=OPLIST(2)
      SIZEY=OPLIST(3)
      PART(1,1)=OPLIST(4)
      PART(1,2)=OPLIST(5)
      PART(1,3)=OPLIST(6)
      PART(1,4)=OPLIST(7)
      PART(1,5)=OPLIST(8)
      PART(1,6)=OPLIST(9)
      NPOS=OPLIST(10)
      IF(NPOS.EQ.0)GOTO 20
      NDATA=NPOS
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NDATA,NINP)
      DO 30 IR=1,NPOS
   30 IRANGE(IR)=OPLIST(IR)
   20 NPART=1
      NCPART=1
      NTURN=1
      NCTURN=0
      NPRINT=-2
      NPLOT=-2
      IORB=0
      IPAGE=0
      IPOINT=0
      RMSX=0.0D0
      RMSY=0.0D0
      RMSIX=0.0D0
      RMSIY=0.0D0
      RPX=0.0D0
      RPY=0.0D0
      IRNG=1
      RTEMPX=0.0D0
      RTEMPY=0.0D0
      PLENG=0.0D0
      IREF=1
      IF(NPRORB.EQ.1)WRITE(IOUT,10000)
      IF(NPRORB.EQ.2)WRITE(IOUT,20000)
10000 FORMAT(//,10X,'REFERENCE ORBIT DISPLACEMENTS',//,
     >'  #    NAME        X          Y',/)
20000 FORMAT('1',20X,'REFERENCE ORBIT DISPLACEMENT PLOT')
      CALL TRACKT
      RRMSPX=(RMSIX-RTEMPX)/(TLENG-PLENG)
      RRMSPX=SQRT(RRMSPX)
      RRMSPY=(RMSIY-RTEMPY)/(TLENG-PLENG)
      RRMSPY=SQRT(RRMSPY)
      RMSX=SQRT(RMSX/IPOINT)
      RMSY=SQRT(RMSY/IPOINT)
      RMSIX=SQRT(RMSIX/TLENG)
      RMSIY=SQRT(RMSIY/TLENG)
      WRITE(IOUT,30000)RMSX,RMSY
30000 FORMAT(//,' THE RMS X ORBIT DISPLACEMENT IS :',E12.4,/,
     >' THE RMS Y ORBIT DISPLACEMENT IS :',E12.4,/)
      WRITE(IOUT,30001)RMSIX,RMSIY
30001 FORMAT(//,' THE INTEGRATED RMS X ORBIT DISPLACEMENT IS :',E12.4,/,
     >' THE INTEGRATED RMS Y ORBIT DISPLACEMENT IS :',E12.4,/)
      WRITE(IOUT,40001)RMAXX,(NAME(NORLST(MAXX),JN),JN=1,4),MAXX,
     >RMINX,(NAME(NORLST(MINX),JM),JM=1,4),MINX
40001 FORMAT(/,'  THE MAXIMUM X ORBIT DISPLACEMENT:',E12.4,
     >' OCCURS AT ELEMENT:',4A1,' #',I6,/,
     >'  THE MINIMUM X ORBIT DISPLACEMENT:',E12.4,
     >' OCCURS AT ELEMENT:',4A1,' #',I6,/)
      WRITE(IOUT,40002)RMAXY,(NAME(NORLST(MAXY),JN),JN=1,4),MAXY,
     >RMINY,(NAME(NORLST(MINY),JM),JM=1,4),MINY
40002 FORMAT(/,'  THE MAXIMUM Y ORBIT DISPLACEMENT:',E12.4,
     >' OCCURS AT ELEMENT:',4A1,' #',I6,/,
     >'  THE MINIMUM Y ORBIT DISPLACEMENT:',E12.4,
     >' OCCURS AT ELEMENT:',4A1,' #',I6,/)
      IF(NPOS.EQ.0)RETURN
      IPPOS=0
      DO 100 IPR=1,NPOS
      RPRX=SQRT(RMSPX(IPR))
      RPRY=SQRT(RMSPY(IPR))
      WRITE(IOUT,30002)IPPOS,IRANGE(IPR),RPRX,RPRY
30002 FORMAT(' BETWEEN POSITION',I4,'  AND POSITION',I4,/,
     >' THE INTEGRATED RMS X ORBIT DISPLACEMENT IS :',E12.4,/,
     >' THE INTEGRATED RMS Y ORBIT DISPLACEMENT IS :',E12.4,/)
      IPPOS=IRANGE(IPR)
  100 CONTINUE
      WRITE(IOUT,30003)IRANGE(NPOS),NELM,RRMSPX,RRMSPY
30003 FORMAT(' BETWEEN POSITION',I4,'  AND POSITION',I4,/,
     >' THE INTEGRATED RMS X ORBIT DISPLACEMENT IS :',E12.4,/,
     >' THE INTEGRATED RMS Y ORBIT DISPLACEMENT IS :',E12.4,/)
      RETURN
      END
C     *************************
      SUBROUTINE RES
C     ******************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/TRI/WCO(15,6),GEN(5,4),PGEN(75,6),DIST,
     <A1(15),B1(15),A2(15),B2(15),XCOR(3,15),XPCOR(3,15),
     1AL1(15),AL2(15),MESH,NIT,NENER,NITX,NITS,NITM1,NANAL,NOPRT
      COMMON/CLSQ/ALSQ(15,2,4),IXY,NCOEF,NAPLT,JENER,LENER(15)
      LOGICAL LENER
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      IF(NANAL.EQ.3) GO TO 3
      WRITE(IOUT,10000)
10000 FORMAT(///,20X,'ORDER TWO RESONANCE STUDY : SYMMETRY AROUND',
     <' ORIGIN IS ASSUMED',//)
      DO 1 JEN=1,NENER
      EN=WCO(JEN,6)
      IF(.NOT.LENER(JEN)) GO TO 5
      WRITE(IOUT,10004)EN
10004 FORMAT(' *** ANALYSIS FOR ENERGY ',F10.6,' NOT DONE :',
     <' MOVEMENT IS STABLE ')
      GO TO 1
    5 X0=WCO(JEN,1)
      XP0=WCO(JEN,2)
      X1 = -X0
      XP1 = -XP0
      AJ1 = A1(JEN)
      BJ1 = B1(JEN)
      AJ2 = A2(JEN)
      BJ2 = B2(JEN)
      WRITE(IOUT,10001)EN,X0,XP0,X1,XP1
10001 FORMAT(//,20X,'ANALYSIS FOR ENERGY : ',
     >F10.6,//,'   CLOSED ORBITS ARE : ',/,
     >'   X1 = ',E20.12,'   XP1 = ',E20.12,/,
     >'   X2 = ',E20.12,'   XP2 = ',E20.12,/)
      WRITE(IOUT,10020)
10020 FORMAT(/,'  THE COORDINATES OF PAIRS OF TWO POINTS ADJACENT TO ',
     >' THE FIRST FIXED POINT',/,'  TO BE USED IN SEPARATRIX TRACING',
     >'  AND PITCH DETERMINATION ARE : ',//)
      FACT1=SQRT((X0**2+XP0**2)/(AJ1**2+BJ1**2))/100.0D0
      AL = AL1(JEN)
      ALI=(AL-1.0D0)/5.0D0
      DO 100 ICO = 1,5
      FACT = FACT1/(1.0D0 +ALI*(ICO-1))
      XO1=X0+AJ1*FACT
      XO2=X0-AJ1*FACT
      XOP1=XP0+BJ1*FACT
      XOP2=XP0-BJ1*FACT
      WRITE(IOUT,10002)XO1,XOP1,XO2,XOP2
  100 CONTINUE
10002 FORMAT(
     >'   X1 = ',E20.12,'   XP1 = ',E20.12,/,
     >'   X2 = ',E20.12,'   XP2 = ',E20.12)
      DENOM =(AJ1*BJ2-BJ1*AJ2)*3.0D0
      ANUM=8.0D0*((AJ1*BJ2+BJ1*AJ2)*X0*XP0
     <        -AJ1*AJ2*XP0*XP0-BJ1*BJ2*X0*X0)
      AREA=ABS(ANUM/DENOM)
      WRITE(IOUT,10003)AREA
10003 FORMAT(/,'   THE STABLE AREA ENCLOSED BY THE SEPARATRICES IS ',
     <E12.4,/)
    1 CONTINUE
      GO TO 4
    3 WRITE(IOUT,10011)
10011 FORMAT(///,20X,' ORDER THREE RESONANCE STUDY ',//)
      DO 10 JEN=1,NENER
      EN = WCO(JEN,6)
      IF(.NOT.LENER(JEN))GO TO 15
      WRITE(IOUT,10004)EN
      GO TO 10
   15 X0=WCO(JEN,1)
      XP0 =WCO(JEN,2)
      X1=XCOR(1,JEN)
      XP1=XPCOR(1,JEN)
      X2=XCOR(2,JEN)
      XP2=XPCOR(2,JEN)
      WRITE(IOUT,10010)EN,X0,XP0,X1,XP1,X2,XP2
10010 FORMAT(//,20X,'  ANALYSIS FOR ENERGY : ',
     <F10.6,//,'    CLOSED ORBITS ARE  : ',/,
     <'    X1 = ',E20.12,'    XP1 = ',E20.12,/,
     <'    X2 = ',E20.12,'    XP2 = ',E20.12,/,
     <'    X3 = ',E20.12,'    XP3 = ',E20.12,/)
      AJ1=A1(JEN)
      BJ1=B1(JEN)
      AJ2=A2(JEN)
      BJ2 = B2(JEN)
      FACT1=SQRT((X0**2+XP0**2)/(AJ1**2+BJ1**2))/100.0D0
      WRITE(IOUT,10020)
      AL = AL1(JEN)
      ALI=(AL-1.0D0)/5.0D0
      DO 101 ICO = 1,5
      FACT = FACT1/(1.0D0 +ALI*(ICO-1))
      XO1=X0+AJ1*FACT
      XO2=X0-AJ1*FACT
      XOP1=XP0+BJ1*FACT
      XOP2=XP0-BJ1*FACT
      WRITE(IOUT,10002)XO1,XOP1,XO2,XOP2
  101 CONTINUE
      AREA=ABS(0.5D0*(X0*XP1-X1*XP0+X1*XP2-X2*XP1+X2*XP0-X0*XP2))
      WRITE(IOUT,10003)AREA
   10 CONTINUE
    4 RETURN
      END

C     ***********************
      SUBROUTINE SEED(IEND)
C     ********************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/MIS/RMISA(7,50),MISELE(50),NMIS,ISEED,IXS,NOPT,
     > NMISE,MISSEL(50),NMRNGE(50),MSRNGE(2,10,50),MISFLG,MCHFLG
       DIMENSION DATA(1)
c dlr
	data nran/1111111/
c dlr
       NCHAR=0
       NDIM=1
       NDATA=1
       NPRINT=1
       CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
       ISEED = DATA(1)
       IF(ISEED.EQ.0)ISEED=ran(nran)
       ISEED=(2*(ISEED/2))+1
       WRITE(IOUT,10000)ISEED
10000 FORMAT(//,'   THE SEED SELECTED FOR THIS RUN IS :',I16,//)
      RETURN
      END
C     ***********************
      SUBROUTINE SETCOR(IEND)
C     ***********************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/CORR/CORVAL(600,4),ICRID(600),ICRPOS(600),ICRSET(600),
     >ICROPT(600),NCORR,NCURCR,ICRFLG,ICRCHK,ALMNEL,NPARC
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      DIMENSION ICHAR(4),OPLIST(6)
      DATA NINE/'9'/
    1 NOP = 0
      NCHAR=4
      INPRT=1
      NDIM=0
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,INPRT)
      IF((ICHAR(1).EQ.NINE).AND.(ICHAR(2).EQ.NINE))GO TO 99
      NOP = 6
      NCHAR=0
      INPRT=1
      NDIM=6
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,INPRT)
      CALL ELID(ICHAR,NELID)
      ICPOS=OPLIST(1)
      DO 2 ICORR=1,NCORR
      IF(ICPOS.LT.ICRPOS(ICORR))GOTO 3
      IF((NELID.EQ.ICRID(ICORR)).AND.(ICPOS.EQ.ICRPOS(ICORR)))GOTO 4
    2 CONTINUE
    3 WRITE(IOUT,10001)
10001 FORMAT(/,'  NO MATCH WAS FOUND FOR CORRECTOR ID AND POSITION',
     >' IN THE CORRECTOR LIST',/,' DEFINED IN THE CORRECTOR DEFINITION',
     >' OPERATION . RUN IS STOPPED',/)
      CALL HALT
      STOP
    4 ICRSET(ICORR)=1
      ICROPT(ICORR)=OPLIST(2)
      CORVAL(ICORR,1)=OPLIST(3)
      CORVAL(ICORR,2)=OPLIST(4)
      CORVAL(ICORR,3)=OPLIST(5)
      CORVAL(ICORR,4)=OPLIST(6)
      GOTO 1
   99 ICRFLG=1
      WRITE(IOUT,88888)(ICRPOS(IW),ICRID(IW),ICRSET(IW),ICROPT(IW),
     >(CORVAL(IW,JW),JW=1,4),IW=1,NCORR)
88888 FORMAT(' ',4I6,4E12.4)
      RETURN
      END
C     ***********************
      SUBROUTINE SETERR(IEND)
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/ERR/ERRVAL(7,50),NERELE(50),NERPAR(7,50),NERR,NEROPT,
     > NERRE,MERSEL(50),NERNGE(50),MERNGE(2,10,50),MERFLG
      DIMENSION DATA(20),ICHAR(4)
C INITIALIZE TO 0 ALL ARRAYS DEFINED IN THIS ROUTINE
      DO 5 INER=1,50
      MERSEL(INER)=0
      NERNGE(INER)=0
      DO 5 JNER=1,10
      DO 5 KNER=1,2
    5 MERNGE(KNER,JNER,INER)=0
      NDIM=20
      NPRINT=1
      NCHAR=0
      NDATA=2
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
      NEROPT=DATA(1)
      NERRE=DATA(2)
      DO 1 IER=1,NERRE
      NCHAR=4
      NDATA=0
      NDIM=0
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
      CALL ELID(ICHAR,NELID)
      DO 3 JM=1,NERR
      IF(NELID.EQ.NERELE(JM))GOTO 4
    3 CONTINUE
      WRITE(IOUT,99994)
99994 FORMAT(/,'  NAME IS NOT FOUND IN THE LIST OF THE',
     >' ELEMENTS WITH ERROR AS DEFINED IN ERRDAT',/)
      STOP
    4 MERSEL(IER)=JM
      NDATA = 1
      NCHAR=0
      NDIM=20
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
      NERNGE(IER)=DATA(1)
      IF((DATA(1).EQ.0.0D0).OR.(DATA(1).EQ.-1.0D0))GOTO 1
      NDATA=NERNGE(IER)*2
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
      NFRNGE=NERNGE(IER)
      DO 2 IRNGE=1,NFRNGE
      MERNGE(1,IRNGE,IER)=DATA((2*IRNGE)-1)
    2 MERNGE(2,IRNGE,IER)=DATA(2*IRNGE)
    1 CONTINUE
      MERFLG=1
      IOPT=NEROPT+1
C     WRITE(IOUT,99000)((NERELE(IN),MERSEL(IN),NERNGE(IN),
C    >MERNGE(1,1,IN),MERNGE(2,1,IN)),IN=1,NERR)
99000 FORMAT(/,' IN ESET',5I5)
      GOTO(10,11,12,13),IOPT
   10 WRITE(IOUT,99990)
99990 FORMAT(/,' NO RANDOM GENERATOR IS USED IN SETTING UP THE'
     >,' ERRORS',/)
      RETURN
   11 WRITE(IOUT,99991)
99991 FORMAT(/,' THE ERROR VALUES ARE MULTIPLIED RANDOMLY BY',
     >/,' +1 AND -1',/)
      RETURN
   12 WRITE(IOUT,99992)
99992 FORMAT(/,' THE ERROR VALUES ARE MULTIPLIED BY THE VALUES',
     >/,' OF A UNIFORM RANDOM DISTRIBUTION WHOSE SIGMA IS 1',/)
      RETURN
   13 WRITE(IOUT,99993)
99993 FORMAT(/,' THE ERROR VALUES ARE MULTIPLIED BY THE VALUES',
     >/,' OF A GAUSSIAN DISTRIBUTION WHOSE SIGMA IS 1 AND THAT IS',/,
     >' TRUNCATED AT 2 SIGMAS',/)
      RETURN
      END
C     ***********************
      SUBROUTINE SETMIS(IEND)
C     ********************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/MIS/RMISA(7,50),MISELE(50),NMIS,ISEED,IXS,NOPT,
     > NMISE,MISSEL(50),NMRNGE(50),MSRNGE(2,10,50),MISFLG,MCHFLG
      DIMENSION DATA(20),ICHAR(4)
      NDIM=20
      NPRINT=1
      NCHAR=0
      NDATA=2
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
      NOPT=DATA(1)
      NMISE=DATA(2)
      DO 1 IMS=1,NMISE
      NCHAR=4
      NDATA=0
      NDIM=0
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
      CALL ELID(ICHAR,NELID)
      DO 3 JM=1,NMIS
      IF(NELID.EQ.MISELE(JM))GOTO 4
    3 CONTINUE
      WRITE(IOUT,99994)
99994 FORMAT(/,'  NAME IS NOT FOUND IN THE LIST OF THE',
     >' MISALIGNED ELEMENTS DEFINED IN MISDAT',/)
      STOP
    4 MISSEL(IMS)=JM
      NDATA = 1
      NCHAR=0
      NDIM=20
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
      NMRNGE(IMS)=DATA(1)
      IF((DATA(1).EQ.0.0D0).OR.(DATA(1).EQ.-1.0D0))GOTO 1
      NDATA=NMRNGE(IMS)*2
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
      NFRNGE=NMRNGE(IMS)
      DO 2 IRNGE=1,NFRNGE
      MSRNGE(1,IRNGE,IMS)=DATA((2*IRNGE)-1)
    2 MSRNGE(2,IRNGE,IMS)=DATA(2*IRNGE)
    1 CONTINUE
      MISFLG=1
      IOPT=NOPT+1
      GOTO(10,11,12,13),IOPT
   10 WRITE(IOUT,99990)
99990 FORMAT(/,' NO RANDOM GENERATOR IS USED IN THE MISALIGNEMENT',/)
      RETURN
   11 WRITE(IOUT,99991)
99991 FORMAT(/,' THE MISALIGNEMENT VALUES ARE MULTIPLIED RANDOMLY BY',
     >/,' +1 AND -1',/)
      RETURN
   12 WRITE(IOUT,99992)
99992 FORMAT(/,' THE MISALIGNMENT VALUES ARE MULTIPLIED BY THE VALUES',
     >/,' OF A UNIFORM RANDOM DISTRIBUTION WHOSE SIGMA IS 1',/)
      RETURN
   13 WRITE(IOUT,99993)
99993 FORMAT(/,' THE MISALIGNMENT VALUES ARE MULTIPLIED BY THE VALUES',
     >/,' OF A GAUSSIAN DISTRIBUTION WHOSE SIGMA IS 1 AND THAT IS',/,
     >' TRUNCATED AT 2 SIGMAS',/)
      RETURN
      END
C     ***********************
      SUBROUTINE SETSYN(IEND)
C     ********************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/SYNC/ENOM,SYNDEL,ISYNFL,ISYNGO
      DIMENSION DATA(2),ICHAR(4)
      NDIM=2
      NDATA=2
      NCHAR=0
      NPRINT=1
      CALL INPUT(ICHAR,NCHAR,DATA,NDIM,IEND,NDATA,NPRINT)
      ENOM=DATA(1)
      ISYNFL=DATA(2)
      RETURN
      END
C     *************************
      SUBROUTINE SETUP
C     *************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      ISOUT=6
      IIN=31
      IOUT=34
      ISO=0
      RETURN
      END
C     ***********************
      SUBROUTINE SOLQUA
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INPUTT/KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      IAD=IADR(N)
      AL =ELDAT(IAD)
      AKQ=ELDAT(IAD+1)
      AKS=ELDAT(IAD+2)
      DO 100 I=1,6
      DO 100 J=1,NOF
      AMAT(N,I,J)=0.0D0
      IF(I.EQ.J) AMAT(N,I,J)=1.0D0
  100 CONTINUE
      IF(AKQ.NE.0.0D0.OR.AKS.NE.0.0D0)GO TO 2
      AMAT(N,1,2)=AL
      AMAT(N,3,4)=AL
      IF(NORDER.EQ.1)RETURN
      AMAT(N,5,13)=AL/2.0D0
      AMAT(N,5,22)=AL/2.0D0
      RETURN
    2 IKQ=1
      IF(AKQ.LT.0.0D0)IKQ=-1
      AKQ4=AKQ*AKQ
      AKS2=AKS*AKS
      AKS3=AKS2*AKS
      AKS4=AKS2*AKS2
      Q2=SQRT(AKQ4+4.0D0*AKS4)
      Q2I=1.0D0/Q2
      SK1=SQRT(2.0D0*AKS2+Q2)
      SK3=SQRT(ABS(Q2-2.0D0*AKS2))
      SS=SIN(SK1*AL)
      SC=COS(SK1*AL)
      BS=SINH(SK3*AL)
      BC=COSH(SK3*AL)
      SKP=0.5D0*(SK1+SK3)
      SKM=0.5D0*(SK1-SK3)
      SKP2=SKP*SKP
      SKP3=SKP2*SKP
      SKM2=SKM*SKM
      SKM3=SKM2*SKM
      AMAT(N,1,1)=Q2I*(SKP2*SC+SKM2*BC)
      AMAT(N,1,2)=Q2I*(SKP*SS-SKM*BS)
      AMAT(N,1,3)=Q2I*AKS*(SKM*SS+SKP*BS)
      AMAT(N,1,4)=Q2I*AKS*(BC-SC)
      AMAT(N,2,1)=Q2I*(-SKP3*SS-SKM3*BS)
      AMAT(N,2,2)=Q2I*(SKP2*SC+SKM2*BC)
      AMAT(N,2,3)=Q2I*AKS3*(SC-BC)
      AMAT(N,2,4)=Q2I*AKS*(SKP*SS-SKM*BS)
      AMAT(N,3,1)=Q2I*AKS*(SKM*BS-SKP*SS)
      AMAT(N,3,2)=Q2I*AKS*(SC-BC)
      AMAT(N,3,3)=Q2I*(SKM2*SC+SKP2*BC)
      AMAT(N,3,4)=Q2I*(SKM*SS+SKP*BS)
      AMAT(N,4,1)=Q2I*AKS3*(BC-SC)
      AMAT(N,4,2)=Q2I*AKS*(-SKM*SS-SKP*BS)
      AMAT(N,4,3)=Q2I*(SKP3*BS-SKM3*SS)
      AMAT(N,4,4)=Q2I*(SKM2*SC+SKP2*BC)
      IF(NORDER.EQ.1)GOTO 300
      DAKS=-AKS
      DAKQ=-AKQ
      DAKQ4=2.0D0*AKQ*DAKQ
      DAKS2=2.0D0*AKS*DAKS
      DAKS3=3.0D0*AKS2*DAKS
      DAKS4=4.0D0*AKS3*DAKS

      DQ2=0.5D0*Q2I*(DAKQ4+4.0D0*DAKS4)
      Q2I2=Q2I*Q2I
      DQ2I=-Q2I2*DQ2
      DSK1=(2.0D0*DAKS2+DQ2)/(2.0D0*SK1)
      DSK3=0.0D0
      IF(SK3.NE.0.0D0)DSK3=(DQ2-2.0D0*DAKS2)/(2.0D0*SK3)
      DSS=SC*DSK1*AL
      DSC=-SS*DSK1*AL
      DBS=BC*DSK3*AL
      DBC=BS*DSK3*AL
      DSKP=0.5D0*(DSK1+DSK3)
      DSKM=0.5D0*(DSK1-DSK3)
      DSKP2=2.0D0*SKP*DSKP
      DSKP3=3.0D0*SKP2*DSKP
      DSKM2=2.0D0*SKM*DSKM
      DSKM3=3.0D0*SKM2*DSKM
      AMAT(N,1,12)=DQ2I*(SKP2*SC+SKM2*BC)+
     > Q2I*(DSKP2*SC+SKP2*DSC+DSKM2*BC+SKM2*DBC)
      AMAT(N,1,17)=DQ2I*(SKP*SS-SKM*BS)+
     > Q2I*(DSKP*SS+SKP*DSS-DSKM*BS-SKM*DBS)
      AMAT(N,1,21)=(DQ2I*AKS+Q2I*DAKS)*(SKM*SS+SKP*BS)
     > +Q2I*AKS*(DSKM*SS+SKM*DSS+DSKP*BS+SKP*DBS)
      AMAT(N,1,24)=(DQ2I*AKS+Q2I*DAKS)*(BC-SC)
     > +Q2I*AKS*(DBC-DSC)
      AMAT(N,2,12)=DQ2I*(-SKP3*SS-SKM3*BS)
     > +Q2I*(-DSKP3*SS-SKP3*DSS-DSKM3*BS-SKM3*DBS)
      AMAT(N,2,17)=AMAT(N,1,12)
      AMAT(N,2,21)=(DQ2I*AKS3+Q2I*DAKS3)*(SC-BC)
     > +Q2I*AKS3*(DSC-DBC)
      AMAT(N,2,24)=(DQ2I*AKS+Q2I*DAKS)*(SKP*SS-SKM*BS)
     > +Q2I*AKS*(DSKP*SS+SKP*DSS-DSKM*BS-SKM*DBS)
      AMAT(N,3,12)=-AMAT(N,2,24)
      AMAT(N,3,17)=-AMAT(N,1,24)
      AMAT(N,3,21)=DQ2I*(SKM2*SC+SKP2*BC)
     > +Q2I*(DSKM2*SC+SKM2*DSC+DSKP2*BC+SKP2*DBC)
      AMAT(N,3,24)=DQ2I*(SKM*SS+SKP*BS)
     > +Q2I*(DSKM*SS+SKM*DSS+DSKP*BS+SKP*DBS)
      AMAT(N,4,12)=-AMAT(N,2,21)
      AMAT(N,4,17)=-AMAT(N,1,21)
      AMAT(N,4,21)=DQ2I*(SKP3*BS-SKM3*SS)
     > +Q2I*(DSKP3*BS+SKP3*DBS-DSKM3*SS-SKM3*DSS)
      AMAT(N,4,24)=AMAT(N,3,21)
      AISSSC=0.0D0
      IF(SK1.NE.0.0D0)AISSSC=SS*SS/(2.0D0*SK1)
      AIBSBC=0.0D0
      IF(SK3.NE.0.0D0)AIBSBC=BS*BS/(2.0D0*SK3)
      AISSBC=Q2I*(SK3*SS*BS-SK1*SC*BC+SK1)
      AISCBS=Q2I*(SK3*SC*BC+SK1*SS*BS-SK3)
      AISS2=0.0D0
      AISC2=AL
      AIBS2=0.0D0
      AIBC2=AL
      IF(SK1.NE.0.0D0)AISS2=0.5D0*(AL-SS*SC/SK1)
      IF(SK1.NE.0.0D0)AISC2=0.5D0*(AL+SS*SC/SK1)
      IF(SK3.NE.0.0D0)AIBS2=0.5D0*(BS*BC/SK3 - AL)
      IF(SK3.NE.0.0D0)AIBC2=0.5D0*(AL+BS*BC/SK3)
      AISSBS=Q2I*(SK3*SS*BC-SK1*SC*BS)
      AISCBC=Q2I*(SK1*SS*BC+SK3*SC*BS)
      AKS5=AKS4*AKS
      AKS6=AKS5*AKS
      SKP4=SKP3*SKP
      SKP5=SKP4*SKP
      SKP6=SKP5*SKP
      SKM4=SKM3*SKM
      SKM5=SKM4*SKM
      SKM6=SKM5*SKM
      Q4I=Q2I*Q2I
      AMAT(N,5,7)=Q4I*0.5D0*(SKP6*AISS2+SKM6*AIBS2-2.0D0*SKP3*SKM3
     >   *AISSBS+AKS6*(AISC2+AIBC2-2.0D0*AISCBC))
      AMAT(N,5,8)=Q4I*(-SKP5*AISSSC-SKP3*SKM2*AISSBC-SKM3*SKP2*AISCBS
     > -SKM5*AIBSBC-AKS4*(-SKM*AISSSC-SKP*AISCBS+SKM*AISSBC+SKP*AIBSBC))
      AMAT(N,5,9)=Q4I*AKS3*((SKP3-SKM3)*(AISSBC-AISSSC)
     >  +(SKP3+SKM3)*(AIBSBC-AISCBS))
      AMAT(N,5,10)=Q4I*(AKS*(-SKP4*AISS2-(SKP3*SKM+SKM3*SKP)*AISSBS
     >  +SKM4*AIBS2)+AKS3*(-SKM2*AISC2-(SKP2-SKM2)*AISCBC+SKP2*AIBC2))
      AMAT(N,5,13)=Q4I*0.5D0*(SKP4*AISC2+2.0D0*SKP2*SKM2*AISCBC
     >  +SKM4*AIBC2+AKS2*(SKM2*AISS2+2.0D0*SKP*SKM*AISSBS+SKP2*AIBS2))
      AMAT(N,5,14)=Q4I*(AKS3*(SKP2*AISC2-(SKP2-SKM2)*AISCBC
     >  -SKM2*AIBC2)-AKS*(-SKM4*AISS2+(SKM*SKP3-SKP*SKM3)*AISSBS+
     >  SKP4*AIBS2))
      AMAT(N,5,15)=Q4I*AKS*((SKP3-SKM3)*AISSSC-(SKP2*SKM+SKP*SKM2)
     >  *AISCBS+(SKM2*SKP-SKM*SKP2)*AISSBC-(SKM3+SKP3)*AIBSBC)
      AMAT(N,5,18)=Q4I*0.5D0*(AKS6*(AISC2-2.0D0*AISCBC+AIBC2)
     >  +SKM6*AISS2-2.0D0*SKM3*SKP3*AISSBS+SKP6*AIBS2)
      AMAT(N,5,19)=Q4I*(AKS4*(SKP*AISSSC-SKM*AISCBS-SKP*AISSBC
     >  +SKM*AIBSBC)-SKM5*AISSSC-SKM3*SKP2*AISSBC+SKP3*SKM2*AISCBS
     >  +SKP5*AIBSBC)
      AMAT(N,5,22)=Q4I*0.5D0*(AKS2*(SKP2*AISS2-2.0D0*SKP*SKM*AISSBS
     > +SKM2*AIBS2)+SKM4*AISC2+2.0D0*SKM2*SKP2*AISCBC+SKP4*AIBC2)
  300 IF(IKQ.GE.0)RETURN
C
C     SET UP THE 90 DEGREE KICK MATRIX IN TEMP
C
      DO 10 IX = 1,6
      DO 10 IY = 1,NOF
      TEMP(IX,IY)=0.0D0
10    CONTINUE
      TEMP(1,3)=1
      TEMP(2,4)=1.0D0
      TEMP(3,1)=-1.0D0
      TEMP(4,2)=-1.0D0
      TEMP(5,5)=1.0D0
      TEMP(6,6)=1.0D0
       KODEPR=15
      CALL PROMAT
C
C  SET -90 DEGREE KICK MATRIX IN AMAT
C
      DO 200 I=1,6
      DO 200 J=1,NOF
      AMAT(N,I,J)=0.0D0
 200  CONTINUE
      AMAT(N,1,3)=-1.0D0
      AMAT(N,2,4)=-1.0D0
      AMAT(N,3,1)=1.0D0
      AMAT(N,4,2)=1.0D0
      AMAT(N,5,5)=1.0D0
      AMAT(N,6,6)=1.0D0
      KODEPR=8
      CALL PROMAT
C
C     PUT TEMP INTO AMAT(N,6,27)
C
      DO 20 IX=1,6
      DO 20 IY=1,NOF
  20  AMAT(N,IX,IY) = TEMP(IX,IY)
      RETURN
      END
C     **************************
      SUBROUTINE SYNPRE(IAD,NEL)
C     **************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z), INTEGER (I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/SYNC/ENOM,SYNDEL,ISYNFL,ISYNGO
      COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN
     +  ,NPTOT,MLOCAT,NTURN
      COMMON/LENGTH/TLENG,ALENG(350),ACLENG(2500)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      ANG=CRDEG*ELDAT(IAD+1)
      SYNDEL=1.408D-05*(ENOM**3)*ANG*ANG/ALENG(NEL)
      ISYNGO=1
      RETURN
      END
C     ***********************
      SUBROUTINE TRAFCT(XI,XPI,YI,YPI,ALI,DELI,
     > XO,XPO,YO,YPO,ALO,DELO,NTURN)
C     **********************
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C
C THIS ROUTINE IS TO BE PROGRAMMED BY THE USER
C THE INPUT COORDINATES HAVE A TRAILING I AND THE OUTPUT
C COORDINATES HAVE A TRAILING O.
C IF THE TRANSFORM THAT IS PROGRAMMED HERE IS NOT SYMPLECTIC
C OR DOES NOT SATISFY LIOUVILLE'S THEOREM SOME OTHER PARTS OF
C THE PROGRAM MAY NOT GIVE MEANINGFUL RESULTS !!!!!
C THE ONLY PARTS OF THE PROGRAMME AFFECTED BY THIS ELEMENT ARE
C THE MOVE(MENT) ANALYSIS OPERATION, THE  TRAC(KING) OPERATION AND
C THE  MODI(FICATION) OF PARAMETERS OPERATION.
C NTURN IN THE CURRENT TURN BEING PROCESSED AND CAN BE USED
C TO DESIGN AN ELEMENT WHOSE BEHAVIOUR VARIES WITH THE TURN.
C
C
      COMMON/ARB/PARA(20)
      ALO=ALI
      DELO=DELI
      YO=YI
      YPO=YPI
      DELO=DELI
      ALO=ALI
      XO=XPI
      XPO=-XI + PARA(1)*XPI**2
      RETURN
      END
C     ************************
      SUBROUTINE TRAKPR(ICODE,IE)
C     ************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
        COMMON/TRACE/PART(350,6),DEL(350),NPART,NCPART,NPRINT,NCTURN
     +  ,NPTOT,MLOCAT,NTURN
      LOGICAL LOGPAR
C
C   WHAT KIND OF PRINTING?
C
        NEL = NORLST(IE)
      IF(ICODE)10,30,30
C
C   INITIAL POSITIONS PRINTING
C
10    WRITE(IOUT,10301)
10301 FORMAT(//,' INITIAL POSITIONS OF PARTICLES ',/)
      DO 20 I=1,NPART
      IF(.NOT.LOGPAR(I)) GO TO 20
      WRITE(IOUT,10300)I,(PART(I,K),K=1,6)
10300 FORMAT(I4,6(E14.5))
20    CONTINUE
      RETURN
C
C   OTHER PRINTING
C
30    WRITE(IOUT,10302)IE,(NAME(NEL,IZ),IZ=1,4),NCTURN
10302 FORMAT(/,' PARTICLE POSITIONS AFTER ELEMENT',2X,I4,'(',4A1,')',
     >  2X,'DURING TURN',I6,/)
      DO 40 I=1,NPART
      IF(.NOT.LOGPAR(I)) GO TO 40
      WRITE(IOUT,10300) I,(PART(I,K),K=1,6)
40    CONTINUE
      RETURN
      END
C     ***********************
      SUBROUTINE TWISS
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON/INPUTT/KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/PRODCT/KODEPR,NEL,NOF
      IAD=IADR(N)
      N=MADR(N)
C
C     CLEAR AMAT(N,6,27)
C
      DO 10 I=1,6
      DO 10 J=1,NOF
      AMAT(N,I,J)=0.0D0
      IF(I.EQ.J) AMAT(N,I,J)=1.0D0
10    CONTINUE
      ANG=ELDAT(IAD)*CRDEG
      CH=COS(ANG)
      SH=SIN(ANG)
      ANG=ELDAT(IAD+3)*CRDEG
      CV=COS(ANG)
      SV=SIN(ANG)
      AMAT(N,1,1)=CH+ELDAT(IAD+2)*SH
      AMAT(N,1,2)=SH*ELDAT(IAD+1)
      AMAT(N,2,1)=-(1.0+ELDAT(IAD+2)*ELDAT(IAD+2))*SH/ELDAT(IAD+1)
      AMAT(N,2,2)=CH-ELDAT(IAD+2)*SH
      AMAT(N,3,3)=CV+ELDAT(IAD+5)*SV
      AMAT(N,3,4)=SV*ELDAT(IAD+4)
      AMAT(N,4,3)=-(1.0D0+ELDAT(IAD+5)*ELDAT(IAD+5))*SV/ELDAT(IAD+4)
      AMAT(N,4,4)=CV-ELDAT(IAD+5)*SV
      RETURN
      END
C  **********************
      FUNCTION URAND(IX)
C  **********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DATA M2/0/,ITWO/2/
      IF(M2.NE.0)GOTO 20
      M=1
   10 M2=M
      M=ITWO*M2
      IF(M.GT.M2)GOTO 10
      HALFM=M2
      IA=8*IDINT(HALFM*ATAN(1.0D0)/8.0D0) + 5
      IC=2*IDINT(HALFM*(0.5D0-SQRT(3.0D0)/6.0D0))+1
      S=0.5D0/HALFM
   20 IX=IX*IA+IC
      IF(IX/2.GT.M2)IX=(IX-M2)-M2
      IF(IX.LT.0)IX=(IX+M2)+M2
      URAND=DFLOAT(IX)*S
      RETURN
      END
C  **********************
      SUBROUTINE VARY(JV,NVPAR,VARVAL)
C  **********************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      NVEL = IADR(JV)
      NV = JV
      ELDAT(NVEL+NVPAR-1) = VARVAL
C
C     RECOMPUTE MATRIX
C
      CALL MATGEN(NV)
      RETURN
      END
C     ***********************
      SUBROUTINE VBEND
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/BND/IAD
C
C     GET ADDRESS OF THE PARAMETERS AND THE MATRIX
C
      IAD = IADR(N)
      N = MADR(N)
C
C     CLEAR AMAT(N,6,27)
C
      DO 100 I=1,6
      DO 100 J=1,NOF
      AMAT(N,I,J)=0.0D0
 100  CONTINUE
C
C     SET UP THE 90 DEGREE KICK MATRIX IN TEMP
C
      DO 10 IX = 1,6
      DO 10 IY = 1,NOF
      TEMP(IX,IY)=0.0D0
10    CONTINUE
      TEMP(1,3)=1
      TEMP(2,4)=1.0D0
      TEMP(3,1)=-1.0D0
      TEMP(4,2)=-1.0D0
      TEMP(5,5)=1.0D0
      TEMP(6,6)=1.0D0
      CALL BEND
      KODEPR=8
C
C  SET -90 DEGREE KICK MATRIX IN AMAT
C
      DO 200 I=1,6
      DO 200 J=1,NOF
      AMAT(N,I,J)=0.0D0
 200  CONTINUE
      AMAT(N,1,3)=-1.0D0
      AMAT(N,2,4)=-1.0D0
      AMAT(N,3,1)=1.0D0
      AMAT(N,4,2)=1.0D0
      AMAT(N,5,5)=1.0D0
      AMAT(N,6,6)=1.0D0
      CALL PROMAT
C
C     PUT TEMP INTO AMAT(N,6,27)
C
      DO 20 IX=1,6
      DO 20 IY=1,NOF
  20  AMAT(N,IX,IY) = TEMP(IX,IY)
      RETURN
      END
C     ***********************
C     SPECIAL FUNCTIONS
C     ***********************
C      FUNCTION SINH(X)
C      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C      DSINH=(EXP(X)-EXP(-X))/2.0D0
C      RETURN
C      END
C      FUNCTION COSH(X)
C      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C      DCOSH=(EXP(X)+EXP(-X))/2.0D0
C      RETURN
C      END
C      FUNCTION TAN(X)
C      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C      DTAN=SIN(X)/COS(X)
C      RETURN
C      END
C      ***********************
      SUBROUTINE fttwiss(r)
C     ***********************
	DOUBLE PRECISION dener,eldat,r(6,6,15)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/DETL/DENER(15),NH,NV,NVH,NHVP(105),MDPRT,NDENER,
     1NUXS(45),NUX(45),NUYS(45),NUY(45),NCO,NHNVHV,MULPRT,NSIG
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
	dimension phas(15,2),beta(15,2),tune(15,2),alpha(15,2)
	character*12 word(2)
	data word/' HORIZONTAL ','  VERTICAL  '/
	data pi/3.141592/
c
	do 10 j=1,3,2
	  l=(j+1)/2
	  if(l.eq.1.and.nh.eq.0)goto 10
	  if(l.eq.2.and.nv.eq.0)goto 10
	  do i=1,ndener
	    phas(i,l)=0.0
	    tune(i,l)=0.0
	    beta(i,l)=0.0
	    alpha(i,l)=0.0
	    arg=.5*(r(j,j,i)+r(j+1,j+1,i))
	    if(abs(arg).le.1.0)then
	      phas(i,l)=acos(arg)
	      tune(i,l)=phas(i,l)/2/pi
	      beta(i,l)=r(j,j+1,i)/sin(phas(i,l))
	      alpha(i,l)=.5*(r(j,j,i)-r(j+1,j+1,i))/sin(phas(i,l))
   	    else
	      write(iout,1)word(l),dener(i)
1	      format(//,7x,a12,' MOTION UNSTABLE FOR DP/P =',e13.5)
	      endif
	    end do
c
	  write(iout,2)word(l)
2	  format(//,' FULL TURN',a12,'FUNCTION VALUES ',/)
      WRITE(IOUT,20025)
20025 FORMAT(/,2X,'ENERGY(DP/P)',4X,'BETA ',7X,'ALPHA ',9X,'NU ',
     >8X,'PHI ',/)
      WRITE(IOUT,20003)(DENER(IEN),BETA(ien,l),ALPHA(ien,l),
     >tune(ien,l),phas(ien,l),IEN=1,NDENER)
20003 FORMAT(/,(2X,5(E13.5)))
10	continue
	return
      END
C     ***********************
      SUBROUTINE ROTQUA(ilk)
C     ***********************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z),INTEGER(I-N)
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
      COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON/INPUTT/KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/PRODCT/KODEPR,NEL,NOF
      COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE,NELM,NOP,
     <NLIST(40)
      DIMENSION DI(6,27),TRI1(6,6,0:6),TRI(6,6,0:6),UROT(6,6)
      DIMENSION DELTA(6,6)
      DATA UROT/36*0.D0/
      DATA DELTA/1.D0,6*0.D0,1.D0,6*0.D0,1.D0,
     &	              6*0.D0,1.D0,6*0.D0,1.D0,6*0.D0,1.D0/
      N1=N
      IAD=IADR(N1)
      AL=ELDAT(IAD)
      AKQ=ELDAT(IAD+1)
      AKS=ELDAT(IAD+2)
      THETA=ELDAT(IAD+3)
      IF(AL.GT.0.0)GOTO 101
	AL=1.0D-06			! set length and strength for thin
	AKQ=AKQ*1.0D06			! quad
	AKS=AKS*1.0D06			! sextupole or solenoid
  101   CONTINUE
      if(name(ilk,2).ne.'S')CALL QSX(AL,AKQ,AKS)
      if(name(ilk,2).eq.'S')CALL SOLQUA
      N=MADR(N1)
      IF(THETA.EQ.0.0)RETURN
c  rotate amat
c
c  generate rotation matrix
      RAD=THETA*CRDEG
      COS1=COS(RAD)
      SIN1=SIN(RAD)
      DO 10 J=1,4
10	UROT(J,J)=COS1
      UROT(5,5)=1.D0
      UROT(6,6)=1.D0
      UROT(1,3)=SIN1
      UROT(2,4)=SIN1
      UROT(3,1)=-SIN1
      UROT(4,2)=-SIN1
c
      DO 20 I=1,6
	DO 20 J=1,27
  	  DI(I,J)=AMAT(N,I,J)
   20     CONTINUE
c  convert amat to transport 6X6X6 notation
      CALL TWO2THRE(DI,TRI1)
c  rotate
      DO 30 I=1,6
	DO 30 J=1,6
	  TRI(I,J,0)=0.D0
	  DO 30 K=1,6
	    TRI(I,J,K)=0.D0
	    DO 30 L=1,6
	      TRI(I,J,0)=TRI(I,J,0)+UROT(I,K)*TRI1(K,L,0)*UROT(J,L)
	      IF(NORDER.EQ.1)GOTO 30
	      DO 30 M=1,6
	        DO 30 K1=M,6
	          TRI(I,J,K)=TRI(I,J,K)+UROT(I,L)*TRI1(L,M,K1)*
     &		   (UROT(J,M)*UROT(K,K1)+UROT(J,K1)*UROT(K,M))
     &		   *(1.D0+DELTA(M,K1))*(1.D0-0.5D0*DELTA(J,K)) !page 1,2 book 2
   30		  CONTINUE
c      	
c  convert back to 6X27 form
      DO 40 I=1,6
        IND=6
        DO 40 J=1,6
	  AMAT(N,I,J)=TRI(I,J,0)
	  IF(NORDER.EQ.1)GOTO 40
	  DO 40 K=J,6
	    IND=IND+1
	    AMAT(N,I,IND)=TRI(I,J,K)
   40	    CONTINUE
      RETURN
      END

	SUBROUTINE RTDUMP(IEND)
C  Dump R and T matrices  in the order of their occurence in the machine
	implicit DOUBLE PRECISION(a-h,o-z)
      COMMON AMAT(350,6,27),NORLST(2500),
     1XPEL(350),YPEL(350),
     1EXPEL,N,LOGPAR(350)
      COMMON /INPUTT/ KODE(350),NAME(350,4),IADR(350),ELDAT(5000)
     +,MADR(350),KCOUNT,NA
      COMMON/INOUT/IIN,IOUT,ISOUT,ISO
	dimension oplist(2),ichar(4)
5000  NOP = -1
      NCHAR=0
      NDIM=2
      NIPR=1
      CALL INPUT(ICHAR,NCHAR,OPLIST,NDIM,IEND,NOP,NIPR)
	norder=oplist(1)
	nprint=oplist(2)
	nord=6
	if(norder.eq.2)nord=27
	do 10 i=1,na
	nel=norlst(i)
	write(98,1)(name(nel,j),j=1,4),i
  1	format(/,1x,'Name ',4a1,3x,'Element # ',i4)
	if(nprint.eq.0)goto 20
	write(34,1)(name(nel,j),j=1,4),i
      WRITE(IOUT,543)
  543 FORMAT(/,'          FIRST ORDER MATRIX')
      WRITE(IOUT,597)((amat(nel,l,j),J=1,6),l=1,6)
  597 FORMAT(' ',6(/,'-',6(E15.7)))
      IF(NORDER.lt.0)goto 20
      WRITE (IOUT,544)
  544 FORMAT(/,'               SECOND ORDER TERMS',/)
      DO 560 l=1,5
      WRITE(IOUT,590)(amat(nel,l,j),J=7,12)
  590 FORMAT('  ',6E15.7)
      WRITE(IOUT,591)(amat(nel,l,j),J=13,17)
  591 FORMAT(' ',16X,5E15.7)
      WRITE(IOUT,592)(amat(nel,l,j),J=18,21)
  592 FORMAT(' ',31X,4E15.7)
      WRITE(IOUT,593)(amat(nel,l,j),J=22,24)
  593 FORMAT(' ',46X,3E15.7)
      WRITE(IOUT,5930)(amat(nel,l,j),J=25,26)
 5930 FORMAT(' ',61X,2E15.7)
      WRITE(IOUT,594)amat(nel,l,27)
  594 FORMAT(' ',76X,E15.7)
  560	continue
  20    if(nprint.gt.0)goto 10
	write(98,*)((amat(nel,j,k),k=1,6),j=1,nord)
  10	continue
	return
	end
	subroutine two2thre(di,tri)
	implicit DOUBLE PRECISION (a-h,o-z)
	dimension di(6,27),tri(6,6,0:6)
c  convert 6X27 second order transfer matrix used by dimat to
c  a 6X6X6 transport style matrix. tri(i,j,0) gives the first order transfer
c  matrix.
	do i=1,6
	  ind2=0
	  ind1=0
	  do j=1,27
	    if(j.le.6)then
	      tri(i,j,0)=di(i,j)
	     else
	      if(j.eq.7.or.j.eq.13.or.j.eq
     &	        .18.or.j.eq.22.or.j.eq.25.or.j.eq.27)then  
	        ind1=ind1+1
	        ind2=ind1
	       else
	        ind2=ind2+1
	        endif
	      tri(i,ind1,ind2)=di(i,j)
	      endif
	    end do
	  end do	  
	return
	end