C
C       PROGRAM GOSIA2(INPUT,OUTPUT,TAPE6=OUTPUT,TAPE3,TAPE14,TAPE1,
C        *TAPE15,TAPE17,TAPE18,TAPE4,TAPE2,TAPE7,TAPE9)
C************************
C HANDLES SIMULTANEOUS PROJECTILE/TARGET EXCITATION
C   THIS IS A 32-GE DETECTOR 386+WEITEK SCALAR VERSION FROM MAR., 1989
C FULL Q MAPS CALCULATED FOR E1 THROUGH E4 - UPDATE FROM AUG. 1989
C NOTE: THERE IS NO LONGER THE DOMINANT MULTIPOLARITY SELECTED
C FULL MAPS AND FITTING OF E5,E6 ADDED - APRIL 1990
C XI AND ZETA RANGES CALCULATED FOR EACH MULTIPOLARITY INDEPENDENTLY
C
C May 1995 additions - matrix elements generator following general
C structure of matrix elements as given in Bohr-Mottelson book.
C Generator is activated by OP,THEO
C Using OP,THEO the starting values are set according to the model while
C all couplings are kept as given using ME suboption. OP,THEO writes
C matrix elements to restart file which should be used subsequently.
C
C Eh. Vogt's addition - OP,FILE - allows to specify OPEN statements,
C if convenient.
C
C November 1990 update - number of levels = 75, yields=32 x 1500
C magnetic substates = 600 matrix elements=500
C April 1991 update - OP,RAW added - handles non-efficiency-corrected
C spectra, allows to form Ge detector clusters. Up to 20 clusters
C can be defined. Number of physical Ge's increased to 200, while
C number of datasets (i.e. single detector+cluster gamma yields)
C is still limited to 32
C Output is written on unit 22 to avoid mixing it with system
C messages on some computers
C PIN diode option added -Sept. 96
C July 1997 - known matrix elements input in OP,YIEL extended to
C all multipolarities. Note change in the input, now:
C LAMDA, NS1, NS2, ME, DME
C************************
C            GOSIA HAS BEEN DEVELOPED BY T.CZOSNYKA,D.CLINE AND C.Y.WU
C            AT NUCLEAR STRUCTURE RESEARCH LABORATORY,UNIV. OF ROCHESTER
C            SOME CONCEPTS USED COME FROM 1978 WINTHER/DE BOER CODE
C            C O U L E X AND FROM NSRL DEEXCITATION CODE C E G R Y.
C            HOWEVER,THE PARTS TAKEN FROM BOTH CODES ARE IN MOST
C            CASES COMPLETELY REWRITTEN,SO THE SIMILARITY OF
C            VARIABLE AND ROUTINE NAMES MAY BE MISLEADING.
C
C            VALUABLE CONTRIBUTIONS WERE ALSO MADE BY:
C            L.HASSELGREN AND A.BACKLIN  (UPPSALA)
C            J.SREBRNY  (WARSAW)
C            B.KOTLINSKI  (WARSAW AND ROCHESTER)
C
C
C            FOR INFORMATION,PLEASE CONTACT:
C            TOMASZ CZOSNYKA,SLCJ, WARSAW UNIVERSITY, WARSZAWA, POLAND
C            02-297 WARSZAWA, BANACHA 4-----PHONE (22)-222-123
C            DOUGLAS CLINE,NSRL,THE UNIVERSITY OF ROCHESTER
C            ROCHESTER,NY14627,USA------PHONE(716)275-4943
C
C            REF.----   UR/NSRL REPORT 308/1986
C
C************************  VERSION FROM SEPT, 2005  *******************
C
C**********************************************************************
      LOGICAL ERR
      COMPLEX ARM,EXPO
      character*4 oph,op1,opcja,op2
      character*1 prp
      DIMENSION IHLM(32),ESP(20),DEDX(20),BTEN(1200)
     *,FIEX1(11,20,2),TITLE(20),PFI(101),ZMIR(6,2,50)
     *,IECD(50),WPI(11,2),TAU1(10),ENG(10),TAU2(10,7),XL1(7),
     *QUI(8,10),CF(8,2),IVARH(500),liscl(200),dsxm(100,20,20),levl(50)
     *,xlevb(50,2),bm(8,20,20,3),mlt(500),ivari(500),jpin(50)
      common/clust/iclust(50,200),lastcl(50,20),sumcl(20,500)
     *,irawex(50)
      common/cccds/ndst(50)
	common/switch/jzb,ibps
      common/inhi/inhb
      COMMON/IDENT/BEQ
      common/efcal/abc(8,10),akavka(8,200),thick(200,7)
      COMMON/PCOM/PSI(500)
      COMMON/TCM/TETACM(50),TREP(50),DSIGS(50)
      COMMON/BREC/BETAR(50)
      COMMON/ADBXI/EXPO(500)
      COMMON/DIMX/DIX(4),ODL(200)
      COMMON/TRA/DELTA(500,3),ENDEC(500),ITMA(50,200),ENZ(200)
      COMMON/CINIT/cnor(32,75),innr,mcfix,cnor1(32,75),cnor2(32,75)
      COMMON/XRA/SE
      COMMON/HHH/HLM(500)
      COMMON/VAC/VACDP(3,75),QCEN,DQ,XNOR,AKS(6,75),IBYP
      COMMON/LIFE/NLIFT
      COMMON/MIXD/DMIXE(20,2),DMIX(20),IMIX(20),NDL
      COMMON/ME2D/NAMX,IAMX(100),IAMY(100,2),EAMX(100,2)
      COMMON/LIFE1/LIFCT(50),TIMEL(2,50)
      COMMON/DFTB/DEVD(500),DEVU(500)
      COMMON/ERRAN/KFERR
	common/resc/elm25(500),elm26(500)
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/SECK/ISKIN(50)
      COMMON/VLIN/XV(51),YV(51),ZV(20),DSG(20),DSE(20),DS
      COMMON/DUMM/GRAD(500),HLMLM(500),ELMH(500)
      COMMON/BRNCH/BRAT(50,2),IBRC(2,50),NBRA
      COMMON/YEXPT/YEXP(32,1500),IY(1500,32),CORF(1500,32),DYEX(32,1500)
     *,NYLDE(50,32),UPL(32,50),YNRM(32,50),IDRN,ILE(32)
      COMMON/YTEOR/YGN(500),YGP(500),IFMO
      COMMON/LEV/TAU(75),KSEQ(500,4)
      COMMON/MAP/PARX(50,12,5),PARXM(50,4,10,6),XIR(6,50)
      COMMON/CCC/eg(50),cc(50,5),NANG(200),Q(3,200,8),NICC,
     *AGELI(50,200,2)
      COMMON/GGG/G(7)
	common/tutaj/part(32,50,2),partl(32,50,2)
      COMMON/AZ/ARM(600,7)
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      COMMON/CXI/XI(500)
      COMMON/ALLC/LOCQ(8,7)
      COMMON /CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON /COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      COMMON/MINNI/IMIN,LNORM(50)
      COMMON/CX/NEXPT,IZ,XA,IZ1(50),XA1(50),EP(50),TLBDG(50),VINF(50)
      COMMON /CEXC/MAGEXC,MEMAX,LMAXE,MEMX6,IVAR(500)
      COMMON/PRT/IPRM(20)
      COMMON /CCOUP/ZETA(50000),LZETA(8)
      COMMON /CB/B(20)
      COMMON /CLM/LMAX
      COMMON/CLCOM0/IFAC(75)
      COMMON/CLCOM8/CAT(600,3),ISMAX
      COMMON/CLCOM9/ERR
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON/CEXC9/INTERV(50)
      COMMON/CAUX0/NCM,EMMA(75)
      COMMON/PTH/IPATH(75),MAGA(75)
      COMMON/APRCAT/QAPR(500,2,7),IAPR(500,2),ISEX(75)
      COMMON/WARN/SGW,SUBCH1,SUBCH2,IWF
      COMMON/THTAR/ITTE(50)
      COMMON/FIT/LOCKF,NLOCK,IFBFL,LOCKS,DLOCK
      COMMON/APRX/LERF,IDIVE(50,2)
      COMMON/SKP/JSKIP(50)
      COMMON/TRB/ITS
      COMMON/SEL/KVAR(500)
      COMMON/ERCAL/JENTR,ICS
      COMMON/LOGY/LNY,INTR,IPS1
      COMMON/FAKUL/IP(26),IPI(26),KF(101,26),PILOG(26)
      DATA(ENG(K),K=1,10)/.05,.06,.08,.1,.15,.2,.3,.5,1.,1.5/
      DATA(TAU1(K),K=1,10)/17.656,10.726,5.076,2.931,1.3065,
     *.8828,.5959,.4357,.3041,.2472/
      DATA(TAU2(K,1),K=1,10)/.9883,.7473,.5442,.4592,.3718,
     *.3302,.2814,.2278,.1657,.1350/
      DATA(TAU2(K,2),K=1,10)/1.014,.7443,.5195,.4261,.3362,
     *.2967,.2518,.2038,.1479,.1204/
      DATA(TAU2(K,3),K=1,10)/15.167,9.405,4.652,2.889,1.525,
     *1.135,.8643,.6592,.4703,.3830/
      DATA(TAU2(K,4),K=1,10)/23.184,14.182,6.777,4.059,1.970,
     *1.384,.9936,.7473,.5274,.4297/
      DATA(TAU2(K,5),K=1,10)/84.351,51.445,23.822,13.070,
     *4.774,2.605,1.339,.7925,.5005,.4032/
      DATA(TAU2(K,6),K=1,10)/93.364,58.559,125.96,70.713,
     *25.302,12.541,5.193,2.215,1.077,.8176/
      DATA(TAU2(K,7),K=1,10)/89.809,56.338,27.009,62.966,
     *22.933,11.334,4.540,1.813,.8020,.5900/
	read*,ibps
	read 997,op1,op2
	call openf1
	ibps=ibps-1
	jzb=25
	nawr=0
	if(ibps.eq.1)jzb=26
      DO 8367 I=1,75
      DO 8367 J=1,32
	cnor1(j,i)=1.
	cnor2(j,i)=1.
 8367 CNOR(J,I)=1.
      mcfix=1
	mres1=0
	mrepf=0
	mret=-1
	chir=0.
	mawr=0
 1408 continue
      do 8812 i=1,50
 8812 lifct(i)=0
      chp=chir 
	if(mret.eq.1.and.jzb.eq.26)chir=0.
      rewind 25
	rewind 26
	read(jzb,*)ibps
	ibps=ibps-1
      jzb=25
      if(ibps.eq.1)jzb=26
      IBYP=0
      IP(1)=2
      IP(2)=3
      IP(3)=5
      IP(4)=7
      IP(5)=11
      IP(6)=13
      IP(7)=17
      IP(8)=19
      IP(9)=23
      IP(10)=29
      IP(11)=31
      IP(12)=37
      IP(13)=41
      IP(14)=43
      IP(15)=47
      IP(16)=53
      IP(17)=59
      IP(18)=61
      IP(19)=67
      IP(20)=71
      IP(21)=73
      IP(22)=79
      IP(23)=83
      IP(24)=89
      IP(25)=97
      IP(26)=101
      inhb=0
      BEQ=-983872.
      ipinf=0
      IYR=0
      PI=3.141592654
      INNR=0
      ITNO=0
      CHISQ=0.
      CHILO=0.
      IWF=1
      IFM=0
      IPS1=11
      IFWD=-1
      INTR=0
      LNY=0
      JENTR=0
      LP0=50000
      ICS=0
      LP1=50
      LP2=500
      LP3=75
      LP4=1500
      LP6=32
      LP7=LP0-4900
      LP8=LP3*28+1
      LP9=LP0-LP3*28
      LP10=600
      LP11=LP8-1
      LP12=365
      LP13=LP9+1
      LP14=4900
      DO 1676 I=1,LP1
      jpin(i)=0
 1676 IECD(I)=0
      TXX=0.
      SGW=3.
      SUBCH1=0.
      SUBCH2=0.
      ITS=0
      IOSR=0
      LOCKS=0
      DLOCK=1.1
      KERF=0
      IFBFL=0
      NLOCK=0
      LOCKF=0
      DO 3709 I=1,LP4
      DO 3709 J=1,LP6
 3709 CORF(I,J)=1.
      DO 3509 I=1,20
      IPRM(I)=1
      DO 3509 J=1,5
 3509 CC(I,J)=0.
      iprm(2)=0
      IPRM(4)=0
      IPRM(5)=1
      IPRM(6)=11111
      IPRM(7)=0
      IPRM(16)=0
      IPRM(17)=0
      IPRM(18)=0
      IPRM(19)=0
      IPRM(20)=0
	iprm(11)=0
	iprm(12)=0
	iprm(14)=0
      DO 3007 I=1,LP1
      DO 3008 J=1,5
      IF(J.EQ.5)GO TO 3031
      DO 3009 K=1,10
      DO 3009 KUKU=1,6
 3009 PARXM(I,J,K,KUKU)=0.
 3031 CONTINUE
      DO 3010 K=1,12
 3010 PARX(I,K,J)=0.
 3008 CONTINUE
 3007 CONTINUE
      DO 3011 K=1,LP1
      IDIVE(K,1)=1
      IDIVE(K,2)=1
      DO 3011 IUY=1,6
      XIR(IUY,K)=0.
 3011 CONTINUE
      IOBL=0
      LFAGG=0
      IZCAP=12800
      KFERR=0
      NDIM=LP3
      ISO=1
      B(1)=1.
      DO 80 I=2,20
 80   B(I)=B(I-1)*(I-1)
      LMAXE=0
      CALL FAKP
      CALL FHIP
      NCM=2
      DO 1282 IJX=1,LP1
 1282 INTERV(IJX)=1
      LA=0
      IPO3=1
      INDX=0
      ACCUR=.00001
      ICG=1
      IENT=1
      JPHD=1
      DIPOL=0.005
      MAGEXC=0
      LAMMAX=0
      DO 160 LAM=1,8
      DO 150 LEXP=1,LP3
 150  LDNUM(LAM,LEXP)=0
      MULTI(LAM)=0
 160  LAMDA(LAM)=0
      DO 200 J=1,LP2
      EXPO(J)=(1.,0.)
      KVAR(J)=1
 200  ELM(J)=0.
      DO 201 J=1,LP1
      JSKIP(J)=1
 201   ISKIN(J)=0
      DO 3810 J=1,LP3
 3810  ISEX(J)=1111
      ISEX(1)=0
      ACCA=.00001
       OPH='    '
      NMEMX=LP2+9
      IEXP=1
      IMIN=0
      I122=0
      DO 1741 J=1,LP2
      DO 1741 K=1,2
      DO 1741 L=1,7
 1741 QAPR(J,K,L)=0.
      ERR=.FALSE.
      INTEND=0
 994  FORMAT(1H1/1X,125(1H*)/1X,125(1H*)/1X,50(1H*),25X,50(1H*)/
     *1X,50(1H*),10X,6HGOSIA2,10X,50(1H*)/1X,50(1H*),25X,50(1H*)/
     *1X,125(1H*)/1X,125(1H*)////)
 2713 FORMAT(1X/20X,43HROCHESTER COULOMB EXCITATION DATA ANALYSIS
     *,37HCODE BY T.CZOSNYKA,D.CLINE AND C.Y.WU /50X,
     *27HLATEST REVISION- JUNE  2006//////)
 1    READ(jzb,997)OP1,OP2
      IF(OP1.NE.'OP, ')GO TO 7893
      IF(OP2.EQ.'GOSI')OPH=OP2
      IF(OP2.EQ.'GOSI')OPCJA=OP2
	if(OP2.eq.'FILE')call openf
      IF(OP2.EQ.'FILE')GO TO 1
      IF(JPHD.EQ.1)WRITE(22,994)
      IF(JPHD.EQ.1)WRITE(22,2713)
      JPHD=0
      IF(OP2.EQ.'GDET')GO TO 5200
      IF(OP2.EQ.'RAND')GO TO 331
      IF(OP2.EQ.'TROU')GO TO 9998
      IF(OP2.EQ.'REST')GO TO 330
      IF(OP2.EQ.'RE,A')GO TO 318
      IF(OP2.EQ.'RE,F')GO TO 318
      IF(OP2.EQ.'ERRO')GO TO 2
      IF(OP2.EQ.'RE,C')GO TO 319
      IF(OP2.EQ.'TITL')GOTO 899
      IF(OP2.EQ.'GOSI')GO TO 900
      IF(OP2.EQ.'COUL')GO TO 900
      IF(OP2.EQ.'EXIT')GO TO 430
      IF(OP2.EQ.'MINI')GO TO 673
      if(OP2.EQ.'THEO')go to 2913
      IF(OP2.EQ.'YIEL')GO TO 950
      IF(OP2.EQ.'INTG')GO TO 471
      IF(OP2.EQ.'CORR')GO TO 310
      IF(OP2.EQ.'POIN')GO TO 805
      IF(OP2.EQ.'MAP ')IOBL=1
      IF(OP2.EQ.'STAR')GO TO 805
      IF(OP2.EQ.'SIXJ')GO TO 1410
      IF(OP2.EQ.'RAW ')GO TO 30
      IF(OP2.EQ.'MAP ')GO TO 805
 7893 WRITE(22,7894)OP1,OP2
 7894 FORMAT(5X,19HUNRECOGNIZED OPTION,1X,1A3,1A4)
      GO TO 9999
 900  READ(jzb,996)OP1
      IF(OP1.EQ.'    ')GO TO 1
      IF(OP1.EQ.'LEVE')GO TO 800
      IF(OP1.EQ.'ME  ')GO TO 801
      IF(OP1.EQ.'CONT')GO TO 803
      IF(OP1.EQ.'EXPT')GO TO 804
      WRITE(22,7895)OP1
 7895 FORMAT(5X,22HUNRECOGNIZED SUBOPTION,1X,1A4)
      GO TO 9999
 2913 rewind(12)
      ibaf=1
      do 2915 jb=1,lp1
      do 2915 lb=1,2
      xlevb(jb,lb)=0
 2915 continue     
      read(jzb,*)nbands
      if(nbands.le.0)ibaf=0
      nbands=iabs(nbands) 
      do 2920 nl=1,8
      do 2920 jb=1,nbands
      do 2920 jl=1,nbands
      do 2920 kl=1,3
 2920 bm(nl,jb,jl,kl)=0.     
      do 2914 jb=1,nbands
      read(jzb,*)bk,ilevls
      read(jzb,*)(levl(ib),ib=1,ilevls)
      do 2916 kb=1,ilevls
      inva=levl(kb)
      xlevb(inva,2)=bk
 2916 xlevb(inva,1)=float(jb)               
 2914 continue
      do 2955 nl=1,8
      read(jzb,*)nnl
 2949 continue
      if(nnl.le.0)go to 2917 
      read(jzb,*)jb1,jb2
      if(jb1.eq.0)go to 2955 
      read(jzb,*)(bm(nnl,jb1,jb2,j),j=1,3)
      do 2981 j=1,3
 2981 bm(nnl,jb2,jb1,j)=bm(nnl,jb1,jb2,j)
      go to 2949
 2955 continue
 2917 continue
      do 2918 kb=1,memax
      if(ibaf.eq.0)go to 2918
      ind1=lead(1,kb)
      ind2=lead(2,kb)
      xi1=spin(ind1)
      xi2=spin(ind2)
      lamd=mlt(kb)
      nb1=ifix(xlevb(ind1,1)+.1)            
      nb2=ifix(xlevb(ind2,1)+.1)
      xk1=xlevb(ind1,2)
      xk2=xlevb(ind2,2)
      xm1=bm(lamd,nb1,nb2,1)
      xm2=bm(lamd,nb1,nb2,2)
      xm3=bm(lamd,nb1,nb2,3)
      elm(kb)=elmt(xi1,xi2,lamd,nb1,nb2,xk1,xk2,xm1,xm2,xm3)
      if(abs(elm(kb)).lt.1e-6)elm(kb)=1.e-6
	irix=12
	if(ibps.eq.1)irix=32
      write(irix,*)elm(kb)
 2918 continue
      go to 1     
 30   rewind 8
      do 31 l=1,8
      read(8,*)(abc(l,j),j=1,10)
      do 32 j=1,10
  32  abc(l,j)=alog(abc(l,j))
  31  continue
      do 33 l=1,nfd
  33  read(8,*)(thick(l,j),j=1,7)
      do 34 l=1,lp1
      do 38 j=1,200
  38  iclust(l,j)=0
      do 39 j=1,20
  39  lastcl(l,j)=0
  34  irawex(l)=0
      do 35 l=1,lp1
      read(jzb,*)mexl
      if(mexl.eq.0)go to 1
      irawex(mexl)=1
      n=nang(mexl)
      do 36 j=1,n
      jj=itma(mexl,j)
      read(jzb,*)(akavka(k,jj),k=1,8)
  36  continue
      read(jzb,*)kclust
      if(kclust.eq.0)go to 35
      do 37 j=1,kclust
      read(jzb,*)numcl
      read(jzb,*)(liscl(k),k=1,numcl)
      lastcl(l,j)=liscl(numcl)
      do 41 k=1,numcl
      kk=liscl(k)
      iclust(l,kk)=j
   41 continue
   37 continue
   35 continue
      go to 1
 5200 CONTINUE
      NL=7
      read(jzb,*)NFDD
      nfd=iabs(nfdd)
      if(nfdd.gt.0)go to 5208
      rewind 8
      do 5209 i=1,nl
 5209 write(8,*)(tau2(l,i),l=1,10)
      write(8,*)(eng(l),l=1,10)
 5208 REWIND 9
      WRITE(9,*)NFD
      DO 5201 I=1,NFD
      read(jzb,*)(DIX(K),K=1,4)
      read(jzb,*)(XL1(K),K=1,NL)
      IF(DIX(1).le.0.)DIX(1)=.01
      WRITE(9,*)DIX(4)
      if(nfdd.gt.0)go to 5207
      write(8,*)(xl1(k),k=1,nl)
 5207 continue
      IND=1
      IF(XL1(5).gt.0.)IND=3
      IF(XL1(6).gt.0.)IND=4
      IF(XL1(7).gt.0.)IND=5
      WRITE(9,*)ENG(IND)
      CALL QFIT(QUI,TAU1,TAU2,ENG,XL1,CF,NL,IND)
      WRITE(22,5206)I
      DO 5202 K=1,8
      WRITE(22,5203)K,CF(K,1),CF(K,2)
      WRITE(9,*)CF(K,1),CF(K,2),QUI(K,IND)
      DO 5204 L=1,10
      ARG=(ENG(L)-ENG(IND))**2
      QC=(QUI(K,IND)*CF(K,2)+CF(K,1)*ARG)/(CF(K,2)+ARG)
 5204 WRITE(22,5205)ENG(L),QC,QUI(K,L),100.*(QC-QUI(K,L))/QUI(K,L)
 5202 CONTINUE
 5201 CONTINUE
 5206 FORMAT(10X,8HDETECTOR,1X,1I2)
 5203 FORMAT(1X,//5X,2HK=,1I1,2X,3HC1=,1E14.6,2X,3HC2=,1E14.6/
     *5X,11HENERGY(MEV),5X,9HFITTED QK,5X,7HCALC.QK,5X,
     *8HPC.DIFF./)
 5205 FORMAT(8X,1F4.2,6X,1F9.4,5X,1F9.4,3X,1E10.2)
      GO TO 1
 1410 CONTINUE
      DO 1411 K=1,2
      L=4*K
      DO 1412 J=1,80
      IXJ=J-1
      DO 1413 MS=1,5
      MEND=2*(MS-3)+IXJ
      WRITE(14,*)WSIXJ(L,4,4,IXJ,MEND,IXJ-4),
     *WSIXJ(L,4,4,IXJ,MEND,IXJ-2),
     *WSIXJ(L,4,4,IXJ,MEND,IXJ),WSIXJ(L,4,4,IXJ,MEND,IXJ+2),
     *WSIXJ(L,4,4,IXJ,MEND,IXJ+4)
 1413 CONTINUE
 1412 CONTINUE
 1411 CONTINUE
      GO TO 9999
 2    read(jzb,*)IDF,MS,MEND,IREP,IFC,REMAX
      mcfix=0
	do 7321 mmmm=1,32
	do 7321 kkkk=1,50
 7321 read(13,*)cnor1(mmmm,kkkk)	
      REM=ALOG(REMAX)
      LOCKS=0
      LOCKF=0
      JENTR=1
      SH=1.
      IFBP=0
      INPO=1
      INKO=1
      IF(IOSR.EQ.0.OR.IDF.EQ.0)GO TO 3212
      INN=0
      IJ=MULTI(1)
      IF(IJ.EQ.0)GO TO 3213
      DO 3214 IJ=1,NMAX
      LXD=LDNUM(1,IJ)
      IF(LXD.EQ.0)GO TO 3214
      DO 3215 IJK=1,LXD
 3215 INN=INN+1
 3214 CONTINUE
      INPO=INN+1
 3213 CONTINUE
      DO 3216 IJ=1,NMAX
      LXD=LDNUM(2,IJ)
      IF(LXD.EQ.0)GO TO 3216
      DO 3218 IJK=1,LXD
 3218 INN=INN+1
 3216 CONTINUE
      INKO=INN
      IF(IREP.EQ.2)GO TO 3212
      WRITE(33,*)NMAX,MEMAX,INPO,INKO
      DO 3273 INN=1,NMAX
 3273 WRITE(33,*)INN,SPIN(INN),EN(INN)
      DO 3219 INN=1,MEMAX
 3219 WRITE(33,*)INN,LEAD(1,INN),LEAD(2,INN)
      DO 3220 INN=1,MEMAX
 3220 WRITE(33,*)INN,ELM(INN)
 3212 CONTINUE
      IF(IREP.NE.0)GO TO 4222
      DO 91 KH1=1,MEMAX
      DEVD(KH1)=ELML(KH1)-ELM(KH1)
 91   DEVU(KH1)=ELMU(KH1)-ELM(KH1)
      GO TO 4223
 4222 REWIND 15
      READ(15,*)(DEVD(KH1),DEVU(KH1),KH1=1,MEMAX)
 4223 CONTINUE
      IF(IMIN.EQ.0)CALL CMLAB(0,DSIG,TTTTT)
      IF(ERR)GO TO 9999
      IF(IMIN.EQ.0)GO TO 610
  7   CONTINUE
      IF(ICS.EQ.1)GO TO 7227
      CALL FTBM(0,CHISS,IDR,0,CHILO,BTEN)
      REWIND 11
      DO 3712 KH1=1,LP4
 3712 write(11)(CORF(KH1,KH2),KH2=1,LP6)
      GO TO 3917
 7227 REWIND 11
      DO 3711 KH1=1,LP4
 3711 read(11)(CORF(KH1,KH2),KH2=1,LP6)
 3917 CALL FTBM(3,CHISS,IDR,1,CHILO,BTEN)
      CHIS0=CHISS
      WRITE(22,1912)CHIS0
      inhb=1
 1912 FORMAT(1X///10X,20H***** CENTRAL CHISQ=,1E12.4,1X,5H*****//)
      CHISL=CHISS
      DO 8 KH=1,MEMAX
 8    HLM(KH)=ELM(KH)
      IF(IDF.EQ.1)GO TO 4000
      NAXFL=0
      IF(MS.EQ.0)MEND=MEMAX
      IF(MS.EQ.0)MS=1
      DO 4002 KH=MS,MEND
      DO 4271 IJ=1,2
       PV=(ELMU(KH)-ELML(KH))/100.
       IF(IJ.EQ.1.AND.(ELM(KH)-ELML(KH)).LT.PV)GO TO 4271
       IF(IJ.EQ.2.AND.(ELMU(KH)-ELM(KH)).LT.PV)GO TO 4271
      DO 4003 KH1=1,MEMAX
 4003 SA(KH1)=0.
      IF(IVAR(KH).EQ.0)GO TO 4002
      SA(KH)=1.*(-1)**IJ
      KH1=KH
      CALL KONTUR(IDR,CHIS0,CHISL,IFBP,-1,KH1,SH,BTEN,REM)
      ELM(KH)=HLM(KH)
 4271 CONTINUE
      REWIND 15
      WRITE(15,*)(DEVD(IJ),DEVU(IJ),IJ=1,MEMAX)
 4002 CONTINUE
 3235 IF(IFBP.NE.1)GO TO 65
      REWIND 17
      DO 1645 LKJ=1,MEMAX
      READ(17,*)ELM(LKJ)
 1645 CONTINUE
      WRITE(22,6828)
 6828 FORMAT(1X///20X,33H*** BEST POINT FOUND (TAPE17) ***///)
      CALL PRELM(3)
  65  CONTINUE
      IF(NAXFL.EQ.0)WRITE(22,6662)
      IF(NAXFL.NE.0)WRITE(22,6673)
 6673 FORMAT(1X///44X,7HOVERALL)
 6662 FORMAT(1X///43X,8HDIAGONAL)
      WRITE(22,66)
 66   FORMAT(40X,16HESTIMATED ERRORS//5X,
     *5HINDEX,5X,2HNI,5X,2HNF,5X,13HME AND ERRORS//)
      DO 67 KH1=1,MEMAX
      IF(IVAR(KH1).EQ.0.OR.IVAR(KH1).GT.999)GO TO 67
      WRITE(22,68)KH1,LEAD(1,KH1),LEAD(2,KH1),HLM(KH1),DEVD(KH1),
     *DEVU(KH1),DEVD(KH1)*100./ABS(HLM(KH1)),
     *DEVU(KH1)*100./ABS(HLM(KH1))
 68   FORMAT(6X,1I3,6X,1I2,5X,1I2,5X,1F9.5,2X,1H(,1F9.5,2H ,,1F9.5,
     *1H),6H......,1F7.1,2H ,,1F7.1,1X,2HPC)
 67   CONTINUE
      IF(NAXFL.NE.0)WRITE(22,6673)
      IF(NAXFL.EQ.0)WRITE(22,6662)
      WRITE(22,6692)
 6692 FORMAT(40X,16HESTIMATED ERRORS,//5X,
     *5HINDEX,5X,2HNI,5X,2HNF,5X,29HB(E,ML)(OR QUADRUPOLE MOMENT)
     *,11H AND ERRORS//)
      DO 6695 KH2=1,MEMAX
      IF(IVAR(KH2).EQ.0.OR.IVAR(KH2).GT.999) GO TO 6695
      ISPA=LEAD(2,KH2)
      IF(LEAD(1,KH2).NE.LEAD(2,KH2)) GO TO 6697
      ISPB=IFIX(SPIN(ISPA))*2
      QFAC=3.170662*WTHREJ(ISPB,4,ISPB,-ISPB,0,ISPB)
      WRITE(22,6694) KH2,LEAD(2,KH2),LEAD(1,KH2),HLM(KH2)*QFAC,
     *DEVD(KH2)*QFAC,DEVU(KH2)*QFAC
      GO TO 6695
 6697 SBE=2.*SPIN(ISPA)+1.
      BE2=HLM(KH2)*HLM(KH2)/SBE
      BE2A=HLM(KH2)+DEVD(KH2)
      BE2B=HLM(KH2)+DEVU(KH2)
      BE2C=BE2B
      IF(ABS(BE2A).GT.ABS(BE2B)) BE2B=BE2A
      IF(abs(be2a-be2c).lt.1.e-6) BE2A=BE2C
      IF(BE2A/HLM(KH2).LE.0..OR.BE2B/HLM(KH2).LE.0.) BE2A=0.
      BE2A=BE2A**2/SBE
      BE2B=BE2B**2/SBE
      WRITE(22,6694) KH2,LEAD(2,KH2),LEAD(1,KH2),BE2,BE2A-BE2,BE2B-BE2
 6694 FORMAT(6X,1I3,6X,1I2,5X,1I2,5X,1F10.5,2X,1H(,1F10.5,2H ,,1F10.5,
     *1H))
 6695 CONTINUE
      GO TO 9999
 4000 CONTINUE
      IFBFL=1
      IF(IREP.NE.2)GO TO 4057
      IF(IOSR.EQ.0)GO TO 4057
      REWIND 33
      READ(33,*)LL,MM,KK,INN
      DO 4058 INN=1,LL
 4058 READ(33,*)MM,YYY,ZZ
      DO 4059 INN=1,MEMAX
 4059 READ(33,*)MM,LL,KK
      DO 4060 INN=1,MEMAX
 4060 READ(33,*)MM,YYY
 4063 READ(33,*)MM,LL
      IF(MM.EQ.0)GO TO 4061
      READ(33,*)KK,LL,YYY
      READ(33,*)(SA(MM),MM=1,MEMAX)
      GO TO 4063
 4061 BACKSPACE 33
 4057 CONTINUE
      IREA=0
      IF(MS.LT.0)IREA=1
      IF(MS.EQ.0)MEND=MEMAX
      IF(MS.EQ.0)MS=1
 4127 NAXFL=1
      IF(IREA.EQ.1)read(jzb,*)MS,MEND
      IF(MS.EQ.0)GO TO 4128
      DO 4510 KH=MS,MEND
      IF(IFC.EQ.1)GO TO 4552
      REWIND 18
      DO 4821 KH1=1,KH
 4821 READ(18,*)(KVAR(JYI),JYI=1,MEMAX)
      DO 4621 KH1=1,MEMAX
      IVRH=IVAR(KH1)
      IF(KVAR(KH1).EQ.0)IVAR(KH1)=0
 4621 KVAR(KH1)=IVRH
 4552 CONTINUE
      DO 4553 IJ=1,2
      SH=DEVU(KH)
      IF(IJ.EQ.1)SH=DEVD(KH)
      IF(abs(SH).lt.1.e-6)SH=(-1)**IJ*ABS(HLM(KH))/10.
      ELM(KH)=HLM(KH)+1.5*SH
      MM=0
      DO 4129 KH1=1,MEMAX
      if(ifc.eq.1)kvar(kh1)=ivar(kh1)
 4129 MM=MM+IVAR(KH1)
      IF(MM.EQ.0)WRITE(22,4131)KH
      IF(MM.EQ.0)GO TO 3232
 4131 FORMAT(10X,3HME=,1I3,5X,
     *23HNO FREE MATRIX ELEMENTS)
      KFERR=1
      IF(IOSR.EQ.1)WRITE(33,*)KH,KH
      IF(IOSR.EQ.1)WRITE(33,*)KH,IJ,ELM(KH)
      LOCKS=1
      DLOCK=.05
      CALL MINI(CHISS,-1.,2,.0001,1000,IDR,100000.,0,IOSR,KH,BTEN)
      DO 4511 KH1=1,MEMAX
 4511 SA(KH1)=(ELM(KH1)-HLM(KH1))/ABS(SH)
      CALL KONTUR(IDR,CHIS0,CHISL,IFBP,INPO,KH,SH,BTEN,REM)
 3232 CONTINUE
      DO 4512 KH1=1,MEMAX
      if(ifc.eq.1)ivar(kh1)=kvar(kh1)
 4512 ELM(KH1)=HLM(KH1)
 4553 CONTINUE
      IF(IFC.EQ.1)GO TO 4555
      DO 4554 KH1=1,MEMAX
 4554 IVAR(KH1)=KVAR(KH1)
 4555 CONTINUE
      REWIND 15
      WRITE(15,*)(DEVD(KH1),DEVU(KH1),KH1=1,MEMAX)
 4510 CONTINUE
      IF(IREA.EQ.1)GO TO 4127
 4128 CONTINUE
      IF(IOSR.EQ.0)GO TO 3234
      IM=0
      WRITE(33,*)IM,IM
 3234 GO TO 3235
 318  JFRE=0
      IRFIX=0
      IF(OP2.EQ.'RE,F')IRFIX=1
      GO TO 321
 319  JFRE=1
      IRFIX=0
 321  DO 322 JRLS=1,MEMAX
      IF(IVAR(JRLS).EQ.0.AND.IRFIX.EQ.1)GO TO 322
      IF(IVAR(JRLS).GT.999)GO TO 323
 324  IVAR(JRLS)=2
      ELML(JRLS)=-ABS(ELML(JRLS))
      ELMU(JRLS)=ABS(ELMU(JRLS))
      IF(JRLS.GT.MEMX6)IVAR(JRLS)=1
      GO TO 322
 323  IF(JFRE.EQ.1)GO TO 322
      GO TO 324
 322  CONTINUE
      DO 1895 JRLS=1,MEMAX
 1895 IVARH(JRLS)=IVAR(JRLS)
      GO TO 1
 331  read(jzb,*)SE
      CALL MIXUP
      WRITE(22,317)
 317  FORMAT(1X///5X,29HMATRIX ELEMENTS RANDOMIZED...///)
      CALL PRELM(2)
      GO TO 1
 330  irix=12
      if(ibps.eq.1)irix=32
      REWIND irix
      memax1=memax+1
      DO 5296 LKJ=1,memax
 5296 READ(irix,*)ELM(LKJ)
      DO 5298 LKJ=1,memax1
      read(jzb,*)LKJ1,XLK
      IF(LKJ1.EQ.0)GO TO 5299
      if(mres1.eq.0)ELM(LKJ1)=XLK
 5298 CONTINUE
 5299 CONTINUE
      do 8331 lkj=1,memax
	if(mres1.eq.0.and.jzb.eq.25)elm25(lkj)=elm(lkj)
	if(mres1.eq.0.and.jzb.eq.26)elm26(lkj)=elm(lkj)
 8331 continue	
      if(jzb.eq.26)mres1=1
      WRITE(22,5523)
 5523  FORMAT(1X///5X,5H*****,2X,
     *35HRESTART-MATRIX ELEMENTS OVERWRITTEN,2X,5H*****///)
       do 7933 kk=1,memax
       la=mlt(kk)
       IF(IVARI(KK).LT.10000)GO TO 7933
      KK1=IVARI(KK)/10000
      KK2=IVARI(KK)-10000*KK1
       LA1=LA
       IF(KK2.LT.100)GO TO 8428
       LA1=KK2/100
       KK2=KK2-100*LA1
 8428  continue
      INX1=MEM(KK1,KK2,LA1)
C      ELML(KK)=ELML(INX1)*ELM(KK)/ELM(INX1)
C      ELMU(KK)=ELMU(INX1)*ELM(KK)/ELM(INX1)
      SA(KK)=ELM(KK)/ELM(INX1)
      IVAR(KK)=1000+INX1
      IF(ELMU(KK).GT.ELML(KK))GO TO 7933
      ELMI=ELMU(KK)
      ELMU(KK)=ELML(KK)
      ELML(KK)=ELMI
 7933  CONTINUE
      CALL PRELM(4)
      GO TO 1
 471  CONTINUE
      REWIND 14
      LFAGG=1
      IF(SPIN(1).lt..25)ISO=0
      DO 472 LX=1,NEXPT
      lpin=1
      if(ipinf.eq.0)go to 1472
      if(jpin(lx).eq.0)go to 1472
      lpin=jpin(lx)
 1472 continue
      IEXP=LX
      TTH=TLBDG(LX)
      ENH=EP(LX)
      do 1473 mpin=1,lpin
      IF(IECD(LX).EQ.1) GO TO 1677
      read(jzb,*)NE,NTT,EMN,EMX,TMN,TMX
      GO TO 1678
 1677 read(jzb,*)NE,NTT,EMN,EMX,WTH,WPH,WTHH
      MFLA=1
      CALL COORD(WTH,WPH,WTHH,NTT,0,PFI,WPI,TTH,LX,TMN,TMX)
      GO TO 1679
 1678 CONTINUE
       MFLA=0
       IF(NTT.LT.0)MFLA=1
 1679 NTT=IABS(NTT)
      JAN=NANG(LX)
      jan1=ndst(lx)
      if(irawex(lx).eq.0)jan1=jan
      IF(IECD(LX).EQ.1) GO TO 1690
      WRITE(14,*)NE,NTT,EMN,EMX,TMN,TMX,JAN1,TMX,TMX,TMX
      GO TO 1691
 1690 WRITE(14,*)NE,NTT,EMN,EMX,TMN,TMX,JAN1,WTH,WPH,WTHH
 1691 CONTINUE
      read(jzb,*)(XV(I),I=1,NE)
      IF(IECD(LX).EQ.1) GO TO 1692
      read(jzb,*)(YV(I),I=1,NTT)
 1692 CONTINUE
      IF(TTH.LT.0.)ELMH(2*LX-1)=YV(1)
      IF(TTH.LT.0.)ELMH(2*LX)=YV(NTT)
      DO 474 KLOOP=1,NE
      ENB=XV(KLOOP)
      EP(LX)=ENB
      DO 474 KTT=1,NTT
      TTA=SIGN(YV(KTT),TTH)
      IF(IAXS(LX).EQ.0)GO TO 552
      IF(IECD(LX).EQ.1) GO TO 552
      IF(KLOOP.NE.1) GO TO 552
      read(jzb,*)NFI
      read(jzb,*)(FIEX1(KTT,JFI,1),FIEX1(KTT,JFI,2),JFI=1,NFI)
      IF(TTH.GE.0.) GO TO 552
      DO 555 JFI=1,NFI
      FIEX1(KTT,JFI,1)=FIEX1(KTT,JFI,1)+180.
 555  FIEX1(KTT,JFI,2)=FIEX1(KTT,JFI,2)+180.
 552  TLBDG(LX)=TTA
      IF(KLOOP.NE.1) GO TO 1680
      IF(IECD(LX).EQ.0) GO TO 1680
      NFI=1
      FIEX1(KTT,1,1)=WPI(KTT,1)
      FIEX1(KTT,1,2)=WPI(KTT,2)
 1680 CALL CMLAB(LX,DSIG,TETRC)
      IF(ERR)GO TO 9999
      TTING=TLBDG(LX)
      IF(ERR)GO TO 999
      CALL LOAD(LX,1,1,0.,JJ)
      CALL ALLOC(ACCUR)
      CALL SNAKE(LX,ZPOL)
      CALL SETIN
      DO 475 J=1,LMAX
      POLM=FLOAT(J-1)-SPIN(1)
      CALL LOAD(LX,2,1,POLM,JJ)
      CALL STING(JJ)
      CALL PATH(JJ)
      CALL INTG(IEXP)
      CALL TENB(J,BTEN,LMAX)
 475  CONTINUE
      CALL TENS(BTEN)
      CALL DECAY(CCD,0,CCC)
      do 7257 j=1,lp2
      do 7257 ijan=1,20
 7257 sumcl(ijan,j)=0.
      ija0=0
      DO 497 IJAN=1,JAN
      IF(IAXS(LX).EQ.0)NFI=1
      DO 477 JYI=1,IDR
 477  GRAD(JYI)=0.
      TODFI=0.
      DO 476 JFI=1,NFI
      FI0=FIEX1(KTT,JFI,1)/57.2957795
      FI1=FIEX1(KTT,JFI,2)/57.2957795
      GTH=AGELI(IEXP,IJAN,1)
      fm=(fi0+fi1)/2.
      FIGL=AGELI(IEXP,IJAN,2)
      CALL ANGULA(YGN,IDR,1,FI0,FI1,TETRC,GTH,FIGL,IJAN,OP2)
      IF(IFMO.EQ.0)GO TO 7232
      ID=ITMA(IEXP,IJAN)
      D=ODL(ID)
      RX=D*SIN(GTH)*COS(FIGL-FM)-.25*SIN(TETRC)*COS(FM)
      RY=D*SIN(GTH)*SIN(FIGL-FM)-.25*SIN(TETRC)*SIN(FM)
      RZ=D*COS(GTH)-.25*COS(TETRC)
      RL=SQRT(RX*RX+RY*RY+RZ*RZ)
      SF=D*D/RL/RL
      THC=TACOS(RZ/RL)
      FIC=ATAN2(RY,RX)
      CALL ANGULA(YGP,IDR,1,FI0,FI1,TETRC,THC,FIC,IJAN,OP2)
      DO 7233 IXL=1,IDR
      IXM=KSEQ(IXL,3)
      TFAC=TAU(IXM)
 7233 YGN(IXL)=YGN(IXL)+.01199182*TFAC*BETAR(IEXP)*
     *(SF*YGP(IXL)-YGN(IXL))
 7232 CONTINUE
      if(irawex(lx).eq.0)go to 7252
      ipd=itma(lx,ijan)
      do 7253 jyi=1,idr
      ni=kseq(jyi,3)
      nf=kseq(jyi,4)
      decen=en(ni)-en(nf)
      cocos=sin(tetrc)*sin(gth)*cos(fm-figl)+cos(tetrc)*
     *cos(gth)
      decen=decen*(1.+betar(lx)*cocos)
      call effix(ipd,decen,effi)
      ygn(jyi)=ygn(jyi)*effi
 7253 continue
      inclus=iclust(lx,ijan)
      if(inclus.eq.0)go to 7252
      do 7254 jyi=1,idr
 7254 sumcl(inclus,jyi)=sumcl(inclus,jyi)+ygn(jyi)
      if(ijan.ne.lastcl(lx,inclus))go to 497
      do 7255 jyi=1,idr
 7255 ygn(jyi)=sumcl(inclus,jyi)
 7252 continue
      if(jfi.eq.1)ija0=ija0+1
      DO 498 JYI=1,IDR
 498  GRAD(JYI)=GRAD(JYI)+YGN(JYI)
       TODFI=TODFI+ABS(FI1-FI0)
 476  CONTINUE
      IF(IAXS(LX).EQ.0) TODFI=6.283185
      AX=1.
       IF(MFLA.EQ.1)AX=1./TODFI
      DSX=DSIG
      IF(MFLA.NE.1) DSX=DSIG*TODFI
      dsxm(mpin,kloop,ktt)=dsx
	write(17,*)lx,mpin,kloop,ktt,dsx
      WRITE(14,*)LX,ENB,TTING,IJA0,DSX,(GRAD(JYI)*DSIG*AX,JYI=1
     *,IDR)
      IF(IPRM(11).NE.1)GO TO 497
      WRITE(22,478)LX,IJA0,ENB,TTA
      IF(TTA.LT.0.)WRITE(22,387)TTING
 387  FORMAT(5X,35HRESPECTIVE TARGET SCATTERING ANGLE=,1F7.3
     *,1X,3HDEG/)
      DO 479 JYI=1,IDR
      NI=KSEQ(JYI,3)
      NF=KSEQ(JYI,4)
 479  WRITE(22,480)NI,NF,SPIN(NI),SPIN(NF),GRAD(JYI)*DSIG*AX
     *,GRAD(JYI)/GRAD(IDRN)
 478  FORMAT(1X//50X,17HCALCULATED YIELDS//
     *5X,11HEXPERIMENT ,1I2,2X,9HDETECTOR ,1I2/
     *5X,7HENERGY ,1F10.3,1X,3HMEV,2X,6HTHETA ,1F7.3,1X,3HDEG
     *//5X,2HNI,5X,2HNF,5X,2HII,5X,2HIF,5X,5HYIELD,
     *5X,16HNORMALIZED YIELD/)
4478  format(1x//50x,17hCALCULATED YIELDS//
     *5x,11hEXPERIMENT ,1i2,2x,9hDETECTOR ,1i2/
     *5x,7hENERGY ,1f10.3,1x,3hMEV,2x,6hTHETA ,1f7.3,1x,3hDEG
     *//5x,2hNI,5x,2hNF,5x,2hII,5x,2hIF,5x,6hE(MeV),
     *5x,'EFFICIENCY'/)
 480  FORMAT(5X,1I2,5X,1I2,3X,1F4.1,3X,1F4.1,3X,1E11.5,3X
     *,1E11.5)
 497  CONTINUE
 474  CONTINUE
 1473 continue
      EP(LX)=ENH
      TLBDG(LX)=TTH
 472  CONTINUE
      REWIND 14
      REWIND 15
      ISKE=0
      DO 4328 NA=1,LP6
 4328 ILE(NA)=1
      ilx=0
      DO 530 LX=1,NEXPT
	rewind 17
	do 1728 ijaja=1,300000
	read(17,*,END=1729)jjlx,jmpin,jkloo,jktt,dsx
	if(jjlx.eq.lx)dsxm(jmpin,jkloo,jktt)=dsx
 1728 continue
 1729 continue	
      NA=NANG(LX)
      IF(LX.EQ.1)GO TO 4329
      DO 4330 NA1=1,LP6
 4330 ILE(NA1)=ILE(NA1)+NYLDE(LX-1,NA1)
 4329 read(jzb,*)NPTX
      IF(NPTX.EQ.0)GO TO 531
      read(jzb,*)(ESP(I),I=1,NPTX)
      read(jzb,*)(DEDX(I),I=1,NPTX)
      NPT=NPTX
 531  read(jzb,*)NPCE,NPCT
       MFLA=0
      IF(NPCT.LT.0)MFLA=1
      IF(IECD(LX).EQ.1) MFLA=1
      NPCT=IABS(NPCT)
      NPCE=NPCE+MOD(NPCE,2)
      NPCT=NPCT+MOD(NPCT,2)
      mpin=1
      if(ipinf.eq.0)go to 1530
      if(jpin(lx).eq.0)go to 1530
      mpin=jpin(lx)
 1530 continue
      dst=0.
      do 1531 lpin=1,mpin
      ilx=ilx+1
      IF(iLX.EQ.1)GO TO 532
      CALL TAPMA(LX,ISKE,ISKO,ISKF,NFLR,IDR,0,NFT,ENB)
 532  READ(14,*)NE,NTT,EMN,EMX,TMN,TMX,JAN,WTH,WPH,WTHH
      IOCC=(NE+NTT)*IDR
      IF(IOCC.GT.IZCAP)GO TO 598
      HEN=(EMX-EMN)/NPCE
      NPCE1=NPCE+1
      HET=(TMX-TMN)/NPCT
      NPCT1=NPCT+1
      IF(IECD(LX).EQ.1) CALL COORD(WTH,WPH,WTHH,NPCT1,1,PFI,WPI,
     *TLBDG(LX),LX,TMN,TMX)
      IF(IECD(LX).EQ.1) GO TO 1681
       IF(MFLA.EQ.1)read(jzb,*)(PFI(J),J=1,NPCT1)
 1681 HET=HET/57.2957795
      DO 533 J=1,NPCE1
      XX=(J-1)*HEN+EMN
      CALL LAGRAN(ESP,DEDX,NPT,1,XX,YY,3,1)
 533  HLMLM(J)=1./YY
      naa=ndst(lx)
      if(irawex(lx).eq.0)naa=nang(lx)
      ISKF=NAA-1
      DO 534 JA=1,NAA
      ICLL=3
      DO 535 JE=1,NE
      LU=ILE(JA)
      ISKO=(JE-1)*NAA*NTT+JA-1
      CALL TAPMA(LX,ISKE,ISKO,ISKF,NTT,IDR,1,NFT,ENB)
      IF(NFT.EQ.1)GO TO 999
      DO 536 JD=1,IDR
      DO 537 JTP=1,NTT
      IF(JD.EQ.1.AND.JA.EQ.1)DSG(JTP)=dsxm(lpin,je,jtp)
      JYV=(JTP-1)*IDR+JD
 537  YV(JTP)=ZETA(JYV)
      DO 5000 JT=1,NPCT1
      XX=(JT-1)*HET+TMN/57.2957795
      CALL LAGRAN(XV,YV,NTT,JT,XX,YY,2,ICLL)
      CALL LAGRAN(XV,DSG,NTT,JT,XX,ZZ,2,ICLL)
      IF(MFLA.EQ.1)YY=YY*PFI(JT)/57.2957795
      IF(YY.le.0.)YY=1.E-15
      IF(MFLA.EQ.1)ZZ=ZZ*PFI(JT)/57.2957795
      XI(JT)=YY*SIN(XX)
      IF(JD.EQ.1.AND.JA.EQ.1)HLM(JT)=ZZ*SIN(XX)
 5000 CONTINUE
      ICLL=4
      LOCAT=NTT*IDR+(JE-1)*IDR+JD
      ZETA(LOCAT)=SIMIN(NPCT1,HET,XI)
      IF(JD.EQ.1.AND.JA.EQ.1)DSE(JE)=SIMIN(NPCT1,HET,HLM)
      ZV(JE)=ENB
 536  CONTINUE
 535  CONTINUE
      ICLL=3
      DO 539 JD=1,IDR
      DO 540 JTP=1,NE
      JYV=(JTP-1)*IDR+JD+NTT*IDR
 540  YV(JTP)=ZETA(JYV)
      DO 541 JT=1,NPCE1
      XX=(JT-1)*HEN+EMN
      CALL LAGRAN(ZV,YV,NE,JT,XX,YY,2,ICLL)
      IF(JD.EQ.1.AND.JA.EQ.1)CALL LAGRAN(ZV,DSE,NE,JT,XX,ZZ,2,ICLL)
      IF(JD.EQ.1.AND.JA.EQ.1)HLM(JT)=ZZ*HLMLM(JT)
 541  XI(JT)=YY*HLMLM(JT)
      ICLL=4
      IF(JD.EQ.1.AND.JA.EQ.1)DS=SIMIN(NPCE1,HEN,HLM)
 539  GRAD(JD)=SIMIN(NPCE1,HEN,XI)
      if(ja.eq.1)dst=dst+ds
      IF(JA.EQ.1)WRITE(22,5001)DS,LX
      WRITE(22,483)LX,JA,EMN,EMX,TMN,TMX
 5001 FORMAT(1X/////5X,36HINTEGRATED RUTHERFORD CROSS SECTION=,1E9.4,
     *2X,8HFOR EXP.,1I2///)
      DO 7218 JD=1,IDR
 7218 WRITE(15,*)GRAD(JD)
      DO 542 JD=1,IDR
      NI=KSEQ(JD,3)
      NF=KSEQ(JD,4)
 542  WRITE(22,480)NI,NF,SPIN(NI),SPIN(NF),GRAD(JD),
     *GRAD(JD)/GRAD(IDRN)
  534 CONTINUE
      IF(IECD(LX).NE.1) GO TO 1683
      if(jpin(lx).ne.0)go to 1683
      CALL COORD(WTH,WPH,WTHH,1,2,PFI,WPI,TLBDG(LX),LX,TXX,TXX)
      WRITE(22,1682) FIEX(LX,1)*57.2957795,FIEX(LX,2)*57.2957795,LX
      IF(TLBDG(LX).GE.0) GO TO 1683
      FIEX(LX,1)=FIEX(LX,1)+3.14159265
      FIEX(LX,2)=FIEX(LX,2)+3.14159265
 1682 FORMAT(//5X,38HWARNING: THE PHI ANGLE WAS REPLACED BY,1X,
     *F8.3,1X,2HTO,F8.3,3X,14HFOR EXPERIMENT,2X,I3)
 1683 ISKE=ISKE+NE*NTT*NAA
 1531 continue 
      if(mpin.gt.1)write(22,1711)dst,lx
 1711 format(1x//2x,'Total integrated Rutherford cross section=',1e8.3,
     *' for exp. ',1i2/)	
 530  CONTINUE
      if(ipinf.eq.0)go to 1
	ngpr=0
      do 1249 lx=1,nexpt
	nged=ndst(lx)
	if(irawex(lx).eq.0)nged=nang(lx)
	if(lx.eq.1)go to 1277
      ngpr=ngpr+idr*jpin(lx-1)*ndst(lx-1)
 1277 lpin=jpin(lx)
      if(lpin.eq.0)lpin=1
      do 1251 jgd=1,nged
      do 1250 jd=1,idr
 1250 grad(jd)=0.
      do 1257 mpin=1,lpin
	rewind 15
      ndum=ngpr+(jgd-1)*idr+(mpin-1)*jgd*idr
      if(ndum.eq.0)go to 1260
      do 1261 jd=1,ndum
 1261 read(15,*)xx
 1260 continue
      do 1259 jd=1,idr
      read(15,*)xx
 1259 grad(jd)=grad(jd)+xx
 1257 continue
      write(17,*)(grad(jd),jd=1,idr)
 1251 continue
 1249 continue
      rewind 15
      rewind 17
      do 1252 lx=1,nexpt
      nged=ndst(lx)
      if(irawex(lx).eq.0)nged=nang(lx)
      do 1252 ija0=1,nged
      read(17,*)(grad(jdy),jdy=1,idr)
      do 1253 jd=1,idr
 1253 write(15,*)grad(jd)
 1252 continue
 483   FORMAT(1X,//50X,17HINTEGRATED YIELDS//
     *5X,11HEXPERIMENT ,1I2,2X,9HDETECTOR ,1I2/
     *5X,13HENERGY RANGE ,1F8.3,3H---,1F8.3,1X,3HMEV,
     *3X,23HSCATTERING ANGLE RANGE ,1F7.3,3H---,1F7.3,1X,
     *3HDEG//5X,2HNI,5X,2HNF,5X,2HII,5X,2HIF,5X,
     *5HYIELD,5X,16HNORMALIZED YIELD/)
      GO TO 1
 673  read(jzb,*)IMODE,NPTL,CHIOK,CONU,XTEST,LOCKF,NLOCK,
     *IFBFL,LOCKS,DLOCK
      OP2=OPCJA
      IMIN=IMIN+1
      IF(IMIN.EQ.1)GO TO 805
      GO TO 674
 800  NMAX=0
      IF(IABS(IPRM(1)).EQ.1)WRITE(22,428)
 428  FORMAT(1X/40X,6HLEVELS,//5X,5HINDEX,5X,6HPARITY
     *,9X,4HSPIN,11X,11HENERGY(MEV))
      NDIMA=NDIM+1
      DO 810 K=1,NDIMA
      read(jzb,*)IPO1,IPO2,PO2,PO1
      IF(IPO1.EQ.0)GO TO 900
      IF(IPO1.EQ.1.AND.abs(PO2).lt.1.e-6)ISO=0
      NMAX=NMAX+1
      SPIN(IPO1)=PO2
      IF(K.EQ.1)IPH=IPO2
      IPRC=IPO2-IPH
      IF(IPRC.NE.0)IPRC=1
      IFAC(IPO1)=(-1)**(IPRC-IFIX(PO2-SPIN(1)))
      EN(IPO1)=PO1
      PRP='+'
      IF(IPO2.EQ.-1)PRP='-'
      IF(IABS(IPRM(1)).EQ.1)WRITE(22,995)IPO1,PRP,SPIN(IPO1),EN(IPO1)
 810  CONTINUE
 995  FORMAT(6X,1I2,11X,1A1,10X,1F4.1,8X,1F10.4)
      GO TO 900
 801  DO 820 K=1,NMEMX
      IF(OP2.EQ.'GOSI')GO TO 608
      IOPRI=1
      read(jzb,*)IPO1,IPO2,PO1
      GO TO 607
 608  read(jzb,*)IPO1,IPO2,PO1,BL,BU
      IOPRI=2
      ICG=2
 607  IF(IPO1.EQ.0)GO TO 234
      IF(IPO2.EQ.0)GO TO 821
      MULTI(LA)=MULTI(LA)+1
      INDX=INDX+1
      IF(IPO1.GT.IABS(IPO2))GO TO 822
      IF(IPO1.EQ.IPO3)GO TO 824
      IF(IPO1.LT.IPO3)GO TO 825
      IPO3=IPO1
 824  ELM(INDX)=PO1
      mlt(indx)=la
      LEAD(1,INDX)=IPO1
      LEAD(2,INDX)=IABS(IPO2)
       LDNUM(LA,IPO1)=LDNUM(LA,IPO1)+1
      IF(OP2.NE.'GOSI')GO TO 820
      IF(IPO2.LT.0)GO TO 334
      ELMU(INDX)=BU
      ELML(INDX)=BL
      IF(abs(bl-bu).lt.1.e-6)GO TO 333
      IVAR(INDX)=2
      IF(LA.GT.4)IVAR(INDX)=1
      GO TO 335
 333  IVAR(INDX)=0
      GO TO 335
 334  IVAR(INDX)=10000*IFIX(BL)+IFIX(BU)
 335  ISIP=ISEX(IPO1)+1
      ISEX(IABS(IPO2))=MIN0(ISIP,ISEX(IABS(IPO2)))
      GO TO 820
 821  IF(IPO1.LE.LA)GO TO 823
      LAMMAX=LAMMAX+1
      LAMDA(LAMMAX)=IPO1
      IPO3=0
      IF(INDX.EQ.0)GO TO 235
 234  DO 233 KK=1,INDX
       IF(abs(ELM(KK)).le.1.e-6)ELM(KK)=1.E-6
      IF(IVAR(KK).LT.10000)GO TO 233
      KK1=IVAR(KK)/10000
      KK2=IVAR(KK)-10000*KK1
       LA1=LA
       IF(KK2.LT.100)GO TO 7428
       LA1=KK2/100
       KK2=KK2-100*LA1
 7428 INX1=MEM(KK1,KK2,LA1)
      ELML(KK)=ELML(INX1)*ELM(KK)/ELM(INX1)
      ELMU(KK)=ELMU(INX1)*ELM(KK)/ELM(INX1)
      SA(KK)=ELM(KK)/ELM(INX1)
      ivari(kk)=ivar(kk)
      IVAR(KK)=1000+INX1
      IF(ELMU(KK).GT.ELML(KK))GO TO 233
      ELMI=ELMU(KK)
      ELMU(KK)=ELML(KK)
      ELML(KK)=ELMI
 233  CONTINUE
       IF(IPO1.EQ.0)GO TO 870
 235  LA=IPO1
      IF(LA.GT.LMAXE.AND.LA.LE.6)LMAXE=LA
 820  CONTINUE
 870  MEMAX=INDX
      if(jzb.eq.25)m25=memax
	if(jzb.eq.26)m26=memax
      IF(LA.GT.6)MAGEXC=1
      MEMX4=MULTI(1)+MULTI(2)+MULTI(3)+MULTI(4)
      MEMX6=MEMX4+MULTI(5)+MULTI(6)
      IF(IABS(IPRM(1)).EQ.1)CALL PRELM(IOPRI)
      DO 1213 KH=1,NMAX
      IF(ISEX(KH).EQ.1111)ISEX(KH)=1
 1213 CONTINUE
      DO 2123 KH=1,MEMAX
 2123 IVARH(KH)=IVAR(KH)
      GO TO 900
 803  READ(jzb,907)OP1,FIPO1
      IPO1=IFIX(FIPO1)
      IF(OP1.EQ.'ACP,')ACCA=10.**(-FIPO1)
      IF(OP1.EQ.'SEL,')ITS=2
      IF(OP1.EQ.'SMR,')IOSR=1
      IF(OP1.EQ.'FMI,')IFM=1
      IF(OP1.EQ.'TEN,')ITNO=1
      IF(OP1.EQ.'NCM,')NCM=IPO1
      IF(OP1.EQ.'WRN,')SGW=FIPO1
      IF(OP1.EQ.'INT,')GO TO 1637
      IF(OP1.EQ.'VAC,')GO TO 1327
      IF(OP1.EQ.'DIP,')DIPOL=0.001*FIPO1
      IF(OP1.EQ.'ACC,')ACCUR=10.**(-FIPO1)
      IF(OP1.EQ.'PRT,')GO TO 440
      IF(OP1.EQ.'FIX,')GO TO 1785
      IF(OP1.EQ.'SKP,')GO TO 1329
      IF(OP1.EQ.'CRF,')ICS=1
      IF(OP1.EQ.'LCK,')GO TO 1602
      IF(OP1.EQ.'INR,')INNR=1
      IF(OP1.EQ.'CRD,') GO TO 1673
      IF(OP1.EQ.'CCF,')IPS1=IPO1
      if(OP1.eq.'PIN,')ipine=IPO1
      if(OP1.eq.'PIN,')ipinf=1 
      if(OP1.eq.'PIN,')go to 2347
      IF(OP1.EQ.'END,')GO TO 900
      GO TO 803
 2347 do 2348 ipp=1,ipine
      read(jzb,*)ig1,ig2
 2348 jpin(ig1)=ig2
      go to 803
 1602 read(jzb,*)LCK1,LCK2
      IF(LCK1.EQ.0)GO TO 803
      DO 1603 JJX=LCK1,LCK2
      IVARH(JJX)=0
 1603 IVAR(JJX)=0
      GO TO 1602
 1673 DO 1674 JJX=1,IPO1
      read(jzb,*)IPO2
 1674 IECD(IPO2)=1
      GO TO 803
 1637 DO 1638 JJX=1,IPO1
      read(jzb,*)IPO2,IJX
 1638 INTERV(IPO2)=IJX
      GO TO 803
 1329 DO 1330 JJX=1,IPO1
      read(jzb,*)IJX
 1330 JSKIP(IJX)=0
      GO TO 803
 1327 CONTINUE
      DO 1328 JJX=1,7
      read(jzb,*)IJX,VAL
      IF(IJX.EQ.0)GO TO 803
      G(IJX)=VAL
 1328 CONTINUE
 1785 read(jzb,*)NALLOW
      DO 1786 JJX=1,NALLOW
      read(jzb,*)IJK
      IVAR(IJK)=-IVAR(IJK)
 1786 CONTINUE
      DO 1787 JJX=1,MEMAX
      IF(IVAR(JJX).LT.0)GO TO 1787
      IF(IVAR(JJX).GT.999)GO TO 1787
      IVAR(JJX)=0
 1787 CONTINUE
      DO 1888 JJX=1,MEMAX
      IF(IVAR(JJX).LT.0)IVAR(JJX)=-IVAR(JJX)
      IVARH(JJX)=IVAR(JJX)
 1888 CONTINUE
      GO TO 803
 440  CONTINUE
      DO 444 JJX=1,20
      read(jzb,*)INM1,INM2
      IF(INM1.EQ.0)GO TO 803
 444  IPRM(INM1)=INM2
      GO TO 803
 804  read(jzb,*)NEXPT,IZ,XA
      G(1)=3.
      G(2)=.02
      G(3)=.0345
      G(4)=3.5
      G(5)=FLOAT(IZ)/XA
      G(6)=6.E-06
      G(7)=.6
      DO 840 K=1,NEXPT
      read(jzb,*)IZ1(K),XA1(K),EP(K),TLBDG(K),EMMA(K),MAGA(K),IAXS(K)
     *,FI0,FI1,ISKIN(K),LNORM(K)
      ITTE(K)=0
      IF(XA1(K).LT.0.)ITTE(K)=1
      XA1(K)=ABS(XA1(K))
      FIEX(K,1)=FI0/57.2957795
      FIEX(K,2)=FI1/57.2957795
      IF(TLBDG(K).GE.0.) GO TO 840
      FIEX(K,1)=FIEX(K,1)+3.14159265
      FIEX(K,2)=FIEX(K,2)+3.14159265
 840  CONTINUE
      GO TO 900
 310  CALL READY(IDR,NTAP,0)
      REWIND 3
      REWIND 15
      REWIND 4
 805  CALL CMLAB(0,DSIG,TTTTT)
      IF(ERR)GO TO 9999
      IF(OP2.EQ.'POIN')read(jzb,*)IFWD,SLIM
      IENT=1
      ICG=1
      IF(SPIN(1).lt.1.e-6)ISO=0
      IF(IOBL.GE.1)GO TO 610
      IF(OP2.EQ.'GOSI')GO TO 610
      IAPX=0
       DO 4739 II=1,LP6
 4739 ILE(II)=1
      NCH=0
      DO 901 JEXP=1,NEXPT
      IEXP=JEXP
      TTTTT=TREP(IEXP)
      DSIG=DSIGS(IEXP)
      IF(OP2.EQ.'STAR')GO TO 4740
      JMM=IEXP
       IF(IEXP.EQ.1)GO TO 4740
      DO 4741 LLI=1,LP6
 4741 ILE(LLI)=ILE(LLI)+NYLDE(IEXP-1,LLI)
 4740 CONTINUE
      FI0=FIEX(IEXP,1)
      FI1=FIEX(IEXP,2)
      CALL LOAD(IEXP,1,ICG,0.,JJ)
      CALL ALLOC(ACCUR)
      CALL SNAKE(IEXP,ZPOL)
      CALL SETIN
      DO 799 J=1,LMAX
      POLM=FLOAT(J-1)-SPIN(1)
      CALL LOAD(IEXP,2,ICG,POLM,JJ)
      CALL STING(JJ)
      CALL PATH(JJ)
      CALL INTG(IEXP)
      CALL TENB(J,BTEN,LMAX)
      PR=0.
      IF(OP2.EQ.'STAR'.OR.IPRM(19).EQ.1)WRITE(22,300)(FLOAT(J)-1.
     *-SPIN(1)),IEXP
      DO 788 K=1,ISMAX
      PR=PR+REAL(ARM(K,5))**2+AIMAG(ARM(K,5))**2
 788  IF(OP2.EQ.'STAR'.OR.IPRM(19).EQ.1)WRITE(22,301)
     *IFIX(CAT(K,1)),CAT(K,2),CAT(K,3),REAL(ARM(K,5)),AIMAG(ARM(K,5))
      IF(OP2.EQ.'STAR' .OR.IPRM(19).EQ.1)WRITE(22,302)PR
 799  CONTINUE
      CALL TENS(BTEN)
      IF(ITNO.EQ.0)GO TO 882
      DO 883 K=2,NMAX
      WRITE(17,*)K
      DO 884 KK=1,4
      IN1=(K-1)*28+1+(KK-1)*7
      IN2=IN1+2*KK-2
      WRITE(17,*)(ZETA(KKK),KKK=IN1,IN2)
  884 CONTINUE
  883 CONTINUE
  882 CONTINUE
      SUMMM=0.
      DO 6329 JGL=2,NMAX
      LOCT=(JGL-1)*28+1
 6329 SUMMM=SUMMM+ZETA(LOCT)
      POP1=1.-SUMMM
      JGL=1
      IF(OP2.EQ.'STAR'.OR.IPRM(19).EQ.1)WRITE(22,303)JGL,POP1
      DO 305 JGL=2,NMAX
      LOCT=(JGL-1)*28+1
 305  IF(OP2.EQ.'STAR'.OR.IPRM(19).EQ.1)WRITE(22,303)JGL,ZETA(
     *LOCT)
 303  FORMAT(2X,5HLEVEL,1X,1I2,10X,10HPOPULATION,1X
     *,1E14.6)
      IF(OP2.EQ.'STAR')GO TO 901
      CALL DECAY(CCD,0,CCC)
      NOGELI=NANG(IEXP)
      jgl1=0
      do 7258 js=1,lp2
      do 7258 jgl=1,20
 7258 sumcl(jgl,js)=0.
      do 962 jgl=1,nogeli
      if(irawex(iexp).eq.0)go to 12
      if(op2.eq.'POIN'.and.iprm(20).eq.1)write(23,4478)
     *iexp,jgl,ep(iexp),tlbdg(iexp)
 12   GTH=AGELI(IEXP,JGL,1)
      FIGL=AGELI(IEXP,JGL,2)
      fm=(fi0+fi1)/2.
      CALL ANGULA(YGN,IDR,1,FI0,FI1,TTTTT,GTH,FIGL,JGL,OP2)
      IF(IFMO.EQ.0)GO TO 8232
      ID=ITMA(IEXP,JGL)
      D=ODL(ID)
      RX=D*SIN(GTH)*COS(FIGL-FM)-.25*SIN(TTTTT)*COS(FM)
      RY=D*SIN(GTH)*SIN(FIGL-FM)-.25*SIN(TTTTT)*SIN(FM)
      RZ=D*COS(GTH)-.25*COS(TTTTT)
      RL=SQRT(RX*RX+RY*RY+RZ*RZ)
      THC=TACOS(RZ/RL)
      SF=D*D/RL/RL
      FIC=ATAN2(RY,RX)
      CALL ANGULA(YGP,IDR,1,FI0,FI1,TTTTT,THC,FIC,JGL,OP2)
      DO 8233 IXL=1,IDR
      IXM=KSEQ(IXL,3)
      TFAC=TAU(IXM)
 8233 YGN(IXL)=YGN(IXL)+.01199182*TFAC*BETAR(IEXP)*
     *(SF*YGP(IXL)-YGN(IXL))
 8232 CONTINUE
      if(irawex(iexp).eq.0)go to 7262
      ipd=itma(iexp,jgl)
      do 7263 jyi=1,idr
      ni=kseq(jyi,3)
      nf=kseq(jyi,4)
      decen=en(ni)-en(nf)
      cocos=sin(ttttt)*sin(gth)*cos(fm-figl)+cos(ttttt)*
     *cos(gth)
      decen=decen*(1.+betar(iexp)*cocos)
      call effix(ipd,decen,effi)
      if(op2.eq.'POIN'.and.iprm(20).eq.1)write(23,480)
     *ni,nf,spin(ni),spin(nf),decen,effi
      ygn(jyi)=ygn(jyi)*effi
 7263 continue
      inclus=iclust(iexp,jgl)
      if(inclus.eq.0)go to 7262
      do 7264 jyi=1,idr
 7264 sumcl(inclus,jyi)=sumcl(inclus,jyi)+ygn(jyi)
      if(jgl.ne.lastcl(iexp,inclus))go to 962
      do 7265 jyi=1,idr
 7265 ygn(jyi)=sumcl(inclus,jyi)
 7262 continue
      jgl1=jgl1+1
      lu=ile(jgl1)
      if(op2.eq.'POIN'.or.iprm(11).eq.1)
     *write(22,478)
     *iexp,jgl1,ep(iexp),tlbdg(iexp)
      JMM=0
      DO 961 JYI=1,IDR
      NI=KSEQ(JYI,3)
      NF=KSEQ(JYI,4)
      IF(OP2.EQ.'POIN'.OR.IPRM(11).EQ.1)
     *WRITE(22,480)
     *NI,NF,SPIN(NI),SPIN(NF),YGN(JYI),YGN(JYI)/YGN(IDRN)
      IF(IFWD.NE.1)GO TO 3211
      IF((YGN(JYI)/YGN(IDRN)).LT.SLIM)GO TO 3211
      IF(JGL1.EQ.1)SH1=YGN(IDRN)
      JMM=JMM+1
      CORF(JMM,1)=FLOAT(NI)
      CORF(JMM,2)=FLOAT(NF)
      CORF(JMM,3)=YGN(JYI)
      IF(YGN(JYI).GE.YGN(IDRN))CORF(JMM,4)=CORF(JMM,3)/20.
      IF(YGN(JYI).LT.YGN(IDRN))CORF(JMM,4)=CORF(JMM,3)*
     *(.05+.2*(1.-YGN(JYI)/YGN(IDRN)))
 3211 CONTINUE
      IF(OP2.NE.'CORR')GO TO 961
      READ(15,*)YYDD
      NCH=NCH+1
      JJJJ=IY(LU,JGL1)/1000
      JYI1=IY(LU,JGL1)-JJJJ*1000
      IF(IY(LU,JGL1).NE.JYI.AND.JJJJ.NE.JYI.AND.JYI1.NE.JYI)GO TO 961
      IF(IY(LU,JGL1).LT.1000)GO TO 3743
      JYI2=JYI1-JJJJ
      IF(JYI2.LE.0)GO TO 961
      DO 3744 IHUJ=1,JYI2
 3744 READ(15,*)YYD1
      YYDD=YYDD+YYD1
      YGN(JYI)=YGN(JYI)+YGN(JYI1)
      REWIND 15
      DO 3745 IHUJ=1,NCH
 3745 READ(15,*)YYD1
 3743 IF(IEXP.EQ.1.AND.LU.EQ.NYLDE(1,1).AND.JGL1.EQ.1)
     *CNST=YYDD/YGN(JYI)
      CORF(LU,JGL1)=YEXP(JGL1,LU)
      YEXP(JGL1,LU)=YEXP(JGL1,LU)/YYDD*YGN(JYI)
      DYEX(JGL1,LU)=DYEX(JGL1,LU)/YYDD*YGN(JYI)
      LU=LU+1
 961  CONTINUE
      IF(IFWD.NE.1)GO TO 962
      XW=1.
      WRITE(4,*)IEXP,jgl1,IABS(IZ1(IEXP)),ABS(XA1(IEXP)),
     *ABS(EP(IEXP)),JMM,XW
      DO 3209 JYI=1,JMM
 3209 WRITE(4,*)IFIX(CORF(JYI,1)),IFIX(CORF(JYI,2)),CORF(JYI,3)
     *,CORF(JYI,4)
 962  CONTINUE
      IF(OP2.NE.'CORR')GO TO 901
      jgl1=0
      DO 4093 JGL=1,NOGELI
      if(irawex(jexp).eq.0)go to 4095
      inclus=iclust(jexp,jgl)
      if(inclus.eq.0)go to 4095
      if(jgl.ne.lastcl(jexp,inclus))go to 4093
 4095 continue
      jgl1=jgl1+1
      READ(3,*)NE,NA,ZP,AP,XEP,NVAL,WAGA
      WRITE(4,*)NE,NA,ZP,AP,EP(IEXP),NVAL,WAGA
      WRITE(22,9990) IEXP,JGL1
 9990 FORMAT(///10X,10HEXPERIMENT,1X,I2,8X,8HDETECTOR,1X,I2,
     1       //9X,2HNI,5X,2HNF,5X,4HYEXP,8X,4HYCOR,8X,5HCOR.F/)
       ILE1=ILE(JGL1)
      DO 313 ITP=1,NVAL
      READ(3,*)NS1,NS2,FIEX1(1,1,1),FIEX1(1,1,2)
      LTRN=IY(ILE1+ITP-1,JGL1)
      IF(LTRN.LT.1000)GO TO 3747
      LTRN1=LTRN/1000
      NS1=KSEQ(LTRN1,3)*100
      NS2=KSEQ(LTRN1,4)*100
      LTRN2=LTRN-LTRN1*1000
      NS1=NS1+KSEQ(LTRN2,3)
      NS2=NS2+KSEQ(LTRN2,4)
      GO TO 312
 3747 NS1=KSEQ(LTRN,3)
      NS2=KSEQ(LTRN,4)
 312  YCORR=YEXP(JGL1,ILE1+ITP-1)
      WRITE(4,*)NS1,NS2,YCORR,DYEX(JGL1,ILE1+ITP-1)
 313  WRITE(22,9991) NS1,NS2,CORF(ILE1+ITP-1,JGL1),YCORR,
     1              YCORR/CORF(ILE1+ITP-1,JGL1)
 9991 FORMAT(5X,I4,5X,I4,3X,E8.3,4X,E8.3,4X,E8.3)
 4093 CONTINUE
 901   CONTINUE
      IF(OP2.EQ.'STAR')OPH=OP2
      IF(OP2.EQ.'STAR')GO TO 1
      IF(OP2.NE.'CORR')GO TO 1
      NTAP=4
      CALL READY(IDR,NTAP,IPRI)
      REWIND NTAP
      GO TO 1
 610  CONTINUE
      IF(IOBL.GE.1)GO TO 2001
      REWIND 7
	rewind 27
	mdupa=7
	if(ibps.eq.1)mdupa=27
      DO 2929 IUY=1,6
      READ(mdupa,*)(XIR(IUY,JJ),JJ=1,NEXPT)
2929  READ(mdupa,*)(ZMIR(IUY,1,JJ),ZMIR(IUY,2,JJ),JJ=1,NEXPT)
      DO 2002 JJ=1,NEXPT
      DO 2003 JK=1,4
      DO 2003 KUKU=1,6
 2003 READ(mdupa,*)(PARXM(JJ,JK,JL,KUKU),JL=1,10)
      DO 2017 JK=1,12
 2017 READ(mdupa,*)(PARX(JJ,JK,JL),JL=1,5)
 2002 CONTINUE
      DO 6342 JGS=1,MEMAX
      DO 6342 JGR=1,7
 6342 QAPR(JGS,1,JGR)=0.
      GO TO 2000
 2001 IENT=1
      ICG=2
      NMAXH=NMAX
      LMAX1=LMAX
      SH1=SPIN(1)
      SH2=SPIN(2)
      IH1=IFAC(1)
      IH2=IFAC(2)
      MAGH=MAGEXC
      LMAXH=LMAXE
      ISOH=ISO
      ISO=0
      EH1=ELM(1)
      LH1=LEAD(1,1)
      LH2=LEAD(2,1)
      LAMH=LAMMAX
      MEMH=MEMAX
      DO 699 KH=1,8
      IHLM(KH)=MULTI(KH)
      IHLM(KH+24)=LDNUM(KH,2)
      IHLM(KH+8)=LAMDA(KH)
 699  IHLM(KH+16)=LDNUM(KH,1)
      DO 611 JEXP=1,NEXPT
      IEXP=JEXP
      INTVH=INTERV(IEXP)
      DO 6241 JGS=1,MEMAX
      DO 6241 JGR=1,7
 6241 QAPR(JGS,1,JGR)=0.
      DO 2930 IUY=1,6
2930  XIR(IUY,IEXP)=0.
      EMHL1=EMMA(IEXP)
      EMMA(IEXP)=FLOAT(MAGA(IEXP))
      JDE=2
      IF(MAGA(IEXP).EQ.0)JDE=1
      DO 2931 IUY=1,6
      ZMIR(IUY,1,IEXP)=0.
 2931 ZMIR(IUY,2,IEXP)=0.
      CALL LOAD(IEXP,1,2,0.,JJ)
      DO 631 JGS=1,LMAX
      POLM=FLOAT(JGS-1)-SPIN(1)
      CALL LOAD(IEXP,3,2,POLM,JJ)
      CALL PATH(JJ)
      CALL LOAD(IEXP,2,2,POLM,JJ)
      ICTL=1
      DO 612 KK=1,6
      LL=IHLM(KK)
      IF(LL.EQ.0)GO TO 612
      LFINI=LL+ICTL-1
      ICT=ICTL
      DO 613 LLL=ICT,LFINI
      ICTL=ICTL+1
      IF(JGS.NE.1)GO TO 632
      XIR(KK,IEXP)=AMAX1(XIR(KK,IEXP),ABS(XI(LLL)))
 632  R1=ABS(QAPR(LLL,1,1))
      R2=ABS(QAPR(LLL,1,4))
      R3=ABS(QAPR(LLL,1,7))
      RM=AMAX1(R1,R2,R3)
      BMX=AMAX1(ABS(ELMU(LLL)),ABS(ELML(LLL)))
      ZMIR(KK,2,IEXP)=AMAX1(ZMIR(KK,2,IEXP),RM*BMX/ABS(ELM(LLL)),RM)
      R1=ABS(QAPR(LLL,1,2))
      R2=ABS(QAPR(LLL,1,3))
      R3=ABS(QAPR(LLL,1,5))
      R4=ABS(QAPR(LLL,1,6))
      RM=AMAX1(R1,R2,R3,R4)
      ZMIR(KK,1,IEXP)=AMAX1(ZMIR(KK,1,IEXP),RM*BMX/ABS(ELM(LLL)),RM)
 613  CONTINUE
      IF(ZMIR(KK,1,IEXP).LT..5)ZMIR(KK,1,IEXP)=.5
      IF(ZMIR(KK,2,IEXP).LT..5)ZMIR(KK,2,IEXP)=.5
 612  CONTINUE
 631  CONTINUE
      DO 633 KK=1,6
      XIR(KK,IEXP)=XIR(KK,IEXP)*1.01
      DO 698 KH=1,8
      MULTI(KH)=0
      LAMDA(KH)=0
      LDNUM(KH,2)=0
 698  LDNUM(KH,1)=0
      NMAX=2
      ELM(1)=1.
      LEAD(1,1)=1
      LEAD(2,1)=2
      SPIN(1)=0.
      IFAC(1)=1
      LAMMAX=1
      MEMAX=1
      MAGEXC=0
      KKK=0
      ICG=1
      IF(IHLM(KK).EQ.0)GO TO 633
      MULTI(KK)=1
      LAMDA(1)=KK
      SPIN(2)=FLOAT(KK)
      IFAC(2)=1
      LDNUM(KK,1)=1
      ICG=1
      CALL LOAD(IEXP,1,ICG,0.,JJ)
      CALL LOAD(IEXP,2,ICG,0.,JJ)
      CALL PATH(1)
      SZ1=AMIN1(ZMIR(KK,1,IEXP),10.)
      SZ2=ZMIR(KK,2,IEXP)/50.
      ACOF=2.4009604E-3/ZMIR(KK,2,IEXP)
      BCOF=8.163265E-4
      DO 614 JD=1,JDE
      NKSI=5
      IF(JD.EQ.2)NKSI=10
      IF(MAGA(IEXP).EQ.0)NKSI=10
      DO 625 JK=1,3
 625  ZETA(JK)=0.
      NZ=50
      IF(JD.EQ.1.AND.MAGA(IEXP).NE.0)NZ=1
      DO 606 JK=1,NKSI
      XI(1)=XIR(KK,IEXP)*(JK-1)/(NKSI-1)
      IF(JK.EQ.1)XI(1)=.02
      S11=0.
      S21=0.
      S12=0.
      S22=0.
      PH1=0.
      PH2=0.
      DO 615 JZ=1,NZ
      ZETA(JD)=SZ2*JZ
      IF(JD.EQ.1.AND.MAGA(IEXP).NE.0)ZETA(JD)=SZ1
      IF(ZETA(JD).LT..1)INTERV(IEXP)=1000
      IF(ZETA(JD).GE..1)INTERV(IEXP)=INTVH
      CALL ALLOC(ACCUR)
      CALL SNAKE(IEXP,ZPOL)
      CALL SETIN
      CALL STING(1)
      IF(KK.LE.2)GO TO 1082
      ARM(1,5)=(.9999999,0.)
      ARM(2,5)=(1.2E-6,0.)
      ARM(1,6)=(.9999998,0.)
      ARM(2,6)=(.9E-6,0.)
      DO 1083 KH=1,4
      ARM(1,KH)=(-1.E-6,0.)
      ARM(2,KH)=(1.E-6,0.)
 1083 CONTINUE
 1082 CALL INTG(IEXP)
      JP=2
      IF(MAGA(IEXP).NE.0.AND.JD.EQ.2)JP=3
      P=REAL(ARM(1,5))
      R=AIMAG(ARM(1,5))
      QR=REAL(ARM(JP,5))
      S=AIMAG(ARM(JP,5))
      TEST=P*P+R*R+QR*QR+S*S
      P=P/SQRT(TEST)
      S=ABS(R/S)
      IF(JK.NE.1)GO TO 620
      IF(MAGA(IEXP).EQ.0)GO TO 2418
      IF(JD.NE.2.AND.MAGA(IEXP).NE.0)GO TO 620
 2418 Q1=0.
      GO TO 621
 620  Q1=ARCTG(S,PH1,PI)
      PH1=Q1
 621  IF(JK.NE.1)GO TO 622
      IF(JD.NE.1.OR.MAGA(IEXP).EQ.0)GO TO 622
      Q2=0.
      GO TO 623
 622  Q2=ARCCOS(P,PH2,PI)
      PH2=Q2
 623  CONTINUE
      Q1=Q1/ZETA(JD)/2.
      Q2=Q2/ZETA(JD)
      IF(JD.EQ.1.AND.MAGA(IEXP).NE.0)Q2=-Q2
      IF(JD.EQ.1.AND.MAGA(IEXP).NE.0)GO TO 615
      S11=S11+Q1
      S12=S12+Q1*JZ
      S21=S21+Q2
      S22=S22+JZ*Q2
 615  CONTINUE
      IF(JD.EQ.1.AND.MAGA(IEXP).NE.0)GO TO 616
      PARXM(IEXP,1,JK,KK)=ACOF*(2.*S12-51.*S11)
      PARXM(IEXP,2,JK,KK)=BCOF*(101.*S11-3.*S12)
      PARXM(IEXP,3,JK,KK)=ACOF*(2.*S22-51.*S21)
      PARXM(IEXP,4,JK,KK)=BCOF*(101.*S21-3.*S22)
      GO TO 606
 616  PARX(IEXP,2*KK-1,JK)=Q1
      PARX(IEXP,2*KK,JK)=Q2
 606  CONTINUE
 614  CONTINUE
 633  CONTINUE
      EMMA(IEXP)=EMHL1
      NMAX=NMAXH
      SPIN(1)=SH1
      SPIN(2)=SH2
      IFAC(1)=IH1
      IFAC(2)=IH2
      MAGEXC=MAGH
      ISO=ISOH
      ELM(1)=EH1
      LEAD(1,1)=LH1
      LEAD(2,1)=LH2
      LAMMAX=LAMH
      MEMAX=MEMH
      DO 696 KH=1,8
      LDNUM(KH,2)=IHLM(KH+24)
      MULTI(KH)=IHLM(KH)
      LAMDA(KH)=IHLM(KH+8)
 696  LDNUM(KH,1)=IHLM(KH+16)
      INTERV(IEXP)=INTVH
 611  CONTINUE
      REWIND 7
	rewind 27
	jkmx=7
	if(ibps.eq.1)jkmx=27
      DO 2932 IUY=1,6
      WRITE(jkmx,*)(XIR(IUY,JJ),JJ=1,NEXPT)
 2932 WRITE(jkmx,*)(ZMIR(IUY,1,JJ),ZMIR(IUY,2,JJ),JJ=1,NEXPT)
      DO 4005 JJ=1,NEXPT
      DO 4006 JK=1,4
      DO 4006 KUKU=1,6
 4006 WRITE(jkmx,*)(PARXM(JJ,JK,JL,KUKU),JL=1,10)
      DO 4008 JK=1,12
 4008 WRITE(jkmx,*)(PARX(JJ,JK,JL),JL=1,5)
 4005 CONTINUE
      jkmy=12
	if(ibps.eq.1)jkmy=32
      do 8112 kuku=1,memax
 8112 write(jkmy,*)elm(kuku)	
      DO 1739 JJ=1,2
      DO 1739 JJ1=1,LP1
 1739 IDIVE(JJ1,JJ)=1
 2000 IF(IPRM(12).EQ.0.and.op2.ne.'MAP ')GO TO 19
      IPRM(12)=0
      DO 21 JEX=1,NEXPT
      DO 22 LEX=1,6
      IF(MULTI(LEX).EQ.0)GO TO 22
      WRITE(22,8300)JEX,XIR(LEX,JEX)
 8300 FORMAT(1X//30X,10HEXPERIMENT,1X,1I2,10X,7HMAX.XI=,1F6.4)
      WRITE(22,8301)LEX,ZMIR(LEX,2,JEX)
 8301 FORMAT(1X/30X,1HE,1I1,8X,4HMI=0,5X,9HMAX.ZETA=,1F6.3//)
      WRITE(22,8302)
 8302 FORMAT(5X,2HXI,13X,2HQ1,22X,2HQ2///13X,5HSLOPE,2X,
     *9HINTERCEPT,7X,5HSLOPE,5X,9HINTERCEPT//)
      DO 8401 KEX=1,10
      XXI=XIR(LEX,JEX)*(KEX-1)/9.
 8401 WRITE(22,8303)XXI,(PARXM(JEX,ILX,KEX,LEX),ILX=1,4)
 8303 FORMAT(2X,1F6.4,3X,1E8.2,2X,1E8.2,6X,1E8.2,2X,1E8.2)
      IF(MAGA(JEX).EQ.0)GO TO 22
      WRITE(22,8405)LEX,ZMIR(LEX,1,JEX)
 8405 FORMAT(1X//30X,1HE,1I1,8X,7HMI=+/-1,5X,9HMAX.ZETA=,1F6.3//)
      WRITE(22,8302)
      DO 8406 KEX=1,5
      XXI=XIR(LEX,JEX)*(KEX-1)/4.
      U=0.
 8406 WRITE(22,8303)XXI,U,PARX(JEX,2*LEX-1,KEX),U,PARX(JEX,
     *2*LEX,KEX)
 22   CONTINUE
 21   CONTINUE
 19   CONTINUE
       IF(OP2.NE.'GOSI'.AND.OP2.NE.'ERRO')GO TO 1
       IF(OP2.EQ.'ERRO')GO TO 7
 674  CONTINUE
      mret=iabs(mret)
      DO 1487 KH1=1,MEMAX
 1487 HLM(KH1)=ELM(KH1)
      LFAGG=0
      DO 2127 KH1=1,MEMAX
 2127 IVAR(KH1)=IVARH(KH1)
      if(nawr.eq.1)go to 3074
      mcfix=1
      CALL MINI(CHISQ,1.e+38,NPTL,CONU,IMODE,IDR,XTEST,0,0,0,BTEN)
	mawr=mawr+1
	if(jzb.eq.25)ccch1=chisq
	if(jzb.eq.26)ccch2=chisq
	chir=chir+chisq
	if(jzb.eq.26)cht=abs(chir-chp)
	if(jzb.eq.26.and.cht.lt.0.1)mret=0
	if(jzb.eq.26.and.mawr.ge.20)mret=0
	if(jzb.eq.26)nawr=1
	do 3073 kh1=1,32
	do 3073 kh2=1,lp3
      if(jzb.eq.26)cnor2(kh1,kh2)=cnor(kh1,kh2)
      if(jzb.eq.25)cnor1(kh1,kh2)=cnor(kh1,kh2)	
 3073 continue
      if(jzb.ne.26)go to 3076
       do 3075 kh1=1,32
	do 3075 kh2=1,75
c	cnor1(kh1,kh2)=cnor1(kh1,kh2)*cnor2(kh1,kh2)*2/(cnor1(kh1,kh2)
c     *+cnor2(kh1,kh2))
c      cnor1(kh1,kh2)=(cnor1(kh1,kh2)*ccch1+cnor2(kh1,kh2)*ccch2)/
c     *(ccch1+ccch2)	
      cnor1(kh1,kh2)=(cnor1(kh1,kh2)+cnor2(kh1,kh2))/2.
 3075 continue
 3076 continue
      if(ibps.eq.0.and.jzb.eq.25)jzb=26
      if(ibps.eq.0)go to 1408
	jzb=25
	go to 1408
 3074	mcfix=0
      CALL MINI(CHISQ,CHIOK,NPTL,CONU,IMODE,IDR,XTEST,0,0,0,BTEN)
	if(ibps.eq.0)jzb=25
	if(ibps.eq.0)mrepf=1
	if(ibps.eq.0)go to 3911
	ibps=ibps+1
	if(ibps.eq.1)jzb=26
	if(ibps.eq.1)go to 1408
 3911 IF(IPS1.EQ.0)GO TO 9999
      IMIN=IMIN+1
      DO 1336 IVA=1,LP1
 1336 JSKIP(IVA)=1
      irix=12
	if(ibps.eq.2)irix=32
      REWIND irix
      DO 5789 LKJ=1,MEMAX
 5789 WRITE(irix,*)ELM(LKJ)
      IF(IFM.EQ.1)CALL PRELM(3)
      IF(IFM.EQ.1)GO TO 9999
	go to 430
  950 CONTINUE
      CALL ADHOC(OPH,IDR,NFD,NTAP,IYR)
      GO TO 1
 822  WRITE(22,522)
      GO TO 999
 899   READ(jzb,998)(TITLE(K),K=1,20)
      WRITE(22,429)(TITLE(K),K=1,20)
 429  FORMAT(10X,20A4/10X,100(1H-))
      GO TO 1
 522  FORMAT(5X,48HERROR-M.E. DOES NOT BELONG TO THE UPPER TRIANGLE)
 823  WRITE(22,523)
      GO TO 999
 523  FORMAT(5X,39HERROR-WRONG SEQUENCE OF MULTIPOLARITIES)
 825  WRITE(22,525)
      GO TO 999
 598  WRITE(22,599)
 599  FORMAT(1X///10X,44HERROR-INSUFFICIENT SPACE FOR E-THETA INTEGR
     *,5HATION)
      GO TO 999
 525  FORMAT(5X,38HERROR-REPEATED APPEARANCE OF THE STATE)
 998  FORMAT(20A4)
 997   FORMAT(1A3,1A4)
 907  FORMAT(1A4,1F7.1)
 996   FORMAT(1A4)
 430  CONTINUE
      if(mret.eq.1.and.jzb.eq.26)nawr=0
      if(mret.eq.1)go to 3912
      IF(IPRM(18).NE.0)CALL PTICC(IDR)
      IF(OPH.NE.'GOSI')GO TO 999
      IF(LFAGG.EQ.1)GO TO 999
      IF(IMIN.EQ.0)GO TO 45
      IF(IPRM(4).EQ.-1)GO TO 452
      GO TO 455
 452  CONTINUE
      IPRM(4)=111111
 455  ISKOK=IPRM(7)+IPRM(8)+IPRM(13)+IPRM(14)
      IF(ISKOK.EQ.0.AND.IPRM(4).EQ.111111)GO TO 45
      IF(ISKOK.EQ.0)GO TO 456
      IF(IPRM(7).EQ.1)IPRM(7)=-1
      IF(IPRM(8).EQ.1)IPRM(8)=-1
      IF(IPRM(3).EQ.1.AND.NBRA.NE.0)IPRM(3)=-1
      IF(IPRM(13).EQ.1)IPRM(13)=-1
      IF(IPRM(14).EQ.1)IPRM(14)=-1
 456  CONTINUE
      CALL MINI(CHISQ,CHIOK,+1,CONU,2000,IDR,XTEST,2,0,0,BTEN)
 45   CONTINUE
      CALL MIXR(IVA,1,CHISQ,CHILO)
      IF(IPRM(15).EQ.0.OR.KFERR.EQ.1.OR.IYR.EQ.0)GO TO 468
      WRITE(22,465)
      DO 466 IVA=2,NMAX
      DO 442 IVA1=1,10
      IF(LIFCT(IVA1).EQ.IVA)GO TO 2782
 442  CONTINUE
      GO TO 443
 2782 WRITE(22,2781)IVA,TAU(IVA),TIMEL(1,IVA1),TIMEL(2,IVA1)
      GO TO 4666
 443  WRITE(22,469)IVA,TAU(IVA)
 4666 continue
      if(iva.ne.nmax)go to 466
      if(namx.lt.1)go to 1479
      write(22,1469)
 1469 format(5x,//,'CALCULATED AND EXPERIMENTAL MATRIX ELEMENTS',//)
      write(22,1470)
 1470 format(5x,'NI ','NF ',' EXP. ME   ', 'CURRENT ME','   SIGMA')
      do 1471 kq=1,namx
      ni=iamy(kq,1)
      nf=iamy(kq,2)
      ind=iamx(kq)
      ess=elm(ind)
      esd=eamx(kq,1)
      dsd=eamx(kq,2)
 1471 write(22,1477)ni,nf,esd,ess,(ess-esd)/dsd
 1477 format(5x,1i2,1x,1i2,1x,1f9.4,1x,1f9.4,1x,1f9.4)
 1479 continue
 466  CONTINUE
 468  CONTINUE
      IF(IMIN.NE.0)CALL PRELM(3)
 999  CONTINUE
      IF(ITS.EQ.0)GO TO 9999
      IVA=0
      WRITE(18,*)IVA,IVA,IVA,CHISQ
      IF(ITS.EQ.2)GO TO 9999
      WRITE(15,*)IVA,CHISQ,CHISQ,CHISQ,CHISQ
      CALL KLOPOT(KMAT,RLR)
      GO TO 9999
 9998 ITS=1
      read(jzb,*)KMAT,RLR
      GO TO 1
 9999 WRITE(22,3728)
 3912 continue
      if(mrepf.ne.1)go to 1911
	mrepf=2
	jzb=26
	go to 1408
 3728 FORMAT(15X,'********* END OF EXECUTION **********')
 465  FORMAT(1X//20X,20HCALCULATED LIFETIMES//5X,5HLEVEL
     *,5X,14HLIFETIME(PSEC),5X,3HEXP,8X,5HERROR/)
 2781 FORMAT(7X,1I2,7X,1E10.4,5X,1E10.4,4X,1E10.4)
 469  FORMAT(7X,1I2,7X,1E10.4)
 300  FORMAT(1X//40X,21HEXCITATION AMPLITUDES//10X,2HM=
     *,1F5.1,5X,10HEXPERIMENT,1X,1I2//5X,5HLEVEL,2X,4HSPIN
     *,2X,1HM,5X,14HREAL AMPLITUDE,2X,19HIMAGINARY AMPLITUDE
     *//)
 301  FORMAT(7X,1I2,3X,1F4.1,2X,1F5.1,2X,1E14.6,2X,1E14.6)
 302  FORMAT(1X/5X,21HSUM OF PROBABILITIES=,1E14.6)
 1911 if(mret.eq.1)jzb=25
      if(mret.eq.1)go to 1408
	do 7621 mmmm=1,32
	do 7621 kkkk=1,50
 7621 write(13,*)cnor1(mmmm,kkkk) 	
      STOP
      END
      FUNCTION ARCCOS(A,F,PI)
      Q=TACOS(A)
      QA=Q
       QAP=Q
      IF(Q.GT.F)GO TO 1
      DO 2 J=1,20
      AN=2*J*PI
      DO 2 K=1,2
      QAP=QA
      IE=(-1)**K
      QA=AN+IE*Q
      IF(QA.GT.F)GO TO 1
 2    CONTINUE
 1    ARCCOS=QA
      IF((QA-F).GT.PI/2.)ARCCOS=QAP
      RETURN
      END
      FUNCTION ARCTG(A,F,PI)
      Q=ATAN(A)
      QA=Q
      QAP=Q
      IF(Q.GT.F)GO TO 1
      DO 2 J=1,40
      AN=J*PI
      DO 2 K=1,2
      QAP=QA
      IE=(-1)**K
      QA=AN+IE*Q
      IF(QA.GT.F)GO TO 1
 2    CONTINUE
 1    ARCTG=QA
      IF((QA-F).GT.PI/4.)ARCTG=QAP
      RETURN
      END
      SUBROUTINE LOAD(IEXP,IENT,ICG,POLM,JOJ)
      LOGICAL ERR
      COMMON /CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON /COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      COMMON/PSPIN/ISHA
      COMMON/CEXC/MAGEXC,MEMAX,LMAXE,MEMX6,IVAR(500)
      COMMON /PCOM/PSI(500)
      COMMON /CCOUP/ZETA(50000),LZETA(8)
      COMMON /CLM/LMAX
      COMMON/CLCOM8/CAT(600,3),ISMAX
      COMMON/CLCOM9/ERR
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON/CX/NEXPT,IZ,XA,IZ1(50),XA1(50),EP(50),TLBDG(50),VINF(50)
      COMMON/CEXC0/NSTART(76),NSTOP(75)
      COMMON/CXI/XI(500)
      COMMON/CAUX0/NCM,EMMA(75)
      COMMON/CAUX4/DISTA
      COMMON/APRCAT/QAPR(500,2,7),IAPR(500,2),ISEX(75)
      COMMON/PTH/IPATH(75),MAGA(75)
      DIMENSION ETAN(75),CPSI(8)
      LMAX=IFIX(SPIN(1)+1.1)
      IF(IENT.NE.1)GO TO 271
      ISHA=0
      ISPI=IFIX(SPIN(1)+.51)
      ISPO=IFIX(SPIN(1)+.49)
      IF(ISPI.NE.ISPO)ISHA=1
      Z1=FLOAT(IABS(IZ1(IEXP)))
      Z2=FLOAT(IZ)
      A1=XA1(IEXP)
      A2=XA
      ZPOL=DIPOL*EP(IEXP)*A2/(Z2*Z2*(1.+A1/A2))
      IF(IZ1(IEXP).LT.0)ZPOL=DIPOL*EP(IEXP)
     **A1/(Z1*Z1*(1.+A2/A1))
      IF(IZ1(IEXP).GT.0)GO TO 11
      AH=A1
      A1=A2
      A2=AH
 11   ETA=Z1*Z2*SQRT(A1/EP(IEXP))/6.349770
      DO 110 M=1,NMAX
      DEP=(1.0+A1/A2)*EN(M)
      ZET=DEP/EP(IEXP)
      SZET=SQRT(1.0-ZET)
 110  ETAN(M)=ETA/SZET
      DO 150 N=1,MEMAX
      I1=LEAD(1,N)
      I2=LEAD(2,N)
 150  XI(N)=ETAN(I1)-ETAN(I2)
      AAZZ=1./(1.+A1/A2)/Z1/Z2
      CPSI(1)=5.169286*AAZZ
      IF(LMAXE.EQ.1)GO TO 200
      AAZ2=AAZZ*AAZZ
      CPSI(2)=14.359366*AAZ2
      IF(LMAXE.EQ.2)GO TO 200
      AAZ3=AAZZ*AAZ2
      CPSI(3)=56.982577 *AAZ3
      IF(LMAXE.EQ.3)GO TO 200
      AAZZ=AAZ2*AAZ2
      CPSI(4)=263.812653*AAZZ
      IF(LMAXE.EQ.4)GO TO 200
      AAZ2=AAZ3*AAZ2
      CPSI(5)=1332.409500*AAZ2
      IF(LMAXE.EQ.5)GO TO 200
      AAZZ=AAZ3*AAZ3
      CPSI(6)=7117.691577*AAZZ
 200   IF(MAGEXC.EQ.0)GO TO 210
      AAZZ=VINF(IEXP)/95.0981942
      CPSI(7)=AAZZ*CPSI(1)
      IF(LAMMAX.EQ.8)GO TO 210
      CPSI(8)=AAZZ*CPSI(2)
 210   ZSQA=Z1*SQRT(A1)
      I3=1
      PPP=1.+A1/A2
      DO 270 I1=1,LAMMAX
      LAM=LAMDA(I1)
      LAM1=LAM
      IF(LAM.GT.6)LAM1=LAM-6
      DO 280 N2=1,NMAX
      NN=LDNUM(LAM,N2)
      IF(NN.EQ.0)GO TO 280
      N3=LEAD(1,I3)
      PP1=EP(IEXP)-PPP*EN(N3)
      DO 260 M1=1,NN
      M2=LEAD(2,I3)
      I2=I3
      I3=I3+1
      PP2=EP(IEXP)-PPP*EN(M2)
 260  PSI(I2)=CPSI(LAM)*ZSQA*(PP1*PP2)**((2.*FLOAT(LAM1)-1.)/4.)
 280  CONTINUE
 270  CONTINUE
      IF(IENT.EQ.1)RETURN
 271  CONTINUE
      DO 803 N=1,NMAX
      NSTART(N)=0
  803 NSTOP(N)=0
      IS=1
      NSTART(1)=1
      DO 380 N=1,NMAX
      WRT=POLM-EMMA(IEXP)
      WRTM=POLM+EMMA(IEXP)
      IF(ICG.EQ.2)WRT=POLM-FLOAT(MAGA(IEXP))
      IF(ICG.EQ.2)WRTM=POLM+FLOAT(MAGA(IEXP))
      IF(WRTM.LT.-SPIN(N))GO TO 371
      IF(ABS(WRT).GT.SPIN(N))WRT=-SPIN(N)
      IF(WRTM.GT.SPIN(N))WRTM=SPIN(N)
      MSTOP=IFIX(WRTM-WRT+1.01)
      DO 370 I=1,MSTOP
      CAT(IS,1)=N
      CAT(IS,2)=SPIN(N)
      CAT(IS,3)=WRT+FLOAT(I-1)
      IF(N.EQ.1.AND.abs(CAT(IS,3)-POLM).lt.1.e-6)JOJ=IS
      IS=IS+1
 370  CONTINUE
      GO TO 372
  371 CONTINUE
      NSTART(N)=0
  372 CONTINUE
      NSTART(N+1)=IS
      NSTOP(N)=IS-1
 380  CONTINUE
      ISMAX=IS -1
      IF(ISMAX.LE.LP10)GOTO 400
      WRITE(22,916) LP10
      GOTO 850
 400  CONTINUE
      IF(IENT.EQ.3)RETURN
      NZ=0
      DO 2 JJ=1,7
      DO 2 JJJ=1,MEMAX
      QAPR(JJJ,1,JJ)=0.
  2   QAPR(JJJ,2,JJ)=0.
      DO 717 I=1,8
 717  LZETA(I)=0
      DO 700 I1=1,LAMMAX
      LAM=LAMDA(I1)
      IF(ICG.EQ.2.AND.LAM.GT.6)GO TO 700
      LA=LAM
      IF(LAM.GT.6)LAM=LAM-6
      RLAM=FLOAT(LAM)
      SSQRT=SQRT(2.*RLAM+1.)
      LZETA(LA)=NZ
      IR=0
 440  IR=IR+1
      IF(IR.GT.ISMAX)GO TO 700
      N=CAT(IR,1)
      IF(ICG.EQ.1)GO TO 1
      IF(MAGA(IEXP).EQ.0.AND.IR.NE.IPATH(N))GO TO 440
      IF(IABS(IR-IPATH(N)).GT.1)GO TO 440
 1    LD=LDNUM(LA,N)
      IF(LD.EQ.0)GO TO 441
      CALL LSLOOP(IR,N,NZ,LD,LAM,LA,SSQRT,ICG,IEXP)
      GO TO 440
 441  IR=IR+NSTOP(N)-NSTART(N)
      GO TO 440
 700   CONTINUE
      IF ( NZ.GT.LP7 ) GOTO 540
      RETURN
 540  WRITE(22,936) LP7
 850  ERR=.TRUE.
      RETURN
 916  FORMAT(27H ERROR-ISMAX EXCEEDS MAGMAX,5X,9H(MAGMAX =,I4,1H))
 936  FORMAT(1x,'ERROR - NUMBER OF ELEMENTS IN ZETA ARRAY EXCEEDS'
     *,5HZEMAX,5X,8H(ZEMAX =,I6,1H))
      END
      SUBROUTINE LSLOOP(IR,N,NZ,LD,LAM,LA,SSQRT,ICG,IEXP)
      COMMON /CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON /COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      COMMON /PCOM/PSI(500)
      COMMON /CCOUP/ZETA(50000),LZETA(8)
      COMMON/CLCOM8/CAT(600,3),ISMAX
      COMMON/CEXC0/NSTART(76),NSTOP(75)
      COMMON/APRCAT/QAPR(500,2,7),IAPR(500,2),ISEX(75)
      COMMON/PTH/IPATH(75),MAGA(75)
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/CLCOM0/IFAC(75)
      LAM2=2*LAM
      INR=CAT(IR,2)*2.
      RMIR=CAT(IR,3)
      JRMIR=2.*RMIR
      DO 300 I2=1,LD
      M=LEADF(N,I2,LA)
      INDX=MEM(N,M,LA)
      IAPR(INDX,1)=N
      IAPR(INDX,2)=M
      ISMIN=0
      INS=SPIN(M)*2.
      IS1=NSTART(M)
       IF(IS1.EQ.0)GO TO 300
      ISPLUS=IFIX(RMIR-CAT(IS1,3))-LAM
      IF(ISPLUS.GE.0)GOTO 100
      ISMIN=ISPLUS
      ISPLUS=0
 100  IS2=IS1+ISPLUS-1
      MRANGE=2*LAM+1+ISMIN
      IF(IS2+MRANGE.GT.NSTOP(M)) MRANGE=NSTOP(M)-IS2
      IF(MRANGE.LE.0)GOTO 300
      DO 200 I3=1,MRANGE
      IS=IS2+I3
      RMIS=CAT(IS,3)
      IF(ISO.EQ.0.AND.RMIS.GT..1.AND.RMIR.GT..1)GO TO 200
      JG1=-RMIS*2.
      JG2=(RMIS-RMIR)*2.
      IF(ICG.EQ.2.AND.IABS(JG2).GT.2*MAGA(IEXP))GO TO 200
      IF(LA.GT.6.AND.JG2.EQ.0)GO TO 200
      NZ=NZ+1
      IF(NZ.GT.LP7) GOTO 200
      IIEX=(INS+JG1)/2
      PHZ=(-1.0)**IIEX
      ZETA(NZ)=PHZ*PSI(INDX)*SSQRT*WTHREJ(INS,LAM2,INR,JG1,JG2,JRMIR)
      IF(ICG.EQ.1)GO TO 200
      MT=CAT(IS,1)
      CALL CODE7(IR,IS,N,MT,INQA,INDX)
      IF(abs(ELM(INDX)).lt.1.e-6)ELM(INDX)=1.E-6
      IF(INQA.EQ.-1)GO TO 200
      QAPR(INDX,1,INQA)=ZETA(NZ)*ELM(INDX)
      IF(ISO.EQ.0.AND.INQA.EQ.1)QAPR(INDX,1,7)=QAPR(INDX,1,1)*IFAC(M)
 200  CONTINUE
 300  CONTINUE
      RETURN
      END
      FUNCTION LEADF(N1,N2,N3)
      COMMON/CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      LSUM=0
      N3M=N3-1
      IF(N3M.EQ.0)GO TO 5
      DO 1 K=1,N3M
 1    LSUM=LSUM+MULTI(K)
 5    N1M=N1-1
      IF(N1M.EQ.0)GO TO 6
      DO 2 K=1,N1M
 2    LSUM=LSUM+LDNUM(N3,K)
 6    N1M=LSUM+N2
      LEADF=LEAD(2,N1M)
      RETURN
      END
      FUNCTION MEM(N1,N2,N3)
      COMMON/CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      MSUM=0
      IF(N3.EQ.1)GO TO 5
      N3M=N3-1
      DO 1 K=1,N3M
 1    MSUM=MSUM+MULTI(K)
 5    N1M=N1-1
      IF(N1M.EQ.0)GO TO 6
      DO 2 K=1,N1M
 2    MSUM=MSUM+LDNUM(N3,K)
 6    N1M=MSUM+1
      N3M=N1M+LDNUM(N3,N1)
      DO 3 K=N1M,N3M
      MSUM=MSUM+1
 3    IF(LEAD(2,K).EQ.N2)GO TO 7
 7    MEM=MSUM
      RETURN
      END
      SUBROUTINE CMLAB(II,DSIG,TETRN)
      LOGICAL ERR
      COMMON/CLCOM9/ERR
      COMMON/SECK/ISKIN(50)
      COMMON/PRT/IPRM(20)
      COMMON/TCM/TETACM(50),TREP(50),DSIGS(50)
      COMMON/BREC/BETAR(50)
      COMMON/CAUX0/NCM,EMMA(75)
      COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON/CX/NEXPT,IZ,XA,IZ1(50),XA1(50),EP(50),TLBDG(50),VINF(50)
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      COMMON/COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      LEXP0=1
      LEXP1=NEXPT
      IF(II.NE.0)LEXP0=II
      IF(II.NE.0)LEXP1=II
      DO 1 LEXP=LEXP0,LEXP1
      IFLAA=0
      IF(TLBDG(LEXP).LT.0)IFLAA=1
      IF(IPRM(1).NE.1)GO TO 1234
      IF(II.EQ.0.AND.IPRM(10).EQ.1)WRITE(22,906)LEXP
 1234 TLBDG(LEXP)=ABS(TLBDG(LEXP))
      A1=XA1(LEXP)
      IF(IZ1(LEXP).LT.0)A1=XA
      A2=XA
      IF(IZ1(LEXP).LT.0)A2=XA1(LEXP)
      Z1=FLOAT(IABS(IZ1(LEXP)))
      Z2=FLOAT(IZ)
      IF(IPRM(1).NE.1)GO TO 2345
      IF(IZ1(LEXP).LT.0.AND.(II.EQ.0.AND.IPRM(10).EQ.1))WRITE(22,907)
     *IZ,XA,IABS(IZ1(LEXP)),XA1(LEXP)
      IF(IZ1(LEXP).GT.0.AND.(II.EQ.0.AND.IPRM(10).EQ.1))WRITE(22,908)
     *IZ,XA,IZ1(LEXP),XA1(LEXP)
 2345 DISTS=1.44*(A1+A2)*Z1*Z2/((A1**.33333+A2**.33333)*1.25+5.)/A2
      DISTA=0.0719949*(1.0+A1/A2)*Z1*Z2/EP(LEXP)
      D2A=20.0*DISTA
      VINF(LEXP)=0.0463365*SQRT(EP(LEXP)/A1)
      IF(IPRM(1).NE.1)GO TO 1111
      IF(II.EQ.0.AND.IPRM(10).EQ.1)WRITE(22,909)EP(LEXP),VINF(LEXP)
      IF(EP(LEXP).GT.DISTS.AND.(II.EQ.0.AND.IPRM(10).EQ.1))
     *WRITE(22,905)(EP(LEXP)/DISTS-1.)*100.
      IF(II.EQ.0.AND.IPRM(10).EQ.1)WRITE(22,910)D2A
 1111 TLBRAD=TLBDG(LEXP)/57.2957795
      ARED=1.0+A1/A2
      EMAX=EP(LEXP)/ARED
      DO 200 N=1,NMAX
 200  IF (EN(N).GT.EMAX) GOTO 100
      GO TO 150
 100  CONTINUE
      WRITE(22,900)EMAX,LEXP
      GOTO 850
 150  EPMIN=EP(LEXP)- EN(NCM)*ARED
      TAUP=SQRT(EP(LEXP)/EPMIN)
      TAU=TAUP*A1/A2
      IF (TAU.LE.1.0) GOTO 120
      TMXDG=TASIN(1.0/TAU)*57.2957795
      IF (TMXDG.GE.TLBDG(LEXP)) GOTO 120
      WRITE(22,902)TMXDG,LEXP
      GOTO 850
 120  TCMRAD=TLBRAD+ TASIN(TAU*SIN(TLBRAD))
      TCMDG=TCMRAD*57.2957795
      IF (TAU.LE.1.0) GOTO 140
      IF(IPRM(1).NE.1)GO TO 4444
      IF(II.EQ.0.AND.IPRM(10).EQ.1)WRITE(22,904) TCMDG,LEXP
 4444 CONTINUE
      IF(ISKIN(LEXP).EQ.1)GO TO 140
      TCMDG=180.+2.*TLBDG(LEXP)-TCMDG
      TCMRAD=TCMDG/57.2957795
 140  CONTINUE
      EPS(LEXP)=1./SIN(TCMRAD/2.)
       TETACM(LEXP)=TCMRAD
      IF(IPRM(1).NE.1)GO TO 5555
      IF(II.EQ.0.AND.IPRM(10).EQ.1)WRITE(22,911)TCMDG,EPS(LEXP)
 5555 CONTINUE
      IF(IZ1(LEXP).GT.0)BETAR(LEXP)=A1*A2/(A1+A2)
     ***2*(1.+TAUP*TAUP-2.*TAUP*COS(TCMRAD))*EPMIN
      IF(IZ1(LEXP).LT.0)BETAR(LEXP)=(A2/(A1+A2))
     ***2*(1.+TAU*TAU+2.*TAU*COS(TCMRAD))*EPMIN
      IF(IPRM(1).NE.1)GO TO 6666
      IF(II.EQ.0.AND.IPRM(10).EQ.1)WRITE(22,920)BETAR(LEXP)
 6666 BETAR(LEXP)=.0463365*SQRT(BETAR(LEXP)/XA)
      IF(IPRM(1).NE.1)GO TO 7777
      IF(II.EQ.0.AND.IPRM(10).EQ.1)WRITE(22,921)BETAR(LEXP)
      IF(II.EQ.0.AND.IPRM(10).EQ.1)WRITE(22,931)
     > EP(LEXP)/(DISTS*.5*(1.+EPS(LEXP)))
 7777 CONTINUE
      IF(IFLAA.EQ.1)GO TO 505
      IF(ABS(TCMDG-180.).LT.1.E-5)GO TO 500
      R3=SIN(TLBRAD)/SIN(TCMRAD)
      R3=R3*R3*ABS(COS(TCMRAD-TLBRAD))
      R3=1./R3
      GO TO 505
 500  R3=(1.-TAU)**2
 505  CONTINUE
      ZCMDG=180.-TCMDG
      ZCMRAD=ZCMDG/57.2957795
      ZLBRAD=ATAN(SIN(ZCMRAD)/(COS(ZCMRAD)+TAUP))
      IF(IFLAA.EQ.0)GO TO 515
      IF(ABS(TCMDG-180.).LT.1.E-5)GO TO 511
      R3=SIN(ZLBRAD)/SIN(ZCMRAD)
      R3=R3*R3
      R3=R3*ABS(COS(ZCMRAD-ZLBRAD))
      R3=1./R3
      TLBDG(LEXP)=ZLBRAD*57.2955795
      GO TO 515
 511  R3=(1.+TAUP)**2
      TLBDG(LEXP)=0.
 515  DSIG=250.*R3*SQRT(EP(LEXP)/(EP(LEXP)-ARED*EN(NCM)))*
     *DISTA*DISTA*(EPS(LEXP))**4
      EROOT(LEXP)=SQRT(EPS(LEXP)*EPS(LEXP)-1.)
      DSIGS(LEXP)=DSIG
      TETRN=ZLBRAD
      IF(IZ1(LEXP).LT.0.)TETRN=TLBRAD
  1   TREP(LEXP)=TETRN
      IPRM(10)=0
      RETURN
 850  ERR=.TRUE.
      RETURN
 900  FORMAT(1X,36HERROR- MAXIMUM EXCITATION ENERGY IS ,F8.4,4H MEV,
     *16H FOR EXPERIMENT ,1I2)
 902  FORMAT(1X,35HERROR- MAXIMUM SCATTERING ANGLE IS ,F7.2,8H DEGREES,
     *16H FOR EXPERIMENT ,1I2)
 904  FORMAT(5X,38HSECOND POSSIBLE CM SCATTERING ANGLE IS ,F7.2,
     *24H DEGREES FOR EXPERIMENT ,1I2)
 905  FORMAT(5X,6H***** ,
     *20HBE CAREFUL-ACCORDING,
     *29H TO D.CLINE BOMBARDING ENERGY,1X,1F6.2,1X,2HPC,1X,
     *39H TOO HIGH FOR HEAD-ON COLLISIONS! *****)
 906  FORMAT(1X,///10X,13H** EXPERIMENT,1X,1I2,1X,2H**//)
 907  FORMAT(5X,25HPROJECTILE EXCITATION OF(,1I3,1H,,1F7.3,
     *5H) ON(,1I3,1H,,1F7.3,1H))
 908  FORMAT(5X,21HTARGET EXCITATION OF(,1I3,1H,,1F7.3,
     *5H) BY(,1I3,1H,,1F7.3,1H))
 909  FORMAT(5X,6HENERGY,1X,1F10.3,1X,3HMEV,5X,4HBETA,1X,
     *1E14.6)
 910  FORMAT(5X,51HDISTANCE OF CLOSEST APPROACH FOR HEAD-ON COLLISIONS
     *,1X,1F10.4,1X,2HFM)
 931  FORMAT(5X,18HBOMBARDING ENERGY=,1F10.3,1X,
     *39HOF SAFE BOMBARDING ENERGY AT THIS ANGLE)
 911  FORMAT(5X,19HCM SCATTERING ANGLE,1X,1F10.3
     *,1X,3HDEG,5X,7HEPSILON,1X,1F10.4)
 920  FORMAT(5X,18HRECOIL ENERGY(MEV),2X,1F10.4)
 921   FORMAT(5X,11HRECOIL BETA,2X,1E14.6)
      END
       SUBROUTINE QE(C,D,B2,C2,D2,B4,B6,D3,B8,C4,D4,B10,D5,
     *B12,D6,LMDA,POL,CQ)
      DIMENSION CQ(7)
      GO TO(110,120,130,140,150,160)LMDA
 110    CQ(1)=0.5*C/B2
      CQ(2)=-0.35355339*D/B2
      RETURN
 120    CQ(1)=0.75*(2.0*C2-D2)/B4*POL
      CQ(2)=-1.83711730*C*D/B4*POL
      CQ(3)=-0.91855865*D2/B4*POL
      RETURN
 130    CQ(1)=1.875*C*(2.0*C2-3.0*D2)/B6
      CQ(2)=-1.62379763*(4.0*C2-D2)*D/B6
      CQ(3)=-5.13489890*C*D2/B6
      CQ(4)=2.09631373*D3/B6
      RETURN
 140    CQ(1)=1.09375000*(8.0*C4-24.0*C2*D2+3.0*D4)/B8
            CQ(2)=-4.89139867*C*(4.0*C2-3.0*D2)*D/B8
      CQ(3)=-3.45874113*(6.0*C2-D2)*D2/B8
      CQ(4)=12.9414244 *C*D3/B8
      CQ(5)=4.57548440*D4/B8
      RETURN
 150    CQ(1)=1.230468*C*(-14.*C2*(9.*D2+B2)+30.*B4)/B10
      CQ(2)=-1.347911*D*(35.*C2*(-3.*D2+B2)+5.*B4)/B10
      CQ(3)=-35.662372*D2*C*(-3.*D2+2.*B2)/B10
      CQ(4)=7.279552*D3*(9.*C2-B2)/B10
      CQ(5)=30.884521*D4*C/B10
      CQ(6)=-9.766543*D5/B10
      RETURN
 160    CQ(1)=2.707031*(21.*C2*(-C2*(11.*D2+4.*B2)+5.*B4)-
     1 5.*B6)/B12
      CQ(2)=-17.543567*D*C*(3.*C2*(-11.*D2+B2)+5.*B4)/
     1 B12
      CQ(3)=-13.869408*D2*(3.*C2*(-11.*D2+5.*B2)+B4)/B12
      CQ(4)=-27.738815*D3*C*(-11.*D2+8.*B2)/B12
      CQ(5)=15.193177*D4*(11.*C2-B2)/B12
      CQ(6)=-71.262308*D5*C/B12
      CQ(7)=-20.571656*D6/B12
      RETURN
      END
      SUBROUTINE QM(C,D,B2,B4,ERT,LMDA,CQ)
      DIMENSION CQ(7)
      IF(LMDA.EQ.8)GO TO 220
      CQ(1)=-.3535533905*ERT/B2
      RETURN
 220  CQ(1)=-.9185586536*C*ERT/B4
      CQ(2)=-CQ(1)*D/C
      RETURN
      END
      SUBROUTINE SNAKE(NEXP,ZPOL)
      DIMENSION LLOC(8),CQ(7),IRL(8)
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      COMMON/CCOUP/ZETA(50000),LZETA(8)
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/ALLC/LOCQ(8,7)
      COMMON/HIPER/SH(365),CH(365)
      ICNT=0
  1    ICNT=ICNT+1
      CALL QRANGE(ICNT,NLM,LLOC,IBM,ICM,IDM,IRL)
      IF(NLM.EQ.0)RETURN
      CHI=CH(ICNT)
      SHI=SH(ICNT)
      B2=EPS(NEXP)*CHI+1.
      POL=1.-ZPOL/B2
      B2=B2*B2
      IF(IBM.EQ.2)GO TO 3
      B4=B2*B2
      IF(IBM.EQ.4)GO TO 3
      B6=B4*B2
      IF(IBM.EQ.6)GO TO 3
      B8=B4*B4
      IF(IBM.EQ.8)GO TO 3
      B10=B6*B4
      IF(IBM.EQ.10)GO TO 3
      B12=B6*B6
 3    IF(ICM.EQ.0)GO TO 4
      C=CHI+EPS(NEXP)
      IF(ICM.EQ.1)GO TO 4
      C2=C*C
      IF(ICM.EQ.2)GO TO 4
      C4=C2*C2
      IF(ICM.EQ.4)GO TO 4
      C6=C2*C4
 4    IF(IDM.EQ.0)GO TO 5
      D=EROOT(NEXP)*SHI
      IF(IDM.EQ.1)GO TO 5
      D2=D*D
      IF(IDM.EQ.2)GO TO 5
      D3=D*D2
      IF(IDM.EQ.3)GO TO 5
      D4=D2*D2
      IF(IDM.EQ.4)GO TO 5
      D5=D3*D2
      IF(IDM.EQ.5)GO TO 5
      D6=D3*D3
 5    DO 7 J=1,NLM
      LMDA=LLOC(J)
      IF(LMDA.GT.6)GO TO 11
      CALL QE(C,D,B2,C2,D2,B4,B6,D3,B8,C4,D4,B10,D5,B12,D6,LMDA,POL,CQ)
      MIMX=LMDA+1
      DO 8 K=1,MIMX
      NIND=LOCQ(LMDA,K)+ICNT
 8    ZETA(NIND+LP7)=CQ(K)
      GO TO 7
 11   LMD=LMDA
      LMDA=LMDA-6
      ERT=EROOT(NEXP)
      CALL QM(C,D,B2,B4,ERT,LMDA,CQ)
      MIMX=LMDA
      DO 9 K=1,MIMX
      NIND=LOCQ(LMD,K)+ICNT
 9    ZETA(NIND+LP7)=CQ(K)
 7    CONTINUE
      GO TO 1
      END
      SUBROUTINE FHIP
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/HIPER/SH(365),CH(365)
      W=-.03
      DO 1 J=1,LP12
      W=W+.03
      EX=EXP(W)
      ER=1./EX
      SH(J)=(EX-ER)/2.
 1    CH(J)=(EX+ER)/2.
      RETURN
      END
      SUBROUTINE ALLOC(ACCUR)
      COMMON/CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON/ALLC/LOCQ(8,7)
      COMMON/RNG/IRA(8),MAXLA
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      CALL RANGEL(ACCUR)
      LOAD=0
      IFLAG=0
      DO 10 J=1,8
      DO 10 K=1,7
 10   LOCQ(J,K)=0
      DO 1 K=1,6
      K1=K+1
      DO 1 J=1,K1
      LOCQ(K,J)=LOAD
 1    LOAD=LOAD+IRA(K)
      DO 2 K=7,8
      K1=K-6
      DO 2 J=1,K1
      LOCQ(K,J)=LOAD
 2    LOAD=LOAD+IRA(K)
      IF(LOAD.LE.LP14)RETURN
      WRITE(22,12)
 12   FORMAT(5X,35HNO SPACE FOR Q FUNCTIONS TABULATION//
     *5X,38HSORRY,JOB WILL BE BRUTALLY TERMINATED!)
      V=-1.
      U=ALOG10(V)
      u=sin(u)
      RETURN
      END
      SUBROUTINE RANGEL(ACC1)
      COMMON/A50/ACC50
      COMMON/RNG/IRA(8),MAXLA
      COMMON/CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      ACL=-ALOG(ACC1)
      ACC50=ACC1/50.
      DO 110 I=1,8
      IF(MULTI(I).NE.0)GO TO 100
      IRA(I)=0
      GO TO 110
 100  GO TO(1,2,3,4,5,6,2,3)I
 1    W=ACL-.693
      GO TO 120
 2    W=ACL/2.+.203
      GO TO 120
 3    W=ACL/3.+.536
      GO TO 120
 4    W=ACL/4.+.716
      GO TO 120
 5    W=ACL/5.+.829
      GO TO 120
 6    W=ACL/6.+.962
 120  W=W/.03
      IRA(I)=IFIX(W+1.5)
 110  CONTINUE
      IF(IRA(7).NE.0)IRA(7)=IRA(7)+1
      IF(IRA(8).NE.0)IRA(8)=IRA(8)+1
      RETURN
      END
      SUBROUTINE QRANGE(ICNT,NLM,LLOC,IBM,ICM,IDM,IRL)
      DIMENSION LLOC(8),IRL(8)
      COMMON/RNG/IRA(8),MAXLA
      COMMON/CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      IF(ICNT.EQ.1)GO TO 1
      IF(IRL(NLM).GE.ICNT)RETURN
      LD=LLOC(NLM)
      LLOC(NLM)=0
      NLM=NLM-1
      IF(NLM.EQ.0)RETURN
      IF(LD.GT.6)RETURN
      GO TO 10
 1    NLM=0
      DO 2 L=1,8
      LLOC(L)=0
 2    IRL(L)=0
      DO 3 K=1,6
      KE=7-K
      KM=13-K
      IF(KM.GT.8)GO TO 4
      IF(MULTI(KM).EQ.0)GO TO 4
      NLM=NLM+1
      LLOC(NLM)=KM
      IRL(NLM)=IRA(KM)
 4    IF(MULTI(KE).EQ.0)GO TO 3
      NLM=NLM+1
      LLOC(NLM)=KE
      IRL(NLM)=IRA(KE)
 3    CONTINUE
      NLEND=IFIX((FLOAT(NLM)+1.1)/2.)
      DO 5 K=1,NLEND
      KE=NLM-K+1
      LS=LLOC(KE)
      IS=IRL(KE)
      LLOC(KE)=LLOC(K)
      IRL(KE)=IRL(K)
      LLOC(K)=LS
 5    IRL(K)=IS
      L=0
      DO 6 K=1,6
      IF(MULTI(K).EQ.0)GO TO 6
      L=K
 6    CONTINUE
      ICM=MIN0(4,L)
      IBM=2*L
      IDM=L
      L=0
      DO 7 K=7,8
      KE=K-6
      IF(MULTI(K).EQ.0)GO TO 7
      L=KE
 7    CONTINUE
      IBM=MAX0(IBM,2*L)
      IDM=MAX0(IDM,L)
      IF(ICM.EQ.1.AND.L.GT.1)ICM=2
      MAXLA=LLOC(1)
      RETURN
 10   L=LLOC(NLM)
      IF(L.GT.6)L=L-6
      ICM=MIN0(2,L)
      IBM=2*L
      IDM=L
      RETURN
      END
      SUBROUTINE AMPDER(I57)
      COMPLEX ARM,EXPO
      COMMON /COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      COMMON/AZ/ARM(600,7)
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON /CAUX/NPT,NDIV,KDIV,LAMR(8),ISG,D2W,NSW,ISG1
      COMMON/PINT/ISSTAR(76),ISSTO(75),MSTORE(2,75)
      COMMON/ADBXI/EXPO(500)
      COMMON/CCOUP/ZETA(50000),LZETA(8)
      COMMON/CLCOM8/CAT(600,3),ISMAX
      COMMON/CEXC0/NSTART(76),NSTOP(75)
      DO 100 K=1,ISMAX
      ARM(K,6)=(0.,0.)
 100  ARM(K,4)=(0.,0.)
      ISG1=ISG
      IF(NPT.EQ.1)ISG1=IABS(ISG1)
      RSG=FLOAT(ISG)
      DO 1 I1=1,LAMMAX
      LAM=LAMDA(I1)
      LAX=LAM
      NZ=LZETA(LAM)
      IF(LAMR(LAM).EQ.0)GO TO 1
      IFLG=1
      NHOLD=1
      GO TO 400
 401  NHOLD=NHOLD+1
      IF(NSTART(NHOLD).EQ.0)GO TO 401
 400  CALL NEWLV(NHOLD,LD,LAM)
      IF(LD.EQ.0)GO TO 401
      IR=NSTART(NHOLD)-1
 200  IR=IR+1
      IF(IR.GT.ISMAX)GO TO 1
      N=CAT(IR,1)
      IF(N.NE.NHOLD)GO TO 203
 204  CALL LAISUM(IR,N,RSG,LAX,LD,NZ,I57)
      GO TO 200
 201  IR=IR+NSTOP(N)-NSTART(N)+1
      N=N+1
      IF(N.GT.NMAX)GO TO 1
      GO TO 202
 203  DO 300 MM=1,LD
      M=MSTORE(1,MM)
      IF(M.EQ.NHOLD)GO TO 300
      INDX=MSTORE(2,MM)
      IBG=ISSTAR(MM)
      IEND=ISSTO(MM)
      DO 301 IS2=IBG,IEND
      ARM(IS2,4)=ARM(IS2,4)+ARM(IS2,6)*ELM(INDX)/EXPO(INDX)
 301   ARM(IS2,6)=(0.,0.)
 300  CONTINUE
 202  CALL NEWLV(N,LD,LAM)
      IF(LD.EQ.0)GO TO 201
      NHOLD=N
      GO TO 204
 1    CONTINUE
      RETURN
      END
      SUBROUTINE LAISUM(IR,N,RSG,LAM,LD,NZ,I57)
      COMPLEX ARM,FAZA,PAMP,EXPO,PAMP1
      COMMON/PSPIN/ISHA
      COMMON/AZ/ARM(600,7)
      COMMON/COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      COMMON /CAUX/NPT,NDIV,KDIV,LAMR(8),ISG,D2W,NSW,ISG1
      COMMON/PINT/ISSTAR(76),ISSTO(75),MSTORE(2,75)
      COMMON/ADBXI/EXPO(500)
      COMMON /CCOUP/ZETA(50000),LZETA(8)
       COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/CLCOM8/CAT(600,3),ISMAX
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/ALLC/LOCQ(8,7)
      COMMON/CEXC0/NSTART(76),NSTOP(75)
      RMIR=CAT(IR,3)
      III=0
      IF(LAM.GT.6)III=1
      LA=LAM
      IF(LAM.GT.6)LAM=LAM-6
      DO 560 I2=1,LD
      PAMP=(0.,0.)
      M=MSTORE(1,I2)
      INDX=MSTORE(2,I2)
      ISMIN=0
      IS1=NSTART(M)
      IF(IS1.EQ.0)GO TO 560
      ISPLUS=IFIX(RMIR-CAT(IS1,3))-LAM
      IF(ISPLUS.GE.0)GOTO 150
      ISMIN=ISPLUS
      ISPLUS=0
 150  IS2=IS1+ISPLUS-1
      MRANGE=2*LAM+1+ISMIN
      IF(IS2+MRANGE.GT.NSTOP(M)) MRANGE=NSTOP(M)-IS2
      IF(MRANGE.LE.0)GOTO 560
      DO 540 I3=1,MRANGE
      IS=IS2+I3
      RMIS=CAT(IS,3)
      IF(ISO.EQ.0.AND.RMIR.GT..1.AND.RMIS.GT..1)GO TO 540
      RMU=RMIS-RMIR
      MUA=ABS(RMU)+1.1
      IF(LA.GT.6.AND.MUA.EQ.1)GO TO 540
      INDQ=LOCQ(LAM,MUA)+NPT
      NZ=NZ+1
      Z=ZETA(NZ)
      Q=ZETA(INDQ+LP7)
      IF(NDIV.NE.0)Q=ZETA(INDQ+LP7)+FLOAT(KDIV)*(ZETA(INDQ+LP7+ISG1)-
     *ZETA(INDQ+LP7))/FLOAT(NDIV)
      PAMP1=FAZA(LA,MUA,RMU,RSG)*Q*Z
      IF(ISO.EQ.0.AND.RMIR.GT..1)GO TO 545
      PAMP=PAMP1*ARM(IS,I57)+PAMP
      IF(ISO.EQ.0.AND.RMIS.GT..1)GO TO 540
 545   IF(N.EQ.M)GO TO 540
      IRS=(-1)**(IFIX(RMIR+RMIS)-ISHA+III)
      ARM(IS,6)=ARM(IS,6)+IRS*PAMP1*ARM(IR,I57)
      ISSTAR(I2)=MIN0(IS,ISSTAR(I2))
      ISSTO(I2)=MAX0(IS,ISSTO(I2))
 540  CONTINUE
      IF(N.EQ.M)GO TO 570
      ARM(IR,4)=ARM(IR,4)+PAMP*ELM(INDX)*EXPO(INDX)
      GO TO 560
 570  ARM(IR,4)=ARM(IR,4)+PAMP*ELM(INDX)
 560  CONTINUE
      LAM=LA
      RETURN
      END
       COMPLEX FUNCTION EXPON(INX,NPT,ISG,ISG1,NDIV,KDIV)
       COMPLEX EXPO1,CI,EXPOX,TCEXP
       COMMON/ADX/ADB(365)
       COMMON/CXI/XI(500)
       DATA CI/(0.,1.)/
      EXPOX=TCEXP(CI*XI(INX)*ADB(NPT)*ISG)
      EXPON=EXPOX
      IF(NDIV.EQ.0)GO TO 1
      EXPO1=TCEXP(CI*XI(INX)*ADB(NPT+ISG1)*ISG)
      EXPON=EXPOX+FLOAT(KDIV)*(EXPO1-EXPOX)/FLOAT(NDIV)
  1   CONTINUE
      RETURN
      END
      COMPLEX FUNCTION FAZA(LA,MI,RMU,RSG)
      COMPLEX CI
      DATA CI/(0.,1.)/
      IF(LA.GT.6)GO TO 100
      IEVEN=(-1)**MI
      IF(IEVEN)2,2,3
 2    FAZA=-CI
      RETURN
  3   FAZA=CMPLX(RSG,0.)
      RETURN
 100  FAZA=-CI
      IF(RMU.LT.0.)FAZA=-FAZA
      IF(LA.EQ.7)RETURN
      IF(MI.EQ.2)RETURN
      FAZA=CMPLX(RSG,0.)
      IF(RMU.LT.0.)FAZA=-FAZA
      RETURN
      END
      SUBROUTINE SETIN
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/HIPER/SH(365),CH(365)
      COMMON/ADX/ADB(365)
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      DO 10 K=1,LP12
 10   ADB(K)=EPS(IEXP)*SH(K)+.03*(K-1)
      RETURN
      END
      SUBROUTINE STING(IRLD)
      COMPLEX ARM,EXPO
      COMMON/CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON/AZ/ARM(600,7)
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/ADBXI/EXPO(500)
      COMMON/FLA/IFLG
      COMMON/PINT/ISSTAR(76),ISSTO(75),MSTORE(2,75)
      COMMON/CCOUP/ZETA(50000),LZETA(8)
      COMMON/CAUX/NPT,NDIV,KDIV,LAMR(8),ISG,D2W,NSW,ISG1
      COMMON/CLCOM8/CAT(600,3),ISMAX
      COMMON/RNG/IRA(8),MAXLA
      MAXH=MAXLA
 20   ISG=-1
      N=1
      RSG=-1.
      IFLG=1
      W0=IRA(MAXLA)*.03+.03
      DO 1 J=1,ISMAX
      DO 1 JJ=1,6
   1  ARM(J,JJ)=(0.,0.)
      ARM(IRLD,5)=(1.,0.)
      DO 2 J=1,8
 2    LAMR(J)=0
      LAMR(MAXLA)=1
      NPT=IRA(MAXLA)+1
      IF(MAXLA.EQ.7.AND.IRA(2).NE.0)GO TO 111
      GO TO 112
 111  LAMR(2)=1
      NPT=NPT-1
      W0=W0-.03
 112  NDIV=0
      KDIV=0
      DO 5 J=1,4
      NPT=NPT-1
      DO 7 J1=1,LAMMAX
      LAM=LAMDA(J1)
      IF(LAMR(LAM).EQ.0)GO TO 7
      CALL NEWLV(N,LD,LAM)
      IF(LD.EQ.0)GO TO 77
      NZ=LZETA(LAM)
      LD=LDNUM(LAM,1)
      I57=5
      CALL LAISUM(IRLD,N,RSG,LAM,LD,NZ,I57)
      DO 300 MM=1,LD
      INDX=MSTORE(2,MM)
      IBG=ISSTAR(MM)
      IEND=ISSTO(MM)
      DO 301 IS2=IBG,IEND
      ARM(IS2,4)=ARM(IS2,4)+ARM(IS2,6)*ELM(INDX)/EXPO(INDX)
 301  ARM(IS2,6)=(0.,0.)
 300  CONTINUE
      GO TO 7
 77   IF(J1.NE.MAXLA)GO TO 7
      IRA(MAXLA)=-IRA(MAXLA)
      DO 88 JJ=1,LAMMAX
      LAM=LAMDA(JJ)
      IF(IRA(LAM).GT.0)GO TO 99
 88   CONTINUE
 99   MAXLA=LAMDA(JJ)
      GO TO 20
 7    CONTINUE
      IF(J.EQ.4)GO TO 4
      DO 5 I=1,ISMAX
      ARM(I,J)=ARM(I,4)
 5    ARM(I,4)=(0.,0.)
 4    CALL LAIAMP(IRLD,W0)
      MAXLA=MAXH
      DO 101 JJ=1,8
 101  IRA(JJ)=IABS(IRA(JJ))
      RETURN
      END
      SUBROUTINE LAIAMP(IR,W0)
      COMPLEX ARM,STAMP,DIS,UHUJ
      COMMON /CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON/AZ/ARM(600,7)
      COMMON /CAUX/NPT,NDIV,KDIV,LAMR(8),ISG,D2W,NSW,ISG1
      COMMON /CCOUP/ZETA(50000),LZETA(8)
      COMMON/CLCOM8/CAT(600,3),ISMAX
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/CEXC0/NSTART(76),NSTOP(75)
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      COMMON/CXI/XI(500)
       PPP=0.
       EPSI=EPS(IEXP)
      ERRT=EROOT(IEXP)
      RMIR=CAT(IR,3)
      DO 580 I1=1,LAMMAX
      LAM=LAMDA(I1)
      NZ=LZETA(LAM)
      IF(LAMR(LAM).EQ.0)GO TO 580
      LA=LAM
      IF(LAM.GT.6) LAM=LAM-6
      LD=LDNUM(LA,1)
      IF(LD.EQ.0)GOTO 580
      DO 560 I2=1,LD
      M=LEADF(1,I2,LA)
      INDX=MEM(1,M,LA)
      XIV=XI(INDX)
      ISMIN=0
      IS1=NSTART(M)
      IF(NSTART(M).EQ.0)GO TO 560
      ISPLUS=IFIX(RMIR-CAT(IS1,3))-LAM
      IF(ISPLUS.GE.0)GOTO 150
      ISMIN=ISPLUS
      ISPLUS=0
 150  IS2=IS1+ISPLUS-1
      MRANGE=2*LAM+1+ISMIN
      IF(IS2+MRANGE.GT.NSTOP(M)) MRANGE=NSTOP(M)-IS2
      IF(MRANGE.LE.0)GOTO 560
      DO 540 I3=1,MRANGE
      IS=IS2+I3
      NZ=NZ+1
      Z=ZETA(NZ)
      RMIS=CAT(IS,3)
      RMU=RMIS-RMIR
      MUA=ABS(RMU)+1.1
      IF(LAM.GT.6.AND.MUA.EQ.1)GO TO 540
      CALL FAZA1(LA,MUA,RMIR,RMIS,DIS,RMU)
      PM=ELM(INDX)*Z
      UHUJ=STAMP(EPSI,ERRT,XIV,.03,W0,LAM,MUA)
      ARM(IS,5)=DIS*PM*UHUJ
      PPP=PPP+TCABS(ARM(IS,5))*TCABS(ARM(IS,5))
 540  CONTINUE
 560  CONTINUE
 580  CONTINUE
      ARM(IR,5)=CMPLX(SQRT(1.-PPP),0.)
      RETURN
      END
       SUBROUTINE FAZA1(LA,MI,RMIR,RMIS,DIS,RMU)
       COMPLEX DIS,CI
       DATA CI/(0.,1.)/
      IRS=(-1)**IFIX(RMIR+RMIS)
      IF(LA.EQ.7)GO TO 4
      IEVEN=(-1)**MI
      IF(IEVEN)2,2,3
  2    DIS=-CI*IRS
      RETURN
 3    DIS=CMPLX(-FLOAT(IRS),0.)
      RETURN
 4    DIS=-CI*IRS
      IF(RMU.LT.0.)DIS=-DIS
      RETURN
      END
      SUBROUTINE TRINT(ARG,SI,CI)
      A=ARG*ARG
      IF(ARG.LT.1.)GO TO 1
      S=SIN(ARG)
      C=COS(ARG)
      F=POL4(1.,38.027246,265.187033,335.67732,38.102495,A)
      F=F/POL4(1.,40.021433,322.624911,570.23628,157.105423,A)/ARG
      G=POL4(1.,42.242855,302.757865,352.018498,21.821899,A)
      G=G/POL4(1.,48.196927,482.485984,1114.978885,449.690326,A)/A
      SI=F*C+G*S
      CI=G*C-F*S
      RETURN
 1    SI=POL4(0.,2.83446712E-5,-1.66666667E-3,.055555555,-1.,A)
      SI=SI*ARG
      CI=POL4(-3.100198413E-6,2.314814815E-4,-.0104166667,.25,0.,A)
      CI=CI-ALOG(ARG)
      RETURN
      END
      FUNCTION POL4(C0,C1,C2,C3,C4,A)
      pol4=1.
      if(abs(a).gt.1.e+9)return
      POL4=C4+A*(C3+A*(C2+A*(C1+A*C0)))
      RETURN
      END
      COMPLEX FUNCTION STAMP(EPSI,ERRT,XIV,DW,W0,LMDA,MUA)
      MI=MUA-1
      AXI=ABS(XIV)
      LA=LMDA
      IF(LMDA.EQ.7)LA=3
      IF(AXI.LT.1.E-5)GO TO 100
      EX=EXP(W0)/2.
      B=AXI*(EPSI*EX+W0)
      CALL TRINT(B,SIB,CIB)
      SB=SIN(B)/B
      CB=COS(B)/B
      BIS=SB+CIB
      BIC=CB-SIB
      BIS2=-SB/B
      BIC2=-CB/B
      DWI=-3.*DW
      EXA=EXP(DWI)
      A=AXI*(EPSI*EX*EXA+W0+DWI)
      SA=SIN(A)/A
      CA=COS(A)/A
      CALL TRINT(A,SIA,CIA)
      CIS=SA+CIA-BIS
      CIC=CA-SIA-BIC
      IF(LA.EQ.1)GO TO 125
      DWI=(BIC2-CIS+CA/A)/2.
      EXA=(BIS2+CIC+SA/A)/2.
      STAMP=CMPLX(DWI,EXA)
      GO TO 101
 125  STAMP=CMPLX(CIC,CIS)
 101  GO TO 200
 100  A=-2.*W0
      IF(LA.EQ.3)A=-W0
      EXA=EXP(A)
      DWI=3*DW
      CIC=EXA*(EXP(DWI)-1.)
      STAMP=CMPLX(CIC,0.)
      GO TO 300
 200  GO TO(51,52,53)LA
 51   IF(MI.EQ.0)FCT=.5*AXI/EPSI
      IF(MI.EQ.1)FCT=.3535533907*ERRT*AXI/EPSI
      GO TO 400
 52   IF(MI.EQ.0)FCT=.75*(3.-EPSI*EPSI)*AXI*AXI/EPSI/EPSI
      IF(MI.EQ.1)FCT=1.837117307*ERRT*AXI*AXI/EPSI/EPSI
      IF(MI.EQ.2)FCT=-.9185586535*ERRT*ERRT*AXI*AXI/EPSI/EPSI
      GO TO 400
 53   FCT=-.3535533905*ERRT*AXI*AXI
      GO TO 400
 300  GO TO(61,62,63)LA
 61   IF(MI.EQ.0)FCT=1./EPSI/EPSI
      IF(MI.EQ.1)FCT=1.414213562*ERRT/EPSI/EPSI
      GO TO 400
 62   IF(MI.EQ.0)FCT=3.*(3.-EPSI*EPSI)/EPSI/EPSI/EPSI/EPSI
      IF(MI.EQ.1)FCT=1.837117307*ERRT/EPSI/EPSI/EPSI/EPSI
      IF(MI.EQ.2)FCT=-3.674234613*ERRT*ERRT/EPSI/EPSI/EPSI/EPSI
      GO TO 400
 63   FCT=-1.414213562*ERRT/EPSI/EPSI
 400  STAMP=STAMP*FCT
      STAMP=CONJG(STAMP)
      RETURN
      END
      SUBROUTINE RESET(ISO)
      COMPLEX ARM
      COMMON/CEXC0/NSTART(76),NSTOP(75)
      COMMON/AZ/ARM(600,7)
      COMMON/CLCOM8/CAT(600,3),ISMAX
      COMMON/COEX2/NMAX,NDIM,NMAX1
      IF(ISO.EQ.0)GO TO 1
      DO 2 J=1,ISMAX
      ARM(J,1)=ARM(J,2)
      ARM(J,2)=ARM(J,3)
 2    ARM(J,3)=ARM(J,4)
      RETURN
 1    DO 3 J=1,NMAX
      IR=NSTART(J)-1
 4    IR=IR+1
      ARM(IR,1)=ARM(IR,2)
      ARM(IR,2)=ARM(IR,3)
      ARM(IR,3)=ARM(IR,4)
      IF(CAT(IR,3).LT.-.1)GO TO 4
 3    CONTINUE
      RETURN
      END
      SUBROUTINE HALF(ISO)
      COMPLEX ARM,FPOM
      COMMON/CEXC0/NSTART(76),NSTOP(75)
      COMMON/AZ/ARM(600,7)
      COMMON/CLCOM8/CAT(600,3),ISMAX
      COMMON/COEX2/NMAX,NDIM,NMAX1
      IF(ISO.EQ.0)GO TO 1
      DO 2 J=1,ISMAX
      FPOM=ARM(J,3)
      ARM(J,1)=-.0625*(ARM(J,4)+ARM(J,1))+.5625*(ARM(J,2)
     *+ARM(J,3))
      ARM(J,3)=ARM(J,3)*.75+.375*ARM(J,4)-ARM(J,2)/8.
 2    ARM(J,2)=FPOM
      RETURN
 1    DO 3 J=1,NMAX
      IR=NSTART(J)-1
 4    IR=IR+1
      FPOM=ARM(IR,3)
      ARM(IR,1)=-.0625*(ARM(IR,1)+ARM(IR,4))+.5625*
     *(ARM(IR,2)+ARM(IR,3))
      ARM(IR,3)=ARM(IR,3)*.75+.375*ARM(IR,4)-ARM(IR,2)/8.
      ARM(IR,2)=FPOM
      IF(CAT(IR,3).LT.-.1)GO TO 4
 3    CONTINUE
      RETURN
      END
      SUBROUTINE DOUBLE(ISO)
      COMPLEX ARM,FPOM
      COMMON/CEXC0/NSTART(76),NSTOP(75)
      COMMON/AZ/ARM(600,7)
      COMMON/CLCOM8/CAT(600,3),ISMAX
      COMMON/COEX2/NMAX,NDIM,NMAX1
      IF(ISO.EQ.0)GO TO 1
      DO 2 J=1,ISMAX
      FPOM=ARM(J,2)
      ARM(J,2)=-8.*ARM(J,3)+6.*ARM(J,2)+3.*ARM(J,4)
      ARM(J,1)=-16.*ARM(J,1)+9.*ARM(J,2)+9.*FPOM-ARM(J,4)
 2    ARM(J,3)=FPOM
      RETURN
 1    DO 3 J=1,NMAX
      IR=NSTART(J)-1
 4    IR=IR+1
       FPOM=ARM(IR,2)
      ARM(IR,2)=-8.*ARM(IR,3)+6.*ARM(IR,2)+3.*ARM(IR,4)
      ARM(IR,1)=-16.*ARM(IR,1)+9.*ARM(IR,2)+9.*FPOM
     *-ARM(IR,4)
      ARM(IR,3)=FPOM
      IF(CAT(IR,3).LT.-.1)GO TO 4
 3    CONTINUE
      RETURN
      END
      SUBROUTINE PATH(IRLD)
      COMMON/CEXC0/NSTART(76),NSTOP(75)
      COMMON/PTH/IPATH(75),MAGA(75)
      COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON/CLCOM8/CAT(600,3),ISMAX
      SPM=CAT(IRLD,3)
      DO 1 I=2,NMAX
      IPATH(I)=0
      IST=NSTART(I)
      IF(IST.EQ.0)GO TO 1
      ISP=NSTOP(I)
      DO 2 J=IST,ISP
      VL=CAT(J,3)
      IF(abs(vl-spm).lt.1.e-6)GO TO 3
  2   CONTINUE
      GO TO 1
  3   IPATH(I)=J
  1   CONTINUE
      IPATH(1)=IRLD
      RETURN
      END
      SUBROUTINE INTG(IEN)
      COMPLEX ARM,HOLD
      COMMON /COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      COMMON/AZ/ARM(600,7)
      COMMON/RNG/IRA(8),MAXLA
      COMMON/A50/ACC50
      COMMON/CLCOM0/IFAC(75)
      COMMON/CLCOM8/CAT(600,3),ISMAX
      COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON/CAUX/NPT,NDIV,KDIV,LAMR(8),ISG,D2W,NSW,ISG1
      COMMON/FLA/IFLG
      COMMON/CEXC0/NSTART(76),NSTOP(75)
      COMMON/PTH/IPATH(75),MAGA(75)
      COMMON/CEXC9/INTERV(50)
      INTEND=INTERV(IEN)
      D2W=.03
      NSW=1
      KAST=0
      NDIV=0
      KDIV=0
 100  IF((NPT+NSW).GT.IRA(MAXLA).AND.ISG.GT.0)RETURN
      DO 101 I=1,8
      LAMR(I)=0
      IF((NPT+NSW).LT.IRA(I))LAMR(I)=1
 101  CONTINUE
      IF(ISO.EQ.0)GO TO 290
      DO 285 IR=1,ISMAX
      ARM(IR,7)=ARM(IR,5)+D2W/24.*(55.0*ARM(IR,4)-59.0*ARM(IR,3)
     1+37.0*ARM(IR,2)-9.0*ARM(IR,1))
 285  CONTINUE
      GOTO 305
 290  DO 300 N=1,NMAX
      IR=NSTART(N)-1
 295  IR=IR+1
      ARM(IR,7)=ARM(IR,5) +D2W/24.*(55.0*ARM(IR,4)-59.0*ARM(IR,3)
     1+37.0*ARM(IR,2)-9.0*ARM(IR,1))
      MIR=CAT(IR,3)
      IR1=IR-2*MIR
      ARM(IR1,7)=IFAC(N)*ARM(IR,7)
      IF(FLOAT(MIR).LT.-0.1)GOTO 295
 300  CONTINUE
 305  CONTINUE
      NPT=NPT+NSW*ISG
      IF(NPT.LE.0)GO TO 601
      IF(NDIV.EQ.0)GO TO 325
      KDIV=KDIV+1
      IF(KDIV.GE.NDIV)GO TO 326
      GO TO 325
 326  KDIV=0
      NPT=NPT+ISG
      IF(NPT.LE.0)GO TO 601
      GO TO 325
 601  NPT=-NPT+2
      ISG=1
 325  CALL RESET(ISO)
      IFLG=1
      I57=7
      CALL AMPDER(I57)
      IF(ISO.EQ.0)GOTO 315
      DO 310 IR=1,ISMAX
      ARM(IR,5)=ARM(IR,5)+D2W/24.*(9.0*ARM(IR,4)+19.0*ARM(IR,3)
     1-5.0*ARM(IR,2)+ARM(IR,1))
 310  CONTINUE
      GOTO 330
 315  DO 311 N=1,NMAX
      IR=NSTART(N)-1
 320  IR=IR+1
      ARM(IR,5)=ARM(IR,5)+D2W/24.*(9.0*ARM(IR,4)+19.0*ARM(IR,3)
     1-5.0*ARM(IR,2)+ARM(IR,1))
      MIR=CAT(IR,3)
      IR1=IR-2*MIR
      ARM(IR1,5)=IFAC(N)*ARM(IR,5)
      IF(FLOAT(MIR).LT.-0.1)GOTO 320
 311  CONTINUE
 330  CONTINUE
      KAST=KAST+1
      IFLG=0
      I57=5
      CALL AMPDER(I57)
      IF((LAMR(2)+LAMR(3)).EQ.0)GO TO 100
      IF(KAST.LT.INTEND)GO TO 100
      KAST=0
      F=0.
      DO 401 K=1,NMAX
       IHOLD=IPATH(K)
      IF(IHOLD.EQ.0)GO TO 401
      HOLD=ARM(IHOLD,5)-ARM(IHOLD,7)
      RL=REAL(HOLD)
      RIM=AIMAG(HOLD)
      SRT=RL*RL+RIM*RIM
      F=AMAX1(F,SRT)
  401 CONTINUE
      F=SQRT(F)/14.
      IF(F.LE.ACCUR.AND.F.GE.ACC50)GO TO 100
      IF(F.LT.ACC50)GO TO 500
      CALL HALF(ISO)
      D2W=D2W/2.
      NSW=(FLOAT(NSW)+.01)/2.
      INTEND=2*INTEND
      IF(NSW.GE.1)GO TO 100
      NDIV=2*NDIV
      IF(NDIV.EQ.0)NDIV=2
      GO TO 100
 500  CALL DOUBLE(ISO)
      D2W=2.*D2W
      NSW=2*NSW
      INTEND=(FLOAT(INTEND)+.01)/2.
      IF(INTEND.EQ.0)INTEND=1
      IF(NSW.GE.1)GO TO 100
       NDIV=(FLOAT(NDIV)+.01)/2.
      IF(NDIV.GE.2)GO TO 100
      NDIV=0
      NSW=1
      GO TO 100
      END
      SUBROUTINE NEWLV(N,LD,LA)
      COMPLEX EXPO,EXPON
      COMMON /CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON /CAUX/NPT,NDIV,KDIV,LAMR(8),ISG,D2W,NSW,ISG1
      COMMON/PINT/ISSTAR(76),ISSTO(75),MSTORE(2,75)
      COMMON/ADBXI/EXPO(500)
      COMMON/FLA/IFLG
      COMMON/CEXC0/NSTART(76),NSTOP(75)
      LD=LDNUM(LA,N)
      IF(LD.EQ.0)RETURN
      DO 1 I2=1,LD
      M=LEADF(N,I2,LA)
      ISSTAR(I2)=NSTOP(M)
      ISSTO(I2)=NSTART(M)
      MSTORE(1,I2)=M
      INDX=MEM(N,M,LA)
      MSTORE(2,I2)=INDX
      IF(IFLG.EQ.0)GO TO 1
      IF(M.EQ.N)GO TO 1
      EXPO(INDX)=EXPON(INDX,NPT,ISG,ISG1,NDIV,KDIV)
 1    CONTINUE
      RETURN
      END
      SUBROUTINE CODE7(IR,IS,N,MT,INQA,INDX)
      COMMON/PTH/IPATH(75),MAGA(75)
      COMMON/APRCAT/QAPR(500,2,7),IAPR(500,2),ISEX(75)
      IAPR(INDX,1)=N
      IAPR(INDX,2)=MT
      IF(IPATH(N).EQ.0.OR.IPATH(MT).EQ.0)GO TO 6
      IDN=IR-IPATH(N)
      IDM=IS-IPATH(MT)
      ISM=IDN+IDM+3
      GO TO(1,2,3,4,5)ISM
 1    INQA=1
      RETURN
 2    INQA=2
      IF(IDN.GT.IDM)INQA=3
      RETURN
 3    INQA=4
      RETURN
 4    INQA=5
      IF(IDN.GT.IDM)INQA=6
      RETURN
 5    INQA=7
      RETURN
  6   INQA=-1
      RETURN
      END
      SUBROUTINE APRAM(IEXP,INC,INDX,IRLD,ACCA)
      COMPLEX ARM
      COMMON/AZ/ARM(600,7)
      COMMON/CXI/XI(500)
      COMMON/APRCAT/QAPR(500,2,7),IAPR(500,2),ISEX(75)
      COMMON/PTH/IPATH(75),MAGA(75)
      COMMON/CEXC/MAGEXC,MEMAX,LMAXE,MEMX6,IVAR(500)
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/APRX/LERF,IDIVE(50,2)
      LERF=0
      ACCAH=ACCA
 500  I7=7
      ITM=-1
      IMG=3
      I1=1
      IF(MAGA(IEXP).NE.0)GO TO 15
      I7=4
      I1=4
      IMG=1
 15   IF(INC.EQ.0)GO TO 1
      IF(LERF.EQ.0)CALL NEWCAT(IEXP,JIDIM)
      IF(LERF.EQ.0)CALL PODZIEL(3,IEXP)
      I56=5
      DO 2 K=1,JIDIM
      ARM(K,2)=(0.,0.)
   2  ARM(K,5)=(0.,0.)
      ARM(IRLD+1,5)=(1.,0.)
 100  KTOTO=0
      LERF=0
      L1=IDIVE(IEXP,1)
      DO 300 L3=1,L1
      ACCA=ACCAH*L3/L1
      CALL POMNOZ(ACCA,1,I56,KTOTO,IMG,JIDIM)
      IF(LERF.EQ.0)GO TO 300
      CALL PODZIEL(1,IEXP)
      GO TO 500
 300  CONTINUE
      L2=IDIVE(IEXP,2)
      DO 301 L3=1,L2
      ACCA=ACCAH+ACCAH*L3/L2
      CALL POMNOZ(ACCA,2,I56,KTOTO,IMG,JIDIM)
      IF(LERF.EQ.0)GO TO 301
      CALL PODZIEL(2,IEXP)
      GO TO 500
 301  CONTINUE
      DO 3 L=1,MEMX6
      DO 3 M=I1,I7
 3    QAPR(L,1,M)=-QAPR(L,1,M)
      DO 302 L3=1,L1
      ACCA=ACCAH*2.+ACCAH*L3/L1
      CALL POMNOZ(ACCA,1,I56,KTOTO,IMG,JIDIM)
 302  CONTINUE
      ACCA=ACCAH
      DO 7 L=1,MEMX6
      DO 7 M=I1,I7
 7    QAPR(L,1,M)=-QAPR(L,1,M)
      IF(INC.EQ.0.AND.ITM.EQ.0)GO TO 1
      IF(INC.EQ.0)GO TO 200
      DO 60 JJ=2,JIDIM
 60   ARM(JJ-1,5)=ARM(JJ,5)
      RETURN
   1     ITM=ITM+1
      I56=ITM+6
      DO 10 K=1,JIDIM
 10   ARM(K,I56)=(0.,0.)
      ARM(IRLD+1,I56)=(1.,0.)
      UWA=-ITM*.0298019802+1.01
      DO 11 L=1,2
      DO 11 J=I1,I7
 11   QAPR(INDX,L,J)=QAPR(INDX,L,J)*UWA
      DO 404 J=1,JIDIM
 404  ARM(J,2)=(0.,0.)
      GO TO 100
 200  DO 20 L=1,JIDIM
      ARM(L,6)=ARM(L,6)-ARM(L,7)
 20   ARM(L,6)=50.*ARM(L,6)/ELM(INDX)
       DO 12 L=1,2
       DO 12 J=I1,I7
 12   QAPR(INDX,L,J)=QAPR(INDX,L,J)/.99
      DO 61 JJ=2,JIDIM
 61   ARM(JJ-1,6)=ARM(JJ,6)
      RETURN
      END
      SUBROUTINE NEWCAT(IEXP,JIDIM)
      COMMON/MAP/PARX(50,12,5),PARXM(50,4,10,6),XIR(6,50)
      COMMON/CXI/XI(500)
      COMMON /CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON/CEXC/MAGEXC,MEMAX,LMAXE,MEMX6,IVAR(500)
      COMMON/PTH/IPATH(75),MAGA(75)
      COMMON/APRCAT/QAPR(500,2,7),IAPR(500,2),ISEX(75)
      JIDIM=NMAX+1
      IF(MAGA(IEXP).NE.0)JIDIM=3*NMAX+1
      IST=1
      DO 11 KK=1,6
      IF(MULTI(KK).EQ.0)GO TO 11
      ISTOP=MULTI(KK)-1+IST
      DO 2 K=IST,ISTOP
      XX=ABS(XI(K))
      XX=XX/XIR(KK,IEXP)
      DO 5 N=1,7,3
      IF(MAGA(IEXP).EQ.0.AND.N.NE.4)GO TO 5
      ZT=QAPR(K,1,N)
      ZT=ABS(ZT)
      XP=9.*XX
      NL=INT(XP)+1
      WG=XP-FLOAT(NL-1)
      NG=NL+1
      WL=FLOAT(NL)-XP
      A=WG*PARXM(IEXP,1,NG,KK)+WL*PARXM(IEXP,1,NL,KK)
      B=WG*PARXM(IEXP,2,NG,KK)+WL*PARXM(IEXP,2,NL,KK)
      Q1=A*ZT+B
      A=WG*PARXM(IEXP,3,NG,KK)+WL*PARXM(IEXP,3,NL,KK)
      B=WG*PARXM(IEXP,4,NG,KK)+WL*PARXM(IEXP,4,NL,KK)
      Q2=A*ZT+B
      QAPR(K,2,N)=QAPR(K,1,N)*Q2*FXIS2(K,N)
      QAPR(K,1,N)=QAPR(K,1,N)*Q1*FXIS1(K,N)
      IF(IAPR(K,1).NE.IAPR(K,2))GO TO 5
      QAPR(K,1,N)=0.
      QAPR(K,2,N)=QAPR(K,2,N)/2.
 5    CONTINUE
      IF(MAGA(IEXP).EQ.0)GO TO 2
      DO 7 N=2,6
      IF(N.EQ.4)GO TO 7
      ZT=QAPR(K,1,N)
      ZT=ABS(ZT)
      XP=4.*XX
      NL=INT(XP)+1
      WG=XP-FLOAT(NL-1)
      NG=NL+1
      WL=FLOAT(NL)-XP
      Q1=WG*PARX(IEXP,2*KK-1,NG)+WL*PARX(IEXP,2*KK-1,NL)
      Q2=WG*PARX(IEXP,2*KK,NG)+WL*PARX(IEXP,2*KK,NL)
      QAPR(K,2,N)=QAPR(K,1,N)*Q2*FXIS2(K,N)
      QAPR(K,1,N)=QAPR(K,1,N)*Q1*FXIS1(K,N)
 7    CONTINUE
  2   CONTINUE
      IST=ISTOP+1
 11   CONTINUE
      RETURN
      END
      SUBROUTINE POMNOZ(ACCA,L,IW,KTOTO,IMG,JIDIM)
      COMPLEX ARM,CI
      common/inhi/inhb
      COMMON/APRCAT/QAPR(500,2,7),IAPR(500,2),ISEX(75)
      COMMON/PTH/IPATH(75),MAGA(75)
      COMMON/CEXC/MAGEXC,MEMAX,LMAXE,MEMX6,IVAR(500)
      COMMON/AZ/ARM(600,7)
      COMMON/APRX/LERF,IDIVE(50,2)
      DATA CI/(0.,-1.)/
      SIG=1.
      IF(L.NE.2)SIG=-1.
      DO 5 KK=1,JIDIM
 5    ARM(KK,1)=ARM(KK,IW)
      DO 1 K=1,100
      KTOTO=KTOTO+1
      DO 2 M=1,MEMX6
      MW1=IAPR(M,1)
      MC1=IAPR(M,2)
      IF(IPATH(MW1).EQ.0.OR.IPATH(MC1).EQ.0)GO TO 2
      MW=IPATH(MW1)+1
      MC=IPATH(MC1)+1
      IF(KTOTO.LT.ISEX(MC1))GO TO 2
      IF(IMG.EQ.1)GO TO 200
      ARM(MW,2)=ARM(MW,2)+QAPR(M,L,4)*ARM(MC,1)
      ARM(MC,2)=ARM(MC,2)+SIG*QAPR(M,L,4)*ARM(MW,1)
      ARM(MW-1,2)=ARM(MW-1,2)+QAPR(M,L,2)*ARM(MC,1)
      ARM(MC,2)=ARM(MC,2)+SIG*QAPR(M,L,2)*ARM(MW-1,1)
      ARM(MW-1,2)=ARM(MW-1,2)+QAPR(M,L,1)*ARM(MC-1,1)
      ARM(MC-1,2)=ARM(MC-1,2)+SIG*QAPR(M,L,1)*ARM(MW-1,1)
      ARM(MW,2)=ARM(MW,2)+QAPR(M,L,3)*ARM(MC-1,1)
      ARM(MC-1,2)=ARM(MC-1,2)+SIG*QAPR(M,L,3)*ARM(MW,1)
      ARM(MW,2)=ARM(MW,2)+QAPR(M,L,5)*ARM(MC+1,1)
      ARM(MC,2)=ARM(MC,2)+SIG*QAPR(M,L,6)*ARM(MW+1,1)
      ARM(MC+1,2)=ARM(MC+1,2)+SIG*QAPR(M,L,5)*ARM(MW,1)
      ARM(MW+1,2)=ARM(MW+1,2)+QAPR(M,L,6)*ARM(MC,1)
      ARM(MW+1,2)=ARM(MW+1,2)+QAPR(M,L,7)*ARM(MC+1,1)
      ARM(MC+1,2)=ARM(MC+1,2)+SIG*QAPR(M,L,7)*ARM(MW+1,1)
      GO TO 2
 200  ARM(MW,2)=ARM(MW,2)+QAPR(M,L,4)*ARM(MC,1)
      ARM(MC,2)=ARM(MC,2)+SIG*QAPR(M,L,4)*ARM(MW,1)
 2    CONTINUE
      TEST=0.
      DO 20 M=1,JIDIM
      ARM(M,1)=ARM(M,2)/K
      ARM(M,2)=(0.,0.)
      IF(L.EQ.1)GO TO 25
      ARM(M,1)=ARM(M,1)*CI
 25   ARM(M,IW)=ARM(M,IW)+ARM(M,1)
      IF(K.LE.5)GO TO 20
      U=TCABS(ARM(M,IW))
      TEST=TEST+U*U
 20   CONTINUE
      IF(ABS(TEST-1.).LT.ACCA)GO TO 30
 1    CONTINUE
      IF(inhb.eq.1)go to 30
      LERF=1
 30    CONTINUE
      RETURN
      END
      SUBROUTINE TENB(ICL,BTEN,LMAX)
      COMPLEX ARM
      DIMENSION BTEN(1200)
      COMMON/COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      COMMON/CLCOM8/CAT(600,3),ISMAX
      COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON/CEXC0/NSTART(76),NSTOP(75)
      COMMON/AZ/ARM(600,7)
      IHA=(-1)**IFIX(2.*SPIN(1)+.01)
      IF(ICL.NE.1)GO TO 11
      MS=16*(NMAX-1)
      DO 10 I=1,MS
  10  BTEN(I)=0.
  11  CONTINUE
      DO 1 I=2,NMAX
      MS=NSTART(I)
      IF(MS.EQ.0)GO TO 1
      MSP=NSTOP(I)
      SI=SPIN(I)
      ISI=IFIX(2.*SI+.01)
      CE=SQRT(2.*SI+1.)
      DO 2 KP=1,7,2
      K=KP-1
      KK=2*K
      IF(ISI.LT.K)GO TO 2
      ILA=-1
      DO 3 LP=1,KP
      ILA=-ILA
      L=LP-1
      LL=2*L
      IND=K*K/4+LP+(I-2)*16
      DO 4 M=MS,MSP
      MM=M
      MP=M+L
      JM=IFIX(2.01*CAT(MM,3))
      IF(MP.GT.NSTOP(I))GO TO 8
      ILG=(-1)**IFIX(SI-CAT(MP,3))
      JMP=-IFIX(2.01*CAT(MP,3))
      FC=WTHREJ(ISI,KK,ISI,JMP,LL,JM)
      ITE=1
  7   CONTINUE
      IF(ILA.EQ.1)X=REAL(ARM(MP,5))*REAL(ARM(MM,5))+
     *AIMAG(ARM(MP,5))*AIMAG(ARM(MM,5))
      IF(ILA.NE.1)X=REAL(ARM(MP,5))*AIMAG(ARM(MM,5))-
     *REAL(ARM(MM,5))*AIMAG(ARM(MP,5))
      BTEN(IND)=BTEN(IND)+X*FC*ILG
      IF(ITE.EQ.2)GO TO 4
  8   CONTINUE
      IF(IHA.EQ.1.AND.ICL.EQ.LMAX)GO TO 4
      ITE=2
      MP=MP-2*L
      IF(MP.LT.NSTART(I))GO TO 4
      JMP=IFIX(2.01*CAT(MP,3))
      JM=-JM
      FC=WTHREJ(ISI,KK,ISI,JMP,LL,JM)
      ILG=(-1)**IFIX(SI+CAT(MP,3))
      GO TO 7
  4   CONTINUE
      IF(ICL.EQ.LMAX)BTEN(IND)=BTEN(IND)*CE/(2.*SPIN(1)+1.)
  3   CONTINUE
  2   CONTINUE
  1   CONTINUE
      RETURN
      END
      SUBROUTINE TENS(BTEN)
      DIMENSION BTEN(1200)
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      COMMON/TCM/TETACM(50),TREP(50),DSIGS(50)
      COMMON/CCOUP/ZETA(50000),LZETA(8)
      COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON/COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      IX=NMAX*28
      ARG=1.570796327+TETACM(IEXP)/2.
      DO 1 I=1,IX
  1   ZETA(I)=0.
      DO 2 I=2,NMAX
      DO 3 KP=1,7,2
      K=KP-1
      K1=IFIX(FLOAT(K)/2.+.01)
      IF(K.EQ.0)GO TO 98
      DO 4 LP=1,KP
      IF(IAXS(IEXP).EQ.0.AND.LP.NE.1)GO TO 4
      INZ=(I-1)*28+K1*7+LP
      L=LP-1
      DO 5 LPP=1,KP
      IND=K*K/4+LPP+(I-2)*16
      LX=LPP-1
      LXX=LX
  13  IPH=(-1)**(L+IFIX(FLOAT(LXX)/2.))
      ZETA(INZ)=ZETA(INZ)+BTEN(IND)*IPH*DJMM(ARG,K,LX,L)
      IF(LPP.EQ.1)GO TO 5
      IF(LX.LT.0)GO TO 5
      LX=-LX
      LXX=LX-1
      GO TO 13
  5   CONTINUE
  4   CONTINUE
      GO TO 3
  98  IND=(I-2)*16+1
      INZ=(I-1)*28+1
      ZETA(INZ)=BTEN(IND)
  3   CONTINUE
  2   CONTINUE
      RETURN
      END
      FUNCTION DJMM(BETA,K,KPP,KP)
      DIMENSION DJM(525),ICZY(525)
      COMMON/IDENT/BEQ
      COMMON/CB/B(20)
      IFZA=1
      IF(BETA.LT.0.)IFZA=(-1)**(KP+KPP)
      SK=FLOAT(K)
      UL=SK*((SK-1.)*(4.*SK+7)/6.+1.)
      LCA=INT(UL+.1)
      LOC=LCA+(2*K+1)*KP+KPP+K+1
      IF(abs(BEQ-ABS(BETA)).gt.1.e-6)GO TO 99
      IF(ICZY(LOC).EQ.1)GO TO 100
      GO TO 101
  99  BEQ=ABS(BETA)
      DO 102 ILL=1,525
  102 ICZY(ILL)=0
  101 BE=BEQ/2.
      CB=COS(BE)
      SB=SIN(BE)
      IFLA=0
      IF(BEQ.GT..01.AND.ABS(BEQ-6.2832).GT..01)IFLA=1
      IF(IFLA.EQ.1)GO TO 3
      IF(KP.EQ.KPP)GO TO 4
      DJMM=0.
      RETURN
  4   SB=1.
  3   CTB=CB*CB/SB/SB
      JA=K+KP+1
      JB=K-KP+1
      JC=K+KPP+1
      JD=K-KPP+1
      B1=B(JA)*B(JB)*B(JC)*B(JD)
      JA=KP+KPP
      JB=2*K-KP-KPP
      IF(ABS(BEQ-3.141592654).LT..01.AND.JA.LT.0)IFLA=3
      IF(IFLA.EQ.3)CB=1.
      F=(-1)**(K-KP)*(CB**JA)*(SB**JB)*SQRT(B1)
      MIS=0
      IF(JA.LT.0)MIS=-JA
      MAS=K-KPP
      IF(KPP.LT.KP)MAS=K-KP
      JA=KP+KPP+MIS+1
      JB=K-KPP-MIS+1
      JC=K-KP-MIS+1
      JD=MIS+1
      B2=B(JA)*B(JB)*B(JC)*B(JD)
      IF(IFLA.EQ.3)GO TO 10
      G=(-CTB)**MIS/B2
      DJMM=G
      JA=MIS+1
      IF(MAS.LT.JA)GO TO 2
      DO 1 J=JA,MAS
      G=-G*CTB*(K-KPP-J+1)*(K-KP-J+1)/(KP+KPP+J)/J
 1    DJMM=DJMM+G
   2  CONTINUE
      IF(IFLA.EQ.0)DJMM=G
      DJMM=DJMM*F*IFZA
      DJM(LOC)=DJMM/IFZA
      ICZY(LOC)=1
      RETURN
 10   DJMM=F*IFZA/((-SB*SB)**MIS)/B2
      DJM(LOC)=DJMM/IFZA
      ICZY(LOC)=1
      RETURN
 100  DJMM=DJM(LOC)*IFZA
      RETURN
      END
      SUBROUTINE FTBM(ICLL,CHISQ,IDR,NCALL,CHILO,BTEN)
      COMPLEX ARM
      DIMENSION JMTE(6),PROP(6),BTEN(1200)
      COMMON/CX/NEXPT,IZ,XA,IZ1(50),XA1(50),EP(50),TLBDG(50),VINF(50)
      COMMON/CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON/TCM/TETACM(50),TREP(50),DSIGS(50)
      COMMON/CEXC0/NSTART(76),NSTOP(75)
      COMMON/CCC/eg(50),cc(50,5),NANG(200),Q(3,200,8),NICC,
     *AGELI(50,200,2)
      COMMON/ILEWY/NWR
	common/switch/jzb,ibps
      COMMON/CH1T/CHIS11
      COMMON/IGRAD/IGRD
      COMMON/CAUX0/NCM,EMMA(75)
      COMMON/CXI/XI(500)
      COMMON/MAP/PARX(50,12,5),PARXM(50,4,10,6),XIR(6,50)
      COMMON/LCZP/LFL,EMH,INM,LFL1,LFL2
      COMMON/ERRAN/KFERR
      COMMON/UWAGA/ITAK2
      COMMON/LEV/TAU(75),KSEQ(500,4)
      COMMON/CCOUP/ZETA(50000),LZETA(8)
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      COMMON/YEXPT/YEXP(32,1500),IY(1500,32),CORF(1500,32),DYEX(32,1500)
     *,NYLDE(50,32),UPL(32,50),YNRM(32,50),IDRN,ILE(32)
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/CLM/LMAX
      COMMON/COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      COMMON/CLCOM8/CAT(600,3),ISMAX
      COMMON/AZ/ARM(600,7)
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/DFTB/DEVD(500),DEVU(500)
      COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON/PTH/IPATH(75),MAGA(75)
      COMMON/PRT/IPRM(20)
      COMMON/CEXC/MAGEXC,MEMAX,LMAXE,MEMX6,IVAR(500)
      COMMON/SKP/JSKIP(50)
      COMMON/LIFE/NLIFT
      COMMON/LOGY/LNY,INTR,IPS1
      ISSP=0
      CHILO=0.
      FX=2.*SPIN(1)+1.
      CHISQ=0.
      LFL=0
      CHIS1=0.
      IXX=NDIM*MEMAX+LP11
      DO 12 I1=1,IXX
 12   ZETA(I1)=0.
       DO 4372 II=1,LP6
 4372 ILE(II)=1
      ITEMP=0
      NWR=0
      IAPX=1
      DO 1 JKL=1,NEXPT
      IEXP=JKL
      IGRD=0
      LFL2=1
      IF(ITAK2.NE.-1)GO TO 605
      DO 601 LARM=1,4
      DO 601 KARM=1,LP10
 601  ARM(KARM,LARM)=(0.,0.)
 605  IFLG=0
       IF(IEXP.EQ.1)GO TO 4933
       KK=NANG(IEXP)
       DO 4934 JJJ=1,LP6
 4934 ILE(JJJ)=ILE(JJJ)+NYLDE(IEXP-1,JJJ)
 4933 LP=3
      IF(JSKIP(JKL).EQ.0)GO TO 500
      IF(MAGA(IEXP).EQ.0)LP=1
      IF(NCALL.EQ.0)GO TO 200
      IF(ICLL.EQ.4)GO TO 10
 202  LOCH=LP3*(MEMAX-1)+NMAX+LP11
      DO 6130 K=1,LOCH
 6130 ZETA(K)=0.
      CALL LOAD(IEXP,1,2,0.,JJ)
      DO 2 K=1,LMAX
      FC=2.
      IF(K.EQ.LMAX)FC=1.
      IF(FLOAT(IFIX(SPIN(1))).lt.SPIN(1))FC=2.
      LOC=0
      POLM=FLOAT(K-1)-SPIN(1)
       CALL LOAD(IEXP,3,2,POLM,JJ)
       CALL PATH(JJ)
       CALL LOAD(IEXP,2,2,POLM,JJ)
      CALL APRAM(IEXP,1,1,JJ,ACCA)
      IF(NCALL.EQ.0)GO TO 30
      IF(ICLL.EQ.3)GO TO 30
      DO 3 INDX=1,MEMX6
      CALL APRAM(IEXP,0,INDX,JJ,ACCA)
      KX=0
      DO 400 I11=1,NMAX
      IF(NSTART(I11).EQ.0)GO TO 400
      LOC=LP3*(INDX-1)+I11+LP11
      JPP=IFIX(2.*SPIN(I11)+1.)
      LPX=MIN0(LP,JPP)
      IF(ISO.NE.0)LPX=NSTOP(I11)-NSTART(I11)+1
      DO 407 LPXD=1,LPX
      KX=KX+1
 407  ZETA(LOC)=ZETA(LOC)+FC*REAL(ARM(KX,5))*REAL(ARM(KX,6))/FX+
     *FC*AIMAG(ARM(KX,5))*AIMAG(ARM(KX,6))/FX
  400 CONTINUE
 3    CONTINUE
 30   CALL TENB(K,BTEN,LMAX)
 2    CONTINUE
      IF(LOC.EQ.0)GO TO 7633
      REWIND 14
      WRITE(14,*)(ZETA(I11),I11=LP8,LOCH)
 7633 CALL TENS(BTEN)
      IF(NCALL.EQ.0)GO TO 500
      IF(ICLL.LT.2)GO TO 505
      GO TO 500
 505  LLX=28*NMAX
      DO 303 LX=1,LLX
 303  ZETA(LP9+LX)=ZETA(LX)
      IF(ICLL.EQ.1)GO TO 10
      GO TO 500
 10   IAPX=0
      ISSP=1
      CALL LOAD(IEXP,1,1,0.,JJ)
      CALL ALLOC(ACCUR)
      CALL SNAKE(IEXP,ZPOL)
      CALL SETIN
      DO 20 K=1,LMAX
      POLM=FLOAT(K-1)-SPIN(1)
      CALL LOAD(IEXP,2,1,POLM,KK)
       IF(IPRM(7).EQ.-1)WRITE(22,701)POLM,IEXP
      CALL STING(KK)
      CALL PATH(KK)
      CALL INTG(IEXP)
      CALL TENB(K,BTEN,LMAX)
      IF(IPRM(7).NE.-1)GO TO 22
      DO 21 J=1,ISMAX
      WRITE(22,702)IFIX(CAT(J,1)),CAT(J,2),
     *CAT(J,3),REAL(ARM(J,5)),AIMAG(ARM(J,5))
 21   CONTINUE
  22  CONTINUE
 20   CONTINUE
      CALL TENS(BTEN)
      IF(IPRM(7).NE.-1)GO TO 500
      DO 708 JJGG=2,NMAX
      LOCT=(JJGG-1)*28+1
 708  WRITE(22,703)JJGG,ZETA(LOCT)
      GO TO 500
 100  CONTINUE
      IF(NCALL.NE.0)GO TO 500
 200   IF(IFLG.EQ.1)GO TO 201
      IF(IFLG.EQ.2)GO TO 3111
      ITEMP=2
      IFLG=1
      GO TO 10
 201  CONTINUE
      ITEMP=1
      IFLG=2
      GO TO 202
 500  CONTINUE
      CALL CEGRY(CHISQ,ITEMP,CHILO,IDR,NWYR,ICLL,ISSP,0)
      ISSP=0
      IF(NCALL.EQ.0.AND.JSKIP(JKL).NE.0)GO TO 100
      NWR=NWR+NWYR
      IF(ICLL.GT.2.OR.JSKIP(JKL).EQ.0)GO TO 3111
      IF(IEXP.EQ.1)CHISH=CHIS11
      IF(ICLL.EQ.1)CHIS1=CHIS11
      IF(ICLL.EQ.0)CHIS1=CHISQ
      LFL2=0
      IGRD=1
      IF(ITAK2.EQ.-1)LFL=1
      REWIND 14
      READ(14,*)(ZETA(I11),I11=LP8,LOCH)
      DO 305 LARM=1,4
      DO 305 KARM=1,LP10
 305  ARM(KARM,LARM)=(0.,0.)
      CHISX=0.
      LLX=28*NMAX
      DO 600 LIX=1,LLX
 600  ZETA(LP9+LIX)=ZETA(LIX)
      CALL CEGRY(CHISX,ITEMP,CHILO,IDR,NWYR,0,0,1)
      DO 301 KNM=1,MEMAX
      INM=KNM
      CHISX=0.
      EMH=ELM(INM)
      ELM(INM)=1.05*EMH
      LCC=LP3*(INM-1)+LP11
      DO 304 LST=2,NMAX
      WZ=ZETA(LST+LCC)
      INPX=(LST-1)*28
      DO  307 JY=1,4
      INP=INPX+(JY-1)*7
      IF(JY.EQ.1)PR=ZETA(LP13+INP)+1.E-12
      JMF=2*JY-1
      IF(IAXS(IEXP).EQ.0)JMF=1
      DO 306 JM=1,JMF
      INP=INP+1
 306  ZETA(INP)=ZETA(INP+LP9)*(1.+.1*EMH*WZ/PR)
 307  CONTINUE
 304  CONTINUE
      CALL CEGRY(CHISX,ITEMP,CHILO,IDR,NWYR,0,0,0)
      ELM(INM)=EMH
 301  CONTINUE
      IF(ITAK2.NE.-1.OR.LFL1.EQ.0)GO TO 3111
      IF(IPRM(17).EQ.0)GO TO 800
      KMT=IABS(IPRM(17))
      WRITE(22,801)IEXP
      NLIN=(NMAX-2)/6+1
      NREST=NMAX-1-6*(NLIN-1)
      DO 802 ILIN=1,NLIN
      NPOZ=6
      IF(ILIN.EQ.NLIN)NPOZ=NREST
      INPO=(ILIN-1)*6+2
      INKO=INPO+NPOZ-1
      LPIT=0
      DO 888 LM=INPO,INKO
      LPIT=LPIT+1
 888  JMTE(LPIT)=LM
      WRITE(22,803)(JMTE(LM),LM=1,LPIT)
      WRITE(22,804)(ZETA(LP13+(JPZ-1)*28),JPZ=INPO,INKO)
      DO 805 JMT=1,KMT
      LPUT=0
      DO 819 LS=INPO,INKO
      LPUT=LPUT+1
      PROP(LPUT)=0.
      DO 820 LM=1,MEMX6
      INZZ=LS+LP3*(LM-1)+LP11
      INZZZ=LP13+(LS-1)*28
      IF(abs(ZETA(INZZZ)).lt.1.e-20)ZETA(INZZZ)=1.E-20
      VAL=2.*ELM(LM)*ZETA(INZZ)/ZETA(INZZZ)
      AVAL=ABS(VAL)
      IF(AVAL.LE.ABS(PROP(LPUT)))GO TO 820
      PROP(LPUT)=VAL
      LMH=LM
      JMTE(LPUT)=LM
  820 CONTINUE
      IZZZ=(LMH-1)*LP3+LP11+LS
      ZETA(IZZZ)=0.
 819  CONTINUE
      WRITE(22,807)(JMTE(LCOU),PROP(LCOU),LCOU=1,NPOZ)
 805  CONTINUE
 802  CONTINUE
      REWIND 14
      READ(14,*)(ZETA(I11),I11=LP8,LOCH)
 801  FORMAT(1X///20X,10HEXPERIMENT,11X,1I2,5X
     *,24HD(LOG(P))/D(LOG(ME)) MAP/20X,52(1H-)///)
 803  FORMAT(5X,5HLEVEL,6(8X,1I2,9X))
 807  FORMAT(10X,6(2X,1H(,1X,1I3,1X,1E8.2,1H),2X))
 804  FORMAT(1X,9HEXC.PROB.,6(5X,1E10.4,4X))
      IF(IPRM(17).LT.0)GO TO 3111
 800   LFL=0
      WRITE(22,610)IEXP
      ILE1=ILE(1)+NYLDE(IEXP,1)-1
       ILE3=ILE(1)
      LICZ=0
      DO 611 ILE2=ILE3,ILE1
      LICZ=LICZ+1
      IDEC=IY(ILE2,1)
      IF(IDEC.GT.1000)IDEC=IDEC/1000
      LUU=6*LICZ-5
      JK=(LUU-1)/LP10+1
      KK=LUU-LP10*(JK-1)
      KK6=KK+5
 611  WRITE(22,612)KSEQ(IDEC,3),KSEQ(IDEC,4),(IFIX(REAL(ARM
     *(KKX,JK))),AIMAG(ARM(KKX,JK)),KKX=KK,KK6)
 610  FORMAT(10X,10HEXPERIMENT,1X,1I2/10X,19HD(LOG(Y)/D(LOG(ME)),//)
 612  FORMAT(2X,1I2,2H--,1I2,5X,6(1H(,1I3,2X,1E8.2,1H),3X))
 3111 CONTINUE
 1    CONTINUE
      IF(ITAK2.EQ.-1.AND.ICLL.LT.2)ITAK2=0
      IF(NCALL.EQ.0)GO TO 999
      IF(ICLL.GT.2)GO TO 501
      IF(ICLL.EQ.1)CALL CEGRY(CHISQ,ITEMP,CHILO,IDR
     *,NOWR,7,ISSP,0)
 501  CALL BRANR(CHISQ,NWR,CHILO)
      CALL MIXR(NWR,0,CHISQ,CHILO)
      CALL CHMEM(NWR,CHISQ,CHILO)
      NWR=NWR+NLIFT
      CHISQ=CHISQ/NWR
      IF(INTR.EQ.0)GO TO 999
      CHX=CHISQ
      CHISQ=CHILO
      CHILO=CHX
 999  CONTINUE
      RETURN
 701  FORMAT(1X//40X,21HEXCITATION AMPLITUDES//10X,2HM=
     *,1F4.1,5X,10HEXPERIMENT,1X,1I2//5X,5HLEVEL,2X,4HSPIN
     *,2X,1HM,5X,14HREAL AMPLITUDE,2X,19HIMAGINARY AMPLITUDE
     *//)
 702  FORMAT(7X,1I2,3X,1F4.1,2X,1F4.1,2X,1E14.6,2X,1E14.6)
 703  FORMAT(2X,5HLEVEL,1X,1I2,10X,10HPOPULATION,1X,1E14.6)
      END
      SUBROUTINE MINI(CHISQ,CHIOK,NPTL,CONV,IMODE,IDR,XTEST,IPS,
     *IS,JJH,BTEN)
      DIMENSION IPM(10),BTEN(1200),GRADP(500)
      COMMON/DUMM/GRAD(500),HLMLM(500),ELMH(500)
	common/switch/jzb,ibps
      COMMON/ILEWY/NWR
      COMMON/CH1T/CHIS11
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/MINNI/IMIN,LNORM(50)
      COMMON/UWAGA/ITAK2
      COMMON/YEXPT/YEXP(32,1500),IY(1500,32),CORF(1500,32),DYEX(32,1500)
     *,NYLDE(50,32),UPL(32,50),YNRM(32,50),IDRN,ILE(32)
      COMMON/DFTB/DEVD(500),DEVU(500)
      COMMON/PRT/IPRM(20)
      COMMON/LCZP/LFL,EMH,INM,LFL1,LFL2
      COMMON/CEXC/MAGEXC,MEMAX,LMAXE,MEMX6,IVAR(500)
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/SEL/KVAR(500)
      COMMON/FIT/LOCKF,NLOCK,IFBFL,LOCKS,DLOCK
      COMMON/ERRAN/KFERR
      COMMON/LOGY/LNY,INTR,IPS1
      COMMON/ERCAL/JENTR,ICS
      DO 1006 I=1,MEMAX
 1006 GRADP(I)=0.
      ICOUNT=0
      LNM=0
      LNY=0
      INTR=0
      METF=0
      LFL1=0
      NCALL=0
      ITAK2=0
      IF(IMODE.LT.2000)GO TO 2
      ICL1=1
      IF(IMODE.GE.2100)METF=1
      IF((IMODE-2000-100*METF).GE.10)LNM=1
      IF((IMODE-2000-100*METF-10*LNM).EQ.1)LNY=1
      ICL2=4
      IF(IPS.EQ.0)GO TO 3
      IF(IPS.EQ.1)GO TO 333
      IF(IPRM(4).LT.0)ITAK2=-2
      GO TO 334
 333  CONTINUE
      IF(IPRM(4).EQ.-1)ITAK2=-2
 334  ICL1=4
      IF(ITAK2.EQ.-2)ICL1=1
      IF(ICL1.EQ.4)GO TO 111
      GO TO 3
 2    ICL1=0
      ICL2=3
      IF(IMODE.GE.1100)METF=1
      IF((IMODE-1000-100*METF).GE.10)LNM=1
      IF((IMODE-1000-100*METF-10*LNM).EQ.1)LNY=1
      IF(JENTR.EQ.1)GO TO 111
      IF(ICS.EQ.0)GO TO 3
      REWIND 11
      DO 3711 JNM=1,LP4
 3711 read(11)(CORF(JNM,KH2),KH2=1,LP6)
      ICS=0
      GO TO 111
 3    CALL FTBM(0,CHISS,IDR,0,CHL,BTEN)
      REWIND 11
      DO 3712 JNM=1,LP4
 3712 write(11)(CORF(JNM,KH2),KH2=1,LP6)
      IF(IPS1.EQ.0)RETURN
 111  NOFLG=0
      NCALL=1
 1    CONTINUE
      SUMHT=0.
      IF(LNY.EQ.1)INTR=1
      LFL1=1
      ITAK2=ITAK2+1
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.NPTL)GO TO 997
      IF(ITAK2.EQ.IPRM(4))ITAK2=-1
      IF(ITAK2.NE.-1)GO TO 700
      IF(KFERR.EQ.1)GO TO 700
      CALL FTBM(3,CHD,IDR,1,CHL,BTEN)
      CHIS11=CHD*NWR
      CALL FTBM(ICL1,CHISQ,IDR,NCALL,CHILO,BTEN)
 700  IF(IPS.EQ.1)RETURN
      IF(ICL1.EQ.1)CALL FTBM(4,CHISQ,IDR,NCALL,CHILO,BTEN)
      IF(IPRM(8).NE.-1.AND.IPRM(13).NE.-1)GO TO 400
      IF(IPRM(8).EQ.-1)IPRM(8)=-2
      IF(IPRM(13).EQ.-1)IPRM(13)=-2
      CALL FTBM(4,CCD,IDR,NCALL,CHL,BTEN)
      IF(IPS.EQ.2)RETURN
 400  CALL FTBM(3,CHIS12,IDR,NCALL,CHILO,BTEN)
      IF(ICL1.EQ.0)CHISQ=CHIS12
      UXA=CHISQ
      IF(INTR.EQ.1)UXA=CHILO
      IPAS=0
      IF(UXA.LT.CHIOK)CHISQ=UXA
      IF(UXA.LT.CHIOK)GO TO 998
 201  INO=1
      IF(METF.EQ.1)IPAS=IPAS+1
      IF(IFBFL.EQ.1)INO=2
      DO 207 JJJ=1,INO
      DO 702 JNM=1,MEMAX
      GRAD(JNM)=0.
      IF(IVAR(JNM).NE.1.AND.IVAR(JNM).NE.2)GO TO 702
      DO 803 JCOUP=1,MEMAX
 803  ELMH(JCOUP)=ELM(JCOUP)
      DO 800 JCOUP=1,MEMAX
      IF(JNM.EQ.JCOUP)GO TO 801
      IF(IVAR(JCOUP).LT.1000)GO TO 800
      JCP=IVAR(JCOUP)-1000
      IF(JCP.NE.JNM)GO TO 800
      IF(IVAR(JNM).EQ.0)GO TO 800
 801  FLT=1.01
      IF(JJJ.EQ.2)FLT=.99
      ELM(JCOUP)=ELMH(JCOUP)*FLT
 800  CONTINUE
      CALL FTBM(3,CHIS13,IDR,NCALL,CHX,BTEN)
      IF(JJJ.EQ.1)HLMLM(JNM)=CHIS13
      IF(IFBFL.EQ.1.AND.JJJ.EQ.1)GO TO 208
      IF(JJJ.EQ.2)CHIS12=CHIS13
      GRAD(JNM)=100.*(HLMLM(JNM)-CHIS12)/ELMH(JNM)
      IF(IFBFL.EQ.1)GRAD(JNM)=GRAD(JNM)/2.
      IF(LNM.EQ.1)GRAD(JNM)=GRAD(JNM)*ABS(ELMH(JNM))
 208  CONTINUE
      DO 804 JCOUP=1,MEMAX
 804  ELM(JCOUP)=ELMH(JCOUP)
 702  CONTINUE
 207  CONTINUE
      IF(KFERR.NE.1)GO TO 701
      GRAD(JJH)=0.
      IF(IS.NE.1.OR.ICOUNT.NE.1)GO TO 701
      WRITE(33,*)(NWR*GRAD(JNM),JNM=1,MEMAX)
 701  CONTINUE
      IF(METF.EQ.1.AND.IPAS.EQ.2)GO TO 862
      SUMG2=0.
      DO 860 JNM=1,MEMAX
      IF(IVAR(JNM).NE.1.AND.IVAR(JNM).NE.2)GO TO 860
      SUMG2=SUMG2+GRAD(JNM)*GRAD(JNM)
 860  CONTINUE
      IF(SUMG2.LT.1.E-10)GO TO 999
      SUMG2=SQRT(SUMG2)
      DO 888 JNM=1,MEMAX
 888  GRAD(JNM)=GRAD(JNM)/SUMG2
      IF(METF.EQ.0)GO TO 861
      DM=0.
      DO 852 JNM=1,MEMAX
      IF(IVAR(JNM).NE.2.AND.IVAR(JNM).NE.1)GO TO 852
      DM=DM+ELM(JNM)*ELM(JNM)*GRAD(JNM)*GRAD(JNM)
 852  CONTINUE
      DM=SQRT(DM)
      DO 851 JNM=1,MEMAX
      DEVD(JNM)=GRAD(JNM)
       DEVU(JNM)=ELM(JNM)
      SEL=DM*GRAD(JNM)/20.
      IF(LNM.EQ.1)SEL=SEL*ABS(ELM(JNM))
 851  ELM(JNM)=ELM(JNM)-SEL
      IF(IFBFL.EQ.0)CALL FTBM(3,CHIS12,IDR,NCALL,CHX,BTEN)
      GO TO 201
 862  CONTINUE
      DO 863 JNM=1,MEMAX
      ELM(JNM)=DEVU(JNM)
 863  CONTINUE
      SHL=DM/20./SUMG2
      SUMG1=0.
      DO 864 JNM=1,MEMAX
      GRAD(JNM)=(DEVD(JNM)*SUMG2-GRAD(JNM))/SHL
 864  SUMG1=SUMG1+GRAD(JNM)*GRAD(JNM)
      SUMG1=SQRT(SUMG1)
      P=0.
      DO 865 JNM=1,MEMAX
      GRAD(JNM)=GRAD(JNM)/SUMG1
      DEVU(JNM)=ELM(JNM)
      SEL=DM*GRAD(JNM)/100.
      IF(LNM.EQ.1)SEL=SEL*ABS(DEVU(JNM))
      P=P+DEVD(JNM)*GRAD(JNM)
 865  ELM(JNM)=ELM(JNM)+SEL
      CALL FTBM(3,CHIS13,IDR,NCALL,CHX,BTEN)
      SHL=DM/100.
      DO 889 JNM=1,MEMAX
      SEL=DM*GRAD(JNM)/50.
      IF(LNM.EQ.1)SEL=SEL*ABS(DEVU(JNM))
 889  ELM(JNM)=ELM(JNM)-SEL
      CALL FTBM(3,CHIS12,IDR,NCALL,CHX,BTEN)
      Q=(CHIS12+CHIS13-2.*CHISQ)/SHL/SHL
      A0=Q*SUMG2/SUMG1-P
      A1=P*P-1.
      SUMG1=SQRT(A0*A0+A1*A1+2.*A0*A1*P)
      DO 866 JNM=1,MEMAX
      ELM(JNM)=DEVU(JNM)
      GRAD(JNM)=(GRAD(JNM)*A1+DEVD(JNM)*A0)/SUMG1
  866 CONTINUE
 861  LFL1=0
      IF(LNM.EQ.0)GO TO 894
      DO 893 JNM=1,MEMAX
 893  GRAD(JNM)=GRAD(JNM)*ABS(ELM(JNM))
 894  CONTINUE
      SUMG1=0.
      DO 895 JNM=1,MEMAX
 895  SUMG1=SUMG1+GRAD(JNM)*GRAD(JNM)
      SUMG1=SQRT(SUMG1)
      DO 896 JNM=1,MEMAX
 896  GRAD(JNM)=GRAD(JNM)/SUMG1
      IF(LNY.EQ.1)CHISQ=CHILO
      IF(NOFLG.EQ.0)CHIRF=CHISQ
      NOFLG=1
      CHIL=CHISQ
      IF(KFERR.EQ.1)GOTO 666
      IF(MOD(ICOUNT,IPRM(5)).EQ.0.OR.ICOUNT.EQ.1)WRITE(22,54)CHISQ
c      WRITE(*,54)CHISQ
      IF(MOD(ICOUNT,IPRM(6)).NE.0)GO TO 666
      WRITE(22,601)
      NLINN=MEMAX/10+1
      DO 602 JLIN=1,NLINN
      JSA=(JLIN-1)*10+1
      DO 608 JIN=1,10
 608  IPM(JIN)=JSA+JIN-1
      JST=MIN0(JSA+9,MEMAX)
      JPR=MIN0(10,MEMAX-JSA+1)
      WRITE(22,603)(IPM(JIN),JIN=1,JPR)
      WRITE(22,604)(GRAD(JIN),JIN=JSA,JST)
 602  CONTINUE
 603  FORMAT(5X,10(5X,1I3,4X))
 604  FORMAT(5X,10(1X,1E10.4,1X)/)
 601  FORMAT(20X,8HGRADIENT//)
 666  CONTINUE
      IF(CHIL.LT.CHIOK)GO TO 998
      DO 5 L=1,MEMAX
      HLMLM(L)=ELM(L)
 5    CONTINUE
      DO 22 L=1,MEMAX
      IF(ABS(GRAD(L)).GT.DLOCK.OR.LOCKS.NE.1.OR.ICOUNT
     *.NE.1.OR.IVAR(L).GT.999.OR.IVAR(L).EQ.0)GO TO 22
      IF(KFERR.NE.1)
     *KVAR(L)=0
      IF(KFERR.NE.1)
     *WRITE(22,227)L,GRAD(L)
      IVAR(L)=0
 227  FORMAT(1X,14HMATRIX ELEMENT,1X,1I3,1X,6HLOCKED,3X,
     *11HDERIVATIVE=,1E14.6)
 22   CONTINUE
      ISTEC=0
 500  DO 66 J=1,MEMAX
 66   ELMH(J)=ELM(J)
      ISTEC=ISTEC+1
      CMAX=0.
      INTR=0
      INMX=1
      DO 777 IHT=1,MEMAX
      IF(ABS(GRAD(IHT)).LE.CMAX)GO TO 777
      CMAX=ABS(GRAD(IHT))
      INMX=IHT
 777  CONTINUE
      HT=.01*ABS(ELM(INMX))/CMAX
      MVFL=0
      IF(ICOUNT.EQ.1.OR.ISTEC.NE.1)GO TO 1000
      XKAT=0.
      DO 1001 J=1,MEMAX
 1001 XKAT=XKAT+GRAD(J)*GRADP(J)
      DO 1002 J=1,MEMAX
 1002 GRADP(J)=GRAD(J)
      IF(XKAT.LT..8)GO TO 1000
      A=0.
      DO 1003 J=1,MEMAX
      IF(IVAR(J).EQ.0.OR.IVAR(J).GT.999)GO TO 1003
      A=AMAX1(A,ABS(GRAD(J)))
      IF(abs(A-ABS(GRAD(J))).lt.1.e-9)IIN=J
 1003 CONTINUE
      WRITE(22,215)IIN
      IVAR(IIN)=0
      GRAD(IIN)=0.
      GRADP(IIN)=0.
 1000 CONTINUE
 300  DO 6 J=1,MEMAX
 6    ELM(J)=ELMH(J)-HT*GRAD(J)
      DO 7 J=1,MEMAX
      IF(IVAR(J).LT.1000)GO TO 7
      INDX1=IVAR(J)-1000
      ELM(J)=ELM(INDX1)*SA(J)
 7    CONTINUE
      IF(MVFL.EQ.0)GO TO 13
      CALL LIMITS
      GO TO 100
 13   CALL FTBM(ICL2,CHISP,IDR,NCALL,CHILO,BTEN)
      DO 8 J=1,MEMAX
   8  ELM(J)=2.*ELMH(J)-ELM(J)
      CALL FTBM(ICL2,CHISF,IDR,NCALL,CHILO,BTEN)
      C=(CHISP+CHISF-2.*CHIL)/HT/HT
      B=(CHISP-CHISF)/HT/2.
      DL=B*B-2.*C*CHIL
      IF(DL.GT.0.)GO TO 11
      F1=B
      F2=C
      GO TO 12
   11 F1=CHIL
      F2=B
 12   MVFL=1
      IF(ABS(F2).LT.1.E-10)GO TO 14
      HT=-F1/F2
      GO TO 300
  14  HT=1.
      GO TO 300
 100  CALL FTBM(ICL2,CHISQ,IDR,NCALL,CHILO,BTEN)
      IF(CHISQ.GE.CHIL)GO TO 16
      CHIL=CHISQ
      SUMHT=SUMHT+HT
      IF(ABS(HT/SUMHT).LT..01)GO TO 17
      GO TO 500
 16   HT=HT/2.
      IF(ABS(HT).LT.CONV)GO TO 17
      GO TO 300
 17   CRIT=0.
      DO 18 JJJ=1,MEMAX
 18   CRIT=CRIT+(ELM(JJJ)-HLMLM(JJJ))**2
      CRIT=SQRT(CRIT)
      IF(CRIT.LT.CONV)GO TO 999
      if(chisq.lt.chiok)go to 998
      RFK=CHIRF/CHISQ
      IF(RFK.GT.XTEST.AND.ICOUNT.LT.NPTL)GO TO 3
      GO TO 1
 997  CONTINUE
        IF(KFERR.EQ.1)RETURN
      IF(IPS.EQ.0)WRITE(22,50)NPTL
      IF(IPS.EQ.0)WRITE(22,54)CHIL
      INTR=0
      RETURN
  998 CHIL=CHISQ
      IF(IPS.EQ.0)WRITE(22,51)ICOUNT
      IF(IPS.EQ.0)WRITE(22,54)CHIL
      RETURN
 999  IF(LOCKF.EQ.0)GO TO 210
      DO 212 KKK=1,NLOCK
      A=0.
      IIN=1
      DO 211 JJJ=1,MEMAX
      IF(IVAR(JJJ).EQ.0.OR.IVAR(JJJ).GT.999)GO TO 211
      A=AMAX1(A,ABS(GRAD(JJJ)))
      IF(abs(A-ABS(GRAD(JJJ))).lt.1.e-9)IIN=JJJ
 211  CONTINUE
      IVAR(IIN)=0
      WRITE(22,215)IIN
 212  CONTINUE
      ITF=0
      DO 213 JJJ=1,MEMAX
      IF(IVAR(JJJ).GT.999)GO TO 213
      IF(IVAR(JJJ).NE.0)ITF=ITF+1
 213  CONTINUE
      if(itf.ne.1)go to 3233
      metf=0
      write(22,3234)
 3234 format(2x,'Warning - only one matrix element free',//2x,
     *'Mode reset to single gradient, execution continues',/)
 3233 continue
      IF(ITF.NE.0)GO TO 1
      WRITE(22,214)
 214  FORMAT(1X/////5X,5H*****,2X,
     *27HALL MATRIX ELEMENTS LOCKED!,2X,5H*****/////)
      INTR=0
      RETURN
 215  FORMAT(1X/5X,14HMATRIX ELEMENT,1X,1I3,1X,7HLOCKED!)
 210  CONTINUE
      IF(CHISQ.LT.CHIL)GO TO 698
      DO 699 JJJ=1,MEMAX
 699  ELM(JJJ)=ELMH(JJJ)
 698  CONTINUE
      IF(KFERR.EQ.1)RETURN
      IF(IPS.EQ.0)WRITE(22,53)ICOUNT,CRIT
      IF(IPS.EQ.0)WRITE(22,54)AMIN1(CHIL,CHISQ)
      INTR=0
      RETURN
 50   FORMAT(5X,42HMINIMIZATION STOPPED-NUMBER OF STEPS NPTL=,
     *1I5,1X,8HEXCEEDED)
 51   FORMAT(5X,7HAT STEP,1X,1I5,1X,
     *25HCHISQ CRITERION FULFILLED)
 53   FORMAT(5X,7HAT STEP,1X,1I5
     *,21HCONVERGENCE ACHIEVED(,1E14.6,1H))
 54   FORMAT(5X,10H*** CHISQ=,1E14.6,1X,3H***)
      END
      SUBROUTINE CEGRY(CHISQ,ITEMP,CHILO,IDR,NWYR,ICALL,ISSP,IREDV)
      CHARACTER*4 WUPL,WAR,OP2
      DIMENSION LIC(32),LTH(500)
     *,CNR(32,50)
      common/clust/iclust(50,200),lastcl(50,20),sumcl(20,500)
     *,irawex(50)
      COMMON/ODCH/DEV(500)
	common/tutaj/part(32,50,2),partl(32,50,2)
      COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON/TRA/DELTA(500,3),ENDEC(500),ITMA(50,200),ENZ(200)
      COMMON/BREC/BETAR(50)
      COMMON/DIMX/DIX(4),ODL(200)
      COMMON/VAC/VACDP(3,75),QCEN,DQ,XNOR,AKS(6,75),IBYP
      COMMON/CINIT/cnor(32,75),innr,mcfix,cnor1(32,75),cnor2(32,75)
      COMMON/PRT/IPRM(20)
      COMMON/LIFE/NLIFT
      COMMON/LEV/TAU(75),KSEQ(500,4)
      COMMON/IGRAD/IGRD
      COMMON/CX/NEXPT,IZ,XA,IZ1(50),XA1(50),EP(50),TLBDG(50),VINF(50)
      COMMON/MINNI/IMIN,LNORM(50)
      COMMON/LCZP/LFL,EMH,INM,LFL1,LFL2
      COMMON/CCOUP/ZETA(50000),LZETA(8)
      COMMON/YTEOR/YGN(500),YGP(500),IFMO
      COMMON/SEL/KVAR(500)
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/CCC/eg(50),cc(50,5),NANG(200),Q(3,200,8),NICC,
     *AGELI(50,200,2)
      COMMON/YEXPT/YEXP(32,1500),IY(1500,32),CORF(1500,32),DYEX(32,1500)
     *,NYLDE(50,32),UPL(32,50),YNRM(32,50),IDRN,ILE(32)
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      COMMON/WARN/SGW,SUBCH1,SUBCH2,IWF
      COMMON/COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      COMMON/SKP/JSKIP(50)
      COMMON/TRB/ITS
      COMMON/TCM/TETACM(50),TREP(50),DSIGS(50)
      common/cccds/ndst(50)
	OP2='    '
      IFXD=0
      TETRC=TREP(IEXP)
      IF(ICALL.NE.4.OR.IPRM(13).NE.-2)GO TO 400
      IPRM(13)=0
      WRITE(22,402)
      DO 401 JPC=1,NEXPT
      K=ndst(JPC)
 401  WRITE(22,403)JPC,(CNOR(L,JPC),L=1,K)
 402  FORMAT(1X//20X,23HNORMALIZATION CONSTANTS//
     *2X,10HEXPERIMENT,5X,15HDETECTORS(1-32))
 403  FORMAT(1X,1I2,2X,32(1E10.4,1X))
      WRITE(22,602)
      DO 601 JPC=1,NEXPT
      IF(abs(CNR(1,JPC)).lt.1.e-9)CNR(1,JPC)=1.
      K=ndst(JPC)
      WRITE(22,403)JPC,(CNR(L,JPC)/CNR(1,JPC),L=1,K)
 601  CONTINUE
 602  FORMAT(1X//20X,40HRECOMMENDED RELATIVE GE(LI) EFFICIENCIES//
     *2X,10HEXPERIMENT)
 400  CONTINUE
      DO 824 JPC=1,LP6
 824  LIC(JPC)=0
      IF(ICALL.EQ.7)GO TO 201
      IF(ITEMP.EQ.0)GO TO 100
      IFXD=1
      IF(ITEMP.NE.2)IFXD=0
      NWYR=1
      CALL DECAY(CCD,0,CCC)
      FI0=FIEX(IEXP,1)
      FI1=FIEX(IEXP,2)
      NA=NANG(IEXP)
      do 6257 k=1,lp2
      do 6257 kj=1,20
 6257 sumcl(kj,k)=0
      k9=0
      DO 105 K=1,NA
      GTH=AGELI(IEXP,K,1)
      FIGL=AGELI(IEXP,K,2)
      fm=(fi0+fi1)/2.
      CALL ANGULA(YGN,IDR,IFXD,FI0,FI1,TETRC,GTH,FIGL,K,OP2)
      IF(IFMO.EQ.0)GO TO 7232
      ID=ITMA(IEXP,K)
      D=ODL(ID)
      RX=D*SIN(GTH)*COS(FIGL-FM)-.25*SIN(TETRC)*COS(FM)
      RY=D*SIN(GTH)*SIN(FIGL-FM)-.25*SIN(TETRC)*SIN(FM)
      RZ=D*COS(GTH)-.25*COS(TETRC)
      RL=SQRT(RX*RX+RY*RY+RZ*RZ)
      SF=D*D/RL/RL
      THC=TACOS(RZ/RL)
      FIC=ATAN2(RY,RX)
      CALL ANGULA(YGP,IDR,IFXD,FI0,FI1,TETRC,THC,FIC,K,OP2)
      DO 7233 IXL=1,IDR
      IXM=KSEQ(IXL,3)
      TFAC=TAU(IXM)
      IF(TFAC.GT.1.E+4)GO TO 7235
 7233 YGN(IXL)=YGN(IXL)+.01199182*TFAC*BETAR(IEXP)*
     *(SF*YGP(IXL)-YGN(IXL))
 7235 IFMO=0
      WRITE(22,7236)
 7236 FORMAT(1X,/,2X,23HDURING THE MINIMIZATION,1X,
     *60HIT WAS NECESSARY TO SWITCH OFF THE TIME-OF-FLIGHT CORRECTION)
 7232 CONTINUE
      if(irawex(iexp).eq.0)go to 6252
      ipd=itma(iexp,k)
      do 6253 l=1,idr
      decen=endec(l)
      cocos=sin(tetrc)*sin(gth)*cos(fm-figl)+cos(tetrc)*
     *cos(gth)
      decen=decen*(1.+betar(iexp)*cocos)
      call effix(ipd,decen,effi)
      ygn(l)=ygn(l)*effi
 6253 continue
      inclus=iclust(iexp,k)
      if(inclus.eq.0)go to 6252
      do 6254 l=1,idr
 6254 sumcl(inclus,l)=sumcl(inclus,l)+ygn(l)
      if(k.ne.lastcl(iexp,inclus))go to 105
      do 6255 l=1,idr
 6255 ygn(l)=sumcl(inclus,l)
 6252 continue
      k9=k9+1
      IYEX=NYLDE(IEXP,K9)+ILE(K9)-1
       ILE2=ILE(K9)
      DO 102 L=ILE2,IYEX
      IF(JSKIP(IEXP).EQ.0)GO TO 102
      IDC=IY(L,K9)
      IF(IDC.LT.1000)GO TO 612
      IDC=IDC/1000
      LL1=IY(L,K9)-IDC*1000
      YGN(IDC)=YGN(IDC)+YGN(LL1)
 612  IF(ITEMP.EQ.1)GO TO 101
      CORF(L,K9)=YGN(IDC)
      IF(IMIN.GT.1.OR.L.NE.IYEX)GO TO 103
      CNOR(K9,IEXP)=YEXP(K9,L)/YGN(IDC)
 103  GO TO 102
  101 CONTINUE
      CORF(L,K9)=CORF(L,K9)/(YGN(IDC)+1.E-24)
 102  CONTINUE
 105   CONTINUE
      RETURN
 100  CONTINUE
      NWYR=0
      IF(IGRD.EQ.1)GO TO 1777
      IF(IEXP.EQ.1)SUMPR=0.
      IF(IEXP.EQ.1)SUM3=0.
      DO 107 JJ=1,LP6
      DO 107 JK=1,2
      PARTL(JJ,IEXP,JK)=0.
 107  PART(JJ,IEXP,JK)=0.
 1777 CALL DECAY(CHISQ,NLIFT,CHILO)
      IF(ICALL.NE.4.OR.IPRM(14).NE.-1)GO TO 414
      IF(IEXP.EQ.NEXPT)IPRM(14)=0
      WRITE(22,462)
      WRITE(22,467)IEXP
      DO 463 IVA=2,NMAX
  463 WRITE(22,464)IVA,(VACDP(II,IVA),II=1,3)
  462 FORMAT(1X//20X,35HVACUUM DEPOLARIZATION COEFFICIENTS //)
  467 FORMAT(5X,10HEXPERIMENT,1X,1I2/5X,5HLEVEL,10X,2HG2,10X,
     *2HG4,10X,2HG6/)
  464 FORMAT(7X,1I2,9X,3(1F6.4,6X))
  414 CONTINUE
      FI0=FIEX(IEXP,1)
      FI1=FIEX(IEXP,2)
      NA=NANG(IEXP)
      do 8257 k=1,lp2
      do 8257 k9=1,20
 8257 sumcl(k9,k)=0.
      k9=0
      DO 2 K=1,NA
      GTH=AGELI(IEXP,K,1)
      FIGL=AGELI(IEXP,K,2)
      IFXD=0
      fm=(fi0+fi1)/2.
      IF(ICALL.EQ.4)IFXD=1
      CALL ANGULA(YGN,IDR,IFXD,FI0,FI1,TETRC,GTH,FIGL,K,OP2)
      IF(IFMO.EQ.0)GO TO 8232
      ID=ITMA(IEXP,K)
      D=ODL(ID)
      RX=D*SIN(GTH)*COS(FIGL-FM)-.25*SIN(TETRC)*COS(FM)
      RY=D*SIN(GTH)*SIN(FIGL-FM)-.25*SIN(TETRC)*SIN(FM)
      RZ=D*COS(GTH)-.25*COS(TETRC)
      RL=SQRT(RX*RX+RY*RY+RZ*RZ)
      SF=D*D/RL/RL
      THC=TACOS(RZ/RL)
      FIC=ATAN2(RY,RX)
      CALL ANGULA(YGP,IDR,IFXD,FI0,FI1,TETRC,THC,FIC,K,OP2)
      DO 8233 IXL=1,IDR
      IXM=KSEQ(IXL,3)
      TFAC=TAU(IXM)
 8233 YGN(IXL)=YGN(IXL)+.01199182*TFAC*BETAR(IEXP)*
     *(SF*YGP(IXL)-YGN(IXL))
 8232 CONTINUE
      if(irawex(iexp).eq.0)go to 8252
      ipd=itma(iexp,k)
      do 8253 l=1,idr
      decen=endec(l)
      cocos=sin(tetrc)*sin(gth)*cos(fm-figl)+cos(tetrc)*
     *cos(gth)
      decen=decen*(1.+betar(iexp)*cocos)
      call effix(ipd,decen,effi)
      ygn(l)=ygn(l)*effi
 8253 continue
      inclus=iclust(iexp,k)
      if(inclus.eq.0)go to 8252
      do 8254 l=1,idr
 8254 sumcl(inclus,l)=sumcl(inclus,l)+ygn(l)
      if(k.ne.lastcl(iexp,inclus))go to 2
      do 8255 l=1,idr
 8255 ygn(l)=sumcl(inclus,l)
 8252 continue
      k9=k9+1
      IF(ICALL.NE.4.OR.IPRM(8).NE.-2)GO TO 410
      WRITE(22,404)IEXP,K9
 404  FORMAT(1X//5X,47HCALCULATED AND EXPERIMENTAL YIELDS   EXPERIMENT
     *,1X,1I2,1X,8HDETECTOR,1X,1I2//6X,
     *2HNI,5X,2HNF,7X,2HII,8X,2HIF,9X,11HENERGY(MEV),
     *6X,4HYCAL,8X,4HYEXP,7X,9HPC. DIFF.,
     *2X,13H(YE-YC)/SIGMA)
 410  LU=ILE(K9)
      DO 460 IABC=1,LP2
 460  LTH(IABC)=0
      DO 3 L=1,IDR
      NI=KSEQ(L,3)
      NF=KSEQ(L,4)
      IF(L.EQ.IY(LU,K9).OR.L.EQ.(IY(LU,K9)/1000))GO TO 300
      IF(JSKIP(IEXP).EQ.0)YGN(IDRN)=1.E+10
      RY=YGN(L)/YGN(IDRN)
      IF(ICALL.NE.4.OR.IPRM(8).NE.-2)GO TO 700
      WUPL='    '
      IF(RY.GT.UPL(K9,IEXP).AND.LTH(L).EQ.0)WUPL='UPL!'
      IF(IPRM(16).EQ.0.AND.WUPL.EQ.'    ')GO TO 700
      IF(WUPL.EQ.'    ')
     *WRITE(22,405)NI,NF,SPIN(NI),SPIN(NF),ENDEC(L),
     *YGN(L)*CNOR(K9,IEXP),WUPL
      IF(WUPL.EQ.'    ')GO TO 700
      SGM=(RY-UPL(K9,IEXP))/UPL(K9,IEXP)
      WRITE(22,406)NI,NF,SPIN(NI),
     *SPIN(NF),ENDEC(L),YGN(L)*CNOR(K9,IEXP),UPL(K9,IEXP)
     **CNOR(K9,IEXP)
     **YGN(IDRN),100.*(1.-YGN(L)/UPL(K9,IEXP)/YGN(IDRN)),
     *SGM,WUPL
      SUBCH1=SUBCH1+SGM*SGM
 700  CONTINUE
      IF(RY.LT.UPL(K9,IEXP).OR.LTH(L).EQ.1)GO TO 3
      CHISQ=CHISQ+(RY-UPL(K9,IEXP))*(RY-UPL(K9,IEXP))
     */UPL(K9,IEXP)/UPL(K9,IEXP)
      CHILO=CHILO+ALOG(RY/UPL(K9,IEXP))**2
      IF(IWF.EQ.0)GO TO 504
      WRITE(22,503)IEXP,NI,NF,RY/UPL(K9,IEXP)
 503  FORMAT(5X,13HWARNINIG-EXP. ,1I2,2X,7HTRANS. ,1I2,2H--,
     *1I2,5X,27HEXCEEDS UPPER LIMIT (RATIO=,1E14.6,1H))
 504  CONTINUE
      GO TO 3
 300  CONTINUE
      IFDU=0
      LIC(K9)=LIC(K9)+1
      LICZ=LIC(K9)
      NWYR=NWYR+1
      WF=CORF(LU,K9)
       IF(ICALL.EQ.4)WF=1.
       IF(ICALL.EQ.1.AND.ISSP.EQ.1)WF=1.
      IF(IY(LU,K9).LT.1000)GO TO 1527
      IFDU=1
      L1=IY(LU,K9)/1000
      L1=IY(LU,K9)-1000*L1
      YGN(L)=YGN(L)+YGN(L1)
      LTH(L1)=1
      IF(ICALL.NE.4.OR.IPRM(8).NE.-2)GO TO 701
      WAR='    '
      SGM=(YEXP(K9,LU)-YGN(L)*CNOR(K9,IEXP))/DYEX(K9,LU)
      IF(ABS(SGM).GE.SGW)WAR='*?!*'
      NI1=KSEQ(L1,3)
      NF1=KSEQ(L1,4)
      WRITE(22,408)NI,NI1,NF,NF1,SPIN(NI),SPIN(NI1),SPIN(NF),
     *SPIN(NF1),ENDEC(L),ENDEC(L1),YGN(L)*CNOR(K9,IEXP),
     *YEXP(K9,LU),100.*(YEXP(K9,LU)-YGN(L)*
     *CNOR(K9,IEXP))/YEXP(K9,LU),
     *SGM,WAR
      SUBCH1=SUBCH1+SGM*SGM
 701  CONTINUE
 1527 RY=YGN(L)*WF*CNOR(K9,IEXP)-YEXP(K9,LU)
      IF(IFDU.EQ.1)GO TO 702
      IF(ICALL.NE.4.OR.IPRM(8).NE.-2)GO TO 702
      WAR='    '
      SGM=(YEXP(K9,LU)-YGN(L)*CNOR(K9,IEXP))/DYEX(K9,LU)
      IF(ABS(SGM).GE.SGW)WAR='*?!*'
      WRITE(22,406)NI,NF,SPIN(NI),SPIN(NF),ENDEC(L),
     *YGN(L)*CNOR(K9,IEXP),YEXP(K9,LU),
     *100.*(YEXP(K9,LU)-YGN(L)*CNOR(K9,IEXP))/YEXP(K9,LU),
     *SGM,WAR
      SUBCH1=SUBCH1+SGM*SGM
 702  CONTINUE
      RYS=RY*RY
      IF(IGRD.EQ.1)CHISQ=CHISQ+RYS/DYEX(K9,LU)/DYEX(K9,LU)
      IF(K9.EQ.1.AND.IREDV.EQ.1)DEV(LICZ)=RY
      IF(IREDV.EQ.1)GO TO 5
      IF(LFL.NE.1)GO TO 5
      IF(K9.NE.1)GO TO 5
      LUU=6*LICZ-5
      JK=(LUU-1)/LP10+1
      KK=LUU-LP10*(JK-1)
      RIK=DEV(LICZ)+YEXP(K9,LU)
      SGM=-DEV(LICZ)/DYEX(K9,LU)
      IF(ITS.EQ.1.AND.KVAR(INM).NE.0)WRITE(17,*)NI,NF,SGM,
     *YGN(L)*CNOR(K9,IEXP)/DYEX(K9,LU)
      IF(ITS.EQ.1.AND.INM.EQ.1)WRITE(15,*)IEXP,RIK/CNOR(1,IEXP),
     *CNOR(1,IEXP),DYEX(K9,LU),YEXP(K9,LU)
      CALL SIXEL(RIK,RY,EMH,JK,KK,INM,LICZ)
 5    CONTINUE
      IF(IGRD.EQ.1)GO TO 1003
      IF(JSKIP(IEXP).EQ.0)GO TO 1003
      DL=DYEX(K9,LU)*DYEX(K9,LU)
      PART(K9,IEXP,1)=PART(K9,IEXP,1)+YGN(L)*YGN(L)
     **WF*WF/DL
      PART(K9,IEXP,2)=PART(K9,IEXP,2)-2.*YGN(L)*WF
     **YEXP(K9,LU)/DL
      SUMPR=SUMPR+YEXP(K9,LU)*YEXP(K9,LU)/DL
      PARTL(K9,IEXP,1)=PARTL(K9,IEXP,1)+YEXP(K9,LU)*YEXP(K9,LU)/DL
      PARTL(K9,IEXP,2)=PARTL(K9,IEXP,2)+ALOG(WF*YGN(L)/YEXP(K9,LU))
     **YEXP(K9,LU)*YEXP(K9,LU)/DL
      SUM3=SUM3+YEXP(K9,LU)*YEXP(K9,LU)*ALOG(WF*YGN(L)/YEXP(K9,LU))
     ***2/DL
 1003 LU=LU+1
 3    CONTINUE
      IF(IEXP.EQ.NEXPT)IWF=0
      IF(ICALL.NE.4.OR.IPRM(8).NE.-2) GO TO 2
      WRITE(22,620) SUBCH1-SUBCH2
      SUBCH2=SUBCH1
 620  FORMAT(1X/50X,17HCHISQ SUBTOTAL = ,E14.6)
 2    CONTINUE
      IF(IGRD.EQ.1)RETURN
      IF(IEXP.NE.NEXPT)RETURN
      IF(ICALL.EQ.1)RETURN
 201  DO 202 JJ=1,NEXPT
      IF(JSKIP(JJ).EQ.0)GO TO 202
      KC=ndst(JJ)
      DO 600 JK=1,KC
      CNR(JK,JJ)=-.5*PART(JK,JJ,2)/PART(JK,JJ,1)
      IF(INNR.EQ.0)GO TO 600
      CNOR(JK,JJ)=CNR(JK,JJ)
 600  CONTINUE
      IF(INNR.EQ.1)GO TO 202
      D=0.
      G=0.
      DO 203 JJ1=JJ,NEXPT
      IF(LNORM(JJ1).NE.JJ)GO TO 203
      K=ndst(JJ1)
      DO 204 JK=1,K
      D=D+YNRM(JK,JJ1)*PART(JK,JJ1,1)*YNRM(JK,JJ1)
 204  G=G-.5*YNRM(JK,JJ1)*PART(JK,JJ1,2)
 203  CONTINUE
      IF(LNORM(JJ).NE.JJ)GO TO 202
      CNOR(1,JJ)=G*YNRM(1,JJ)/D
      K=ndst(JJ)
      IF(K.EQ.1)GO TO 202
      DO 205 JK=2,K
 205  CNOR(JK,JJ)=YNRM(JK,JJ)*CNOR(1,JJ)/YNRM(1,JJ)
 202  CONTINUE
      IF(INNR.EQ.1)GO TO 209
      DO 206 JJ=1,NEXPT
      IF(LNORM(JJ).EQ.JJ)GO TO 206
      IW=LNORM(JJ)
      K=ndst(JJ)
      DO 207 JK=1,K
 207  CNOR(JK,JJ)=CNOR(1,IW)*YNRM(JK,JJ)/YNRM(1,IW)
 206  CONTINUE
 209  CONTINUE
      IF(ICALL.EQ.7)CHISQ=0.
      DO 501 JJ=1,NEXPT
      K=ndst(JJ)
      DO 502 JK=1,K
	if(mcfix.eq.0)cnor(jk,jj)=cnor1(jk,jj)
      CHILO=CHILO+PARTL(JK,JJ,1)*ALOG(CNOR(JK,JJ))**2+
     *PARTL(JK,JJ,2)*2.*ALOG(CNOR(JK,JJ))
 502  CHISQ=CHISQ+CNOR(JK,JJ)*CNOR(JK,JJ)*PART(JK,JJ,1)
     *+CNOR(JK,JJ)*PART(JK,JJ,2)
 501  CONTINUE
      CHISQ=CHISQ+SUMPR
      CHILO=CHILO+SUM3
      RETURN
 408  FORMAT(4X,1I2,1H+,1I2,2H--,1I2,1H+,1I2,3X,1F4.1,
     *1H+,1F4.1,2H--,1F4.1,1H+,1F4.1,3X,1F6.4,1H+,1F6.4,
     *2X,1E9.4,6X,1E9.4,3X,1F6.1,5X,1F4.1,10X,1A4)
 406  FORMAT(6X,1I2,5X,1I2,7X,1F4.1,6X,1F4.1,9X,1F6.4,
     *6X,1E9.4,6X,1E9.4,3X,1F6.1,5X,1F4.1,10X,1A4)
 405  FORMAT(6X,1I2,5X,1I2,7X,1F4.1,6X,1F4.1,9X,1F6.4,
     *6X,1E9.4,10X,1A4)
      END
      SUBROUTINE FAKP
      COMMON/FAKUL/IP(26),IPI(26),KF(101,26),PILOG(26)
      DO 99 I=1,26
      X=FLOAT(IP(I))
      PILOG(I)=ALOG(X)
   99 CONTINUE
      DO 1 L=1,26
      KF(1,L)=0
    1 KF(2,L)=0
      DO 3 K=3,101
      CALL PRIM(K-1)
      DO 2 I=1,26
    2 KF(K,I)=KF(K-1,I)+IPI(I)
    3 CONTINUE
      RETURN
      END
      SUBROUTINE PRIM(N)
      COMMON/FAKUL/IP(26),IPI(26),KF(101,26),PILOG(26)
      NNK=N
      DO 3 I=1,26
      NNI=NNK
      IPI(I)=0
    1 NNI=NNI/IP(I)
      IF(IP(I)*NNI.NE.NNK) GOTO 3
      IPI(I)=IPI(I)+1
      NNK=NNI
      GOTO1
    3 CONTINUE
      RETURN
      END
        SUBROUTINE SEQ(IDR)
        COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON/TRA/DELTA(500,3),ENDEC(500),ITMA(50,200),ENZ(200)
      COMMON/CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
        COMMON/LEV/TAU(75),KSEQ(500,4)
      COMMON/CATLF/FP(4,500,3),GKP(4,500,2),KLEC(75)
      M6=0
      DO 5 L=1,6
  5   M6=M6+MULTI(L)
      IDECAY=0
      IDR=0
      DO 515 L=1,LP3
 515  KLEC(L)=0
      DO 913 K=1,LP2
      DO 914 J=1,3
      DO 915 L=1,4
      FP(L,K,J)=0.
      IF(J.EQ.3)GO TO 915
      GKP(L,K,J)=0.
 915  CONTINUE
 914  DELTA(K,J)=0.
 913   CONTINUE
        DO 1 N=1,NMAX
        TAU(N)=EN(N)
  1     CONTINUE
        DO 2 N=1,NMAX
        EMAX=0.
         DO 3 J=1,NMAX
        IF(TAU(J).LT.EMAX)  GOTO 3
        EMAX=TAU(J)
        JSAVE=J
  3     CONTINUE
      DO 100 IS=1,NMAX
      DO 101 LA=1,8
      IF(LA.GT.3.AND.LA.NE.7.AND.LA.NE.8)GO TO 101
      LD=LDNUM(LA,IS)
      IF(LD.EQ.0)GO TO 101
      DO 102 IR=1,LD
      M=LEADF(IS,IR,LA)
      IF(M.NE.JSAVE.AND.IS.NE.JSAVE)GO TO 102
      IF(IS.EQ.JSAVE.AND.EN(M).GE.EN(IS))GO TO 102
      IF(M.EQ.JSAVE.AND.EN(IS).GE.EN(M))GO TO 102
      INDX=MEM(IS,M,LA)
      IDECAY=IDECAY+1
      KSEQ(IDECAY,1)=M
      KSEQ(IDECAY,2)=IS
      KSEQ(IDECAY,3)=INDX
      KSEQ(IDECAY,4)=LA+10
      IF(EN(M).GT.EN(IS))GO TO 102
      KSEQ(IDECAY,1)=IS
      KSEQ(IDECAY,2)=M
 102  CONTINUE
 101  CONTINUE
 100  CONTINUE
        TAU(JSAVE)=-1.
  2     CONTINUE
      DO 300 L=1,IDECAY
      ISTR1=0
      IF(KSEQ(L,4).LT.10)GO TO 300
      ISTR2=0
      N=KSEQ(L,1)
      M=KSEQ(L,2)
      INX=KSEQ(L,3)
      LA=KSEQ(L,4)-10
      EGA=EN(N)-EN(M)
      TWOI=1./SQRT(2.*SPIN(N)+1.)
      SPINI=SPIN(N)+.001
      SPINF=SPIN(M)+.001
      EGS=SQRT(EGA)*TWOI
      JS=L+1
      LA1=0
      INX1=0
      DO 301 J=JS,IDECAY
      IF(KSEQ(J,4).LT.10)GO TO 301
      N1=KSEQ(J,1)
        M1=KSEQ(J,2)
      IF(N1.NE.N.OR.M1.NE.M)GO TO 301
      INX1=KSEQ(J,3)
      LA1=KSEQ(J,4)-10
      KSEQ(J,4)=KSEQ(J,4)-10
 301  CONTINUE
      KSEQ(L,4)=KSEQ(L,4)-10
      IDR=IDR+1
      MULE=0
      MULM=0
      NOB=1
 700  IF(LA.GT.3)GO TO 400
      GO TO(500,501,502)LA
 400  LA=LA-6
      IF(LA.EQ.2)GO TO 401
      DELTA(IDR,2)=4.1952*EGA*EGS
      MULM=1
      ISTR2=4
      GO TO 600
 401  DELTA(IDR,2)=.0368*EGA*EGA*EGS
      MULM=2
      ISTR2=5
      GO TO 600
 500  DELTA(IDR,1)=399.05*EGA*EGS
      MULE=1
      ISTR1=1
      GO TO 600
 501  DELTA(IDR,1)=3.4928*EGS*EGA*EGA
      MULE=2
      ISTR1=2
      GO TO 600
 502  DELTA(IDR,1)=.02391*EGA*EGA*EGA*EGS
      MULE=3
      ISTR1=3
 600  CONTINUE
      IF(NOB.EQ.2)GO TO 303
      IF(MULE.EQ.1)GO TO 304
      NOB=NOB+1
      IF(LA.GT.3)INX1=INX
      IF(LA1.EQ.0)GO TO 304
      LA=LA1
      GO TO 700
 304  INX1=0
 303  DELTA(IDR,3)=DELTA(IDR,1)*DELTA(IDR,2)
      DELTA(IDR,1)=DELTA(IDR,1)*DELTA(IDR,1)
      DELTA(IDR,2)=DELTA(IDR,2)*DELTA(IDR,2)
      KSEQ(IDR,1)=INX
      KSEQ(IDR,2)=INX1
      KSEQ(IDR,3)=N
      KSEQ(IDR,4)=M
      IF(INX.LE.M6)GO TO 6
      KSEQ(IDR,2)=INX
      KSEQ(IDR,1)=0
  6   ENDEC(IDR)=EN(N)-EN(M)
      DO 8 MK=1,7,2
      KPA=MK/2+1
      K=MK-1
      IF(MULE.LT.3.AND.K.EQ.6)GO TO 8
      GKP(KPA,IDR,1)=GF(K,SPINI,SPINF,MULE)*DELTA
     *(IDR,1)*(1.+CONV(EGA,ISTR1))
      GKP(KPA,IDR,2)=GF(K,SPINI,SPINF,MULM)*DELTA
     *(IDR,2)*(1.+CONV(EGA,ISTR2))
      FP(KPA,IDR,1)=F(K,SPINI,SPINF,MULE,MULE)
     **DELTA(IDR,1)
      FP(KPA,IDR,3)=F(K,SPINI,SPINF,MULM,MULE)*
     *DELTA(IDR,3)
      FP(KPA,IDR,2)=F(K,SPINI,SPINF,MULM,MULM)*
     *DELTA(IDR,2)
 8    CONTINUE
      DELTA(IDR,1)=DELTA(IDR,1)*( 1.+CONV(EGA,ISTR1))
      DELTA(IDR,2)=DELTA(IDR,2)*(CONV(EGA,ISTR2)+1.)
      KLEC(N)=KLEC(N)+1
 300  CONTINUE
      NMAX1=0
      DO 71 N=1,NMAX
      IF(KLEC(N).NE.0)NMAX1=NMAX1+1
 71   CONTINUE
        RETURN
         END
        FUNCTION GF(K,SJI,SJF,L)
      GF=0.
      IF(L.EQ.0)RETURN
      IX=IFIX(SJI+SJF+.0001)
        I=IX+L+K
        PHASE=1.
        IF(I/2*2.NE.I)  PHASE=-1.
        KZ=K*2
        JIZ=SJI*2
        JFZ=SJF*2
        LZ=L*2
        GF=PHASE*SQRT((JIZ+1.)*(JFZ+1.))
     1      *WSIXJ(JIZ,JIZ,KZ,JFZ,JFZ,LZ)
        RETURN
        END
        FUNCTION F(K,SJI,SJF,L1,L2)
      F=0.
      IF((L1*L2).EQ.0)RETURN
      IX=IFIX(SJI+SJF+.0001)
        L=IX-1
        PHASE=1.
        IF(L/2*2.NE.L)  PHASE=-1.
        KZ=K*2
        JIZ=SJI*2
        JFZ=SJF*2
        L1Z=L1*2
        L2Z=L2*2
        F=PHASE*SQRT((L1Z+1.)*(L2Z+1.)*(JIZ+1.)*(KZ+1.))
     1          *WTHREJ(L1Z,L2Z,KZ,2,-2,0)
     2          *WSIXJ(JIZ,JIZ,KZ,L2Z,L1Z,JFZ)
        RETURN
        END
        FUNCTION CONV(EGA,N)
      DIMENSION CPO(51),CPO1(51)
      COMMON/CCC/eg(50),cc(50,5),NANG(200),Q(3,200,8),NICC,
     *AGELI(50,200,2)
      IF(N.EQ.0)GO TO 10
        IF(abs(CC(1,N)).lt.1.e-9) GO TO 10
      NEN=4
      DO 20 J=1,NICC
      IF(EGA.LE.EG(J))GO TO 11
 20   CONTINUE
 11   N1=J-2
      IF(N1.LT.1)N1=1
      IF((J+1).GT.NICC)N1=N1-1
      IF(NICC.GT.4)GO TO 12
      N1=1
      NEN=NICC
 12    CONTINUE
      DO 1 J=1,NEN
      CPO(J)=CC(N1+J-1,N)
      CPO1(J)=EG(N1+J-1)
 1    CONTINUE
        CALL LAGRAN(CPO1,CPO,4,1,EGA,CV,2,1)
      CONV=CV
        RETURN
 10   CONV=0.0
      RETURN
        END
      FUNCTION WTHREJ(J1,J2,J3,M1,M2,M3)
      DIMENSION JVORA(26)
      COMMON/FAKUL/IP(26),IPI(26),KF(101,26),PILOG(26)
      WTHREP=0.E+00
      JJHA=(J1+J2-J3)/2+1
      JJHB=(J1-J2+J3)/2+1
      JJHC=(-J1+J2+J3)/2+1
      IF((JJHA.LT.1).OR.(JJHB.LT.1).OR.(JJHC.LT.1).OR.
     *((M1+M2+M3).NE.0))GO TO 8
      JJHD=(J1+J2+J3+4)/2
      JMAX=MAX0(J1,J2,J3)
      IF(JMAX.EQ.J1) GOTO1
      IF(JMAX.EQ.J2) GOTO2
      IF(JMAX.EQ.J3) GOTO3
    1 JJ1=J2
      JJ2=J3
      JJ3=J1
      MM1=M2
      MM2=M3
      MM3=M1
      GOTO4
    2 JJ1=J3
      JJ2=J1
      JJ3=J2
      MM1=M3
      MM2=M1
      MM3=M2
      GOTO4
    3 JJ1=J1
      JJ2=J2
      JJ3=J3
      MM1=M1
      MM2=M2
      MM3=M3
    4 JMA=(JJ1+MM1)/2
      JMB=(JJ1-MM1)/2
      JMC=(JJ2+MM2)/2
      JMD=(JJ2-MM2)/2
      JME=(JJ3+MM3)/2
      JMF=(JJ3-MM3)/2
      JABC=(JJ1+JJ2-JJ3)/2
      JABM=(JJ2-JJ3-MM1)/2
      JBMA=(JJ1+MM2-JJ3)/2
      IZMIN=MAX0(JABM,JBMA,0)
      IZMAX=MIN0(JABC,JMB,JMC)
      NMAX=MAX0(JJHD,IZMAX+1)
      DO 9 N=1,26
      IF(IP(N).GE.NMAX) GOTO10
    9 CONTINUE
      GOTO8
   10 DO 5 JLP=1,N
      JTA=KF(JJHA,JLP)+KF(JJHB,JLP)+KF(JJHC,JLP)-KF(JJHD,JLP)
      JTB=KF(JMA+1,JLP)+KF(JMB+1,JLP)+KF(JMC+1,JLP)
      JTC=KF(JMD+1,JLP)+KF(JME+1,JLP)+KF(JMF+1,JLP)
      JVORA(JLP)=JTA+JTB+JTC
    5 CONTINUE
      VORZ=-1.E+00
      IF(2*(IZMIN/2).EQ.IZMIN) VORZ=+1.E+00
      IF(IZMIN.GT.IZMAX) GOTO8
      DO7 IZ=IZMIN,IZMAX
      QSUMLO=0.E+00
      IZA=IZ+1
      IZB=JABC+1-IZ
      IZC=JMB+1-IZ
      IZD=JMC+1-IZ
      IZE=IZ-JABM+1
      IZF=IZ-JBMA+1
      DO6 JLP=1,N
      IZEXP=JVORA(JLP)-2*KF(IZA,JLP)-2*KF(IZB,JLP)-2*KF(IZC,JLP)
     *-2*KF(IZD,JLP)-2*KF(IZE,JLP)-2*KF(IZF,JLP)
      SUMLO=IZEXP
      QSUMLO=QSUMLO+SUMLO*PILOG(JLP)*(.5E+00)
    6 CONTINUE
      ZUTHRE=VORZ* EXP(QSUMLO)
      WTHREP=WTHREP+ZUTHRE
    7 VORZ=-VORZ
      JVO=JJ1-JJ2-MM3
      IF(4*(JVO/4).EQ.JVO) GOTO8
      WTHREP=-WTHREP
    8 WTHREJ=WTHREP
      RETURN
      END
      FUNCTION WSIXJ(J1,J2,J3,L1,L2,L3)
      DIMENSION ISUMFA(26),IVORFA(26)
      COMMON/FAKUL/IP(26),IPI(26),KF(101,26),PILOG(26)
      WSIXP=0.E+00
      IF(((J1+J2-J3).LT.0).OR.((J1-J2+J3).LT.0).OR.((-J1+J2+J3).LT.0))
     1 GOTO8
      IF(((J1+L2-L3).LT.0).OR.((J1-L2+L3).LT.0).OR.((-J1+L2+L3).LT.0))
     1 GOTO8
      IF(((L1+J2-L3).LT.0).OR.((L1-J2+L3).LT.0).OR.((-L1+J2+L3).LT.0))
     1 GOTO8
      IF(((L1+L2-J3).LT.0).OR.((L1-L2+J3).LT.0).OR.((-L1+L2+J3).LT.0))
     1 GOTO8
      KQA=(J1+J2-J3)/2
      KQB=(J1-J2+J3)/2
      KQC=(J2+J3-J1)/2
      KQD=(J1+J2+J3)/2
      KRA=(J1+L2-L3)/2
      KRB=(J1-L2+L3)/2
      KRC=(L2+L3-J1)/2
      KRD=(J1+L2+L3)/2
      KSA=(L1+J2-L3)/2
      KSB=(L1-J2+L3)/2
      KSC=(J2+L3-L1)/2
      KSD=(L1+J2+L3)/2
      KTA=(L1+L2-J3)/2
      KTB=(L1-L2+J3)/2
      KTC=(L2+J3-L1)/2
      KTD=(L1+L2+J3)/2
      IZMIN=MAX0(KQD,KRD,KSD,KTD)
      KUA=KQA+KTA+J3
      KUB=KSC+KTC+L1
      KUC=KRB+KTB+L2
      IZMAX=MIN0(KUA,KUB,KUC)
      IF(IZMIN.GT.IZMAX) GOTO8
      NMAX=MAX0(IZMAX+2,KQD+2,KRD+2,KSD+2,KTD+2)
      DO 3 N=1,26
      IF(IP(N).GE.NMAX) GOTO4
    3 CONTINUE
      GOTO8
    4 VORZ=-1.E+00
      IF(2*(IZMIN/2).EQ.IZMIN) VORZ=+1.E+00
      DO1 IRL=1,N
      IVA=KF(KQA+1,IRL)+KF(KQB+1,IRL)+KF(KQC+1,IRL)-KF(KQD+2,IRL)
      IVB=KF(KRA+1,IRL)+KF(KRB+1,IRL)+KF(KRC+1,IRL)-KF(KRD+2,IRL)
      IVC=KF(KSA+1,IRL)+KF(KSB+1,IRL)+KF(KSC+1,IRL)-KF(KSD+2,IRL)
      IVD=KF(KTA+1,IRL)+KF(KTB+1,IRL)+KF(KTC+1,IRL)-KF(KTD+2,IRL)
      IVORFA(IRL)=IVA+IVB+IVC+IVD
    1 CONTINUE
      DO7 IZ=IZMIN,IZMAX
      SUMLO=0.E+00
      IZA=IZ+2
      IZB=IZ-KQD+1
      IZC=IZ-KRD+1
      IZD=IZ-KSD+1
      IZE=IZ-KTD+1
      IZF=KUA-IZ+1
      IZG=KUB-IZ+1
      IZH=KUC-IZ+1
      DO5 IRJ=1,N
      ISA=2*KF(IZA,IRJ)-2*KF(IZB,IRJ)-2*KF(IZC,IRJ)
      ISB=-2*KF(IZD,IRJ)-2*KF(IZE,IRJ)-2*KF(IZF,IRJ)
      ISC=IVORFA(IRJ)-2*KF(IZG,IRJ)-2*KF(IZH,IRJ)
      ISUMFA(IRJ)=ISA+ISB+ISC
      QSUMFA=ISUMFA(IRJ)
      SUMLO=SUMLO+QSUMFA*PILOG(IRJ)
    5 CONTINUE
      QSUMLO=(.5E+00)*SUMLO
      ZUSIX=EXP(QSUMLO)*VORZ
      WSIXP=WSIXP+ZUSIX
    7 VORZ=-VORZ
    8 WSIXJ=WSIXP
      RETURN
       END
      SUBROUTINE LAGRAN(X,Y,NDATA,IPC,XX,YY,ISCAL,IRC)
      DIMENSION X(51),Y(51),W(51),ARH(51,51)
      GO TO(50,60,70,80)IRC
 50   DO 1 I=1,NDATA
      W(I)=1.
      DO 2 J=1,NDATA
      IF(I.EQ.J)GO TO 2
      W(I)=W(I)*(XX-X(J))/(X(I)-X(J))
 2    CONTINUE
 1    CONTINUE
 60   YY=0.
      DO 11 J=1,NDATA
      Y1=Y(J)
 11   YY=YY+W(J)*FUNC(Y1,ISCAL)
      YY=FUNC1(YY,ISCAL)
      RETURN
 70   DO 21 I=1,NDATA
      T=1.
      DO 22 J=1,NDATA
      IF(I.EQ.J)GO TO 22
      T=T*(XX-X(J))/(X(I)-X(J))
 22   CONTINUE
 21   ARH(IPC,I)=T
 80   YY=0.
      DO 31 J=1,NDATA
      Y1=Y(J)
 31   YY=YY+ARH(IPC,J)*FUNC(Y1,ISCAL)
      YY=FUNC1(YY,ISCAL)
      RETURN
      END
      FUNCTION FUNC(Y,I)
      GOTO (1,2,3),I
  1   FUNC=Y
      RETURN
 2    CONTINUE
      IF(Y.LT.1.E-12)Y=1.E-12
      FUNC=ALOG(Y)
      RETURN
  3   FUNC=SQRT(Y)
      RETURN
      END
      FUNCTION FUNC1(Y,I)
      GOTO (1,2,3),I
  1   FUNC1=Y
      RETURN
  2   FUNC1=EXP(Y)
      RETURN
  3   FUNC1=Y*Y
      RETURN
      END
        SUBROUTINE GKVAC(IL)
      COMMON/LEV/TAU(75),KSEQ(500,4)
      COMMON/BREC/BETAR(50)
      COMMON/GGG/AVJI,GAMMA,XLAMB,TIMEC,GFAC,FIEL,POWER
      COMMON/CX/NEXPT,IZ,XA,IZ1(50),XA1(50),EP(50),TLBDG(50),VINF(50)
      COMMON/GVAC/GKI(3),SUM(3)
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      COMMON/VAC/VACDP(3,75),QCEN,DQ,XNOR,AKS(6,75),IBYP
      COMMON/COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
       COMMON/THTAR/ITTE(50)
       IF(abs(XLAMB).lt.1.e-9)GO TO 5
       IF(ITTE(IEXP).EQ.0)GO TO 1
  5    CONTINUE
       DO 2 I=1,3
  2    VACDP(I,IL)=1.
       RETURN
  1    CONTINUE
       SP=SPIN(IL)
      BETA=BETAR(IEXP)
       TIME=TAU(IL)
       CALL GKK(IZ,BETA,SP,TIME,IL)
       VACDP(1,IL)=GKI(1)
       VACDP(2,IL)=GKI(2)
       VACDP(3,IL)=GKI(3)
        RETURN
        END
       SUBROUTINE GKK(IZ,BETA,SPIN,TIME,IL)
        COMMON/GVAC/GKI(3),SUM(3)
      COMMON/VAC/VACDP(3,75),QCEN,DQ,XNOR,AKS(6,75),IBYP
      COMMON/GGG/AVJI,GAMMA,XLAMB,TIMEC,GFAC,FIEL,POWER
      IF(IBYP.EQ.1)GO TO 100 
      IMEAN=0
      CALL XSTATIC(IZ,INQ,IFQ,BETA)
      L=0
      DO 77 I=1,6
  77  AKS(I,IL)=0.
 10   CONTINUE
      IF(IMEAN.EQ.1)INQ=1
      IF(IMEAN.EQ.1)IFQ=1
      DO 1 J=INQ,IFQ
      L=L+1
      NZ=IZ-J
      XJI=ATS(NZ)
      SM=SPIN
      IF(IMEAN.EQ.1)XJI=AVJI
      IF(SPIN.GT.XJI)SM=XJI
      NCOUP=INT(2.*SM+.5)+1
      SUM(1)=0.
      SUM(2)=0.
      SUM(3)=0.
      VALMI=SPIN-XJI
      IF(VALMI.LT.0.)VALMI=-VALMI
      DO 2 M=1,NCOUP
      F=VALMI+FLOAT(M)-1.
      DO 3 K=1,3
      RK=2.*FLOAT(K)
      IF2=F*2.+0.0001
      IRK2=RK*2.+0.0001
      ISPIN2=SPIN*2.+0.0001
      IXJI2=XJI*2.+0.0001
 3    SUM(K)=SUM(K)+((2.*F+1.)*WSIXJ(IF2,IF2,IRK2,ISPIN2,ISPIN2,IXJI2)
     *)**2/(2.*XJI+1.)
 2    CONTINUE
      IF(IMEAN.EQ.1)GO TO 11
      DO 4 K=1,3
      K1=2*K-1
 4    AKS(K1,IL)=AKS(K1,IL)
     *+SUM(K)*EXP(-((QCEN-FLOAT(J))/DQ)**2/2.)/XNOR
      IF(IMEAN.EQ.0)GO TO 1
 11   DO 12 K=1,3
      K1=2*K
 12   AKS(K1,IL)=AKS(K1,IL)+SUM(K)
 1    CONTINUE
      IMEAN=IMEAN+1
      IF(IMEAN.EQ.1)GO TO 10
 100  CONTINUE
      HMEAN=FIEL*IZ*(BETA**POWER)
      WSP=4789.*GFAC*HMEAN/AVJI
      WSP=WSP*TIMEC
      WSP=WSP*WSP*AVJI*(AVJI+1.)/3.
      DO 5 K=1,3
      K2=2*K
      K1=2*K-1
      WRT=WSP*K2*(K2+1)
      W2=WRT
      WRT=-WRT/(1.-AKS(K2,IL))
      XLAM=(1.-AKS(K2,IL))*(1.-EXP(WRT))/TIMEC
      UP=(GAMMA*TIME*AKS(K1,IL)+1.)/(TIME*GAMMA+1.)
      UP=UP*XLAMB*TIME+1.
      DOWN=TIME*(XLAM+XLAMB)+1.
      GKI(K)=UP/DOWN
      ALP=9.*XLAM*XLAM+8.*XLAM*TIMEC*(W2-XLAM*XLAM)
      ALP=SQRT(ALP)-3.*XLAM
      ALP=ALP/4./XLAM/TIMEC
      UPC=XLAM*TIME*(DOWN-2.*ALP*ALP*TIME*TIMEC)
      DWC=(DOWN+ALP*TIME)*(DOWN+2.*ALP*TIME)
      CCF=1.+UPC/DWC
      GKI(K)=GKI(K)*CCF
  5   CONTINUE
      RETURN
      END
      SUBROUTINE XSTATIC(IZ,IDO,IUP,BETA)
      COMMON/VAC/VACDP(3,75),QCEN,DQ,XNOR,AKS(6,75),IBYP
      H=1./(1.+(IZ**.45*.012008/BETA)**1.666667)
      QCEN=IZ*H**.6
      DQ=SQRT(QCEN*(1.-H))/2.
      IUP=INT(QCEN+3.*DQ+.5)
      IDO=INT(QCEN-3.*DQ-.5)
      IF(IUP.GT.IZ)IUP=IZ
      IF(IDO.LT.1)IDO=1
      XNOR=0.
      DO 1 LQ=IDO,IUP
  1   XNOR=XNOR+EXP(-((QCEN-FLOAT(LQ))/DQ)**2/2.)
      RETURN
      END
      FUNCTION ATS(N)
      IF(N.LE.0.OR.N.GT.96)GO TO 15
      X=N/2.+1
      M=N/2+1
      XM=FLOAT(M)
      IF(abs(x-xm).lt.1.e-9)GO TO 100
      GO TO(2,2,2,3,3,2,2,3,3,2,3,5,9,5,2,2,3,3,2,3,5,9,5
     *,2,2,3,3,2,7,7,2,5,13,17,2,3,2,9,5,2,2,3,3,2,
     *3,11,11,7),M
 100  M=M-1
      GO TO(1,1,1,4,1,1,1,4,1,16,1,6,8,1,1,1,4,1,1,1,6,8,1,
     *1,1,4,1,4,8,4,8,4,14,8,1,16,6,8,1,1,1,4,1,1,4,12,8,4),M
 1    ATS=0.
      RETURN
 2    ATS=.5
      RETURN
 3    ATS=1.5
      RETURN
 4    ATS=2.
      RETURN
 5    ATS=2.5
      RETURN
 6    ATS=3.
      RETURN
 7    ATS=3.5
      RETURN
   8  ATS=4.
      RETURN
 9    ATS=4.5
      RETURN
 11   ATS=5.5
      RETURN
 12   ATS=6.
      RETURN
 13   ATS=7.5
      RETURN
 14   ATS=8.
      RETURN
 15   ATS=0.
      RETURN
  16  ATS=1.
      RETURN
  17  ATS=6.5
      RETURN
      END
      SUBROUTINE YLM(THETA,YLMR)
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      DIMENSION YLMR(9,9),ST(7)
      CT=COS(THETA)
      CTSQ=CT*CT
      IF(IAXS(IEXP).EQ.0)GO TO 120
      ST(1)=SIN(THETA)
      DO 10  I=2,7
      J=I-1
      ST(I)=ST(J)*ST(1)
  10  CONTINUE
      YLMR(1,3)=.1089659406
      YLMR(1,2)=-.2179318812*CT
      YLMR(1,1)=.0889703179*(3.*CTSQ-1.)
      YLMR(2,5)=.1248361677
      YLMR(2,4)=-.3530900028*CT
      YLMR(2,3)=.0943672726*(7.*CTSQ-1.)
      YLMR(2,2)=-.1334554768*CT*(7.*CTSQ-3.)
      YLMR(2,1)=.0298415518*((35.*CTSQ-30.)*CTSQ+3.)
      YLMR(3,7)=.1362755124
      YLMR(3,6)=-.4720722226*CT
      YLMR(3,5)=.100646136*(11.*CTSQ-1.)
      YLMR(3,4)=-.1837538634*CT*(11.*CTSQ-3.)
      YLMR(3,3)=.0918769316*((33.*CTSQ-18.)*CTSQ+1.)
      YLMR(3,2)=-.1162161475*CT*((33.*CTSQ-30.)*CTSQ+5.)
      YLMR(3,1)=.0179325408*(((231.*CTSQ-315.)*CTSQ
     1+105.)*CTSQ-5.)
      DO 100 L=1,3
      LF=2*L+1
      DO 99 M=2,LF
      YLMR(L,M)=YLMR(L,M)*ST(M-1)
  99  CONTINUE
 100  CONTINUE
      RETURN
 120  YLMR(1,1)=.0889703179*(3.*CTSQ-1.)
      YLMR(2,1)=.0298415518*((35.*CTSQ-30.)*CTSQ+3.)
      YLMR(3,1)=.0179325408*(((231.*CTSQ-315.)*CTSQ
     *+105.)*CTSQ-5.)
      RETURN
      END
      SUBROUTINE DECAY(CHISQ,NLIFT,CHILO)
      COMMON/TRA/DELTA(500,3),ENDEC(500),ITMA(50,200),ENZ(200)
      COMMON/GGG/AVJI,GAMMA,XLAMB,TIMEC,GFAC,FIEL,POWER
      COMMON/LIFE1/LIFCT(50),TIMEL(2,50)
      COMMON/VAC/VACDP(3,75),QCEN,DQ,XNOR,AKS(6,75),IBYP
      COMMON/CCOUP/ZETA(50000),LZETA(8)
      COMMON/LEV/TAU(75),KSEQ(500,4)
      COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      COMMON/CATLF/FP(4,500,3),GKP(4,500,2),KLEC(75)
      COMMON/LCDL/DELLA(500,3)
	common/switch/jzb,ibps
      DIMENSION GK(4)
      IDR=1
      DO 1 IL=1,NMAX1
      L=KSEQ(IDR,3)
      N1=28*(L-1)
      IBRA=KLEC(L)
      BSUM=0.
      IDRH=IDR
      DO 2 J=1,IBRA
      INX=KSEQ(IDR,1)
      INX1=KSEQ(IDR,2)
      EL1=0.
      IF(INX.NE.0)EL1=ELM(INX)
      EMT=EL1*EL1
      DELLA(IDR,1)=EMT
      IF(INX1.NE.0)EMT1=ELM(INX1)*ELM(INX1)
      BSUM=BSUM+DELTA(IDR,1)*EMT
      IF(INX1.EQ.0)GO TO 2
      DELLA(IDR,3)=EL1*ELM(INX1)
      DELLA(IDR,2)=EMT1
      BSUM=BSUM+DELTA(IDR,2)*EMT1
  2   IDR=IDR+1
      IDR=IDRH
      TAU(L)=1./BSUM
      CALL GKVAC(L)
      DO 20 J=1,IBRA
      L1=KSEQ(IDR,4)
      N2=28*(L1-1)
      INX1=KSEQ(IDR,2)
      DO 10 I=1,4
 10   GK(I)=GKP(I,IDR,1)*DELLA(IDR,1)
      IF(INX1.EQ.0)GO TO 11
      DO 12 I=1,4
 12   GK(I)=GK(I)+GKP(I,IDR,2)*DELLA(IDR,2)
 11   DO 13 I=1,4
      VCD=1.
      IF(I.NE.1)VCD=VACDP(I-1,L)
      GK(I)=GK(I)*TAU(L)
      IFN=2*I-1
      IU=(I-1)*7
      IF(IAXS(IEXP).EQ.0)IFN=1
      DO 22 KQ=1,IFN
      LC1=N1+IU+KQ
      LC2=N2+IU+KQ
 22   ZETA(LC2)=ZETA(LC2)+GK(I)*VCD*ZETA(LC1)
 13   CONTINUE
      IDR=IDR+1
 20   CONTINUE
 1    CONTINUE
      IBYP=1
      IF(NLIFT.EQ.0.OR.IEXP.NE.1)GO TO 50
      DO 51 JLT=1,NLIFT
      KL=LIFCT(JLT)
      DF=(TAU(KL)-TIMEL(1,JLT))/TIMEL(2,JLT)
      CHILO=CHILO+(ALOG(TAU(KL)/TIMEL(1,JLT))*TIMEL(1,JLT)/
     *TIMEL(2,JLT))**2
 51   CHISQ=CHISQ+DF*DF
 50   DO 30 L=2,NMAX
      IF(KLEC(L).EQ.0)GO TO 30
      N1=28*(L-1)
      DO 31 J=1,4
      VCD=1.
      IF(J.NE.1)VCD=VACDP(J-1,L)
      IFN=2*J-1
      IU=(J-1)*7
      DO 32 K=1,IFN
      LC1=N1+IU+K
 32   ZETA(LC1)=ZETA(LC1)*VCD
 31   CONTINUE
 30   CONTINUE
      RETURN
      END
        SUBROUTINE ANGULA(YGN,IDR,IFUL,FI0,FI1,TREC,GTH,FIGL,NGL,OP2)
	character*4 OP2  
      DIMENSION F(4),YLMR(9,9),AT(28),ALAB(9,9),ATTL(9,9)
     *,YGN(500)
      COMMON/CCOUP/ZETA(50000),LZETA(8)
      COMMON/TRA/DELTA(500,3),ENDEC(500),ITMA(50,200),ENZ(200)
      COMMON/LEV/TAU(75),KSEQ(500,4)
      COMMON/CCC/eg(50),cc(50,5),NANG(200),Q(3,200,8),NICC,
     *AGELI(50,200,2)
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      COMMON/LCDL/DELLA(500,3)
      COMMON/CATLF/FP(4,500,3),GKP(4,500,2),KLEC(75)
      COMMON/BREC/BETAR(50)
      COMMON/THTAR/ITTE(50)
      COMMON/TCM/TETACM(50),TREP(50),DSIGS(50)
	COMMON/CX/NEXPT,IZ,XA,IZ1(50),XA1(50),EP(50),TLBDG(50),VINF(50)
      DO 1 L=1,IDR
      NLV=KSEQ(L,3)
      IL=(NLV-1)*28
      INX1=KSEQ(L,2)
      DO 2 J=1,4
      F(J)=FP(J,L,1)*DELLA(L,1)
 2    CONTINUE
      IF(INX1.EQ.0)GO TO 10
      DO 3 J=1,4
      F(J)=F(J)+2.*FP(J,L,3)*DELLA(L,3)
     *+FP(J,L,2)*DELLA(L,2)
 3    CONTINUE
 10   DO 11 J=1,4
      F(J)=F(J)*TAU(NLV)
      IU=(J-1)*7
      IFN=2*J-1
      IF(IAXS(IEXP).EQ.0)IFN=1
      DO 12 KQ=1,IFN
      IS=IU+KQ
      IG=IS+IL
 12   AT(IS)=ZETA(IG)*F(J)
 11   CONTINUE
      IF(IFUL.EQ.1)GO TO 100
      IXS=IAXS(IEXP)
      FI01=FI0-FIGL
      FI11=FI1-FIGL
      CALL FIINT(FI01,FI11,AT,IXS)
      IF(L.EQ.1)CALL YLM(GTH,YLMR)
      YGN(L)=AT(1)*.0795774715
      DO 14 JJ=1,3
      JI=JJ*7+1
      SM=YLMR(JJ,1)*AT(JI)
      IF(IAXS(IEXP).EQ.0)GO TO 16
      MIND=2*JJ+1
      DO 13 JM=2,MIND
      JI=JI+1
      SM=YLMR(JJ,JM)*AT(JI)*2.+SM
 13   CONTINUE
  16  IPD=ITMA(IEXP,NGL)
      ARG=(ENDEC(L)-ENZ(IPD))**2
      QV=(Q(3,IPD,2*JJ)*Q(2,IPD,2*JJ)+Q(1,IPD,2*JJ)*ARG)
     */(Q(2,IPD,2*JJ)+ARG)
      YGN(L)=YGN(L)+SM*QV
 14   CONTINUE
      GO TO 1
 100  DO 101 J=1,9
      DO 101 K=1,9
      ALAB(J,K)=0.
 101  ATTL(J,K)=0.
      DO 102 J=1,4
      LF=2*J-1
      LF1=LF
      IF(IAXS(IEXP).EQ.0)LF1=1
      DO 103 K=1,LF1
      INAT=(J-1)*7+K
 103  ALAB(LF,K)=AT(INAT)
 102  CONTINUE
      BT=BETAR(IEXP)
      IF(ITTE(IEXP).EQ.1)GO TO 200
      CALL RECOIL(ALAB,ATTL,BT,TREC)
 200  CONTINUE
      IF(L.EQ.1)CALL YLM1(GTH,YLMR)
      IXS=IAXS(IEXP)
      FI01=FI0-FIGL
      FI11=FI1-FIGL
      CALL FIINT1(FI01,FI11,ALAB,IXS)
      YGN(L)=ALAB(1,1)*.0795774715
      DO 104 J=2,9
      SM=YLMR(J,1)*ALAB(J,1)
      IF(IAXS(IEXP).EQ.0)GO TO 105
      DO 106 K=2,J
 106  SM=SM+2.*YLMR(J,K)*ALAB(J,K)
  105 IPD=ITMA(IEXP,NGL)
      ARG=(ENDEC(L)-ENZ(IPD))**2
      QV=(Q(3,IPD,J-1)*Q(2,IPD,J-1)+Q(1,IPD,J-1)*ARG)
     */(Q(2,IPD,J-1)+ARG)
      YGN(L)=YGN(L)+SM*QV
 104  CONTINUE
 1    CONTINUE
      if(OP2.eq.'INTG')return
      dsig=dsigs(iexp)
	ttx=tlbdg(iexp)/57.2957795
	do 300 j=1,idr
 300  ygn(j)=ygn(j)*dsig*sin(ttx)	
      RETURN
      END
      SUBROUTINE READY(IDR,NTAP,IPRI)
      DIMENSION IYTOT(32)
      COMMON/YEXPT/YEXP(32,1500),IY(1500,32),CORF(1500,32),DYEX(32,1500)
     *,NYLDE(50,32),UPL(32,50),YNRM(32,50),IDRN,ILE(32)
      COMMON/CX/NEXPT,IZ,XA,IZ1(50),XA1(50),EP(50),TLBDG(50),VINF(50)
      COMMON/LEV/TAU(75),KSEQ(500,4)
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/CCCDS/ndst(50)
      REWIND NTAP
      DO 33 K=1,LP6
 33   IYTOT(K)=0
      IF(IPRI.EQ.1)WRITE(22,99)
      DO 200 LXP=1,NEXPT
      DO 501 KKL=1,LP6
 501  NYLDE(LXP,KKL)=0
      II=ndst(LXP)
      DO 500 KK=1,II
      READ(NTAP,*)NE,NANX,ZP,AP,XEP,NVAL,WAGA
      IF(IPRI.EQ.1)WRITE(22,1)NE,ZP,AP,XEP,ndst(NE),WAGA
 1    FORMAT(1X,///5X,10HEXPERIMENT,1X,1I2/
     *2X,10HPROJECTILE,1X,1H(,1F4.0,1H,,1F4.0,1H),1X,
     *1F7.3,1X,3HMEV,1X,3H---,1I1,1X,
     *18HGE(LI) DETECTOR(S),2X,7HWEIGHT=,1E8.2/20X,11H** EXPERIME
     *,14HNTAL YIELDS **)
      IF(IPRI.EQ.1)WRITE(22,888)
      DO 3 J=1,NVAL
      READ(NTAP,*)NS1,NS2,U,W
      NSXH=NS1
      NSYH=NS2
      IF(NS1.LT.100)GO TO 450
      NS1=NS1/100
      NS2=NS2/100
 450  DO 15 NDE=1,IDR
      IF(NS1.EQ.KSEQ(NDE,3).AND.NS2.EQ.KSEQ(NDE,4))GO TO 16
 15   CONTINUE
      IF(IPRI.EQ.1)WRITE(22,17)NS1,NS2
 17    FORMAT(1X///5X,38HERROR-NO MATRIX ELEMENT BETWEEN STATES
     *,1X,1I2,5H AND ,1I2,/10X,23HTHIS TRANSITION IGNORED,//)
      GO TO 3
 16   IDC=NDE
      IYTOT(KK)=IYTOT(KK)+1
      IDC1=0
      IF(NSXH.LT.100)GO TO 460
      NS3=NSXH-100*NS1
      NS4=NSYH-100*NS2
      DO 461 NDE1=1,IDR
      IF(NS3.EQ.KSEQ(NDE1,3).AND.NS4.EQ.KSEQ(NDE1,4))GO TO 462
 461  CONTINUE
      IF(IPRI.EQ.1)WRITE(22,17)NS3,NS4
      GO TO 463
 462  IDCX=IDC*1000+NDE1
      IF(IDC.GT.NDE1)IDCX=NDE1*1000+IDC
      IDC=IDCX
 463  CONTINUE
 460  CONTINUE
      IDC1=IDC
      IF(IDC1.GT.1000)IDC1=IDC/1000
      IF(IPRI.EQ.1)WRITE(22,4)IDC,KSEQ(IDC1,3),KSEQ(IDC1,4),
     *U,W
 4    FORMAT(2X,1I6,2X,1I2,2X,1I2,1(1E14.6,3X,1E14.6))
 888  FORMAT(4X,5HDECAY,1X,2HIS,2X,2HIF,1(9X,13HYIELD+/-ERROR,9X)/)
      IYTT=IYTOT(KK)
      YEXP(KK,IYTT)=U
      DYEX(KK,IYTT)=W/(SQRT(WAGA)+1.E-4)
      IY(IYTT,KK)=IDC
 3    CONTINUE
      IYTT=IYTOT(KK)
      LBG=IYTT-NVAL+1
      CALL SZEREG(LBG,IYTT,KK)
 500  NYLDE(LXP,KK)=NVAL
 200  CONTINUE
 99   FORMAT(5X/47X,
     *41HREPRINT OF EXPERIMENTAL DATA TO BE FITTED//)
      RETURN
      END
      SUBROUTINE BRANR(CHISQ,NWYR,CHILO)
      COMMON/CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON/COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      COMMON/BRNCH/BRAT(50,2),IBRC(2,50),NBRA
      COMMON/TRA/DELTA(500,3),ENDEC(500),ITMA(50,200),ENZ(200)
      COMMON/PRT/IPRM(20)
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/LEV/TAU(75),KSEQ(500,4)
      IF(NBRA.EQ.0)RETURN
      IF(IPRM(3).EQ.-1)WRITE(22,11)
      NWYR=NWYR+NBRA
      MUL2=MULTI(1)+MULTI(2)
      DO 1 K=1,NBRA
      CH1=0.
      CH2=0.
      IFLG=1
      ITT=1
      IOUT=0
      N1=IBRC(1,K)
      N2=IBRC(2,K)
      I1=KSEQ(N1,1)
      I2=KSEQ(N2,1)
      ENG1=EN(KSEQ(N1,3))-EN(KSEQ(N1,4))
      ENG2=EN(KSEQ(N2,3))-EN(KSEQ(N2,4))
      IF(I1.EQ.0)GO TO 717
      IF(I1.LE.MULTI(1))LAB1=1
      IF(I1.GT.MULTI(1).AND.I1.LE.MUL2)LAB1=2
      IF(I1.GT.MUL2)LAB1=3
  717 CONTINUE
      IF(I2.EQ.0)GO TO 718
      IF(I2.LE.MULTI(1))LAB2=1
      IF(I2.GT.MULTI(1).AND.I2.LE.MUL2)LAB2=2
      IF(I2.GT.MUL2)LAB2=3
  718 CONTINUE
      IF(I1.EQ.0)GO TO 712
      CH1=ELM(I1)*ELM(I1)*DELTA(N1,1)/(1.+CONV(ENG1,LAB1))
  712 IF(I2.EQ.0)GO TO 713
      CH2=ELM(I2)*ELM(I2)*DELTA(N2,1)/(1.+CONV(ENG2,LAB2))
  713 J1=KSEQ(N1,2)
      IF(J1.EQ.0)GO TO 2
      IFLG=IFLG+1
      LAB1=LAB1+2
      CH1=CH1+ELM(J1)*ELM(J1)*DELTA(N1,2)/(1.+CONV(ENG1,LAB1))
 2    J2=KSEQ(N2,2)
      IF(J2.EQ.0)GO TO 4
      IFLG=IFLG+1
      LAB2=LAB2+2
      CH2=CH2+ELM(J2)*ELM(J2)*DELTA(N2,2)/(1.+CONV(ENG2,LAB2))
 4    U=(CH1/CH2-BRAT(K,1))/BRAT(K,2)
      CHISQ=CHISQ+U*U
      CHILO=CHILO+(BRAT(K,1)*ALOG(CH1/CH2/BRAT(K,1))
     */BRAT(K,2))**2
      IF(IPRM(3).EQ.-1)WRITE(22,10)KSEQ(N1,3),KSEQ(N1,4),
     *KSEQ(N2,3),KSEQ(N2,4),BRAT(K,1),BRAT(K,2),CH1/CH2
     *,-U
 1    CONTINUE
      IF(IPRM(3).EQ.-1)IPRM(3)=0
      RETURN
 11   FORMAT(1X,///10X,36HEXP. AND CALCULATED BRANCHING RATIOS
     *,//5X,3HNS1,5X,3HNF1,5X,3HNS2,5X,3HNF2,5X,10HRATIO(1:2),
     *9X,5HERROR,7X,10HCALC.RATIO,5X,15H(EXP-CAL)/ERROR,//)
 10   FORMAT(5X,3(1I2,6X),1I2,5X,3(1F10.5,5X),5X,1F4.1)
      END
      SUBROUTINE LIMITS
      COMMON/CEXC/MAGEXC,MEMAX,LMAXE,MEMX6,IVAR(500)
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      DO 1 J=1,MEMAX
      IF(IVAR(J).EQ.0)GO TO 1
      IF(ELM(J).LE.ELMU(J).AND.ELM(J).GE.ELML(J))GO TO 1
      IF(ELM(J).GT.ELMU(J))GO TO 2
      ELM(J)=ELML(J)
      WRITE(22,10)J,ELM(J)
      GO TO 1
 2    ELM(J)=ELMU(J)
      WRITE(22,10)J,ELM(J)
 1    CONTINUE
 10   FORMAT(2X,'Warning - matrix element ',1I3,' reset to ',1F10.6)
      RETURN
      END
      SUBROUTINE SZEREG(LST,LS,L)
      COMMON/YEXPT/YEXP(32,1500),IY(1500,32),CORF(1500,32),DYEX(32,1500)
     *,NYLDE(50,32),UPL(32,50),YNRM(32,50),IDRN,ILE(32)
      IF(LST.EQ.LS)RETURN
      LST1=LST
      LSP=LS-1
 100  IA=IY(LST1,L)
      IF(IA.GT.1000)IA=IA/1000
      INX=LST1
      DO 1 K=LST1,LSP
      IB=IY(K+1,L)
      IF(IB.GT.1000)IB=IB/1000
      IA=MIN0(IA,IB)
      IF(IA.EQ.IB)INX=K+1
 1    CONTINUE
      IF(INX.EQ.LST1)GO TO 200
      IH=IY(LST1,L)
      IY(LST1,L)=IY(INX,L)
      IY(INX,L)=IH
      YH=YEXP(L,LST1)
      DYH=DYEX(L,LST1)
      YEXP(L,LST1)=YEXP(L,INX)
      DYEX(L,LST1)=DYEX(L,INX)
      YEXP(L,INX)=YH
      DYEX(L,INX)=DYH
 200  LST1=LST1+1
      IF(LST1.GT.LSP)RETURN
      GO TO 100
      END
      SUBROUTINE SIXEL(RIK,RV,EM,JK,KK,INDX,LU)
      COMPLEX ARM
      COMMON/AZ/ARM(600,7)
      COMMON/ODCH/DEV(500)
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      COMMON/TRB/ITS
      COMMON/SEL/KVAR(500)
      KK6=KK+5
      RN=DEV(LU)
      AL=(RV-RN)*20./RIK
      IF(ITS.EQ.1.AND.KVAR(INDX).NE.0)WRITE(18,*)LU,INDX,IEXP,AL/EM
      AL1=ABS(AL)
      IF(ITS.EQ.2)WRITE(18,*)LU,INDX,IEXP,AL1
      IF(AL1.LE.ABS(AIMAG(ARM(KK6,JK))))RETURN
      DO 1 J=KK,KK6
      A1=ABS(AIMAG(ARM(J,JK)))
      IF(AL1.LE.A1)GO TO 1
      J1=J+1
      DO 2 L=J1,KK6
      L1=KK6+J1-L
      C1=REAL(ARM(L1-1,JK))
      C2=AIMAG(ARM(L1-1,JK))
 2    ARM(L1,JK)=CMPLX(C1,C2)
      RX=FLOAT(INDX)
      ARM(J,JK)=CMPLX(RX,AL)
      GO TO 11
 1    CONTINUE
 11   RETURN
      END
      SUBROUTINE PRELM(IOP)
      character*3 wrn
      COMMON/HHH/HLM(500)
	common/switch/jzb,ibps
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/CEXC/MAGEXC,MEMAX,LMAXE,MEMX6,IVAR(500)
      COMMON/COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      COMMON/CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON/COEX2/NMAX,NDIM,NMAX1
	common/resc/elm25(500),elm26(500)
      INX=0
      WRITE(22,100)
      DO 1 J=1,8
      M=MULTI(J)
      IF(M.EQ.0)GO TO 1
      WRITE(22,2)J
      IF(IOP.EQ.1)WRITE(22,101)
      IF(IOP.EQ.2.or.iop.eq.4)WRITE(22,102)
      IF(IOP.EQ.3)WRITE(22,103)
      DO 3 K=1,NMAX
      L=LDNUM(J,K)
      IF(L.EQ.0)GO TO 3
      DO 4 KK=1,L
      INX=INX+1
      GO TO (5,6,7,77)IOP
 5    WRITE(22,10)INX,LEAD(1,INX),LEAD(2,INX),ELM(INX)
      GO TO 4
 6    CONTINUE
 77   continue
      IF(IVAR(INX).EQ.0)GO TO 20
      IF(IVAR(INX).GT.1000)GO TO 21
      if(iop.eq.2)WRITE(22,11)INX,LEAD(1,INX),LEAD(2,INX)
     *,ELM(INX),ELML(INX)
     *,ELMU(INX)
      if(iop.eq.4.and.jzb.eq.25)
     *WRITE(22,11)INX,LEAD(1,INX),LEAD(2,INX)
     *,ELM25(INX),ELML(INX)
     *,ELMU(INX)
       if(iop.eq.4.and.jzb.eq.26)
     * WRITE(22,11)INX,LEAD(1,INX),LEAD(2,INX)
     *,ELM26(INX),ELML(INX)
     *,ELMU(INX)
      GO TO 4
 21   WRITE(22,12)INX,LEAD(1,INX),LEAD(2,INX),ELM(INX),(IVAR(INX)-1000)
      GO TO 4
 20   WRITE(22,13)INX,LEAD(1,INX),LEAD(2,INX),ELM(INX)
      GO TO 4
 7    ISP=LEAD(2,INX)
       PV=(ELMU(INX)-ELML(INX))/100.
       WRN='   '
       IF((ELM(INX)-ELML(INX)).LT.PV)WRN= '*?*'
       IF((ELMU(INX)-ELM(INX)).LT.PV)WRN= '*?*'
      if(jzb.eq.25)STE=elm25(INX)
	if(jzb.eq.26)ste=elm26(inx)
      B=ELM(INX)*ELM(INX)/(2.*SPIN(ISP)+1.)
      IF(LEAD(1,INX).EQ.LEAD(2,INX))B=9999999.
      WRITE(22,11)INX,LEAD(1,INX),LEAD(2,INX),ELM(INX),
     *100.*(ELM(INX)-STE)/STE,B,WRN
 4    CONTINUE
 3    CONTINUE
 1    CONTINUE
 100  FORMAT(2X/40X,15HMATRIX ELEMENTS,//)
 2    FORMAT(5X,14HMULTIPOLARITY=,1I1)
 10   FORMAT(5X,1I3,5X,1I2,5X,1I2,5X,1F10.5)
 11   FORMAT(5X,1I3,5X,1I2,5X,1I2,3(5X,1F10.5),1A3)
 12   FORMAT(5X,1I3,5X,1I2,5X,1I2,5X,1F10.5,5X,
     *10HCOUPLED TO,1X,1I3)
 13   FORMAT(5X,1I3,5X,1I2,5X,1I2,5X,1F10.5,5X,5HFIXED)
 101  FORMAT(4X,5HINDEX,3X,2HNF,5X,2HNS,10X,2HME)
 102  FORMAT(4X,5HINDEX,3X,2HNF,5X,2HNS,10X,2HME,15X,6HLIMITS)
 103  FORMAT(4X,5HINDEX,3X,2HNF,5X,2HNS,10X,2HME,10X,
     *9HPC CHANGE,5X,17HRED. TRANS. PROB.)
      RETURN
      END
        SUBROUTINE RECOIL(ALAB,ATTL,BETA,THETA)
        DIMENSION ALAB(9,9),ATTL(9,9),ATEMP(16)
        HOLD=ALAB(1,1)
      IF(abs(HOLD).lt.1.e-9)RETURN
        CALL ROTATE(ALAB,ATTL,-THETA,7,2)
        ATTL(2,1)=(2./SQRT(15.))*(SQRT(5.)*ATTL(1,1)
     *    -ATTL(3,1))
        ATTL(2,2)=-ATTL(3,2)/SQRT(5.)
        ATTL(4,1)=(4./SQRT(35.))*(3.*ATTL(3,1)
     *    -SQRT(5.)*ATTL(5,1))
        ATTL(4,2)=(8.*SQRT(2.)*ATTL(3,2)
     *    -5.*SQRT(3.)*ATTL(5,2))/SQRT(35.)
        ATTL(4,3)=(2./SQRT(7.))*(2.*ATTL(3,3)
     *    -SQRT(3.)*ATTL(5,3))
        ATTL(4,4)=-ATTL(5,4)
        ATTL(6,1)=(10./SQRT(11.))*(ATTL(5,1)-(3./SQRT(13.))*ATTL(7,1))
        ATTL(6,2)=(1./SQRT(11.))*(4.*SQRT(6.)*ATTL(5,2)-5.*
     *  SQRT(35./13.)*ATTL(7,2))
        ATTL(6,3)=SQRT(4./11.)*(SQRT(21.)*ATTL(5,3)-10.*SQRT(2./13.)*
     *  ATTL(7,3))
        ATTL(6,4)=SQRT(1./11.)*(8.*ATTL(5,4)-15.*SQRT(3./13.)*
     *  ATTL(7,4))
        ATTL(6,5)=SQRT(4./11.)*(3.*ATTL(5,5)-5.*SQRT(5./13.)*
     *  ATTL(7,5))
        ATTL(6,6)=-ATTL(7,6)*SQRT(25./13.)
        ATTL(8,1)=(56./SQRT(195.))*ATTL(7,1)
        ATTL(8,2)=(32./SQRT(65.))*ATTL(7,2)
        ATTL(8,3)=(8.*SQRT(3./13.))*ATTL(7,3)
        ATTL(8,4)=(16.*SQRT(2./39.))*ATTL(7,4)
        ATTL(8,5)=(8.*SQRT(11./65.))*ATTL(7,5)
        ATTL(8,6)=(16.*SQRT(2./65.))*ATTL(7,6)
        ATTL(8,7)=(8./SQRT(15.))*ATTL(7,7)
        DO 150  L=2,8,2
        DO 149  M=1,L
        ATTL(L,M)=BETA * ATTL(L,M)
  149   CONTINUE
  150   CONTINUE
        BETASQ=BETA*BETA
        IF (BETASQ .LT. 1.0E-10)  GO TO 199
        I1=0
        DO 400 I=1,7,2
        DO 400 J=1,I
        I1=I1+1
        ATEMP(I1)=ATTL(I,J)
 400    CONTINUE
        DUM=(2./5.)*SQRT(5.)*ATEMP(1)-(10./7.)*ATEMP(2)+
     *  (12./35.)*SQRT(5.)*ATEMP(5)
        ATTL(3,1)=ATEMP(2)+BETASQ*DUM
        DUM=-(17./14.)*ATEMP(3)+(2./7.)*SQRT(6.)*ATEMP(6)
        ATTL(3,2)=ATEMP(3)+BETASQ*DUM
        DUM=-(4./7.)*ATEMP(4)+(2./7.)*SQRT(3.)*ATEMP(7)
        ATTL(3,3)=ATEMP(4)+BETASQ*DUM
        DUM=(8./7.)*SQRT(5.)*ATEMP(2)-(380./77.)*ATEMP(5)
     *  +(100./11.)*SQRT(1./13.)*ATEMP(10)
        ATTL(5,1)=ATEMP(5)+BETASQ*DUM
        DUM=(20./21.)*SQRT(6.)*ATEMP(3)-(723./154.)*ATEMP(6)+
     *  (20./11.)*SQRT(70./39.)*ATEMP(11)
        ATTL(5,2)=ATEMP(6)+BETASQ*DUM
        DUM=(20./21.)*SQRT(3.)*ATEMP(4)-(306./77.)*ATEMP(7)+
     *  (40./11.)*SQRT(14./39.)*ATEMP(12)
        ATTL(5,3)=ATEMP(7)+BETASQ*DUM
        DUM=-(61./22.)*ATEMP(8)+(40./11.)*SQRT(3./13.)*ATEMP(13)
        ATTL(5,4)=ATEMP(8)+BETASQ*DUM
        DUM=-(12./11.)*ATEMP(9)+(20./11.)*SQRT(5./13.)*ATEMP(14)
        ATTL(5,5)=ATEMP(9)+BETASQ*DUM
        DUM=(210./11.)*SQRT(1./13.)*ATEMP(5)-(574./55.)*ATEMP(10)
        ATTL(7,1)=ATEMP(10)+BETASQ*DUM
        DUM=(14./11.)*SQRT(210./13.)*ATEMP(6)-(1121./110.)*ATEMP(11)
        ATTL(7,2)=ATEMP(11)+BETASQ*DUM
        DUM=(28./11.)*SQRT(42./13.)*ATEMP(7)-(104./11.)*ATEMP(12)
        ATTL(7,3)=ATEMP(12)+BETASQ*DUM
        DUM=(84./11.)*SQRT(3./13.)*ATEMP(8)-(181./22.)*ATEMP(13)
        ATTL(7,4)=ATEMP(13)+BETASQ*DUM
        DUM=(42./11.)*SQRT(5./13.)*ATEMP(9)-(358./55.)*ATEMP(14)
        ATTL(7,5)=ATEMP(14)+BETASQ*DUM
        ATTL(7,6)=ATEMP(15)*(1.-(43./10.)*BETASQ)
        ATTL(7,7)=ATEMP(16)*(1.-(8./5.)*BETASQ)
        ATTL(9,1)=(672./5.)*SQRT(1./221.)*ATEMP(10)*BETASQ
        ATTL(9,2)=(144./5.)*SQRT(21./221.)*ATEMP(11)*BETASQ
        ATTL(9,3)=36.*SQRT(12./221.)*ATEMP(12)*BETASQ
        ATTL(9,4)=24.*SQRT(22./221.)*ATEMP(13)*BETASQ
        ATTL(9,5)=(144./5.)*SQRT(11./221.)*ATEMP(14)*BETASQ
        ATTL(9,6)=(72./5.)*SQRT(2./17.)*ATEMP(15)*BETASQ
        ATTL(9,7)=(24./5.)*SQRT(7./17.)*ATEMP(16)*BETASQ
  199   CALL ROTATE(ATTL,ALAB,THETA,9,1)
        TEST=ABS(1.0-ALAB(1,1)/HOLD)
        IF(TEST.GT.1.0E-07)GO TO 333
        GOTO 51
  333   WRITE(22,335)TEST
  51    CONTINUE
        RETURN
  335   FORMAT(18H ERROR IN ROTATION,1X,1E10.3/)
        END
        SUBROUTINE ROTATE(ALAB,ATTL,THETA,K2,KD)
        DIMENSION ALAB(9,9),ATTL(9,9)
        IF(ABS(THETA).GT..01)GO TO 1
        DO 2 J=1,9
        DO 2 K=1,9
  2     ATTL(J,K)=ALAB(J,K)
        RETURN
   1    CONTINUE
        DJARG=THETA
        DO 111 KA=1,K2,KD
        IDJ=KA-1
        DO 110 KAPPA=1,KA
        IDMP=KAPPA-1
        SUM=0.0
        DO 105  KAPRI=1,KA
        IDM=KAPRI-1
        DKKK=DJMM(DJARG,IDJ,IDM,IDMP)
        SUM=SUM+DKKK*ALAB(KA,KAPRI)
  105   CONTINUE
        IF (KA .EQ. 1)  GO TO 100
        DO 106  KAPRI=2,KA
        IDM=-KAPRI+1
        DKKK=DJMM(DJARG,IDJ,IDM,IDMP)
        SUM=SUM+DKKK*ALAB(KA,KAPRI)*(-1.0)**(KAPRI-1)
  106   CONTINUE
  100   ATTL(KA,KAPPA)=SUM
  110   CONTINUE
  111   CONTINUE
        RETURN
        END
        SUBROUTINE YLM1(THETA,YLMR)
        DIMENSION YLMR(9,9),ST(9)
        CT=COS(THETA)
        CTSQ=CT*CT
        ST(1)=SIN(THETA)
        DO 10  I=2,9
        J=I-1
        ST(I)=ST(J)*ST(1)
  10    CONTINUE
        DO 30 L=2,9
        DO 29 M=1,9
        YLMR(L,M)=0.0
  29    CONTINUE
  30    CONTINUE
        YLMR(2,2)=-SQRT(6.)/2.
        YLMR(2,1)=SQRT(3.)*CT
        YLMR(3,3)=SQRT(30.)/4.
        YLMR(3,2)=-(SQRT(30.)/2.)*CT
        YLMR(3,1)=(SQRT(5.)/2.)*(3.*CTSQ-1.)
        YLMR(4,4)=-SQRT(35.)/4.
        YLMR(4,3)=(SQRT(210.)/4.)*CT
        YLMR(4,2)=-(SQRT(21.)/4.)*(5.*CTSQ-1.)
        YLMR(4,1)=(SQRT(7.)/2.)*CT*(5.*CTSQ-3.)
        YLMR(5,5)=3.*SQRT(70.)/16.
        YLMR(5,4)=-(3.*SQRT(35.)/4.)*CT
        YLMR(5,3)=(3.*SQRT(10.)/8.)*(7.*CTSQ-1.)
        YLMR(5,2)=-(3.*SQRT(5.)/4.)*CT*(7.*CTSQ-3.)
        YLMR(5,1)=(3./8.)*((35.*CTSQ-30.)*CTSQ+3.)
        YLMR(6,6)=-3.*SQRT(77.)/16.
        YLMR(6,5)=(3.*SQRT(770.)/16.)*CT
        YLMR(6,4)=-(SQRT(385.)/16.)*(9.*CTSQ-1.)
        YLMR(6,3)=(SQRT(2310.)/8.)*CT*(3.*CTSQ-1.)
        YLMR(6,2)=-(SQRT(330.)/16.)*((21.*CTSQ-14.)*CTSQ+1.)
        YLMR(6,1)=(SQRT(11.)/8.)*CT*((63.*CTSQ-70.)*CTSQ+15.)
        YLMR(7,7)=SQRT(3003.)/32.
        YLMR(7,6)=-(3.*SQRT(1001.)/16.)*CT
        YLMR(7,5)=(3.*SQRT(182.)/32.)*(11.*CTSQ-1.)
        YLMR(7,4)=-(SQRT(1365.)/16.)*CT*(11.*CTSQ-3.)
        YLMR(7,3)=(SQRT(1365.)/32.)*((33.*CTSQ-18.)*CTSQ+1.)
        YLMR(7,2)=-(SQRT(546.)/16.)*CT*((33.*CTSQ-30.)*CTSQ+5.)
        YLMR(7,1)=(SQRT(13.)/16.)*(((231.*CTSQ-315.)*CTSQ
     1  +105.)*CTSQ-5.)
        YLMR(8,8)=-3.*SQRT(1430.)/64.
        YLMR(8,7)=(3.*SQRT(5005.)/32.)*CT
        YLMR(8,6)=-(3.*SQRT(770.)/64.)*(13.*CTSQ-1.)
        YLMR(8,5)=(3.*SQRT(770.)/32.)*(13.*CTSQ-3.)*CT
        YLMR(8,4)=-(3.*SQRT(70.)/64.)*((143.*CTSQ-66.)*CTSQ+3.)
        YLMR(8,3)=(3.*SQRT(35.)/32.)*((143.*CTSQ-110.)*CTSQ+15.)*CT
        YLMR(8,2)=-(SQRT(210.)/64.)*(((429.*CTSQ-495.)*CTSQ+135.)*
     1  CTSQ-5.)
        YLMR(8,1)=(SQRT(15.)/16.)*(((429.*CTSQ-693.)*CTSQ+315.)*
     1  CTSQ-35.)*CT
        YLMR(9,9)=3.*SQRT(24310.)/256.
        YLMR(9,8)=-(3.*SQRT(24310.)/64.)*CT
        YLMR(9,7)=(SQRT(7293.)/64.)*(15.*CTSQ-1.)
        YLMR(9,6)=-(3.*SQRT(34034.)/64.)*(5.*CTSQ-1.)*CT
        YLMR(9,5)=(3.*SQRT(2618.)/128.)*((65.*CTSQ-26.)*CTSQ+1.)
        YLMR(9,4)=-(SQRT(39270.)/64.)*((39.*CTSQ-26.)*CTSQ+3.)*CT
        YLMR(9,3)=(3.*SQRT(595.)/64.)*(((143.*CTSQ-143.)*CTSQ+33.)*
     1  CTSQ-1.)
        YLMR(9,2)=-(3.*SQRT(34.)/64.)*(((715.*CTSQ-1001.)*CTSQ+385.)
     1  *CTSQ-35.)*CT
        YLMR(9,1)=(SQRT(17.)/128.)*((((6435.*CTSQ-12012.)*CTSQ+6930.)
     1  *CTSQ-1260.)*CTSQ+35.)
        DO 100 L=2,9
        YLMR(L,1)=YLMR(L,1)*.0795774715
        DO 99 M=2,L
        YLMR(L,M)=YLMR(L,M)*ST(M-1)*.0795774715
99      CONTINUE
100     CONTINUE
        RETURN
        END
      SUBROUTINE FIINT(FI0,FI1,AT,IXS)
      DIMENSION AT(28)
      IF(IXS.EQ.0)GO TO 1
      DO 2 M=2,7
      JS=M/2
      MM=M-1
      WSP=(SIN(MM*FI1)-SIN(MM*FI0))/MM
      JS=JS*7+M
      JF=M+21
      DO 3 J=JS,JF,7
 3    AT(J)=AT(J)*WSP
 2    CONTINUE
      WSP=FI1-FI0
 1    IF(IXS.EQ.0)WSP=6.283185308
      DO 4 J=1,4
      JS=(J-1)*7+1
 4    AT(JS)=AT(JS)*WSP
      RETURN
      END
      SUBROUTINE FIINT1(FI0,FI1,ALAB,IXS)
      DIMENSION ALAB(9,9)
      IF(IXS.EQ.0)GO TO 1
      DO 2 M=2,9
      MM=M-1
      WSP=(SIN(MM*FI1)-SIN(MM*FI0))/MM
      DO 3 J=1,9
  3   ALAB(J,M)=ALAB(J,M)*WSP
 2    CONTINUE
      WSP=FI1-FI0
 1    IF(IXS.EQ.0)WSP=6.283185308
      DO 4 J=1,9
 4    ALAB(J,1)=ALAB(J,1)*WSP
      RETURN
      END
      SUBROUTINE TAPMA(LX,ISKE,ISKO,ISKF,NFLR,IDR,NCO,NFT,ENB)
      COMMON/VLIN/XV(51),YV(51),ZV(20),DSG(20),DSE(20),DS
      COMMON/CCOUP/ZETA(50000),LZETA(8)
      COMMON/YTEOR/YGN(500),YGP(500),IFMO
      NFT=0
      NFILT=0
      REWIND 14
      IF(ISKE.EQ.0)GO TO 2
 1    READ(14,*)NE,NTT,EMN,EMX,TMN,TMX,NA,TMX,TMX,TMX
      NFIL=NE*NTT*NA
      NFILT=NFILT+NFIL
      DO 3 J=1,NFIL
 3    READ(14,*)LX1,ENB,TTA,NG,DS,(YGN(K),K=1,IDR)
      IF(NFILT.EQ.ISKE)GO TO 2
      GO TO 1
 2    IF(NCO.EQ.0)RETURN
      READ(14,*)NE,NTT,EMN,EMX,TMN,TMX,NA,TMX,TMX,TMX
      IF(ISKO.EQ.0)GO TO 5
      DO 4 J=1,ISKO
 4    READ(14,*)LX1,ENB,TTA,NG,DS,(YGN(K),K=1,IDR)
 5    CONTINUE
      DO 6 J=1,NFLR
      JS=(J-1)*IDR+1
      JF=JS+IDR-1
      READ(14,*)LX1,ENB,TTA,NG1,DS,(ZETA(K),K=JS,JF)
      IF(LX1.NE.LX)NFT=1
      IF(NFT.EQ.1)GO TO 99
      XV(J)=TTA/57.2957795
      IF(ISKF.EQ.0.OR.J.EQ.NFLR)GO TO 6
      DO 7 JJ=1,ISKF
 7    READ(14,*)LX1,EN0,TTA,NG,DS,(YGN(K),K=1,IDR)
 6    CONTINUE
      RETURN
 99   WRITE(22,98)
 98   FORMAT(10X///10X,15HTAPE READ ERROR/
     *10X,11HJOB ABORTED)
      RETURN
      END
      FUNCTION SIMIN(NP,H,Y)
      DIMENSION Y(101)
      IF(NP.LT.3)GO TO 2
      IK=NP-2
      SM=Y(1)+Y(NP)
      DO 1 IN=1,IK
      EE=IN/2.
 1    SM=SM+2.*Y(IN+1)/(1.+INT(EE)-EE)
      SIMIN=SM*H/3.
      RETURN
 2    IF(NP.EQ.1)GO TO 3
      SIMIN=(Y(1)+Y(2))*H/2.
      RETURN
 3    SIMIN=Y(1)
      RETURN
      END
      SUBROUTINE MIXUP
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/CEXC/MAGEXC,MEMAX,LMAXE,MEMX6,IVAR(500)
      COMMON/XRA/SE
      DO 2 K=1,MEMAX
      IF(IVAR(K).EQ.0.OR.IVAR(K).GT.999)GO TO 2
      ELM(K)=ELML(K)+RNDM(SE)*(ELMU(K)-ELML(K))
 2    CONTINUE
      DO 3 K=1,MEMAX
      IF(IVAR(K).LT.999)GO TO 3
      K1=IVAR(K)-1000
      IF(abs(ELMU(K1)).lt.1.e-9)GO TO 4
      ELM(K)=ELM(K1)*SA(K)
      GO TO 3
 4    ELM(K)=0.
 3    CONTINUE
      RETURN
      END
      FUNCTION FXIS1(I,N)
      COMMON/CXI/XI(500)
      GO TO (1,2,2,1,2,2,1)N
 1    FXIS1=-SIGN(1.,XI(I))
      RETURN
 2    FXIS1=1.
      RETURN
      END
      FUNCTION FXIS2(I,N)
      COMMON/CXI/XI(500)
      GO TO(1,2,2,1,2,2,1)N
 1    FXIS2=1.
      RETURN
 2    FXIS2=-SIGN(1.,XI(I))
      RETURN
      END
      SUBROUTINE PODZIEL(I,J)
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/APRCAT/QAPR(500,2,7),IAPR(500,2),ISEX(75)
      COMMON/APRX/LERF,IDIVE(50,2)
      IF(I.EQ.3)GO TO 7
      IF(I.EQ.1)GO TO 2
      L1=IDIVE(J,2)
      IDIVE(J,2)=L1+1
 7    L2=IDIVE(J,2)
      IF(I.EQ.3)L1=1
      DO 5 K=1,LP2
      DO 5 L=1,7
 5    QAPR(K,2,L)=QAPR(K,2,L)*L1/L2
      IF(I.EQ.2)WRITE(22,11)J,IDIVE(J,1),L2
      IF(I.EQ.3)GO TO 8
      RETURN
 2    L1=IDIVE(J,1)
      IDIVE(J,1)=L1+1
 8    L2=IDIVE(J,1)
      IF(I.EQ.3)L1=1
      DO 6 K=1,LP2
      DO 6 L=1,7
 6    QAPR(K,1,L)=QAPR(K,1,L)*L1/L2
      IF(I.EQ.1)WRITE(22,11)J,L2,IDIVE(J,2)
      RETURN
 11   FORMAT(5X,5H*****,1X,25HEXP(A) EXPANSION FAILURE!,1X,5H*****
     */5X,10HEXPERIMENT,1X,1I2,3X,15HNEW SUBDIVISION,1X,
     *1H(,1I1,1H,,1I1,1H))
      END
      SUBROUTINE KLOPOT(K,RLR)
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/YEXPT/YEXP(32,1500),IY(1500,32),CORF(1500,32),DYEX(32,1500)
     *,NYLDE(50,32),UPL(32,50),YNRM(32,50),IDRN,ILE(32)
      COMMON/CEXC/MAGEXC,MEMAX,LMAXE,MEMX6,IVAR(500)
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,LP8,
     *LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/CCOUP/ZETA(50000),LZETA(8)
      COMMON/CX/NEXPT,IZ,XA,IZ1(50),XA1(50),EP(50),TLBDG(50),VINF(50)
      COMMON/SEL/KVAR(500)
      REWIND 14
      REWIND 18
      IPF=1
      LNGT=0
      INDX=1
      REWIND 15
      REWIND 17
      DO 1 I=1,MEMAX
      ELM(I)=0.
      ELMU(I)=0.
  1   ELML(I)=0.
      IEXH=1
 700  G=0.
      D=0.
 200  READ(15,*)IEX,A,B,C,E
      IF(IEX.NE.IEXH)GO TO 400
      G=G+E*A/C/C
      D=D+A*A/C/C
      LNGT=LNGT+1
      GO TO 200
 400  EP(IEXH)=G/D
      TLBDG(IEXH)=G
      VINF(IEXH)=D
      IEXH=IEX
      BACKSPACE 15
      IF(IEX.NE.0)GO TO 700
      REWIND 15
      IEXP=1
 3    G1=0.
      G2=0.
      INH=INDX
      IEXH=IEXP
 5    READ(18,*)LU,INDX,IEXP,AL
      IF(INDX.EQ.0)GO TO 601
      READ(17,*)NI,NF,SGM,AL1
      READ(15,*)IEX,A,B,C,E
      IF(IEXP.EQ.1.OR.IPF.EQ.1)GO TO 800
 801  READ(15,*)IEX,A,B,C,E
      IF(IEXP.NE.IEX)GO TO 801
      IPF=1
 800  CONTINUE
      IF(INDX.NE.INH)GO TO 601
      DY=AL*AL1/B/C
      G1=E*DY+G1
      G2=-2.*DY*A+G2
      WRITE(14,*)INDX,IEXP,NI,NF,DY,A,E,C
      GO TO 5
 601  LOC=(IEXH-1)*LP2+INH
      IPF=0
      ZETA(LOC)=(VINF(IEXH)*G1+TLBDG(IEXH)*G2)/VINF(IEXH)/VINF(IEXH)
      INH=INDX
      REWIND 15
      BACKSPACE 17
      BACKSPACE 18
      IF(INDX.NE.0)GO TO 3
      WRITE(14,*)INDX,IEXP,NI,NF,DY,A,E,B
      REWIND 14
      REWIND 17
 606  READ(14,*)INDX,IEXP,NI,NF,DY,A,E,B
      IF(INDX.EQ.0)GO TO 603
      LOC=(IEXP-1)*LP2+INDX
      SGM=(E-A*EP(IEXP))/B
      U=DY*EP(IEXP)*B+A*ZETA(LOC)/B
      WRITE(17,*)INDX,IEXP,SGM,NI,NF,U
      GO TO 606
 603  WRITE(17,*)INDX,IEXP,SGM,NI,NF,U
      REWIND 17
      LL=0
      CH=0.
  607 READ(17,*)INDX,IEXP,SGM,NI,NF,U
      IF(INDX.EQ.0)GO TO 608
      LL=LL+1
      CH=CH+SGM*SGM
      UX=2.*SGM*U
      ELM(INDX)=ELM(INDX)+UX
      ELMU(INDX)=ELMU(INDX)+ABS(UX)
      GO TO 607
 608  CONTINUE
      WRITE(22,111)
      WRITE(22,211)CH/LL
      DO 212 I=1,NEXPT
 212  WRITE(22,213)I,EP(I)
      WRITE(22,217)
      DO 11 I=1,MEMAX
      IF(KVAR(I).EQ.0)GO TO 11
      RL=ALOG10(ELMU(I)/ABS(ELM(I)))
      IF(RL.GE.RLR)ELML(I)=1.
      WRITE(22,112)I,RL,ELMU(I)/LNGT
 11   CONTINUE
      WRITE(22,115)
      DO 12 I=1,MEMAX
      IF(KVAR(I).EQ.0)GO TO 12
      LC=0
      IF(ELML(I).LT..5)GO TO 12
      REWIND 17
 13   READ(17,*)INDX,IEXP,SGM,NI,NF,AL
      IF(INDX.EQ.0)GO TO 14
      IF(INDX.NE.I)GO TO 13
      LC=LC+1
      IY(LC,1)=IEXP
      IY(LC,2)=NI
      IY(LC,3)=NF
      CORF(LC,1)=SGM
      CORF(LC,2)=AL
      GO TO 13
 14   CONTINUE
      NP=0
      NM=0
      DO 15 J=1,LC
      U=CORF(J,1)*CORF(J,2)*2.
      IF(ABS(U)/ELMU(I).LT..05)GO TO 15
      IF(U.LT.0.)NM=NM+1
      IF(U.GT.0.)NP=NP+1
 15   CONTINUE
      WRITE(22,113)I,NP,NM
      DO 16 L=1,K
      UMP=0.
      UMM=0.
      DO 17 J=1,LC
      U=2.*CORF(J,1)*CORF(J,2)
      IF(U.LT.0.)GO TO 18
      IF(U.LT.UMP)GO TO 19
      UMP=U
      JP=J
 19   GO TO 17
 18   IF(U.GT.UMM)GO TO 17
      UMM=U
      JM=J
 17   CONTINUE
      WRITE(22,114)IY(JP,1),IY(JP,2),IY(JP,3),CORF(JP,1),
     *CORF(JP,2),UMP,IY(JM,1),IY(JM,2),IY(JM,3),
     *CORF(JM,1),CORF(JM,2),UMM
      CORF(JP,1)=0.
      CORF(JM,1)=0.
 16   CONTINUE
 12   CONTINUE
      RETURN
 111  FORMAT(2X////40X,20HTROUBLESHOOTING ROUT,
     *25HINE HAS BEEN ACTIVATED...//5X,
     *31HLOCAL MINIMUM ANALYSIS FOLLOWS://)
 112   FORMAT(6X,1I3,18X,1F4.1,20X,1E7.2)
 115   FORMAT(2X////40X,35HANALYSIS OF SIGNIFICANT DEPENDENCES
     *//)
 113  FORMAT(1X/5X,10(1H*),5X,4HM.E.,1X,1I3,5X,1I3,1X,
     *19HPOSITIVE COMPONENTS,20X,1I3,1X,
     *19HNEGATIVE COMPONENTS///
     *30X,8HPOSITIVE,52X,8HNEGATIVE//5X,3HEXP,2X,
     *10HTRANSITION,2X,5HSIGMA,3X,10HDERIVATIVE,3X,
     *17HD(SIGMA**2)/D(ME),4X,1HI,1X,3HEXP,2X,
     *10HTRANSITION,2X,5HSIGMA,3X,10HDERIVATIVE,
     *3X,17HD(SIGMA**2)/D(ME))
 114  FORMAT(6X,1I2,3X,1I2,2H--,1I2,5X,1F4.1,4X,
     *1E9.2,7X,1E9.2,9X,1HI,2X,1I2,3X,1I2,2H--,
     *1I2,5X,1F4.1,4X,1E9.2,7X,1E9.2)
 211  FORMAT(2X//5X,29HCHISQ FOR FIRST GE(LI)S ONLY ,
     *31HWITH INDEPENDENT NORMALIZATION=,1E12.4//
     *5X,15HNORM.CONSTANTS://)
 213  FORMAT(5X,4HEXP.,1X,1I2,5X,2HC=,1E14.6)
 217  FORMAT(1X//5X,4HM.E.,20X,2HRL,20X,8HSTRENGTH,//)
      END
      SUBROUTINE MIXR(NW,IPSW,CHI,CHILO)
      COMMON/LEV/TAU(75),KSEQ(500,4)
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/MIXD/DMIXE(20,2),DMIX(20),IMIX(20),NDL
      COMMON/LOGY/LNY,INTR,IPS1
      IF(NDL.EQ.0)RETURN
      NW=NW+NDL
      DO 1 I=1,NDL
      IT=IMIX(I)
      INX=KSEQ(IT,1)
      INX1=KSEQ(IT,2)
      IF(ABS(ELM(INX1)).LT.1.E-5)ELM(INX1)=1.E-5
      DL=DMIX(I)*ELM(INX)/ELM(INX1)
      IF(IPSW.EQ.1)DMIX(I)=DL
      CHI=CHI+(DL-DMIXE(I,1))**2/DMIXE(I,2)/DMIXE(I,2)
      IF(LNY.EQ.1)CHILO=CHILO+(DMIXE(I,1)*ALOG(
     *ABS(DL/DMIXE(I,1)))/DMIXE(I,2))**2
   1  CONTINUE
      IF(IPSW.EQ.0)RETURN
      WRITE(22,2)
 2    FORMAT(1X//10X,19HE2/M1 MIXING RATIOS/10X,
     *10HTRANSITION,10X,9HEXP.DELTA,10X,10HCALC.DELTA,10X,5HSIGMA/)
      DO 3 I=1,NDL
      DL=(DMIX(I)-DMIXE(I,1))/DMIXE(I,2)
      IT=IMIX(I)
 3    WRITE(22,4)KSEQ(IT,3),KSEQ(IT,4),DMIXE(I,1),DMIX(I),DL
      RETURN
 4    FORMAT(10X,1I2,3H---,1I2,14X,1F7.2,12X,1F7.2,13X,1F5.2)
      END
      SUBROUTINE COORD(WTH,WPH,WTHH,NAA,IFW,PFI,WPI,WTLB,LZ,TYY,TZZ)
      DIMENSION PFI(101),WPI(11,2)
      COMMON/VLIN/XV(51),YV(51),ZV(20),DSG(20),DSE(20),DS
      COMMON/KIN/EPS(50),EROOT(50),IEXP,IAXS(50),FIEX(50,2)
      COMMON/CX/NEXPT,IZ,XA,IZ1(50),XA1(50),EP(50),TLBDG(50),VINF(50)
       COMMON/SECK/ISKIN(50)
      DATA RADE/57.2957795/
      IF(IFW.NE.0) GO TO 6
      TYY=WTH-WTHH
      TZZ=WTH+WTHH
 6    XTH=WTH/RADE
      XPH=WPH/RADE
      XTHH=WTHH/RADE
      ZL=TAN(XTHH)
      ZA=COS(XTH)
      ZA1=SIN(XTH)
      ZB=COS(XTHH)
      RMASS=XA1(LZ)/XA
      IF(IZ1(LZ).LT.0) RMASS=1./RMASS
      IF(IFW.EQ.2) GO TO 7
      WS=(TZZ-TYY)/(NAA+1)
      IF(IFW.EQ.1) WS=(TZZ-TYY)/(NAA-1)
 7    DO 5 I=1,NAA
      IF(IFW.NE.2) GO TO 27
      XAA=ABS(WTLB)/RADE
      IF(WTLB.GT.0.) GO TO 20
      IF(IZ1(LZ).LT.0) GO TO 32
      IF(XA1(LZ).LE.XA) GO TO 26
      GO TO 34
 32   IF(XA.LE.XA1(LZ)) GO TO 26
 34   IF(ISKIN(LZ).EQ.0) GO TO 28
 26   TTCM=XAA+TASIN(RMASS*SIN(XAA))
      XAA=(3.14159265-TTCM)/2.
      GO TO 20
 28   continue
      TTCM=XAA-TASIN(RMASS*SIN(XAA))
      XAA=ABS(TTCM)/2.
      GO TO 20
 27   IF(IFW.EQ.0) YV(I)=TYY+I*WS
      XAA=(TYY+WS*(I-1))/RADE
      IF(IFW.EQ.1.AND.(I.EQ.1.OR.I.EQ.NAA)) GO TO 15
      IF(IFW.EQ.0) XAA=YV(I)/RADE
 20   continue
      GI=(ZA-COS(XAA)/ZB)/(ZL*ZA1)
      GA=TACOS(GI)
      WPA=ATAN(ZL*SIN(GA)/(ZA1+ZL*COS(GA)*ZA))
      WPA=ABS(WPA)
      IF(IFW.EQ.2) GO TO 25
      IF(IFW.EQ.1) GO TO 10
      WPI(I,1)=(XPH-WPA)*RADE
      WPI(I,2)=(XPH+WPA)*RADE
      GO TO 5
 10   PFI(I)=2.*WPA*RADE
      GO TO 5
 15   PFI(I)=0.
      GO TO 5
 25   FIEX(LZ,1)=(XPH-WPA)
      FIEX(LZ,2)=(XPH+WPA)
 5    CONTINUE
      IF(WTLB.GE.0..OR.IFW.NE.0) GO TO 30
      DO 50 I=1,NAA
      XAA=YV(I)/RADE
      THETB=ATAN(SIN(2.*XAA)/(RMASS-COS(2.*XAA)))*RADE
      IF(THETB.LT.0.) THETB=180.+THETB
      YV(I)=-1.*THETB
      WPI(I,1)=WPI(I,1)+180.
      WPI(I,2)=WPI(I,2)+180.
 50   CONTINUE
 30   CONTINUE
      RETURN
      END
      SUBROUTINE CHMEM(NW,CHI,CHILO)
      COMMON/ME2D/NAMX,IAMX(100),IAMY(100,2),EAMX(100,2)
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      IF(NAMX.EQ.0) RETURN
      NW=NW+NAMX
      DO 10 IA=1,NAMX
      IB=IAMX(IA)
      IF(IAMY(IA,1).NE.IAMY(IA,2)) GO TO 12
      DI=(ELM(IB)-EAMX(IA,1))/EAMX(IA,2)
      CHILO=CHILO+(ALOG(ABS(ELM(IB)/EAMX(IA,1)))*
     *ABS(EAMX(IA,1))/EAMX(IA,2))**2
      CHI=CHI+DI*DI
      GO TO 10
 12   DI=(ELM(IB)-EAMX(IA,1))/EAMX(IA,2)
      CHILO=CHILO+(ALOG(ABS(ELM(IB)/EAMX(IA,1)))*
     *ABS(EAMX(IA,1))/EAMX(IA,2))**2
      CHI=CHI+DI*DI
 10   CONTINUE
      RETURN
      END
      SUBROUTINE PTICC(IDR)
      COMMON/CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON/COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      COMMON/LEV/TAU(75),KSEQ(500,4)
      WRITE(22,100)
      DO 10 L=1,IDR
      IINX=KSEQ(L,1)
      NI=KSEQ(L,3)
      NF=KSEQ(L,4)
      ENET=EN(NI)-EN(NF)
      CONE2=CONV(ENET,2)
      if(abs(spin(ni)-spin(nf)).gt.2.)cone2=0.
      CONM1=0.
      CONE1=0.
      IF(IINX.LE.MULTI(1))CONE1=CONV(ENET,1)
      IF(ABS(SPIN(NI)-SPIN(NF)).LT.2.) CONM1=CONV(ENET,4)
      WRITE(22,101) NI,NF,SPIN(NI),SPIN(NF),ENET,CONE1,CONE2
     *,CONM1
 10   CONTINUE
 100  FORMAT(1X//20X,31HCALCULATED INTERNAL CONVERSION ,
     >29HCOEFFICIENTS FOR E1,E2 AND M1//5X,2HNI,5X,2HNF,
     >7X,2HII,8X,2HIF,9X,11HENERGY(MEV),6X,7HICC(E1),8X,
     >7HICC(E2),8X,
     >7HICC(M1))
 101  FORMAT(5X,I2,5X,I2,7X,F4.1,6X,F4.1,9X,F6.4,8X,E9.4,6X,
     >E9.4,6X,E9.4)
      RETURN
      END
      FUNCTION RNDM(SE)
      IF(SE.GT.32000.)GO TO 1
 2    SE=SE*SE
      U=ALOG10(SE)
      I=IFIX(U)+1
      T=SE/(10.**I)
      R=SQRT(SQRT(SQRT(T)))
      P=SQRT(SQRT(SQRT(.1)))
      RXDM=(R-P)/(1.-P)
      RXDM=10.*RXDM
      AI=FLOAT(IFIX(RXDM))
      RNDM=RXDM-AI
      RETURN
 1    SE=100.*T+.511
      GO TO 2
      END
      SUBROUTINE KONTUR(IDR,CHIS0,CHIL,IFBF,INPO,JJ,SH,BTEN,REM)
      DIMENSION F(3),BTEN(1200)
      COMMON/VLIN/XV(51),YV(51),ZV(20),DSG(20),DSE(20),DS
      COMMON/DFTB/DEVD(500),DEVU(500)
      COMMON/COMME/ELM(500),ELMU(500),ELML(500),SA(500)
      COMMON/CEXC/MAGEXC,MEMAX,LMAXE,MEMX6,IVAR(500)
      COMMON/HHH/HLM(500)
      COMMON/ILEWY/NWR
      COMMON/LOGY/LNY,INTR,IPS1
      LNY=0
      H=.05*ABS(HLM(JJ))
      IF(INPO.NE.-1)H=ABS(SH)
 555  INTR=0
      SAJJ=ABS(SA(JJ))
      DO 222 L=1,MEMAX
      ELM(L)=HLM(L)
 222  SA(L)=SA(L)/SAJJ
      YV(1)=0.
      XV(1)=HLM(JJ)
      F(3)=1.
      I=1
 111  CONTINUE
      ITL=0
      V=ELMU(JJ)-ELM(JJ)
      IF(SA(JJ).LT.0.)V=ELM(JJ)-ELML(JJ)
      IF(H.GT.V)ITL=1
      IF(H.GT.V)H=V
      I=I+1
      F(1)=F(3)
      DO 2 J=1,MEMAX
  2   ELM(J)=.5*H*SA(J)+ELM(J)
      CALL LIMITS
      CALL FTBM(3,CHIS1,IDR,1,CHILO,BTEN)
      IF(CHIS1.GT.CHIS0)GO TO 66
      IF(INPO.EQ.-1)WRITE(22,52)JJ,ELM(JJ),CHIS1
      IF(CHIS1.GT.CHIL.OR.INPO.EQ.-1)GO TO 66
      IFBF=1
      IX=1
      CHIL=CHIS1
      WRITE(22,51)CHIL
      GO TO 112
  66  CONTINUE
      WW=.5*(CHIS0-CHIS1)*NWR
      IF(WW.GE.REM)GO TO 888
      F(2)=EXP(WW)
      IF(I.EQ.2.AND.F(2).LT..1.AND.abs(XV(1)-HLM(JJ)).lt.1e-9)GO TO 444
      DO 3 J=1,MEMAX
  3   ELM(J)=ELM(J)+.5*SA(J)*H
      V=ELM(JJ)
      CALL LIMITS
      IF(abs(V-ELM(JJ)).gt.1.e-6)ITL=1
      CALL FTBM(3,CHIS2,IDR,1,CHILO,BTEN)
      IF(CHIS2.GT.CHIS0)GO TO 44
      IF(INPO.EQ.-1)WRITE(22,52)JJ,ELM(JJ),CHIS2
      IF(CHIS2.GT.CHIL.OR.INPO.EQ.-1)GO TO 44
      IFBF=1
      IX=2
      CHIL=CHIS2
      WRITE(22,51)CHIL
      GO TO 112
 44   CONTINUE
      WW=.5*(CHIS0-CHIS2)*NWR
      IF(WW.GT.REM)GO TO 888
      F(3)=EXP(WW)
      IF(ITL.EQ.1)WRITE(22,500)JJ
      IF(I.NE.2)GO TO 200
      IF(ITL.EQ.1)GO TO 200
      IF(F(3).LT..1.AND.abs(XV(1)-HLM(JJ)).lt.1.e-9)GO TO 444
      IF(F(1).GT.F(2).AND.F(2).GT.F(3))GO TO 200
      IF(F(1).LT.F(2).AND.F(2).GT.F(3))GO TO 300
      I=1
      XV(1)=ELM(JJ)
      IF(INPO.EQ.-1)H=2.*H
      GO TO 111
 300  D1=F(2)-F(1)
      D2=F(3)-F(1)
      AC=(D2-4.*D1)*H/(D2-2.*D1)/4.
      DO 301 L=1,MEMAX
 301  ELM(L)=(ELM(L)-H*SA(L))+AC*SA(L)
      CALL LIMITS
      XV(1)=ELM(JJ)
      I=1
      CALL FTBM(3,CHIS1,IDR,1,CHILO,BTEN)
      WW=.5*(CHIS0-CHIS1)*NWR
      IF(WW.GE.REM)GOTO 888
      F(3)=EXP(WW)
      GO TO 111
 200  Y=YV(I-1)
      YV(I)=RK4(Y,H,F)
      XV(I)=ELM(JJ)
      IF(NWR*(CHIS2-CHIS0).LT.2..AND.INPO.EQ.-1)H=2.*H
      IF(ITL.EQ.1)GO TO 33
      IF(F(3).LT.1.E-3)GO TO 33
      GO TO 1
  52  FORMAT(5X,4HELM(,1I3,2H)=,1F10.6,5X,6HCHISQ=,1E12.4)
  51  FORMAT(10X,50HBETTER POINT FOUND...MATRIX ELEMENTS WRITTEN ON 17
     *,3X,6HCHISQ=,1E12.4)
 112  REWIND 17
      DO 55 L=1,MEMAX
  55  WRITE(17,*)ELM(L)
      IF(IX.EQ.1)GO TO 66
      IF(IX.EQ.2)GO TO 44
  1   GO TO 111
 444  H=H/2.
      GO TO 555
 33   C=YV(I)
      M=0
      DO 6 L=1,I
      YV(L)=1.00001-YV(L)/C
      IF(M.EQ.0.AND.YV(L).LT..317)M=L
 6    CONTINUE
      X=(XV(M)-XV(M-1))*(.317-YV(M))/(YV(M-1)-YV(M))
      T=XV(M)-X-HLM(JJ)
      IF(T.GE.0.)DEVU(JJ)=T
      IF(T.LT.0.)DEVD(JJ)=T
 500  FORMAT(5X,11HWARNING-ME(,1I3,1H),5X
     *,32HINTEGRATION STOPPED AT THE LIMIT)
      RETURN
 888  WRITE(22,889)JJ
 889  FORMAT(5X,13H** WARNING **,/,2X,3HME=,1I3,2X,
     *59HTOO FAR FROM THE MINIMUM TO CARRY OUT THE ERROR ESTIMATION!,/)
      RETURN
      END
      FUNCTION RK4(Y,H,F)
      DIMENSION F(3)
      RK4=Y+H*(F(1)+4.*F(2)+F(3))/6.
      RETURN
      END
      SUBROUTINE QFIT(QUI,TAU1,TAU2,ENG,XL1,CF,NL,IND)
      COMMON/DIMX/DIX(4),ODL(200)
      DIMENSION TAU1(10),ENG(10),TAU2(10,7),XL1(7),QUI(8,10),CF(8,2)
      CALL GAMATT(QUI,TAU1,TAU2,XL1,NL)
      IND1=5
      IF(IND.EQ.4)IND1=6
      IF(IND.EQ.5)IND1=7
      DO 1 K=1,8
      CO=QUI(K,IND)
      CN=QUI(K,10)
      CM=QUI(K,IND1)
      CA=(ENG(IND1)-ENG(IND))**2
      CB=(ENG(10)-ENG(IND))**2
      D=CA*(CO-CN)-CB*(CO-CM)
      D1=CA*CM*(CO-CN)-CB*CN*(CO-CM)
      D2=CA*CB*(CN-CM)
      CF(K,1)=D1/D
      CF(K,2)=D2/D
  1   CONTINUE
      RETURN
      END
      SUBROUTINE GAMATT(QUI,TAU1,TAU2,XL1,NL)
      COMMON/DIMX/DIX(4),ODL(200)
      DIMENSION TAU1(10),TAU2(10,7),XL1(7),THING3(10)
     *,Q(9),QUI(8,10)
      DO 3 I=1,10
      I1=1
      THING3(I)=0.
 2    THING1=-TAU2(I,I1)*XL1(I1)+THING3(I)
      I1=I1+1
      THING3(I)=THING1
      IF(I1.LE.NL) GO TO 2
  3   CONTINUE
      DO 4 I=1,10
      TAU=TAU1(I)
      THING=THING3(I)
      CALL GCF(TAU,THING,Q)
      DO 5 K=2,9
 5    QUI(K-1,I)=Q(K)
 4    CONTINUE
      END
      SUBROUTINE GCF(TAU,THING,Q)
      COMMON/DIMX/A,R,XL,D,ODL(200)
      DIMENSION F(101),B(4),Q(9)
      B(1)=ATAN2(A,D+XL)
      B(2)=ATAN2(A,D)
      B(3)=ATAN2(R,D+XL)
      B(4)=ATAN2(R,D)
      DO 100 K=1,9
      Q(K)=0.0
      DO 100 J=1,3
      YL=B(J)
      YU=B(J+1)
      DL=(YU-YL)/100.
      DO 90 M=1,101
      XM=YL+DL*(M-1)
      GO TO (10,20,30),J
 10   EX=TAU*(A-(D+XL)*TAN(XM))/SIN(XM)
      GO TO 40
 20   EX=-TAU*XL/COS(XM)
      GO TO 40
 30   EX=TAU*(D*TAN(XM)-R)/SIN(XM)
 40   F(M)=SIN(XM)*(1-EXP(EX))*EXP(THING/COS(XM))
      IF(J.EQ.1) F(M)=F(M)*EXP(-TAU*(A/SIN(XM)-D/COS(XM)))
      GO TO (90,50,60,70,80,81,82,83,84),K
 50   F(M)=F(M)*COS(XM)
      GO TO 90
 60   F(M)=F(M)*(1.5*COS(XM)**2-0.5)
      GO TO 90
 70   F(M)=F(M)*(2.5*COS(XM)**3-1.5*COS(XM))
      GO TO 90
 80   F(M)=F(M)*(4.375*COS(XM)**4-3.75*COS(XM)**2+.375)
      GO TO 90
 81   F(M)=F(M)*((63.*COS(XM)**5-70.*COS(XM)**3+15.)/8.)
      GO TO 90
 82   F(M)=F(M)*((21.*COS(XM)**2*(11.*COS(XM)**4-15.*COS(XM)**
     *2+5.)-5.)/16.)
      GO TO 90
 83   F(M)=F(M)*(429.*COS(XM)**7-693.*COS(XM)**5+315.*COS(XM)**3
     *-35.*COS(XM))/16.
      GO TO 90
 84   F(M)=F(M)*(6435.*COS(XM)**8-12012.*COS(XM)**6+6930.*COS(XM)
     ***4-1260.*COS(XM)**2+35.)/128.
 90   CONTINUE
      EV=0.0
      OD=0.0
      DO 95 M=2,98,2
      EV=EV+F(M)
 95   OD=OD+F(M+1)
      FINT=DL/3.*(F(1)+4.*(EV+F(100))+2.*OD+F(101))
      Q(K)=Q(K)+FINT
 100  CONTINUE
      DO 101 I=1,8
 101  Q(I+1)=Q(I+1)/Q(1)
      Q(1)=Q(1)/2.
      RETURN
      END
      COMPLEX FUNCTION TCEXP(Z)
      COMPLEX Z
      A=REAL(Z)
      B=AIMAG(Z)
      A=EXP(A)
      C=A*COS(B)
      D=A*SIN(B)
      TCEXP=CMPLX(C,D)
      RETURN
      END
      FUNCTION TCABS(Z)
      COMPLEX Z
      A=REAL(Z)
      B=AIMAG(Z)
      IF(ABS(A).LT.1.E-16)A=0.
      IF(ABS(B).LT.1.E-16)B=0.
      TCABS=SQRT(A*A+B*B)
      RETURN
      END
      FUNCTION TASIN(X)
      TEST=ABS(X)-1.
      IF(ABS(TEST).LT.1.E-9)GO TO 1
      DOL=SQRT(1.-X*X)
      WAR=X/DOL
      TASIN=ATAN(WAR)
      RETURN
   1  TASIN=1.570796327
      IF(X.LT.0.)TASIN=-1.570796327
      RETURN
      END
      FUNCTION TACOS(X)
      TACOS=1.570796327-TASIN(X)
      RETURN
      END
      SUBROUTINE OPENF
      CHARACTER NAME*60,OPT1*20,OPT2*20
	common/switch/jzb,ibps
 1    READ(jzb,*)I,J,K
      IF (I.EQ.0) RETURN
      IF (J.EQ.1) OPT1='OLD'
      IF (J.EQ.2) OPT1='NEW'
      IF (J.EQ.3) OPT1='UNKNOWN'
      IF (K.EQ.1) OPT2='FORMATTED'
      IF (K.EQ.2) OPT2='UNFORMATTED'
      READ(jzb,1000)NAME
 1000 FORMAT(A)
      if(i.ne.25.and.i.ne.26)
     *OPEN(I,IOSTAT=K,FILE=NAME,STATUS=OPT1,FORM=OPT2)
      if(i.eq.25.or.i.eq.26)k=0
c      IF (K.EQ.0) WRITE(6,1030) 'OPENED ',NAME
c 1030 FORMAT (1X,2A)
c      WRITE(6,1010) ' IO-num = ',I,OPT1,OPT2
c 1010 FORMAT (1X,A,I4,2(1x,A))
      IF (K.EQ.0) GO TO 1
c      WRITE (6,1020) 'PROBLEMS OPENING ',NAME,K
c 1020 FORMAT(A,A,I6)
      RETURN
      END
      subroutine effix(ipd,en,effi)
      dimension xx(51),yy(51)
      common/efcal/abc(8,10),akavka(8,200),thick(200,7)
	effi=1.e-6
      en=en+1.e-24
      enl=alog(en)
      do 1 i=1,10
      ll=11-i
      j=ll
      if(enl.ge.abc(8,ll))go to 2
      j=-1
  1   continue
  2   continue
      if(j.eq.-1)effi=1.e-10
      if(j.eq.-1)return
      if(j.eq.1.or.j.eq.10)go to 3
      if(j.eq.9)go to 5
      xx(1)=abc(8,j)
      xx(2)=abc(8,j+1)
      xx(3)=abc(8,j+2)
      go to 6
  3   s=0.
      do 10 l=1,7
      if(abs(thick(ipd,l)).lt.1.e-9)go to 10
      t=exp(abc(l,j))
      d=thick(ipd,l)
      s=s+t*d
 10   continue
      go to 20
  5   xx(1)=abc(8,8)
      xx(2)=abc(8,9)
      xx(3)=abc(8,10)
  6   continue
      s=0.
      do 11 l=1,7
      if(abs(thick(ipd,l)).lt.1.e-9)go to 11
      if(j.eq.9)go to 12
      yy(1)=abc(l,j)
      yy(2)=abc(l,j+1)
      yy(3)=abc(l,j+2)
      go to 13
  12  yy(1)=abc(l,8)
      yy(2)=abc(l,9)
      yy(3)=abc(l,10)
  13  continue
      call lagran(xx,yy,3,0,enl,t,1,1)
      s=s+exp(t)*thick(ipd,l)
  11  continue
  20  effi=exp(-s)
c FITEFF or GREMLIN check
      if(akavka(8,ipd).le.-999.)go to 1501
      if(akavka(5,ipd).gt.0..and.akavka(5,ipd).lt.10.)goto1301
      if(akavka(5,ipd).ge.10.)go to 1500
c GREMLIN
      w=alog(20.*en)
      pw=akavka(1,ipd)+akavka(2,ipd)*w+akavka(3,ipd)*w*w+
     *akavka(4,ipd)*w*w*w
      effi=effi*exp(pw)
      if(abs(akavka(5,ipd)).lt.1.e-9)go to 21
      n=ifix(akavka(6,ipd)+.1)
      pw=w**n
      w=akavka(5,ipd)/pw
      effi=effi*exp(w)
  21  continue
      if(abs(akavka(8,ipd)).lt.1.e-9)return
      w=(akavka(7,ipd)-1000.*en)/akavka(8,ipd)
      pw=exp(w)
      if(abs(pw-1.).lt.1.e-6)write(22,23)
      effi=effi/(1.-pw)
  23  format(5x,'***** CRASH - EFFIX *****')
      return
c FITEFF eff. calib. by P.Olbratowski use
c PJN@2000    
 1301 w=alog(en/akavka(5,ipd))
      pw=akavka(2,ipd)*w
      if(en.lt.akavka(5,ipd))pw=pw+w*w*(akavka(3,ipd)+w*akavka(4,ipd))
      effi=effi*exp(pw)*akavka(1,ipd)
      return
c     JAERI calibration - TC, Nov.2000 
 1500 w=alog(en/.511)
      effi=exp(akavka(1,ipd)+akavka(2,ipd)*w-exp(akavka(3,ipd)+
     *akavka(4,ipd)*w))
      return
C     LEUVEN CALIBRATION
 1501 effi=akavka(1,ipd)
      enek=1000.*en
	w=alog(enek) 
      do 1502 ixi=1,6
	effi=effi+akavka(ixi+1,ipd)*w**ixi	
 1502 continue
      effi=exp(effi)
	return	
      end
      SUBROUTINE ADHOC(OPH,IDR,NFD,NTAP,IYR)
      CHARACTER*4 OPH
      common/clust/iclust(50,200),lastcl(50,20),sumcl(20,500)
     *,irawex(50)
      common/switch/jzb,ibps
      common/cccds/ndst(50)
      COMMON/IDENT/BEQ
      common/efcal/abc(8,10),akavka(8,200),thick(200,7)
      COMMON/DIMX/DIX(4),ODL(200)
      COMMON/TRA/DELTA(500,3),ENDEC(500),ITMA(50,200),ENZ(200)
      COMMON/LIFE/NLIFT
      COMMON/MIXD/DMIXE(20,2),DMIX(20),IMIX(20),NDL
      COMMON/ME2D/NAMX,IAMX(100),IAMY(100,2),EAMX(100,2)
      COMMON/LIFE1/LIFCT(50),TIMEL(2,50)
      COMMON/ERRAN/KFERR
      COMMON/MGN/LP1,LP2,LP3,LP4,LP6,LP7,
     *LP8,LP9,LP10,LP11,LP12,LP13,LP14
      COMMON/SECK/ISKIN(50)
      COMMON/BRNCH/BRAT(50,2),IBRC(2,50),NBRA
      COMMON/YEXPT/YEXP(32,1500),IY(1500,32),CORF(1500,32),DYEX(32,1500)
     *,NYLDE(50,32),UPL(32,50),YNRM(32,50),IDRN,ILE(32)
      COMMON/YTEOR/YGN(500),YGP(500),IFMO
      COMMON/LEV/TAU(75),KSEQ(500,4)
      COMMON/CCC/eg(50),cc(50,5),NANG(200),Q(3,200,8),NICC,
     *AGELI(50,200,2)
      COMMON/GGG/G(7)
      COMMON /CLCOM/LAMDA(8),LEAD(2,500),LDNUM(8,75),LAMMAX,MULTI(8)
      COMMON /COEX/EN(75),SPIN(75),ACCUR,DIPOL,ZPOL,ISO,ACCA
      COMMON/MINNI/IMIN,LNORM(50)
      COMMON/CX/NEXPT,IZ,XA,IZ1(50),XA1(50),EP(50),TLBDG(50),VINF(50)
      COMMON /CEXC/MAGEXC,MEMAX,LMAXE,MEMX6,IVAR(500)
      COMMON/PRT/IPRM(20)
      COMMON/CLCOM0/IFAC(75)
      COMMON/CLCOM9/ERR
      COMMON/COEX2/NMAX,NDIM,NMAX1
      COMMON/THTAR/ITTE(50)
      COMMON/SKP/JSKIP(50)
      COMMON/TRB/ITS
      IOSR=0
      read(jzb,*)IFMO
      read(jzb,*)NICC,NISTR
      read(jzb,*)(EG(JICC),JICC=1,NICC)
      IYR=1
      DO 951 JIC=1,NISTR
      read(jzb,*)ISRT1
      IF(ISRT1.GT.6)ISRT1=ISRT1-3
 951  read(jzb,*)(CC(JICC,ISRT1),JICC=1,NICC)
      read(jzb,*)(NANG(JICC),JICC=1,NEXPT)
      REWIND 9
      READ(9,*)NFD
      DO 954 JICC=1,NFD
      READ(9,*)ODL(JICC)
      READ(9,*)ENZ(JICC)
      DO 954 ISRT1=1,8
  954 READ(9,*)(Q(LICC,JICC,ISRT1),LICC=1,3)
      DO 952 JIC=1,NEXPT
      JUF=NANG(JIC)
      IF(JUF.LT.0)GO TO 955
      read(jzb,*)(ITMA(JIC,JICC),JICC=1,JUF)
      read(jzb,*)(AGELI(JIC,JICC,1),JICC=1,JUF)
      read(jzb,*)(AGELI(JIC,JICC,2),JICC=1,JUF)
      GO TO 952
  955 JUF=IABS(JUF)
      DO 956 JICC=1,JUF
      AGELI(JIC,JICC,1)=AGELI(JIC-1,JICC,1)
      AGELI(JIC,JICC,2)=AGELI(JIC-1,JICC,2)
      ITMA(JIC,JICC)=ITMA(JIC-1,JICC)
  956 CONTINUE
      IF(OPH.NE.'GOSI')NANG(JIC)=IABS(NANG(JIC))
  952 CONTINUE
      CALL SEQ(IDR)
      DO 953 JIC=1,NEXPT
      JUF=NANG(JIC)
      JUF=IABS(JUF)
      DO 953 JICC=1,JUF
      DO 953 LXT=1,2
 953  AGELI(JIC,JICC,LXT)=AGELI(JIC,JICC,LXT)*.0174532925
      TAU(1)=1.E+25
      read(jzb,*)NS1,NS2
      DO 735 LI=1,IDR
      IF(KSEQ(LI,3).EQ.NS1.AND.KSEQ(LI,4).EQ.NS2)GO TO 736
 735  CONTINUE
 736  IDRN=LI
      IF(OPH.NE.'GOSI')RETURN
      DO 737 LI=1,NEXPT
      JUF=NANG(LI)
      IF(JUF.LT.0)GO TO 957
      read(jzb,*)ndst(li)
      ndas=ndst(li)
      read(jzb,*)(UPL(JICC,LI),JICC=1,ndas)
      read(jzb,*)(YNRM(JICC,LI),JICC=1,ndas)
      GO TO 737
  957 JUF=IABS(JUF)
      NANG(LI)=JUF
      NDST(LI)=NDST(LI-1)
      DO 958 JICC=1,JUF
      UPL(JICC,LI)=UPL(JICC,LI-1)
  958 YNRM(JICC,LI)=YNRM(JICC,LI-1)
 737  CONTINUE
      read(jzb,*)NTAP
      IF(NTAP.EQ.0)GO TO 2266
      IPRI=IPRM(2)
      CALL READY(IDR,NTAP,IPRI)
      NDTP=0
      DO 87 IEXP1=1,NEXPT
      JUF=ndst(IEXP1)
      DO 87 IUF=1,JUF
 87   NDTP=NDTP+NYLDE(IEXP1,IUF)
      NVARE=0
      DO 88 IEXP1=1,MEMAX
      IF(IVAR(IEXP1).EQ.1.OR.IVAR(IEXP1).EQ.2)NVARE=NVARE+1
 88   CONTINUE
      WRITE(22,89)NDTP,NVARE
 89   FORMAT(1X//5X,1I4,1X,19HEXPERIMENTAL YIELDS,10X,
     *1I3,1X,28HMATRIX ELEMENTS TO BE VARIED///)
 2266 read(jzb,*)NBRA,WBRA
      IF(ITS.NE.2)GO TO 2623
      REWIND 18
      WRITE(18,*)MEMAX
 2623 CONTINUE
      IF(NBRA.EQ.0)GO TO 7321
      WRITE(22,431)
 431  FORMAT(40X,16HBRANCHING RATIOS,//5X,3HNS1,5X,3HNF1,
     *5X,3HNS2,5X,3HNF2,5X,10HRATIO(1:2),9X,5HERROR)
      DO 730 LB=1,NBRA
      read(jzb,*)NS1,NS2,NS3,NS4,BRAT(LB,1),BRAT(LB,2)
      BRAT(LB,2)=BRAT(LB,2)/(SQRT(WBRA)+1.E-10)
      WRITE(22,432)NS1,NS2,NS3,NS4,BRAT(LB,1),BRAT(LB,2)
 432  FORMAT(5X,1I2,6X,1I2,6X,1I2,6X,1I2,5X,1F10.5,5X,1F10.5)
      DO 731 LI=1,IDR
      IF(KSEQ(LI,3).EQ.NS3.AND.KSEQ(LI,4).EQ.NS4)GO TO 733
      IF(KSEQ(LI,3).EQ.NS1.AND.KSEQ(LI,4).EQ.NS2)GO TO 732
      GO TO 731
 732  IBRC(1,LB)=LI
      GO TO 731
 733  IBRC(2,LB)=LI
 731  CONTINUE
      IF(ITS.NE.2)GO TO 730
      N1=IBRC(1,LB)
      N2=IBRC(2,LB)
      WRITE(18,*)KSEQ(N1,1),KSEQ(N2,1)
      WRITE(18,*)KSEQ(N1,1),KSEQ(N2,2)
      WRITE(18,*)KSEQ(N1,1),KSEQ(N1,2)
      WRITE(18,*)KSEQ(N2,1),KSEQ(N1,2)
      WRITE(18,*)KSEQ(N2,1),KSEQ(N2,2)
      IF(KSEQ(N1,2).NE.0.AND.KSEQ(N2,2).NE.0)WRITE(18,*)KSEQ(N1,2),
     *KSEQ(N2,2)
 730  CONTINUE
      WRITE(22,433)WBRA
 433  FORMAT(5X,38HBRANCHING RATIOS ARE TAKEN WITH WEIGHT,2X,1E14.6)
 7321 read(jzb,*)NLIFT,WLF
      IF(NLIFT.EQ.0)GO TO 7388
      WRITE(22,7325)
      DO 7323 ILFT=1,NLIFT
      read(jzb,*)LIFCT(ILFT),TIMEL(1,ILFT),TIMEL(2,ILFT)
      TIMEL(2,ILFT)=TIMEL(2,ILFT)/(SQRT(WLF)+1.E-10)
 7323 WRITE(22,7324)LIFCT(ILFT),TIMEL(1,ILFT),TIMEL(2,ILFT)
      WRITE(22,7326)WLF
 7325 FORMAT(1X///30X,15HLIFETIMES(PSEC)///5X,
     *5HLEVEL,9X,8HLIFETIME,5X,5HERROR/)
 7324 FORMAT(7X,1I2,6X,1F10.2,3X,1F10.2)
 7326 FORMAT(1X/10X,31HLIFETIMES ARE TAKEN WITH WEIGHT,
     *2X,1E14.6)
 7388 read(jzb,*)NDL,WDL
      IF(NDL.EQ.0)GO TO 7451
      WRITE(22,7404)
      DO 7400 LI=1,NDL
      read(jzb,*)NS1,NS2,DMIXE(LI,1),DMIXE(LI,2)
      DMIXE(LI,2)=DMIXE(LI,2)/(SQRT(WDL)+1.E-10)
      WRITE(22,7405)NS1,NS2,DMIXE(LI,1),DMIXE(LI,2)
      DO 7401 LB=1,IDR
      IF(KSEQ(LB,3).EQ.NS1.AND.KSEQ(LB,4).EQ.NS2)GO TO 7402
      GO TO 7401
 7402 IMIX(LI)=LB
      DMIX(LI)=.8326*(EN(NS1)-EN(NS2))
      IF(ITS.EQ.2)WRITE(18,*)KSEQ(LB,1),KSEQ(LB,2)
 7401 CONTINUE
 7400 CONTINUE
      WRITE(22,7406) WDL
 7406 FORMAT(/10X,41HE2/M1 MIXING RATIOS ARE TAKEN WITH WEIGHT,2X,
     11E14.6)
 7451 CONTINUE
      IF(ITS.EQ.2)WRITE(18,*)IOSR,IOSR
      read(jzb,*)NAMX,WAMX
      IF(NAMX.EQ.0)RETURN
      WRITE(22,7453)
 7453 FORMAT(1X//30X,30HEXPERIMENTAL MATRIX ELEMENT(S)///
     110X,10HTRANSITION,10X,7HMAT.EL.,10X,5HERROR/)
      DO 7460 IAX=1,NAMX
      read(jzb,*)llia,NS1,NS2,EAMX(IAX,1),EAMX(IAX,2)
      IAMY(IAX,1)=NS1
      IAMY(IAX,2)=NS2
      EAMX(IAX,2)=EAMX(IAX,2)/(SQRT(WAMX)+1.E-10)
      WRITE(22,7405) NS1,NS2,EAMX(IAX,1),EAMX(IAX,2)
      iamx(iax)=mem(ns1,ns2,llia)
 7460 CONTINUE
      WRITE(22,7465) WAMX
 7465 FORMAT(/10X,40H MATRIX ELEMENT(S) ARE TAKEN WITH WEIGHT,
     12X,1E14.6)
 7404 FORMAT(1X//20X,32HEXPERIMENTAL E2/M1 MIXING RATIOS///
     *10X,10HTRANSITION,12X,5HDELTA,10X,5HERROR/)
 7405 FORMAT(10X,1I2,3H---,1I2,14X,1F9.4,8X,1F9.4)
      RETURN
      END
      function elmt(xi1,xi2,lam,nb1,nb2,xk1,xk2,xm1,xm2,xm3)
      la=lam
      if(la.gt.6)la=la-6
      xlam=float(la)
      i1=ifix(2.*xi1)
      i2=ifix(2.*xi2)
      llam=2*la
      k1=ifix(2.*xk1)
      k2=ifix(2.*xk2)
      fac=sqrt(2.*xi1+1.)*sqrt(2.*xi2+1.)
C-----In-band matrix element
      if(nb1.ne.nb2)go to 1
C-----K=0
      if(k1.ne.0)go to 2
      elmt=fac*wthrej(i1,llam,i2,0,0,0)*xm1
      return
C-----In band, K.ne.0
  2   pha1=(-1.)**((i1-llam+k1)/2)
      pha2=(-1.)**((k1+i1)/2+1)*pha1
      elmt=fac*(pha1*wthrej(i1,llam,i2,k1,0,-k1)*xm1+
     *pha2*wthrej(i1,llam,i2,-k1,2*k1,-k1)*xm2)
      return
C-----Interband, K-allowed             
C-----One K=0
  1   continue
      if(abs(k1-k2).ge.llam)go to 4
      if(k1.ne.0.and.k2.ne.0)go to 3 
      ipha=(i1-llam+k2)/2
      if(k2.eq.0)ipha=((i2-llam+k1)/2)
      pha1=(-1.)**ipha
      elmt=fac*pha1*wthrej(i1,llam,i2,0,k2,-k2)*xm1
      if(k2.eq.0)elmt=fac*pha1*wthrej(i2,llam,i1,0,k1,-k1)*xm1       
      if(k1.ne.0.or.k2.ne.0)elmt=elmt*sqrt(2.)
      return
C-----Both K's non-zero
  3   continue
      pha1=(-1.)**((i1-llam+k2)/2)
      pha2=(-1.)**((i1+k1)/2)*pha1
      elmt=fac*(pha1*wthrej(i1,llam,i2,k1,k2-k1,-k2)*xm1+
     *pha2*wthrej(i1,llam,i2,-k1,k1+k2,-k2)*xm2)  
      return
C-----Forbidden and K1-K2=lambda, Mikhailov formula
  4   continue
      addt=0.
      if(k1.ne.1)go to 11
      addt=(-1.)**((i1+1)/2)*(i1+1)/2.*xm3
 11   continue     
      xn=abs(xk1-xk2)-xlam
      n=ifix(xn+.1)
      if(n.eq.0)go to 5
      if(n.eq.1)go to 6
      s1=xi1-xk1      
      s2=xi1+xk1+1.
      do 7 l=1,n
      s1=s1*(xi1-xk1-float(l))
  7   s2=s2*(xi1+xk2+1.+float(l))
      fct=sqrt(s1*s2)
      go to 9
  6   fct=sqrt((xi1-xk1)*(xi1+xk1+1.))
      go to 9
  5   fct=1.
  9   pha1=(-1.)**ifix((xi1-xlam+xk2)+.1)
      elmt=fac*pha1*fct*wthrej(i1,llam,i2,k2-llam,llam,-k2)*
     *(xm1+xm2*(xi2*(xi2+1.)-xi1*(xi1+1.))+addt)
      return
      end
      SUBROUTINE OPENF1
      CHARACTER NAME*60,OPT1*20,OPT2*20
 1    READ *,I,J,K
      IF (I.EQ.0) RETURN
      IF (J.EQ.1) OPT1='OLD'
      IF (J.EQ.2) OPT1='NEW'
      IF (J.EQ.3) OPT1='UNKNOWN'
      IF (K.EQ.1) OPT2='FORMATTED'
      IF (K.EQ.2) OPT2='UNFORMATTED'
      READ 1000,NAME
 1000 FORMAT(A)
      OPEN(I,IOSTAT=K,FILE=NAME,STATUS=OPT1,FORM=OPT2)
c      IF (K.EQ.0) WRITE(6,1030) 'OPENED ',NAME
c 1030 FORMAT (1X,2A)
c      WRITE(6,1010) ' IO-num = ',I,OPT1,OPT2
c 1010 FORMAT (1X,A,I4,2(1x,A))
      IF (K.EQ.0) GO TO 1
c      WRITE (6,1020) 'PROBLEMS OPENING ',NAME,K
c 1020 FORMAT(A,A,I6)
      RETURN
      END
C-----------------------------------------------------------------------