*     ******************************************************************
*     *                                                                *
*     *        PWA Analysis of J/Psi --> Gamma K+ K- at BES !          *
*     *                                                                *
*     *                  data analysis program v 16.51                 *
*     *                                                                *
*     *                                                                *
*     *                                               Guo Zijin 1999   *
*     *                                                                *
*     ******************************************************************
*
*
*     ******************** parameter list ******************************
*
*     notation:   <spin(x) |l(Jpsi,Gamma), spin(Jpsi.Gamma)combined>
*
*     ******************  0+ partial wave **********************kon1(1)*
*
*     wmode(1)  ='<0+|00>'           !faa(  1-2  )    -   ca0p1
*
*     ******************  2+ partial wave **********************kon1(2)*
*
*     wmode(6)  ='<2+|02>'           !faa(  11-12  )   -   ca2p1
*     wmode(7)  ='<2+|20>'           !faa(  13-14  )
*     wmode(8)  ='<2+|2(1,2)>'       !faa(  15-16  )
*
*     ******************  4+ partial wave **********************kon1(3)*
*
*     wmode(18) ='<4+|22>'           !faa(  35-36  )  -   ca4p1
*     wmode(19) ='<4+|40>'           !faa(  37-38  )
*     wmode(20) ='<4+|4(1,2)>'       !faa(  39-40  )
*
*     ***************** end parameter list *****************************
*
*     ******************************************************************
*     *                                                                *
*     *        PWA Analysis of J/Psi --> Gamma K+ K-  at BES !         *
*     *                   begin of main program                        *
*     *                                                                *
*     ******************************************************************
*
      program gkkzj_r
      parameter (npa=41,nd1=10000,nd2=4,nall=35)
      parameter (nex=nd1*nd2*4)
      implicit complex (c)
*
*     *************** common blocks for fumili ******************
*
      common/a/faa(npa)
      common/pl/fpl(npa)
      common/au/famx(npa)
      common/exda/fex(nex)
      common/sigma/sig0(npa)
      common/al/famn(npa)
      common/ned/nt,ns
      common/uprmon/ijhr
*
*     ***********************************************************
*
      common/metr/eps(4,4,4,4),del(4,4),pn(4)
      common/iscba1/icase,mi1
      common/bar/fud1,fud2,fud3
      common/mass/amj,pk
      common/data/akn(nd1,2,5)
      common/coef/fun(21,21),nmode
      common/pan/pa(20,20)
*
*     ***********************************************************
*
      common/info/sx
      common/check/ak1(4),ak2(4),prob
      common/meth/method, nprojection
      common/norm/wa1,iyw
      common/dvb/ci
      common/parrho/pk2,sj
      common/ncount/ncount,nlimit,fudge
      common/funmode/xinmass,nof
      common/xinfo/xmass(11),xwidth(11)
      common/trans/fu(21,21)
      common/startup/idcs,funall(nd1,nall,nall)
      common/dly1/wazerop,watwop,wafourp,wac,wad
      common/cfnew/cf(20,4,4),kon(20),kon1(3),kon2
      common/x/x(11)
      common/fun_temp/fun_temp(21,21)
      common/cppp/cp(20),waa(npa),was
      common/nnn/Nreal,Nbg1,Nbg2,Nt1
*
      character wmode(20)*16,rmode(11)*10,asele(npa)*5,amode(npa)*16
      common/wrmode/wmode,rmode
      real dreson(11)
*
                                                             go to 20
   10 write(*, *) '****error****  please choose a right parameter ! *'
   20 write(*,*) '    '
*
      write(*,*) '    '
      write(*,*) '    '
      write(*,190)
      write(*,200)
      write(*,210)
      write(*,220)
      write(*,230)
      write(*,240)
      write(*,250)
      write(*,260)
      write(*,270)
      write(*,280)
      write(*,290)
      write(*,300)
      write(*,310)
      write(*,320)
      write(*,330)
      write(*,*) '    '
      write(*,*) '    '
*
      iflagcase = 0
*
*     ************** initial parameters *************************
*
      ci = cmplx( 0.0, 1.0 )
      pk  = 0.4936
      amj = 3.097
      pk2 = pk**2
      sj  = amj**2
*
*     ************** set up eps(i,j,k,l) and delta(i,j)**********
      call metric
*     ************** pn=momentum vector for Jpsi ****************
*
      do 30 i = 1, 3
         pn(i) = 0.0
   30 continue
      pn(4) = amj
*
*     ************** fud 1-3 are centrifugal barrier factors ****
*     ************** the old fud1 value was 0.3562 **************
*
      fud1 = 0.22
      fud2 = fud1**2
      fud3 = fud1/3.0
*
*     ***********************************************************
*
   40 ijhr = 0                           ! start piont ......dly!
*
*     ******************************************************************
*     * ijhr used by fumili                                            *
*     * icase=1 monte carlo evaluation required; 2 if read from store  *
*     * method=1 if monte carlo evaluation of denominator is done from *
*     * stored events; 2 to generate monte carlo data using the stored *
*     * parameters.                                                    *
*     * iyw=1 at first entry; set to 2 as a flag after normalisation   *
*     * integral has been done in subroutine integ                     *
*     * nlimit = number of monte carlo events                          *
*     * fudge= factor by which the probability of every event is       *
*     * multiplied in order to get the likelihood in a range near      *
*     * 1 for numerical convenience and accuracy                       *
*     * nprojection = a flag for use in method 2 to indicate wether    *
*     * the monte carlo data is to be used to create projection (1)    *
*     * or to calculate chai**2 (0)                                    *
*     ******************************************************************
*
      nlimit = 149971
      idcs   = 0
      fudge  = 5.0
      if ( iflagcase .ne. 0 )                                 go to 50
*
      write(*, *) '  '
      write(*, *) '******* please enter iflag ? ******'
      read(5, *, err = 10) iflag
*
      write(*, *) '  '
      write(*, *) 'ok, you have choosed iflag = ', iflag
      write(*, *) '  '
*
      if ( iflag .eq. 1 )                                         then
         icase  = 1
         method = 1
      else if ( iflag .eq. 2 )                                    then
         icase  = 2
         method = 1
      else if ( iflag .eq. 3 )                                    then
         icase  = 2
         method = 2
      else if ( iflag .eq. 4 )                                    then
         icase  = 1
         method = 1
      else if ( iflag .eq. 5 )                                    then
         icase  = 3
         method = 1
      else if ( iflag .eq. 6 )                                    then
         icase  = 1
         method = 1
      else
                                                              go to 10
      endif
*
*     ***********************************************************
*
   50 nprojection = 1                    ! continue piont
      iyw         = 1
*
*     **** read input parameter list ****************************
*
      open(1,file='res.inp', status='unknown')
      read(1,*) mii
      do i = 1, mii
         read(1,340) lg, xmass(i), xwidth(i), rmode(i)
      end do
      close(1)
*
      if ( method .eq. 1 )                                        then
         open(1,file='para.inp', status='unknown')
      else if ( method .eq. 2 )                                   then
         open(1,file='para.res',status='unknown')
      endif
*
      read(1,*) mi
      do i = 1, mi
         read(1,350) lg,faa(i),fpl(i),asele(i),amode(i),famn(i),famx(i)
      end do
      close(1)
*
      nmode = 20
      mi1   = mi
*
      do i = 1, nmode
         wmode(i) = amode( 2*i - 1 )
      end do
*
*     *********** set up some kinematics ************************
      open(1,file='fun.out',status='unknown')
*     *********** iain's routine for making projections *********
*
      if ( method .eq. 2 )                                        then
         write(*,*) '  '
         write(*,*) '**************************************************'
         write(*,*) 'icase = 2, method = 2, begin to project to data'
         write(*,*) '**************************************************'
         write(*,*) '  '
         do i=1, nmode + 1
           do j=1, nmode + 1
             read(1,*) fun_temp(i,j)
           end do
         end do
         close(1)
         call eval
         write(*,*) '  '
         write(*,*) '  '
         write(*,360)
         write(*,370)
         write(*,380)
         write(*,390)
         write(*,400) nlimit
         write(*,410)
         write(*,*) '  '
         write(*,*) '  '
         stop
      endif
*
      kon2 = 0
      do 60 i = 1, nmode + 1
         do 60 j = 1, nmode + 1
   60 fu(i,j) = 0.0
*
*     ** set up monte carlo sums for the denominator in fun(21,21) *****
*
      if ( icase .eq. 1 )                                         then
         write(*,*) '  '
         write(*,*) '**************************************************'
         write(*,*) 'icase = 1, method = 1, begin to generate mc data  '
         write(*,*) '**************************************************'
         write(*,*) '  '
         call integ(1)
*
         do 70 i = 1, nmode + 1
           do 72 j=1, nmode + 1
             write(1,*) fun(i,j)
   72      continue
   70    continue
         close(1)
*
         write(*,*) '  '
         write(*,*) '  '
         write(*,430)
         write(*,440)
         write(*,452)
         write(*,460) nlimit
         write(*,470)
         write(*,*) '  '
         write(*,*) '  '
*
         if ( iflag .ge. 4 )                                      then
            icase     = 2
            method    = 1
            iflagcase = 1
                                                              go to 40
         endif
         stop
      endif
*
*
*    **** read monte carlo data generated by BES howl ******************
*
      if ( icase .eq. 3 )                                         then
         write(*,*) '  '
         write(*,*) '**************************************************'
         write(*,*) 'icase = 3, method = 3, begin to calcute fun(i,j)'
         write(*,*) '**************************************************'
         write(*,*) '  '
         call conv(cp)
         call integ(3)
*
         do 75 i=1,nmode + 1
           do 77 j = 1, nmode + 1
             write(1,*)fun(i,j)
   77      continue
   75    continue
         close(1)
*
         write(*,*) '  '
         write(*,*) '  '
         write(*,430)
         write(*,445)
         write(*,450)
         write(*,460) nlimit
         write(*,470)
         write(*,*) '  '
         write(*,*) '  '
*
         stop
         endif
*
*     **** read monte carlo sums from store into fun(21,21)************
*
      if ( icase .eq. 2 )                                         then
         write(*,*) '  '
         write(*,*) '**************************************************'
         write(*,*) 'icase = 2, method = 1, begin to optimize cp(i) '
         write(*,*) '**************************************************'
         write(*,*) '  '
*
         do i=1, nmode + 1
           do j=1, nmode + 1
             read(1,*) fun(i,j)
           end do
         end do
*
         close(1)
*
         open(1,file='fun.out',status='unknown')
         do i=1, nmode + 1
           do j=1, nmode + 1
             read(1,*)fun_temp(i,j)
           end do
         end do
         close(1)
      endif
*
      do 80 i = 1, nmode + 1
        do 80 j = 1, nmode + 1
          fun(i,j) = fun(i,j)*10
   80 continue
*
*     ********* read data events ********************************
*
      open(1,file='real.dat',status='unknown')
      n1 = 0
      n2 = 0
      n3 = 0
      read(1,*) Nreal
      do 100 j1 = 1, Nreal
        read(1,*) ( ( akn(j1,j,i),i = 1, 3 ),j = 1, 2 )
        do 90 i1 = 1, 2
          akn(j1,i1,4) = sqrt( pk2 + akn(j1,i1,1)**2
     >           + akn(j1,i1,2)**2 + akn(j1,i1,3)**2 )
   90   continue
  100 continue
      close(1)
      open(1,file='bg1.dat',status='unknown')
      read(1,*) Nbg1
      do 1101 j1 = Nreal+1, Nreal+Nbg1
        read(1,*) ( ( akn(j1,j,i),i = 1, 3 ),j = 1, 2 )
        do 1102 i1 = 1, 2
          akn(j1,i1,4) = sqrt( pk2 + akn(j1,i1,1)**2
     >           + akn(j1,i1,2)**2 + akn(j1,i1,3)**2 )
 1102   continue
 1101 continue
      close(1)
      nt1  = Nreal + Nbg1
      open(1,file='bg2.dat',status='unknown')
      read(1,*) Nbg2
      do 2201 j1 = Nt1+1, Nt1+Nbg2
        read(1,*) ( ( akn(j1,j,i),i = 1, 3 ),j = 1, 2 )
        do 2202 i1 = 1, 2
          akn(j1,i1,4) = sqrt( pk2 + akn(j1,i1,1)**2
     >           + akn(j1,i1,2)**2 + akn(j1,i1,3)**2 )
 2202   continue
 2201 continue
      close(1)
*
      nt   = Nt1 + Nbg2
      Nact = Nreal - Nbg1 - Nbg2
*
*     ********** define fun values for all data points **********
*
      if ( icase .le. 2 )                                         then
         do 130 i = 1, Nt
*
            if ( i .eq. 10   ) write(*,*) 'no. real data event =', i
            if ( i .eq. 500  ) write(*,*) 'no. real data event =', i
            if ( i .eq. 1000 ) write(*,*) 'no. real data event =', i
            if ( i .eq. 1500 ) write(*,*) 'no. real data event =', i
            if ( i .eq. 2000 ) write(*,*) 'no. real data event =', i
*
            x(1) = i
            dummy = funct(x)
            j1 = 0
*
            do 120 j = 1, nmode
               if ( kon(j) .eq. 0 )                          go to 120
               j1 = j1 + 1
               if ( j1 .gt. nall )                           go to 120
               k1 = 0
               do 110 k = 1, nmode
                  if ( kon(k) .eq. 0 )                       go to 110
                  k1 = k1 + 1
                  if ( k1 .gt. nall )                        go to 110
                  funall(i,j1,k1) = fu(j, k)
  110          continue
  120       continue
*
            j1 = j1 + 1
            k1 = k1 + 1
            funall(i,j1,k1) = fu(21,21)
            if ( i .ne.  1)                                  go to 130
            if ( j1 .gt. nall .or. k1 .gt. nall )                 then
               write(*,*) 'dimension of funall is too small', j1, k1
               stop
            endif
*
  130    continue
         idcs = 1
         write(*,*) 'no. real data event =', Nact
*
      endif
*
*     ************ fumili data **********************************
*
      it   = 1
      ns   = 1
      n1   = 3
      n2   = 2
      n3   = 60
      epfu = 0.1
*
*     ***** data for array fex(nex) fumili **************************
*
      do 140 i = 1, nt
         fex(i) = i
  140 continue
*
*     ****************** enter maximum likelihood fit ******************
*     * write out fitted parameter list into file param1 (note that it *
*     * is written into file dout automatically at every iteration)    *
*     ******************************************************************
*
      call likelm(ss,mi,n1,n2,n3,epfu,aka,ala,it,ms)
*
      close(4)
      open (4,file='para.res',status='unknown')
      write(4,730) mi1
      do j = 1, mi1
         write(4,350) j,faa(j),fpl(j),asele(j),amode(j),famn(j),famx(j)
      end do
      close(4)
      open (4,file='error.res',status='unknown')
      write(4,*) mi1
      do j = 1, mi1
         write(4,*) j,sig0(j)
      end do
      close(4)
*
      tl  = 0.0
      tll = 0.0
      n   = 0
*
*     ** calculate the fitted likelihood function and write 10 events **
*
      do 150 i = 1, nt
         x(1) = i
         ddd  = funct(x)
*
         if( i.le.Nreal ) then
           ad = alog(ddd)
         else if( i.gt.Nreal.and.i.le.Nt1 ) then
           ad =-1*alog(ddd)
         else if( i.gt.Nt1.and.i.le.nt ) then
           ad =-1*alog(ddd)
         endif
*
         tl   = tl - ad
         if ( ddd .lt. 0.05 )                                     then
            tll = tll - ad
            n   = n + 1
         endif
  150 continue
*
      write(*,*) '  '
      write(*,*) '  '
      write(*,*) 'scan finish !'
      write(*,*) '  '
      write(*,*) 'sum of -log is equal to:'
      write(*,*) 'low cross-section points: (-lns<0.05)      ', tll, n
      write(*,*) 'number  real data points: ', Nact
*
*     ************ save the final results ***********************
*
      open (22, file='denom.out',status='unknown')
*
      write(22,590)
      write(22,480)
      write(22,610) ms
      if ( ms .eq. 1 )                                            then
         write(22,620)
      else if ( ms .eq. -1 )                                      then
         write(22,630)
      else if ( ms .eq. -2 )                                      then
         write(22,640)
      else if ( ms .eq. -3 )                                      then
         write(22,650)
      else if ( ms .eq. -4 )                                      then
         write(22,660)
      end if
      write(22,670) tl
      write(22,490) was
      write(22,700) Nact, nlimit
      write(22,710)
      write(22,*) '  '
      write(22,500)
*
      d0p = 0.0
      d2p = 0.0
      d4p = 0.0
*
      do i = 1, 11
         dreson(i) = 0.0
      end do
*
      do 170 i = 1, nmode
         if ( kon(i) .eq. 0 )                                go to 170
         do 160 j = 1, nmode
            if ( kon(j) .eq. 0 )                             go to 160
*
            if ( i .eq. j )                                       then
*
               write (22,*) '   '
               dvalue  = pa(i,j)*fun(i,j)/nlimit
               pdvalue = dvalue/was
               xnevents = pdvalue*Nact
*
               write (22,720) i, j, dvalue, pdvalue, xnevents,
     >                        wmode(i), wmode(j)
*
               if (i.ge.1 .and.i.le.5  .and. j.ge.1 .and.j.le.5 ) then
                  d0p = d0p + dvalue
               endif
               if (i.ge.6.and.i.le.17.and.j.ge.6 .and.j.le.17)    then
                  d2p = d2p + dvalue
               endif
               if (i.ge.18.and.i.le.20.and.j.ge.18 .and.j.le.20)  then
                  d4p = d4p + dvalue
               endif
* 0+
               if (i.eq.1 .and. j.eq.1)
     >                             dreson(1) = dreson(1) + dvalue
               if (i.eq.2 .and. j.eq.2)
     >                             dreson(2) = dreson(2) + dvalue
               if (i.eq.3 .and. j.eq.3)
     >                             dreson(3) = dreson(3) + dvalue
               if (i.eq.4 .and. j.eq.4)
     >                             dreson(4) = dreson(4) + dvalue
               if (i.eq.5 .and. j.eq.5)
     >                             dreson(5) = dreson(5) + dvalue

* 2+
               if ( i.ge.6.and.i.le.8.and.j.ge.6.and.j.le.8 )
     >                             dreson(6) = dreson(6) + dvalue
               if ( i.ge.9.and.i.le.11.and.j.ge.9.and.j.le.11)
     >                             dreson(7) = dreson(7) + dvalue
               if ( i.ge.12.and.i.le.14.and.j.ge.12.and.j.le.14 )
     >                             dreson(8) = dreson(8) + dvalue
               if ( i.ge.15.and.i.le.17.and.j.ge.15.and.j.le.17 )
     >                             dreson(9) = dreson(9) + dvalue
* 4+
               if ( i.ge.18.and.i.le.20.and.j.ge.18.and.j.le.20 )
     >                             dreson(10) = dreson(10) + dvalue
*
            endif
*
            if ( i .lt. j )                                       then
*
               dvar    = (pa(i,j)*fun(i,j) + pa(j,i)*fun(j,i))/nlimit
               pdvar   = dvar/was
               xnevents = pdvar*Nact
*
               if (dvar .ne. 0)                                   then
                  write (22,720) i, j, dvar, pdvar, xnevents,
     >                           wmode(i), wmode(j)
               end if
*
               if (i.ge.1 .and.i.le.5  .and. j.ge.1 .and.j.le.5 ) then
                  d0p = d0p + dvar
               endif
               if (i.ge.6.and.i.le.17.and.j.ge.6 .and.j.le.17)    then
                  d2p = d2p + dvar
               endif
               if (i.ge.18.and.i.le.20.and.j.ge.18 .and.j.le.20)  then
                  d4p = d4p + dvar
               endif

* 0+
               if (i.eq.1 .and. j.eq.1 )
     >                             dreson(1) = dreson(1) + dvar
               if (i.eq.2 .and. j.eq.2 )
     >                             dreson(2) = dreson(2) + dvar
               if (i.eq.3 .and. j.eq.3 )
     >                             dreson(3) = dreson(3) + dvar
               if (i.eq.4 .and. j.eq.4 )
     >                             dreson(4) = dreson(4) + dvar
               if (i.eq.5 .and. j.eq.5 )
     >                             dreson(5) = dreson(5) + dvar
* 2+
               if ( i.ge.6.and.i.le.8.and.j.ge.6.and.j.le.8 )
     >                             dreson(6) = dreson(6) + dvar
               if ( i.ge.9.and.i.le.11.and.j.ge.9.and.j.le.11 )
     >                             dreson(7) = dreson(7) + dvar
               if ( i.ge.12.and.i.le.14.and.j.ge.12.and.j.le.14 )
     >                             dreson(8) = dreson(8) + dvar
               if ( i.ge.15.and.i.le.17.and.j.ge.15.and.j.le.17 )
     >                             dreson(9) = dreson(9) + dvar
* 4+
               if ( i.ge.18.and.i.le.20.and.j.ge.18.and.j.le.20 )
     >                             dreson(10) = dreson(10) + dvar
            endif
*
  160    continue
  170 continue
*
      bgdenom = faa(41)*fun(21,21)/nlimit
*
      write (22,*) '  '
      write (22,510)
      write (22,520)
      write (22,530)
      write (22,540)
      write (22,530)
      write (22,550) 'zero plus', d0p, d0p/was, d0p/was*Nact
      write (22,550) 'two  plus', d2p, d2p/was, d2p/was*Nact
      write (22,550) 'four plus', d4p, d4p/was, d4p/was*Nact
      write (22,530)
*
      do 180 i = 1, 11
        if ( dreson(i) .lt. 0.000001 )                       go to 180
        write(22,550) rmode(i),dreson(i),
     >                         dreson(i)/was,dreson(i)/was*Nact
  180 continue
      write(22,550) 'bkg', bgdenom, bgdenom/was, bgdenom/was*Nact
*
      write (22,550) 'total denom', was ,was/was, was/was*Nact
      write (22,560)
*
      write(*,*) '  '
      write(*,*) '  '
      write(*,590)
      write(*,600)
      write(*,610) ms
      if ( ms .eq. 1 )                                            then
         write(*,620)
      else if ( ms .eq. -1 )                                      then
         write(*,630)
      else if ( ms .eq. -2 )                                      then
         write(*,640)
      else if ( ms .eq. -3 )                                      then
         write(*,650)
      else if ( ms .eq. -4 )                                      then
         write(*,660)
      end if
      write(*,670) tl
      write(*,490) was
      write(*,680)
      write(*,690)
      write(*,700) Nact,nlimit
      write(*,710)
      write(*,*) '  '
      write(*,*) '  '
*
      if ( iflag .ge. 6 )                                         then
         icase     = 2
         method    = 2
         iflagcase = 2
                                                              go to 40
      endif
      stop
*
  190 format(9x,'*****************************************************')
  200 format(9x,'* PWA Analysis of J/Psi --> Gamma K+ K-  at BES     *')
  210 format(9x,'*                                                   *')
  220 format(9x,'* please input run-time parameter                   *')
  230 format(9x,'* the availbale paramters are:                      *')
  240 format(9x,'* iflag=1 ==> icase=1, method=1, generate mc data   *')
  250 format(9x,'* iflag=2 ==> icase=2, method=1, optimize cp(i)     *')
  260 format(9x,'* iflag=3 ==> icase=2, method=2, project to data    *')
  270 format(9x,'* iflag=4 ==> do iflag=1 and iflag=2                *')
  280 format(9x,'* iflag=5 ==> icase=3, method=3, generate fun.out   *')
  290 format(9x,'* iflag=6 ==> do iflag=1, iflag=2 and iflag=3       *')
  300 format(9x,'* iflag=the other ==> please input again !          *')
  310 format(9x,'*                                                   *')
  320 format(9x,'* now, choose a flag !                              *')
  330 format(9x,'*****************************************************')
  340 format(3x, i2,f13.4,f13.4,20x,a10,2x)
  350 format(1x, i3,f9.4,f9.3,4x,a5,1x,a16,f10.3,f11.3)
  360 format(12x,'****************************************************')
  370 format(12x,'*  icase=2, method=2 has done !                    *')
  380 format(12x,'*  the results has been put to gkkzj-fit.tohbk !   *')
  390 format(12x,'*  you must run histogen to generate hbook file !  *')
  400 format(12x,'*  the numbers of mc events is',i10, '           *')
  410 format(12x,'****************************************************')
  420 format(97(e14.7,1x))
  430 format(12x,'****************************************************')
  440 format(12x,'*  icase=1, method=1 has done !                    *')
  445 format(12x,'*  icase=3, method=1 has done !                    *')
  452 format(12x,'*  the gen. mc data have been put to mcgkk.dat !   *')
  450 format(12x,'*  the fun result has been put to fun.out !        *')
  460 format(12x,'*  the numbers of mc events is',i10, '           *')
  470 format(12x,'****************************************************')
  480 format(12x,'*                fitting results                   *')
  490 format(12x,'*  the total denom value is:  ',f13.4, '        *')
  500 format(' i',2x,' j',2x,'   denom ',1x,'percent',1x,' nevents',2x,
     >'<partial wave mode> *<partial wave mode>')
  510 format(4x,'*****************************************************')
  520 format(4x,'*              conclusionm result                   *')
  530 format(4x,'*                                                   *')
  540 format(4x,'*    component      denom    percent     n-events   *')
  550 format(4x,'*   ',a10,3x, f8.3, 4x, f7.3, 4x, f9.4, '   *')
  560 format(4x,'*****************************************************')
  570 format(13x,'total      1.00---1.65   1.65---1.90   1.90---2.50'  )
  580 format(6x, 4f14.4)
  590 format(12x,'****************************************************')
  600 format(12x,'*  icase=2, method=1 has been done !               *')
  610 format(12x,'*  the optimitise situation is:',i3,6x,'           *')
  620 format(12x,'*         normal return on finding minimum !!!!    *')
  630 format(12x,'*         no further decrease in ob function ????  *')
  640 format(12x,'*         z matrix can not be inverted ????        *')
  650 format(12x,'*         iteraction limit exceeded ????           *')
  660 format(12x,'*         ml objective function is negative ????   *')
  670 format(12x,'*  the likelihood function is:',f13.4, '        *')
  680 format(12x,'*  the fitting results has been put to denom.out ! *')
  690 format(12x,'*  the fitting xpara.. has been put to para.res !  *')
  700 format(12x,'*  data events is:',i5,',   mc events is:',i8, '   *')
  710 format(12x,'****************************************************')
  720 format(i2,2x,i2,2x,f9.3,2x,f5.2,2x,f8.2,2x,a16,' *',a16)
  730 format(5x,i4)
  740 format(5x,4f15.4)
  750 format(3f12.3)
  760 format(/1x,70('-'),/)
*
      end
*
*     ******************************************************************
*     *                calculation of parameters cp(i)                 *
*     ******************************************************************
*
      subroutine conv(cp)
      parameter (npa=41,nd1=10000,nd2=4)
      implicit complex (c)
      common/a/faa(npa)
      common/pl/fpl(npa)
      common/cfnew/cf(20,4,4),kon(20),kon1(3),kon2
      common/dvb/ci
      common/fun_temp/fun_temp(21,21)
      common/coef/fun(21,21),nmode
      character wmode(20)*16,rmode(11)*10
      common/wrmode/wmode,rmode
      dimension cp(20)
*
      j = 1
      do 10 i = 1, nmode
*       cp(i) = cmplx( faa(j), faa(j+1) )
        PHI=FAA(J+1)*3.14159/180.
        CP(I)=FAA(J)*(COS(PHI)+CI*SIN(PHI))
        j = j + 2
   10 continue
***************************
*0+
cc        cp(3) = cp(4)*faa(5)
*2+
        cp(7) = cp(6)*faa(13)
        cp(8) = cp(6)*faa(15)
cc        cp(6) = cp(7)*faa(11)
cc        cp(8) = cp(7)*faa(15)
*
        cp(10) = cp(9)*faa(19)
        cp(11) = cp(9)*faa(21)
*
        cp(13) = cp(12)*faa(25)
        cp(14) = cp(12)*faa(27)
cccc        cp(12) = cp(13)*faa(23)
c        cp(14) = cp(13)*faa(27)
c        cp(12) = cp(14)*faa(23)
cc        cp(13) = cp(14)*faa(25)
*
cc        cp(16) = cp(15)*faa(31)
cc        cp(17) = cp(15)*faa(33)
*
*4+
cc        cp(19) = cp(18)*faa(37)
cc        cp(20) = cp(18)*faa(39)
*
      if ( kon2 .eq. 0 )                                          then
         j = 1
         do 50 i = 1, nmode
            kon(i) = 1
            if (  faa(j) .eq. 0. .and. faa(j+1) .eq. 0.
     >      .and. fpl(j) .le. 0. .and. fpl(j+1) .le. 0. )  kon(i) = 0
            j = j + 2
   50    continue
*
         write(*,*) '  '
         write(*,*) 'the partial waves used in the fit are :'
         write(*,*) '  '
         do 60 i = 1, nmode
            if ( kon(i) .ne. 0 ) write(*,140) i, kon(i), wmode(i)
   60    continue
         write(*,*) '  '
*
         do 70 i = 1, 3
   70       kon1(i) = 0
         do 80 i = 1, 5
   80       kon1(1) = kon1(1) + kon(i)
         do 90 i = 6, 17
            kon1(2) = kon1(2) + kon(i)
   90    continue
         do 95 i = 18, 20
            kon1(3) = kon1(3) + kon(i)
   95    continue
*
         kon2 = 1
         write(*,*) '   '
         write(*,150)
         write(*,160) (kon1(i),i = 1, 3), kon1(1)+kon1(2)+kon1(3)
         write(*,*) '   '
*
         do 130 i = 1, 20
            do 130 j = 1, 4
               do 130 k = 1, 4
  130    cf(i,j,k) = 0.0
*
      endif
*
  140 format(8x,i3,3x,i2,5x,a16)
  150 format(3x,'0+wave 2+wave 4+wave',3x,'total')
  160 format(2x,3(3x,i2,2x),5x,i2,2x)
*
      return
      end
*
*     ******************************************************************
*     *          calculation of the differential cross section         *
*     ******************************************************************
      function dcs(pa)
      parameter (npa=41,nd1=10000,nd2=4,nall=35)
      implicit complex (c)
      common/mass/amj,pk
      common/metr/eps(4,4,4,4),del(4,4),pn(4)
      common/a/faa(npa)
      common/info/sx
      common/iscba1/icase,mi1
      common/coef/fun(21,21),nmode
      common/bar/fud1,fud2,fud3
      common/trans/fu(21,21)
      common/check/ak1(4),ak2(4),prob
      common/akx/akx,q
      common/dvb/ci
      common/parrho/pk2,sj
      common/x/x(11)
      common/cppp/cp(20),waa(npa),was
      common/startup/idcs, funall(nd1,nall,nall)
      common/ncount/ncount,nlimit,fudge
      common/cfnew/cf(20,4,4),kon(20),kon1(3),kon2
      common/dly1/wazerop,watwop,wafourp,wac,wad
*
      dimension q(4),pa(20,20),akd(4),akx(4),
     >          delp(4,4),delpp(4,4),akxq(4)
*
      dimension akw(4),tf2(4,4),tf4(4,4,4,4)
*
*     ************ form amplitudes ******************************
*     ************ four-vectors for x and gamma, k12=k1-k2 ******
*
      do i = 1, 4
        akx(i) = ak1(i) + ak2(i)
        q(i) = pn(i) - ak1(i) - ak2(i)
        akd(i) = ak1(i) - ak2(i)
        akxq(i) = 2.0*(ak1(i) + ak2(i)) - pn(i)
      end do
*
      sx = scalar(akx,akx)
      q2gg=(3.097**2-sx)**2/(2*3.097)**2
*
      qkx   = scalar(q,akx)
      qkx2  = qkx**2
*
************************************************************************
      if( idcs .eq. 1 )                                          then
*
        wa = 0.0
        ii = x(1)
        i1 = 0
*
        do 20 i = 1, nmode
          if ( kon(i) .eq. 0 )                               go to 20
          i1 = i1 + 1
          j1 = 0
          do 10 j = 1, nmode
            if( kon(j) .eq. 0 )                              go to 10
              j1 = j1 + 1
              fu(i,j) = funall(ii,i1,j1)
              wa = wa + pa(i,j)*fu(i,j)
   10     continue
   20   continue
        i1 = i1 + 1
        j1 = j1 + 1
        fu(21,21) = funall(ii,i1,j1)
*
        if( wa .lt. 0.0001 )                                     then
          wa = 0.00001
        endif
*
        dcs = wa
        return
*
      endif
*
*    ****************** barrier func ********************
*
      qf2k = sx/4.0 - pk2
      qjsif = (pn(4)**2 - sx )**2/pn(4)**2/4.0
*
      b2gx = sqrt( qjsif**2 + 3.*qjsif*fud3 + 9.*fud3**2)
      b4gx = sqrt( qjsif**4 + 10.*qjsif**3*fud3 +
     >   135.*qjsif**2*fud3**2 + 1575.*qjsif*fud3**3 + 11025.*fud3**4)
*
      b2f2 = sqrt( qf2k**2 + 3.*qf2k*fud3 + 9.*fud3**2)
      b4f2 = sqrt( qf2k**4 + 10.*qf2k**3*fud3 +
     >   135.*qf2k**2*fud3**2 + 1575.*qf2k*fud3**3 + 11025.*fud3**4)
*
*     ******* factors for sums over spins ***********************
*
      do i = 1, 4
        do j = 1, 4
          delp(i,j)  = del(i,j) - akx(i)*akx(j)/sx
          delpp(i,j) = del(i,j) - ( q(i)*akx(j) + akx(i)*q(j) )/qkx
     >                                          + sx/qkx2*q(i)*q(j)
        end do
      end do
*
*     ************
*
      do i=1,4
        akw(i) = 0.0
      end do
*
      do i=1,4
        do j=1,4
          akw(i) = akw(i) + akd(j)*del(j,j)*delp(i,j)
        end do
      end do
*
      akxqw = scalar(akd,akw)
*
      do i=1,4
        do j=1,4
          tf2(i,j) = akw(i)*akw(j) - 1./3.*delp(i,j)*akxqw
*
          do k=1,4
            do l=1,4
              tf4(i,j,k,l) = akw(i)*akw(j)*akw(k)*akw(l) - akxqw/7.*
     >           (delp(i,j)*akw(k)*akw(l) + delp(j,k)*akw(i)*akw(l)
     >           +delp(k,i)*akw(j)*akw(l) + delp(i,l)*akw(j)*akw(k)
     >           +delp(j,l)*akw(k)*akw(i) + delp(k,l)*akw(i)*akw(j))
     >     + akxqw**2/35.*( delp(i,j)*delp(k,l)+delp(j,k)*delp(i,l)
     >                     +delp(k,i)*delp(j,l) )
            end do
          end do
*
        end do
      end do
*
*     *** propagators for 0+, 2+ and 4+ resonances ***
*
      cd0p1 = ca0p1(sx)
      cd0p2 = ca0p2(sx)
      cd0p3 = ca0p3(sx)
      cd0p4 = ca0p4(sx)
      cd0p5 = ca0p5(sx)
*
      cd2p1 = ca2p1(sx)
      cd2p2 = ca2p2(sx)
      cd2p3 = ca2p3(sx)
      cd2p4 = ca2p4(sx)
*
      cd4p1 = ca4p1(sx)
*
      cdbg  = cabg(sx)
*
*     ******************************************************************
*     *                        0+ contribution                         *
*     ******************************************************************
*
      if ( kon1(1) .eq. 0 )                                  go to 50
*
* for 0+
*
      do 40 i = 1, 2
        do 30 j = 1, 3
          if(j.ne.i) go to 30
*
          cf(1,i,j) = cd0p1*del(i,j)
*
          cf(2,i,j) = cd0p2*del(i,j)
*
*         cf(3,i,j) = cd0p3*del(i,j)
          cf(3,i,j) = cd0p4*del(i,j)*sx
*
          cf(4,i,j) = cd0p4*del(i,j)
*
          cf(5,i,j) = cd0p5*del(i,j)
*
   30   continue
   40 continue
*
   50 continue
*
*     ******************************************************************
*     *                        2+ contribution                         *
*     ******************************************************************
*
      if ( kon1(2) .eq. 0 )                                  go to 60
*
* for 2+
*
      do i=1,2
        do j=1,3
*
        cf(6,i,j) = cd2p1*tf2(i,j)/b2f2
        cf(7,i,j) = cd2p1*del(i,j)*tf2(4,4)/b2gx/b2f2
        cf(8,i,j) = cd2p1*akxq(i)*tf2(j,4)/b2gx/b2f2
*
        cf(9,i,j) = cd2p2*tf2(i,j)/b2f2
        cf(10,i,j) = cd2p2*del(i,j)*tf2(4,4)/b2gx/b2f2
        cf(11,i,j) = cd2p2*akxq(i)*tf2(j,4)/b2gx/b2f2
*
        cf(12,i,j) = cd2p3*tf2(i,j)/b2f2
        cf(13,i,j) = cd2p3*del(i,j)*tf2(4,4)/b2gx/b2f2
        cf(14,i,j) = cd2p3*akxq(i)*tf2(j,4)/b2gx/b2f2
*
        cf(15,i,j) = cd2p4*tf2(i,j)/b2f2
        cf(16,i,j) = cd2p4*del(i,j)*tf2(4,4)/b2gx/b2f2
        cf(17,i,j) = cd2p4*akxq(i)*tf2(j,4)/b2gx/b2f2
*
        end do
      end do
*
  60  continue
*
*     ******************************************************************
*     *                        4+ contribution                         *
*     ******************************************************************
*
      if ( kon1(3) .eq. 0 )                                  go to 70
*
* for 4+
*
      do i=1,2
        do j=1,3
*
          cf(18,i,j) = cd4p1*tf4(i,j,4,4)/b4f2/b2gx
          cf(19,i,j) = cd4p1*del(i,j)*tf4(4,4,4,4)/b4gx/b4f2
          cf(20,i,j) = cd4p1*akxq(i)*tf4(j,4,4,4)/b4gx/b4f2
*
        end do
      end do
*
   70 continue
*
*     ***********************************************************
*     *  ok, now calculation of the differential cross section  *
*     ***********************************************************
*
      wa      = 0.0
      wazerop = 0.0
      watwop  = 0.0
      wafourp = 0.0
      wac     = 0.0
      wad     = 0.0
*
      ii = x(1)
*
      do 90 i = 1, nmode
        if ( kon(i) .eq. 0 )                                 go to 90
        do 80 j = 1, nmode
          if ( kon(j) .eq. 0 )                               go to 80
*
          cw = 0.0
          do k = 1, 2
            do l = 1, 3
              do m = 1, 3
                cw = cw - cf(i,k,l)*conj(cf(j,k,m))*delpp(l,m)/2.0
              end do
	    end do
	  end do
*
          if ( i .eq. j ) fu(i,j) =  cw
          if ( i .lt. j ) fu(i,j) =  real(cw)
          if ( i .gt. j ) fu(i,j) = -aimag(cw)
*
          temp = pa(i,j)*fu(i,j)
          wa   = wa + temp
*
          if( i.ge.1 .and. i.le.5 .and. j.ge.1 .and. j.le.5 ) then
            wazerop = wazerop + temp
          endif
          if( i.ge.6 .and. i.le.17 .and. j.ge.6 .and. j.le.17 ) then
            watwop = watwop + temp
          endif
          if( i.ge.18 .and. i.le.20 .and. j.ge.18 .and. j.le.20 ) then
            wafourp = wafourp + temp
          endif
          if( i.ge.1 .and. i.le.5 .and. j.ge.6 .and. j.le.17 ) then
            wac = wac + temp
          endif
          if( i.ge.6 .and. i.le.17 .and. j.ge.1 .and. j.le.5 ) then
            wac = wac + temp
          endif
          if( i.ge.1 .and. i.le.1 .and. j.ge.6 .and. j.le.8 ) then
            wad = wad + temp
          endif
          if( i.ge.6 .and. i.le.8 .and. j.ge.1 .and. j.le.1 ) then
            wad = wad + temp
          endif
*
  80    continue
  90  continue
*
      fu(21,21) = cdbg
*
      if ( wa .lt. 0.0001 ) then
        wa = 0.00001
      endif
*
*** according to andrei
*
      if ( wa .lt. -0.001 ) then
        open(4, file='wa.dat',status='unknown')
        write(4,*)'wa = ',wa
        close(4)
      end if
*
***********************
*
      if ( wazerop .lt. 0.0001 )                                 then
        wazerop = 0.00001
      endif
      if ( watwop .lt. 0.0001 )                                  then
        watwop = 0.00001
      endif
      if ( wafourp .lt. 0.0001 )                                 then
        wafourp = 0.00001
      endif
*
      dcs = wa
*
      return
      end
*
*     ******************************************************************
*     *      this function is called for every data event in every     *
*     *      iteration by fumili                                       *
*     ******************************************************************
      function funct(x)
      parameter (npa=41,nd1=10000,nd2=4)
      implicit complex (c)
      common/a/faa(npa)
      common/data/akn(nd1,2,5)
      common/iscba1/icase,mi1
      common/coef/fun(21,21),nmode
      common/pan/pa(20,20)
      common/check/ak1(4),ak2(4),prob
      common/norm/wa1,iyw
      common/meth/method, nprojection
      common/cppp/cp(20),waa(npa),was
      common/ncount/ncount,nlimit,fudge
      common/cfnew/cf(20,4,4),kon(20),kon1(3),kon2
      common/trans/fu(21,21)
      common/gggg/fc
      dimension x(11)
*
*     ****** the event number is stored in x(1) and put into ii ********
*
      ii = x(1)
      if ( ii .ne. 1 )                                        go to 60
*
*     ******************************************************************
*     * form the denominator at first entry and store in was at first  *
*     * entry, calculate cp and pa; lambda parameters (coupling        *
*     * constants) are stored in faa(7) et seq and the list ends after *
*     * mm2 pairs of numbers; lambda set up in cp(1) to cp(mm2)        *
*     ******************************************************************
*
      call conv(cp)
*
      do 20 i = 1, nmode
         if ( kon(i) .eq. 0 )                                 go to 20
         do 10 j = 1, nmode
            if ( kon(j) .eq. 0 )                              go to 10
            cw = cp(i)*conj( cp(j) )
            if (i .eq. j ) pa(i,j) = cw
            if (i .lt. j ) pa(i,j) = 2.0*real(cw)
            if (i .gt. j ) pa(i,j) = 2.0*aimag(cw)
   10    continue
   20 continue
*
      was   = 0.0
*
      do 50 i = 1, nmode
         if ( kon(i) .eq. 0 )                                 go to 50
         do 40 j = 1, nmode
            if ( kon(j) .eq. 0 )                              go to 40
*
            was = was + pa(i,j)*fun(i,j)
*
   40    continue
   50 continue
*
      fc  = faa(41)
      was = was + faa(41)*fun(21,21)
      was = was/nlimit
      if ( ii .eq. 1 ) write(*,*) 'denom =', was
*
*     ********** form the numerator using pa ********************
*
   60 continue
      do 70 i = 1, 4
         ak1(i) = akn(ii,1,i)
         ak2(i) = akn(ii,2,i)
   70 continue
*
*     ********** likelihood function for this event *************
*
      temp1 = dcs(pa)
      temp2 = faa(41)*fu(21,21)
      prob  = ( temp1 + temp2 )*fudge
      funct = prob/was
*
      return
      end
*
*     ******************************************************************
*     *  this routine is used to prepare the values for pa for         *
*     *  method 2 monte carlo, and then call integ to generate         *
*     *  the data points.                                              *
*     ******************************************************************
*
      subroutine eval
      parameter (npa=41,nd1=10000,nd2=4)
      implicit complex (c)
      common/a/faa(npa)
      common/data/akn(nd1,2,5)
      common/iscba1/icase,mi1
      common/coef/fun(21,21),nmode
      common/pan/pa(20,20)
      common/norm/wa1,iyw
      common/meth/method, nprojection
      common/cppp/cp(20),waa(npa),was
      common/cfnew/cf(20,4,4),kon(20),kon1(3),kon2
      common/ncount/ncount,nlimit,fudge
*
*     ***** calculate cp and pa values for use in monte carlo **********
*
      call conv(cp)
*
*     ** pa(mm2,mm2) is a matrix containing lambda(i)*conj(lambda(j)) **
*     ** with a factor 2 for later arithmetic **************************
*
      do 20 i = 1, nmode
         if ( kon(i) .eq. 0 )                                   go to 20
         do 10 j = 1, nmode
            if ( kon(j) .eq. 0 )                                go to 10
            cw = cp(i)*conj(cp(j))
            if (i .eq. j ) pa(i,j) = cw
            if (i .lt. j ) pa(i,j) = 2.0*real(cw)
            if (i .gt. j ) pa(i,j) = 2.0*aimag(cw)
   10    continue
   20 continue
*
      call integ(2)
*
      return
      end
*
*     **********************************************************
*     *     calculation of the renormalization integral        *
*     **********************************************************
*
      subroutine integ(iph)
      parameter (npa=41,nd1=10000,nd2=1)
      implicit complex (c)
      common/coef/fun(21,21),nmode
      common/pan/pa(20,20)
      common/mass/amj,pk
      common/ned/nt,ns
      common/norm/wa1,iyw
      common/check/ak1(4),ak2(4),prob
      common/ncount/ncount,nlimit,fudge
      common/funmode/xinmass,nof
      common/meth/method, nprojection
      common weightmax, nflag
      common/util/np,tecm,amass(18),pcm(5,18),wt    ! for mc generator
*
      common/a/faa(npa)
      common/metr/eps(4,4,4,4),del(4,4),pn(4)
      common/iscba1/icase,mi1
      common/parrho/pk2,sj
      common/trans/fu(21,21)
      common/dly1/wazerop,watwop,wafourp,wac,wad
      dimension akx(4)
      dimension akr(10000,2,5),akb1(10000,2,5),akb2(10000,2,5)
      dimension xak1(3),xak2(3)
*
      real xak1,xak2,xp,sx,sqx
*
*     input for mc genev for J/Psi  -> Gamma K+ K-
*
      np=3
      tecm = amj
      amass(1)= pk
      amass(2)= pk
      amass(3)= 0.
*
      if ( iph .eq. 3 )              then
        do i = 1, nmode
          do j = 1, nmode
            if ( i .eq. j ) pa(i,j) = 1.0
            if ( i .lt. j ) pa(i,j) = 2.0
            if ( i .gt. j ) pa(i,j) = 0.0
            fun(i,j) = 0.0
          end do
        end do
            fun(21,21) = 0.0
*
        open (33, file='mcgkk.dat',status='old')
*
        read(33,*) nmc
*
        do i1=1, nmc
          read(33,*) (ak1(i2), i2=1,4)
          read(33,*) (ak2(i2), i2=1,4)
*
*     ****** form fun *******************
*
          temp1 = dcs(pa)
          wabg  = faa(41)*fu(21,21)
*
          do i = 1, nmode + 1
            do j = 1, nmode + 1
              fun(i,j) = fun(i,j) + fu(i,j)
            end do
          end do
*
        end do
*
        close(33)
        go to 200
*
      endif
*
      if ( iph .eq. 1 ) then
*
*     *********** open output file for mc **********************
*
        ncount=0
        open(44, file='mcgkk.dat',status='unknown')
*
        write(44,*) nlimit
  100   call genev                ! start mc !
*
        do j=1,4
          ak1(j)=pcm(j,1)
          ak2(j)=pcm(j,2)
          akx(j)=ak1(j)+ak2(j)
        enddo
*
        sx  = scalar(akx,akx)
        sqx = sqrt(sx)
*
czj     if ( sqx .lt.1.00.or.sqx.gt.2.00 )    go to 100
*
*     ********* save mc data **********************
*
        write(44,*) (ak1(i),i=1,4)
        write(44,*) (ak2(i),i=1,4)
*
        write(44,*) wt
*
        ncount = ncount + 1
*
        if ( ncount .eq. 10     ) write(*,*) 'ncount=', ncount
        if ( ncount .eq. 1000   ) write(*,*) 'ncount=', ncount
        if ( ncount .eq. 5000   ) write(*,*) 'ncount=', ncount
        if ( ncount .eq. 10000  ) write(*,*) 'ncount=', ncount
        if ( ncount .eq. 20000  ) write(*,*) 'ncount=', ncount
        if ( ncount .eq. 30000  ) write(*,*) 'ncount=', ncount
        if ( ncount .eq. 40000  ) write(*,*) 'ncount=', ncount
        if ( ncount .eq. 50000  ) write(*,*) 'ncount=', ncount
        if ( ncount .eq. 60000  ) write(*,*) 'ncount=', ncount
        if ( ncount .eq. 70000  ) write(*,*) 'ncount=', ncount
        if ( ncount .eq. 80000  ) write(*,*) 'ncount=', ncount
        if ( ncount .eq. 90000  ) write(*,*) 'ncount=', ncount
        if ( ncount .eq. 100000 ) write(*,*) 'ncount=', ncount
*
        if(ncount.lt.nlimit)   go to 100
*
        close(44)
        go to 200
*
      end if
*
      if ( iph .eq. 2 ) then
*
        nof = 55
        open (nof, file='gkk-fit.tohbk', status='unknown')
*
        open(66, file='mcgkk.dat',status='unknown')
*
        read(66,*) n_mc
        do j=1, n_mc
          read(66,*)(ak1(i),i=1,4)
          read(66,*)(ak2(i),i=1,4)
*
          do i=1,4
            akx(i) = ak1(i) + ak2(i)
          end do
*
          sx  = scalar(akx,akx)
          sqx = sqrt(sx)
*
*    ********specially for calculation of wazerop ...***********
*
          temp1 = dcs(pa)
          wabg  = faa(41)*fu(21,21)
          weight = temp1 + wabg
          wazerop = wazerop*1.
          watwop = watwop*1.
          wafourp = wafourp*1.
          wac  = wac*1.
          wad  = wad*1.
          wabg = wabg*1.
*
          xp=sqrt( akx(1)*akx(1)+akx(2)*akx(2)+akx(3)*akx(3) )
*
*     ***********************************************************
*     *              lorentz transformation                     *
*     ***********************************************************
*
          xak1(1)=(ak1(1)*akx(2)-ak1(2)*akx(1))/sqrt(akx(1)**2+akx(2)
     >    **2)
          xak1(2)=(ak1(1)*akx(1)*akx(3)+ak1(2)*akx(2)*akx(3)-ak1(3)
     >    *akx(1)**2-ak1(3)*akx(2)**2)/sqrt(akx(1)**2+akx(2)**2)/xp
          xak1(3)=(-ak1(4)*(akx(4)**2-sx)+akx(4)*(ak1(1)*akx(1)+ak1
     >    (2)*akx(2)+ak1(3)*akx(3)))/sqx/xp
          xak2(1)=(ak2(1)*akx(2)-ak2(2)*akx(1))/sqrt(akx(1)**2+akx(2)
     >    **2)
          xak2(2)=(ak2(1)*akx(1)*akx(3)+ak2(2)*akx(2)*akx(3)-ak2(3)
     >    *akx(1)**2-ak2(3)*akx(2)**2)/sqrt(akx(1)**2+akx(2)**2)/xp
          xak2(3)=(-ak2(4)*(akx(4)**2-sx)+akx(4)*(ak2(1)*akx(1)+ak2
     >    (2)*akx(2)+ak2(3)*akx(3)))/sqx/xp
*
*    ***********************************************************
*
          xgam_jsi = -akx(3)/xp
          xk_x = -xak1(3)/sqrt(xak1(1)**2+xak1(2)**2+xak1(3)**2)
          xphik_x = xatan(xak1(1),xak1(2))
*
*     ***********************************************************
*     *           write the value out                           *
*     ***********************************************************
*
          write (nof,*) sqx,weight,wazerop, watwop,wafourp,
     >                  wac,wad,wabg,xgam_jsi,xk_x,xphik_x
*
        end do
*
        close(66)
        close(nof)
*
*     ********* read data events ********************************
*
        open(77,file='real.dat',status='unknown')
        open(88,file='real_proj.dat',status='unknown')
*
        read(77,*) nrl
        do j1 = 1, nrl
          read(77,*)( ( akr(j1,j,i),i = 1, 3 ),j = 1, 2 )
          do i1 = 1, 2
            akr(j1,i1,4) = sqrt( pk2 + akr(j1,i1,1)**2
     >                               + akr(j1,i1,2)**2
     >                               + akr(j1,i1,3)**2 )
          end do
*
          do k=1,4
            ak1(k) = akr(j1,1,k)
            ak2(k) = akr(j1,2,k)
            akx(k) = akr(j1,1,k) + akr(j1,2,k)
          end do
*
          sx = scalar(akx,akx)
          sqx = sqrt(sx)
*
*     ***********************************************************
*     *              lorentz transformation                     *
*     ***********************************************************
*
          xp=sqrt(akx(1)**2+akx(2)**2+akx(3)**2)
          xak1(1)=(ak1(1)*akx(2)-ak1(2)*akx(1))/sqrt(akx(1)**2+akx(2)
     >    **2)
          xak1(2)=(ak1(1)*akx(1)*akx(3)+ak1(2)*akx(2)*akx(3)-ak1(3)
     >    *akx(1)**2-ak1(3)*akx(2)**2)/sqrt(akx(1)**2+akx(2)**2)/xp
          xak1(3)=(-ak1(4)*(akx(4)**2-sx)+akx(4)*(ak1(1)*akx(1)+ak1
     >    (2)*akx(2)+ak1(3)*akx(3)))/sqx/xp
          xak2(1)=(ak2(1)*akx(2)-ak2(2)*akx(1))/sqrt(akx(1)**2+akx(2)
     >    **2)
          xak2(2)=(ak2(1)*akx(1)*akx(3)+ak2(2)*akx(2)*akx(3)-ak2(3)
     >    *akx(1)**2-ak2(3)*akx(2)**2)/sqrt(akx(1)**2+akx(2)**2)/xp
          xak2(3)=(-ak2(4)*(akx(4)**2-sx)+akx(4)*(ak2(1)*akx(1)+ak2
     >    (2)*akx(2)+ak2(3)*akx(3)))/sqx/xp
*
*   ************************************************************
*
          rgam_jsi = -akx(3)/xp
          rk_x = -xak1(3)/sqrt(xak1(1)**2+xak1(2)**2+xak1(3)**2)
          rphik_x = xatan(xak1(1),xak1(2))
*
          write(88,*) sqx,rgam_jsi,rk_x,rphik_x
*
        end do
*
        close(88)
        close(77)
*
*     ********* background events 1 ********************************
*
        open(97,file='bg1.dat',status='unknown')
        open(98,file='bg1_proj.dat',status='unknown')
*
        read(97,*) nback1
        do j1 = 1, nback1
          read(97,*)( ( akb1(j1,j,i),i = 1, 3 ),j = 1, 2 )
          do i1 = 1, 2
            akb1(j1,i1,4) = sqrt( pk2 + akb1(j1,i1,1)**2
     >                                + akb1(j1,i1,2)**2
     >                                + akb1(j1,i1,3)**2 )
          end do
*
          do k=1,4
            ak1(k) = akb1(j1,1,k)
            ak2(k) = akb1(j1,2,k)
            akx(k) = akb1(j1,1,k) + akb1(j1,2,k)
          end do
*
          sx = scalar(akx,akx)
          sqx = sqrt(sx)
*
*     ***********************************************************
*     *              lorentz transformation                     *
*     ***********************************************************
*
          xp=sqrt(akx(1)**2+akx(2)**2+akx(3)**2)
          xak1(1)=(ak1(1)*akx(2)-ak1(2)*akx(1))/sqrt(akx(1)**2+akx(2)
     >    **2)
          xak1(2)=(ak1(1)*akx(1)*akx(3)+ak1(2)*akx(2)*akx(3)-ak1(3)
     >    *akx(1)**2-ak1(3)*akx(2)**2)/sqrt(akx(1)**2+akx(2)**2)/xp
          xak1(3)=(-ak1(4)*(akx(4)**2-sx)+akx(4)*(ak1(1)*akx(1)+ak1
     >    (2)*akx(2)+ak1(3)*akx(3)))/sqx/xp
          xak2(1)=(ak2(1)*akx(2)-ak2(2)*akx(1))/sqrt(akx(1)**2+akx(2)
     >    **2)
          xak2(2)=(ak2(1)*akx(1)*akx(3)+ak2(2)*akx(2)*akx(3)-ak2(3)
     >    *akx(1)**2-ak2(3)*akx(2)**2)/sqrt(akx(1)**2+akx(2)**2)/xp
          xak2(3)=(-ak2(4)*(akx(4)**2-sx)+akx(4)*(ak2(1)*akx(1)+ak2
     >    (2)*akx(2)+ak2(3)*akx(3)))/sqx/xp
*
*   ************************************************************
*
          b1gam_jsi = -akx(3)/xp
          b1k_x = -xak1(3)/sqrt(xak1(1)**2+xak1(2)**2+xak1(3)**2)
          b1phik_x = xatan(xak1(1),xak1(2))
*
          write(98,*) sqx,b1gam_jsi,b1k_x,b1phik_x
*
        end do
*
        close(98)
        close(97)
*
*     ********* background events 2 ********************************
*
        open(93,file='bg2.dat',status='unknown')
        open(94,file='bg2_proj.dat',status='unknown')
*
        read(93,*) nback2
        do j1 = 1, nback2
          read(93,*)( ( akb2(j1,j,i),i = 1, 3 ),j = 1, 2 )
          do i1 = 1, 2
            akb2(j1,i1,4) = sqrt( pk2 + akb2(j1,i1,1)**2
     >                                + akb2(j1,i1,2)**2
     >                                + akb2(j1,i1,3)**2 )
          end do
*
          do k=1,4
            ak1(k) = akb2(j1,1,k)
            ak2(k) = akb2(j1,2,k)
            akx(k) = akb2(j1,1,k) + akb2(j1,2,k)
          end do
*
          sx = scalar(akx,akx)
          sqx = sqrt(sx)
*
*     ***********************************************************
*     *              lorentz transformation                     *
*     ***********************************************************
*
          xp=sqrt(akx(1)**2+akx(2)**2+akx(3)**2)
          xak1(1)=(ak1(1)*akx(2)-ak1(2)*akx(1))/sqrt(akx(1)**2+akx(2)
     >    **2)
          xak1(2)=(ak1(1)*akx(1)*akx(3)+ak1(2)*akx(2)*akx(3)-ak1(3)
     >    *akx(1)**2-ak1(3)*akx(2)**2)/sqrt(akx(1)**2+akx(2)**2)/xp
          xak1(3)=(-ak1(4)*(akx(4)**2-sx)+akx(4)*(ak1(1)*akx(1)+ak1
     >    (2)*akx(2)+ak1(3)*akx(3)))/sqx/xp
          xak2(1)=(ak2(1)*akx(2)-ak2(2)*akx(1))/sqrt(akx(1)**2+akx(2)
     >    **2)
          xak2(2)=(ak2(1)*akx(1)*akx(3)+ak2(2)*akx(2)*akx(3)-ak2(3)
     >    *akx(1)**2-ak2(3)*akx(2)**2)/sqrt(akx(1)**2+akx(2)**2)/xp
          xak2(3)=(-ak2(4)*(akx(4)**2-sx)+akx(4)*(ak2(1)*akx(1)+ak2
     >    (2)*akx(2)+ak2(3)*akx(3)))/sqx/xp
*
*   ************************************************************
*
          b2gam_jsi = -akx(3)/xp
          b2k_x = -xak1(3)/sqrt(xak1(1)**2+xak1(2)**2+xak1(3)**2)
          b2phik_x = xatan(xak1(1),xak1(2))
*
          write(94,*) sqx,b2gam_jsi,b2k_x,b2phik_x
*
        end do
*
        close(94)
        close(93)
*
      endif
*
  200 continue
      return
      end
*
*     ******************************************************************
*     * file arithm called by fumili for every event to form gradients *
*     ******************************************************************
*
      subroutine arithm (y)
      parameter (npa=41,nd1=10000,nd2=4)
*     ******* arithm sets y and calculates dy/da ****************
      common /df/df(npa)/a/a(npa)/x/x(11)
      common /endflg/ endflg,na,indflg(5)
      common /pl/pl(npa)/au/amx(npa)/al/amn(npa)
*
*     ******* 10.*maximum relative precision on cdc 6000 ********
*
      data rp/1.e-14/
*
*     ******* unperturbed y **************************
*
      y = funct(x)
*
*     ******* run through all variables **************
*
      do 20 i = 1, na
         df(i) = 0.0
         if (pl(i)) 20, 20, 10
   10    ai    = a(i)
*
*     ******* hi=perturbation ************************
*
         hi    = 0.01*pl(i)
         pi    = rp*abs(ai)
         if ( hi .le. pi ) hi = pi
         a(i)  = ai + hi
*
*     ******* form gradient and restore parameters ***
*
         df(i) = grad(x,hi,i)
*        df(i) = ( funct(x) - y )/hi
         a(i)  = ai
   20 continue
      return
      end
*
*     ********** form gradients (called by subroutine arithm) **
*     ********** nb: this subroutine must not disturb cp or pa *
*
      function grad(x,step,ider)
      parameter (npa=41,nd1=10000,nd2=4)
      implicit complex (c)
      common/a/faa(npa)
      common/data/akn(nd1,2,5)
      common/coef/fun(21,21),nmode
      common/pan/pa(20,20)
      common/pad/pag(20,20)
      common/check/ak1(4),ak2(4),prob
      common/norm/wa1,iyw
      common/meth/method, nprojection
      common/cppp/cpn(20),waa(npa),was
      common/trans/fu(21,21)
      common/gggg/fc
      common/ncount/ncount,nlimit,fudge
      common/cfnew/cf(20,4,4),kon(20),kon1(3),kon2
      dimension x(11),cp(20),cdr(20)
*
*     ********* much of this subroutine is a carbon copy of funtn ******
*     ********* ider=index of parameter in faa being varied ************
*
      ii = x(1)
*
      call conv(cp)
      do 10 i = 1, nmode
         if ( kon(i) .eq. 0 )                                   go to 10
         cdr(i) = ( cp(i) - cpn(i) )/step
   10 continue
      ff = ( faa(41) - fc )/step
      dprob = 0.0
      do 30 i = 1, nmode
         if ( kon(i) .eq. 0 )                                   go to 30
         do 20 j = 1, nmode
            if ( kon(j) .eq. 0 )                                go to 20
            cw = cdr(i)*conj(cpn(j)) + cpn(i)*conj(cdr(j))
            if ( i .eq. j ) pag(i,j) = cw
            if ( i .lt. j ) pag(i,j) = 2.0*real(cw)
            if ( i .gt. j ) pag(i,j) = 2.0*aimag(cw)
            dprob = dprob + pag(i,j)*fu(i,j)
   20    continue
   30 continue
      dprob = dprob + ff*fu(21,21)
      if ( ii .ge. 2 )                                          go to 60
*
*     **** form perturbed denominator at first entry and store in waa **
*
      wa1 = 0.0
      do 50 i = 1, nmode
         if ( kon(i) .eq. 0 )                                   go to 50
         do 40 j = 1, nmode
            if ( kon(j) .eq. 0 )                                go to 40
            wa1 = wa1 + pag(i,j)*fun(i,j)
   40    continue
   50 continue
      waa(ider) = ( wa1 + ff*fun(21,21) )/nlimit
*
*     *************** form gradient ****************************
*
   60 dprob = dprob*fudge
      grad  = dprob/was - prob/was**2*waa(ider)
*
      return
      end
*
*     ******************************************************************
*
      complex function ca0p1(s)
      implicit complex (c)
      common/xinfo/xmass(11),xwidth(11)
      common/dvb/ci
      am    = xmass( 1)
      g1    = xmass( 1)*xwidth( 1)
      ca0p1 = g1/( s - am**2 + ci*g1 )
c      ca0p1 = 1.
      return
      end
*     ***********************************************************
*
*     ***********************************************************
      complex function ca0p2(s)
      implicit complex (c)
      common/xinfo/xmass(11),xwidth(11)
      common/dvb/ci
      am    = xmass( 2)
      g1    = xmass( 2)*xwidth( 2)
      ca0p2 = g1/( s - am**2 + ci*g1 )
      return
      end
*     ***********************************************************
*
*     ***********************************************************
      complex function ca0p3(s)
      implicit complex (c)
      common/xinfo/xmass(11),xwidth(11)
      common/dvb/ci
      am    = xmass( 3)
      g1    = xmass( 3)*xwidth( 3)
      ca0p3 = g1/( s - am**2 + ci*g1 )
      return
      end
*     ***********************************************************
*
*     ***********************************************************
      complex function ca0p4(s)
      implicit complex (c)
      common/xinfo/xmass(11),xwidth(11)
      common/dvb/ci
ccc      am    = xmass( 4)
ccc      g1    = xmass( 4)*xwidth( 4)
ccc      ca0p4 = g1/( s - am**2 + ci*g1 )
ccc      return
ccc      end
c----------------------------------------------------------
c       sigma from bsz, nucl.phys.b471 (1996) 59
c----------------------------------------------------------
      ci=cmplx(0.,1.)
      pm=0.135
      am=1.067
      as=am*am
      q2g=(3.097**2-s)**2/(2*3.097)**2
      cgam1=am*1.378*cro(s,pm,pm)/cro(as,pm,pm)
     1  *(s-0.0097)/(as-0.0097)*exp(-(s-as)/4./0.49)
      cgam2=0.0036*am*r4pip(s)/r4pip(as)
c      ca0p4=1./(as-s-ci*(cgam1+cgam2))*exp(0.60*q2g)
      ca0p4=1./(as-s-ci*(cgam1+cgam2))
c      ca0p4=1./(as-s-ci*(cgam1+cgam2))*exp(-0.03*q2g)
      return
      end
c
c----------------------------------------------------------
c     calculation of two particle phase volume
c----------------------------------------------------------
      complex function cro(s,am1,am2)
      implicit complex (c)
      common/dvb/ci
      t1=(am1+am2)**2
      t2=(am1-am2)**2
      st=(s-t1)*(s-t2)
      cro=sqrt(abs(st))/s
      if(st.lt.0.) cro=cro*ci
      return
      end
c
c----------------------------------------------------------
c     4 pion phase volume
c----------------------------------------------------------
      function r4pip(s)
      xk2=s-0.56**2
      if(xk2.le.0.)xk2=0.
      r4pip=sqrt(xk2/s)/(1.+exp(3.5*(2.8-s)))
      return
      end
c
*     ***********************************************************
      complex function ca0p5(s)
      implicit complex (c)
      common/xinfo/xmass(11),xwidth(11)
      common/dvb/ci
      am    = xmass( 5)
      g1    = xmass( 5)*xwidth( 5)
      ca0p5 = g1/( s - am**2 + ci*g1 )
      return
      end
c
*     ***********************************************************
      complex function ca2p1(s)
      implicit complex (c)
      common/xinfo/xmass(11),xwidth(11)
      common/dvb/ci
      am    = xmass( 6)
      g1    = xmass( 6)*xwidth( 6)
      ca2p1 = g1/( s - am**2 + ci*g1 )
c      ca2p1 = 1.
      return
      end
*     ***********************************************************
*
*     ***********************************************************
      complex function ca2p2(s)
      implicit complex (c)
      common/xinfo/xmass(11),xwidth(11)
      common/dvb/ci
      am    = xmass( 7)
      g1    = xmass( 7)*xwidth( 7)
      ca2p2 = g1/( s - am**2 + ci*g1 )
      return
      end
*     ***********************************************************
*
*     ***********************************************************
      complex function ca2p3(s)
      implicit complex (c)
      common/xinfo/xmass(11),xwidth(11)
      common/dvb/ci
      am    = xmass( 8)
      g1    = xmass( 8)*xwidth( 8)
      ca2p3 = g1/( s - am**2 + ci*g1 )
      return
      end
*     ***********************************************************
*
*     ***********************************************************
      complex function ca2p4(s)
      implicit complex (c)
      common/xinfo/xmass(11),xwidth(11)
      common/dvb/ci
      am    = xmass( 9)
      g1    = xmass( 9)*xwidth( 9)
      ca2p4 = g1/( s - am**2 + ci*g1 )
      return
      end
*     ***********************************************************
*
*     ***********************************************************
      complex function ca4p1(s)
      implicit complex (c)
      common/xinfo/xmass(11),xwidth(11)
      common/dvb/ci
      am    = xmass( 10)
      g1    = xmass( 10)*xwidth( 10)
c      ca4p1 = g1/( s - am**2 + ci*g1 )
      ca4p1 = 1.
      return
      end
*     ***********************************************************
*
*     ***********************************************************
      complex function cabg(s)
      implicit complex (c)
      common/xinfo/xmass(11),xwidth(11)
      common/dvb/ci
*
      cabg = 1.
*
      return
      end
*
*     ************* scalar product ******************************
*
      function scalar(q,w)
      common/metr/eps(4,4,4,4),del(4,4),pn(4)
      dimension q(4),w(4)
      scalar  = 0.0
      do 10 i = 1, 4
   10 scalar  = scalar + q(i)*w(i)*del(i,i)
      return
      end
*
*     ************ form complex conjugate ***********************
*
      complex function conj(c)
      implicit complex (c)
      conj = cmplx(real(c),-aimag(c))
      return
      end
*
*     ******** set up delta(i,j) and epsilon(i,j,k,l) ***********
*
      subroutine metric
      common/metr/eps(4,4,4,4),del(4,4),pn(4)
*
      do 10 i = 1, 4
         do 10 j = 1, 4
            del(i,j) = 0.0
            if(i.eq.j) del(i,j) = -1.0
            do 10 k = 1, 4
               do 10 l = 1, 4
   10 eps(i,j,k,l) = 0.0
      del(4,4) = 1.0
*
      eps(1,2,3,4) =  1.0
      eps(1,2,4,3) = -1.0
      eps(1,3,2,4) = -1.0
      eps(1,3,4,2) =  1.0
      eps(1,4,2,3) =  1.0
      eps(1,4,3,2) = -1.0
      eps(2,1,3,4) = -1.0
      eps(2,1,4,3) =  1.0
      eps(2,3,1,4) =  1.0
      eps(2,3,4,1) = -1.0
      eps(2,4,1,3) = -1.0
      eps(2,4,3,1) =  1.0
      eps(3,1,2,4) =  1.0
      eps(3,1,4,2) = -1.0
      eps(3,2,1,4) = -1.0
      eps(3,2,4,1) =  1.0
      eps(3,4,1,2) =  1.0
      eps(3,4,2,1) = -1.0
      eps(4,1,2,3) = -1.0
      eps(4,1,3,2) =  1.0
      eps(4,2,1,3) =  1.0
      eps(4,2,3,1) = -1.0
      eps(4,3,1,2) = -1.0
      eps(4,3,2,1) =  1.0
*
      return
      end
*
c*****************************************************
c     file fumili
c*****************************************************
        subroutine fumili(s,m,n1,n2,n3,eps,akappa,alambd,it,mc)
        call fumixx(s,m,n1,n2,n3,eps,akappa,alambd,it,mc,1)
        return
        end
c
        subroutine likelm(s,m,n1,n2,n3,eps,akappa,alambd,it,mc)
        call fumixx(s,m,n1,n2,n3,eps,akappa,alambd,it,mc,2)
        return
        end
c
      subroutine fumixx(s,m,n1,n2,n3,eps,akappa,alambd,it,mc,nlog)
c-----entry for chisq minimisation
      parameter (npa=41,nd1=10000,nd2=4)
      parameter (nda=nd1*nd2,nex=nd1*nd2*4,nzz=npa*(npa+1)/2)
      common /z/ z(nzz)/g/g(npa)/a/a(npa)/pl/pl0(npa)/sigma/sigma(npa)/
     1plu/pl(npa)/r/r(npa)/da/da(npa)/endflg/endflg,na,indflg(5)/au/amx(
     2npa)/al/amn(npa)/z0/z0(nzz)
c-----10.*maximum relative precision on cdc 6000
      data rp/1.e-14/
        goto (201,202),nlog
201     continue
      indflg(3)=0
 1    if (it.ge.0) print  84
      call vfll(amx,amn,npa,1.e35)
      nn2=0
      n=m
      fixflg=0.
      endflg=0.
      indflg(2)=0
      ifix1=0.
      fi=0.
      nn3=0
      do 2 i=1,n
      r(i)=0.
      if (eps.gt.0.) sigma(i)=0.
 2    pl(i)=pl0(i)
c-----start new iteration
 3    nn1=1
      t1=1.
c-----repeat iteration with smaller step
 4    s=0.
      n0=0
      do 7 i=1,n
      g(i)=0.
      if (pl0(i)) 7,7,5
 5    n0=n0+1
      if (pl(i)) 7,7,6
 6    pl0(i)=pl(i)
 7    continue
      nn0=n0*(n0+1)/2
      if (nn0.lt.1) go to 9
      do 8 i=1,nn0
      z(i)=0.
 8    continue
 9    na=m
      indflg(1)=0
c-----calculate objective function
      call sgz (m,s)
      sp=rp*abs(s)
      if (nn0.lt.1) go to 11
      do 10 i=1,nn0
      z0(i)=z(i)
 10   continue
 11   if (nn3) 19,19,12
 12   if (nn1-n1) 13,13,19
 13   t=2.*(s-olds-gt)
      if (indflg(1)) 16,14,16
 14   if (abs(s-olds).le.sp.and.-gt.le.sp) go to 19
      if (0.59*t+gt) 19,15,15
 15   t=-gt/t
      if (t-0.25) 16,17,17
 16   t=0.25
 17   gt=gt*t
      t1=t1*t
      nn2=0
      do 18 i=1,n
      if (pl(i).le.0.) go to 18
      a(i)=a(i)-da(i)
      pl(i)=pl(i)*t
      da(i)=da(i)*t
      a(i)=a(i)+da(i)
 18   continue
      nn1=nn1+1
      go to 4
c-----remove contribution of fixed parameters from z
   19 if(indflg(1).eq.0) go to 20
      endflg=-4.
      go to 85
 20   k1=1
      k2=1
      i1=1
      do 30 i=1,n
      if (pl0(i)) 30,30,21
 21   if (pl(i).eq.0.) pl(i)=pl0(i)
      if (pl(i)) 23,23,24
 22   pl(i)=0.
 23   k1=k1+i1
      go to 29
 24   if (a(i).ge.amx(i).and.g(i).lt.0.) go to 22
      if (a(i).le.amn(i).and.g(i).gt.0.) go to 22
      do 28 j=1,i
      if (pl0(j)) 28,28,25
 25   if (pl(j)) 27,27,26
 26   z(k2)=z0(k1)
      k2=k2+1
 27   k1=k1+1
 28   continue
 29   i1=i1+1
 30   continue
c-----invert z
      i1=1
      l=i1
      do 32 i=1,n
      if (pl(i)) 32,32,31
 31   r(i)=z(l)
      i1=i1+1
      l=l+i1
 32   continue
      n0=i1-1
      call mconv (n0)
      if (indflg(1)) 33,34,33
 33   indflg(1)=0
      indflg(2)=1
      go to 49
 34   continue
c-----calculate theoretical step to minimum
      i1=1
      do 41 i=1,n
      da(i)=0.
      if (pl(i)) 41,41,35
 35   l1=1
      do 40 l=1,n
      if (pl(l)) 40,40,36
 36   if (i1-l1) 37,37,38
 37   k=l1*(l1-1)/2+i1
      go to 39
 38   k=i1*(i1-1)/2+l1
 39   da(i)=da(i)-g(l)*z(k)
      l1=l1+1
 40   continue
      i1=i1+1
 41   continue
c-----check for parameters on boundary
      afix=0.
      ifix=0
      i1=1
      l=i1
      do 47 i=1,n
      if (pl(i)) 47,47,42
 42   sigi=sqrt(abs(z(l)))
      r(i)=r(i)*z(l)
      if (eps) 44,44,43
 43   sigma(i)=sigi
 44   if ((a(i).lt.amx(i).or.da(i).le.0.).and.(a(i).gt.amn(i).or.da(i).g
     1e.0.)) go to 46
      akap=abs(da(i)/sigi)
      if (akap-afix) 46,46,45
 45   afix=akap
      ifix=i
      ifix1=i
 46   i1=i1+1
      l=l+i1
 47   continue
      if (ifix) 48,50,48
 48   pl(ifix)=-1.
 49   fixflg=fixflg+1.
      fi=0.
c-----repeat calculation of theoretical step after fixing each parameter
      go to 19
c-----calculate step correction factor
 50   alambd=1.
      akappa=0.
      imax=0
      do 60 i=1,n
      if (pl(i)) 60,60,51
 51   bm=amx(i)-a(i)
      abi=a(i)+pl(i)
      abm=amx(i)
      if (da(i)) 52,52,53
 52   bm=a(i)-amn(i)
      abi=a(i)-pl(i)
      abm=amn(i)
 53   bi=pl(i)
      if (bi-bm) 55,55,54
 54   bi=bm
      abi=abm
 55   if (abs(da(i))-bi) 58,58,56
 56   al=abs(bi/da(i))
      if (alambd-al) 58,58,57
 57   imax=i
      aimax=abi
      alambd=al
 58   akap=abs(da(i)/sigma(i))
      if (akap-akappa) 60,60,59
 59   akappa=akap
 60   continue
c-----calculate new corrected step
      gt=0.
      amb=1.e18
      if (alambd) 62,62,61
 61   amb=0.25/alambd
 62   continue
      do 67 i=1,n
      if (pl(i)) 67,67,63
 63   if (nn2-n2) 66,66,64
 64   if (abs(da(i)/pl(i))-amb) 66,65,65
 65   pl(i)=4.*pl(i)
      t1=4.
 66   da(i)=da(i)*alambd
      gt=gt+da(i)*g(i)
 67   continue
c-----check if minimum attained and set exit mode
      if (-gt.gt.sp.or.t1.ge.1..or.alambd.ge.1.) go to 68
      endflg=-1.
 68   if (endflg) 85,69,69
 69   if (akappa-abs(eps)) 70,75,75
 70   if (fixflg) 72,71,72
 71   endflg=1.
      go to 85
 72   if (endflg) 85,77,73
 73   if (ifix1) 85,85,76
 74   if (fi-fixflg) 76,76,77
 75   if (fixflg) 74,76,74
 76   fi=fi+1.
      endflg=0.
 85   if(endflg.eq.0..and.nn3.ge.n3) endflg=-3.
      if(endflg.gt.0..and.indflg(2).gt.0) endflg=-2.
      call monito (s,m,nn3,it,eps,gt,akappa,alambd)
      if (endflg) 83,79,83
c-----check if fixing on bound is correct
 77   endflg=1.
      fixflg=0.
      ifix1=0
      do 78 i=1,m
 78   pl(i)=pl0(i)
      indflg(2)=0
      go to 19
c-----next iteration
 79   endflg=0.
      do 80 i=1,n
      a(i)=a(i)+da(i)
 80   continue
      if (imax) 82,82,81
 81   a(imax)=aimax
 82   olds=s
      nn2=nn2+1
      nn3=nn3+1
      go to 3
 83   mc=endflg
      return
c-----entry for maximum liklehood
c      entry likelm(s,m,n1,n2,n3,eps,akappa,alambd,it,mc)
202     continue
      indflg(3)=1
      go to 1
c
* 84   format (1h1,43x,50hfunction minimisation by subroutine fumili/like
*     +lm./55x,26hin the following print-out/27x,'s = value of
*     +objective function,  ec = expected change in s during next iterati
*     +on',/34x,'kappa = estimated distance to minimum,  lambda = st
*     +ep length modifier',///)
 84   format (//3x,'****************************************************
     +**********************',/
     +3x,'*',11x,'function minimisation by subroutine fumili/likelm.',
     +9x,'  *',
     +/3x,'*',11x, '         in the following print-out',24x,'  *',
     +/3x,'*',72x,'*',
     +/3x,'* s = value of objective function',38x,'  *',
     +/3x,'* ec = expected change in s during next iteration',22x,'  *',
     +/3x,'* kappa = estimated distance to minimum',
     + 3x,'lambda = step length modifier','  *',
     +/3x,'*************************************************************
     +*************',///)
       end
c
      subroutine mconv (n)
c-----mconv inverts the positive definite packed symmetric matrix z
c-----by the square-root method
      parameter (npa=41,nd1=10000,nd2=4)
      parameter (nda=nd1*nd2,nex=nd1*nd2*4,nzz=npa*(npa+1)/2)
      common /z/ z(nzz)
      common /plu/ pl0(npa)/r/r(npa)
      common /endflg/ endflg,na,indflg(5)
c-----maximum real number and 10.*maximum relative precision on cdc6000
      data am,rp/1.e35,1.e-14/
      if (n.lt.1) return
      aps=sqrt(am/float(n))
      ap=1./(aps*aps)
      ir=0
      do 11 i=1,n
 1    ir=ir+1
      if (pl0(ir)) 1,1,2
 2    ni=i*(i-1)/2
      ii=ni+i
      k=n+1
      if (z(ii).le.rp*abs(r(ir)).or.z(ii).le.ap) go to 19
      z(ii)=1./sqrt(z(ii))
      nl=ii-1
 3    if (nl-ni) 5,5,4
 4    z(nl)=z(nl)*z(ii)
      if (abs(z(nl)).ge.aps) go to 16
      nl=nl-1
      go to 3
 5    if (i-n) 6,12,12
 6    k=k-1
      nk=k*(k-1)/2
      nl=nk
      kk=nk+i
      d=z(kk)*z(ii)
      c=d*z(ii)
      l=k
 7    ll=nk+l
      li=nl+i
      z(ll)=z(ll)-z(li)*c
      l=l-1
      nl=nl-l
      if (l-i) 9,9,7
 8    ll=nk+l
      li=ni+l
      z(ll)=z(ll)-z(li)*d
 9    l=l-1
      if (l) 10,10,8
 10   z(kk)=-c
      if (k-i-1) 11,11,6
 11   continue
 12   do 14 i=1,n
      do 14 k=i,n
      nl=k*(k-1)/2
      ki=nl+i
      d=0.
      do 13 l=k,n
      li=nl+i
      lk=nl+k
      d=d+z(li)*z(lk)
      nl=nl+l
 13   continue
      ki=k*(k-1)/2+i
      z(ki)=d
 14   continue
 15   return
 16   k=i+nl-ii
      ir=0
      do 18 i=1,k
 17   ir=ir+1
      if (pl0(ir)) 17,17,18
 18   continue
 19   pl0(ir)=-2.
      r(ir)=0.
      indflg(1)=ir
      go to 15
      end
      subroutine sgz (m,s)
c-----subroutine sgz sets up s(objective function),g(gradient of s) and
c-----z(approximate covariance matrix)
      parameter (npa=41,nd1=10000,nd2=4)
      parameter (nda=nd1*nd2,nex=nd1*nd2*4,nzz=npa*(npa+1)/2)
      common /g/ g(npa)/z/z(nzz)/a/a(npa)/df/df(npa)/ned/nt,ns/exda/ex
     1da(nex)/x/x(11)/pl/pl(npa)/endflg/endf6g,na,indflg(5)
      common/uprmon/ikk
      common/nnn/Nreal,Nbg1,Nbg2,Nt1
      we=1.0
      k=nt
      k2=1
      do 12 l1=1,k
      k1=k2
      nx=ns-2
      if (indflg(3)) 1,2,1
 1    nx=ns
      k1=k1-2
 2    continue
      do 3 i=1,nx
      ki=k1+1+i
      x(i)=exda(ki)
 3    continue
      call arithm (y)
      if(ikk.eq.2) then
      print 100,x(1),y,exda(k1),exda(k1+1)
  100 format(5x,4e15.4)
      endif
      if (indflg(3)) 4,6,4
 4    if (y) 13,13,5
c-----maximum liklehood
 5    continue
      if(l1.gt.Nreal.and.l1.le.Nt1) we=-1.0
      if(l1.gt.Nt1.and.l1.le.nt)    we=-1.0
      s=s-log(y)*we
      y=-y
      sig=y
      go to 7
c-----chi squared
 6    sig=exda(k2+1)
      y=y-exda(k1)
      s=s+((y/sig)**2)/2.
 7    continue
      n=0
      do 9 j=1,m
      if (pl(j)) 9,9,8
 8    n=n+1
      df(n)=df(j)/sig
      g(j)=g(j)+df(n)*(y/sig)*we
 9    continue
      l=1
      if (n.lt.1) go to 11
      do 10 i=1,n
      do 10 j=1,i
      z(l)=z(l)+df(i)*df(j)*we
      l=l+1
 10   continue
 11   k2=k2+ns
 12   continue
      return
c-----  -ve or zero y in maximum liklehood
 13   indflg(1)=1
      s=1.e10
      return
      end
      subroutine errorf (m)
c-----final error analysis for chisq.
      parameter (npa=41,nd1=10000,nd2=4)
      parameter (nda=nd1*nd2,nex=nd1*nd2*4,nzz=npa*(npa+1)/2)
      common /ned/ ns,np/x/x(11)/exda/exda(nex)/error/error(nda)/a/
     . a(npa)/df/df(npa)/z/z(nzz)
      print 3
      if (np.gt.7) print 4
      do 2 j=1,ns
      k1=np*(j-1)+1
      fun=exda(k1)
      sig=exda(k1+1)
      nx=np-2
      do 1 k=1,nx
      k2=k1+1+k
      x(k)=exda(k2)
 1    continue
c-----calculate dy/da"s for scal
      call arithm (y)
      call scal (m,er)
      xi=(fun-y)/sig
      xi=0.5*xi*xi
      er=sqrt(er)
      error(j)=er
      print 5,j,y,er,xi,(x(i),i=1,nx)
 2    continue
      return
c
 3    format (1h1,79herror analysis for each data point using final para
     +meter values (chisq only)   ////1h ,10x,5hpoint,8x,6hfitted,9x,10h
     +y standard,6x,12hcontribution,4x,14hx co-ordinates/1h ,11x,3hno.,8
     +x,8hy  value,8x,9hdeviation,7x,10hto chisq/2,6x,14hof data point./
     +/)
 4    format (1h+,86x,22h(printed in row order))
 5    format (1h ,10x,i3,2x,7(5x,e12.5),(/1h ,66x,4(5x,e12.5)))
      end
      subroutine scal (m,er)
c-----subroutine scal calculates er=variance of theoretical function y
      parameter (npa=41,nd1=10000,nd2=4)
      parameter (nda=nd1*nd2,nex=nd1*nd2*4,nzz=npa*(npa+1)/2)
      common /z/ z(nzz)/df/df(npa)
      common /plu/ pl(npa)
      er=0.
      n=0
      do 2 j=1,m
      if (pl(j)) 2,2,1
 1    n=n+1
      df(n)=df(j)
 2    continue
      if (n.eq.0) return
      do 6 i=1,n
      do 6 l=1,n
      if (i-l) 3,3,4
 3    k=l*(l-1)/2+i
      go to 5
 4    k=i*(i-1)/2+l
 5    er=er+z(k)*df(i)*df(l)
 6    continue
      return
      end
      subroutine monito (s,m,nn3,it,eps,gt,akappa,alambd)
c-----iteration progress output
      parameter (npa=41,nd1=10000,nd2=4)
      parameter (nda=nd1*nd2,nex=nd1*nd2*4,nzz=npa*(npa+1)/2)
      common /a/ a(npa)/sigma/sigma(npa)/r/r(npa)/pl/pl(npa)/plu/pl0(npa
     1)/endflg/endflg,na,indflg(5)/au/amx(npa)/al/amn(npa)
      common/uprmon/ikk
      if (it) 11,3,1
 1    if (nn3) 4,4,2
 2    if (nm) 3,4,4
 3    if (endflg) 4,12,4
c-----printer carriage control
 4    i1=6
      if (m.gt.6) i1=5
      if (m.gt.12) i1=4
      if (m.gt.23) i1=1
c   non-ansi carriage control suppressed on ibm
      if(i1.gt.1) i1=0
      print 19,i1,nn3,s,gt,akappa,alambd
      if(ikk.ge.1) print 191
c***************************************************
c-----record parameters to hard disk
      open(13,file='xaram_tmp.res',status='unknown')
      write(13,116) na
      write(13,117)(j,a(j),pl(j),amn(j),amx(j),j=1,na)
  116 format(5x,i5)
  117 format(i5,f15.5,3f15.3)
      close(13)
c***************************************************
      do 10 i=1,m
      if (pl(i)) 9,9,5
 5    if (pl0(i)) 8,7,6
 6    continue
      if(ikk.ge.1) print 20,i,a(i),sigma(i),r(i)
      go to 10
    7 continue
      if(ikk.ge.1) print 21,i,a(i),sigma(i),r(i)
      go to 10
 8    if (pl0(i).ge.-1.) go to 7
      if(ikk.ge.1) print 22,i,a(i)
      go to 10
    9 continue
      if(ikk.ge.1) print 23,i,a(i)
 10   continue
 11   nm=-it
 12   nm=nm+1
      if (endflg) 13,14,14
 13   i=-endflg
      go to (15,16,17,18), i
 14   return
 15   print 24
      go to 14
 16   print  25
      go to 14
 17   print  26
      go to 14
 18   print  27
      go to 14
c
* 19   format (i1,13hiteration no.,i3,5h, s= ,e12.5,7h, ec = ,e12.5,9h, k
*     +appa= ,e12.5,10h, lambda= ,e12.5)
  19  format (/1x,i2,' **********',2x,'iteration no.',i3,/4x,'s= ',f8.3,
     +4x,'ec = ',f8.3,4x,'kappa= ',f8.3,4x,'lambda= ',f8.3)
 191  format (/1h ,6x,9hparameter,6x,9hparameter,9x,8hstandard,8x,
     +11hcorrelation/1h ,8x,6hnumber,9x,5hvalue,11x,9
     +hdeviation,9x,6hfactor/)
 20   format (1h ,8x,i3,4x,3(5x,e12.5))
 21   format (1h ,8x,i3,4x,3(5x,e12.5),22h parameter on boundary)
 22   format (1h ,8x,i3,9x,e12.5,5x,24hinfinite error estimated)
 23   format (1h ,8x,i3,9x,e12.5,5x,20hthis parameter fixed)
 24   format (1h0,65hminimisation terminated as no further decrease in s
     + is obtainable/1h1)
 25   format (1h0,52hminimisation terminated as infinite errors estimate
     +d/1h1)
 26   format (1h0,50hminimisation terminated as iteration limit reached/
     +1h1)
 27   format (1h0,82hminimisation terminated as negative or zero y encou
     +ntered as logarithmic arguement/1h1)
      end
c*****************************************************
c     file vfll
c*****************************************************
      subroutine vfll(amx,amn,n,edd)
      parameter (npa=41,nd1=10000,nd2=4)
      dimension amx(npa),amn(npa)
      common/pl/pl(npa)
      do 1 i=1,n
      if(amx(i).lt.amn(i)) then
      write(6,100)i
      go to 1
      endif
      if(amx(i).eq.0.and.amn(i).eq.0.) then
      amx(i)=edd
      amn(i)=-edd
      endif
    1 continue
      do 2 i=1,n
      if(amx(i).eq.0.) write (6,101)i
      if(amn(i).eq.0.) write (6,102)i
    2 continue
  100 format(10x,'maximum less then minimum for parametr',i3)
  102 format(10x,'warning: minimum is 0. for parametr',i3)
  101 format(10x,'warning: maximum is 0. for parametr',i3)
      return
      end
*
**
*
      subroutine genev
c--      called from - main program
c --     purpose - generates event (pcm and wt ) using amass and tecm
      common/util/np,tecm,amass(18),pcm(5,18),wt
c--       util2 contains further numbers useful to user,
c--            namely eff.massof particles 1-i, m**2, and delta sq.
c--       m**2 and delta sq. are indefinite if raubold-lynch method is u
      common/util2/ emm(18), emms(18), d2(18)
     +/shuffl/ rno(50)   ,ntnm4    ,ntm2     ,ntm1     ,qqcons(50) ,tir
c--       pcm1 is linear equiv. of pcm to avoid double indices
      dimension em(18),pd(18),ems(18),sm(18),ffq(18),pcm1(90)
      equivalence (nt,np),(amass(1),em(1)),(pcm1(1),pcm(1,1))
c   ffq(n)=pi * (twopi)**(n-2) / (n-2)factorial
      data  ffq/0.,3.141592, 19.73921, 62.01255, 129.8788, 204.0131,
     +                       256.3704, 268.4705, 240.9780, 189.2637,
     +                       132.1308,  83.0202,  47.4210,  24.8295,
     +                        12.0006,   5.3858,   2.2560,   0.8859/
      data etc, init, twopi / 0. , 0 , 6.2831853073 /
      if(tecm-etc) 115,455,115
c        initialization
  115 if(init.gt.0) goto 300
      init=1
      ntm1=nt-1
      ntm2=nt-2
      ntp1=nt+1
      ntnm4 = 3*nt - 4
      emm(1)=em(1)
      tm=0.0
      do 200 i=1,nt
      ems(i)=em(i)**2
      tm=tm+em(i)
 200  sm(i)=tm
c        constants depending on tecm
  300 continue
      tecmtm=tecm-tm
      etc=tecm
      emm(nt)=tecm
	kgenev=2
      if(kgenev.gt.1) goto 400
c        constant cross section as function of tecm
      emmax=tecmtm+em(1)
      emmin=0.0
      wtmax=1.0
      do 350 i=2,nt
      emmin=emmin+em(i-1)
      emmax=emmax+em(i)
  350 wtmax=wtmax*pdk(emmax,emmin,em(i))
      wtmaxq=1.0/wtmax
      goto 455
c--      fermi energy dependence for cross section
  400 wtmaxq=tecmtm**ntm2*ffq(nt) / tecm
c        calculation of wt based on effective masses emm
c--       rangnr fills rno with 3*nt-4 random numbers,
  455 call rangnr
c--            of which the first nt-2 are ordered.
      if(ntm2) 900,509,460
  460 continue
      do 508 j=2,ntm1
  508 emm(j)=rno(j-1)*(tecmtm)+sm(j)
  509 wt=wtmaxq
      ir=ntm2
      do 530 i=1,ntm1
      pd(i)=pdk(emm(i+1),emm(i),em(i+1))
  530 wt=wt*pd(i)
c--       complete specification of event (raubold-lynch method)
      pcm(1,1)=0.0
      pcm(2,1)=pd(1)
      pcm(3,1)=0.0
      do 570 i=2,nt
      pcm(1,i)=0.0
      pcm(2,i) = -pd(i-1)
      pcm(3,i)=0.0
      ir=ir+1
      bang=twopi*rno(ir)
      cb=cos(bang)
      sb=sin(bang)
      ir=ir+1
      c=2.0*rno(ir)-1.0
      s=sqrt(1.0-c*c)
      if(i.eq.nt) goto 1567
      esys=sqrt(pd(i)**2+emm(i)**2)
      beta=pd(i)/esys
      gama=esys/emm(i)
      do 568 j=1,i
      ndx = 5*j - 5
      aa= pcm1(ndx+1)**2 + pcm1(ndx+2)**2 + pcm1(ndx+3)**2
      pcm1(ndx+5) = sqrt(aa)
      pcm1(ndx+4) = sqrt(aa+ems(j))
      call rotes2(c,s,cb,sb,pcm,j)
      psave = gama*(pcm(2,j)+beta*pcm(4,j))
  568 pcm(2,j)=psave
      goto 570
 1567 do 1568 j=1,i
      aa=pcm(1,j)**2 + pcm(2,j)**2 + pcm(3,j)**2
      pcm(5,j)=sqrt(aa)
      pcm(4,j)=sqrt(aa+ems(j))
      call rotes2(c,s,cb,sb,pcm,j)
 1568 continue
  570 continue
  900 continue
      return
      end
      function pdk(a,b,c)
c=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
c--  called from -  genev
c     pdk = sqrt(abs(a*a+(b*b-c*c)**2/(a*a) - 2.0*(b*b+c*c)))/2.0
      a2 = a*a
      b2 = b*b
      c2 = c*c
      pdk = 0.5*sqrt(abs(a2 + (b2-c2)**2/a2 - 2.0*(b2+c2)))
      return
      end
      subroutine rangnr
c--       called from genev.  assembles random numbers for one event.
c--       it includes the quasirandom generator qqrndm,
c--       and uses a pseudorandom generator (rndm) for shuffling
      common
     +/shuffl/ rno(50)   ,ntnm4    ,ntm2     ,ntm1     ,qqcons(50) ,tir
      call nran(rno,ntnm4)
c--       order the first ntm2 random numbers
c--         two is a special case (faster)
      if(ntm2 - 2) 200,160,110
  110 km1 = ntm2 - 1
      do 150 i= 1, km1
      iquit = 0
      ni = ntm2 - i
      do 140 j= 1, ni
      if(rno(j) - rno(j+1)) 140,140,120
  120 sav = rno(j)
      rno(j) = rno(j+1)
      rno(j+1) = sav
      iquit = 1
  140 continue
      if(iquit) 200,200,150
  150 continue
      goto 200
  160 if(rno(1).le.rno(2)) goto 200
      sav = rno(1)
      rno(1) = rno(2)
      rno(2) = sav
  200 continue
      return
      end
      subroutine rotes2(c,s,c2,s2,pr,i)
c--  called from - genev
c         this subroutine now does two rotations (xy and xz)
      dimension pr(50)
      k1 = 5*i - 4
      k2 = k1 + 1
      sa = pr(k1)
      sb = pr(k2)
      a      = sa*c - sb*s
      pr(k2) = sa*s + sb*c
      k2 = k2 + 1
      b = pr(k2)
      pr(k1) = a*c2 - b*s2
      pr(k2) = a*s2 + b*c2
      return
      end
*
      function xatan(y,x)
c  get value of phi between 0 and twopi
c
      xatan = 0.
      if(x.eq.0.0.and.y.eq.0.0) return
      xatan = atan2(y,x)
      if(xatan.lt.0.0) then
      xatan =xatan+3.14159267*2
      endif
      return
      end
*
*    +******************************************************************
*     *                                                                *
*     *             end of data analysis  program v h1                 *
*     *                                                                *
*     *                                 tue oct  14 11:25 1997         *
*     *                                                                *
*     ******************************************************************
*
