      subroutine getorb (iz, ihole, xion, iunf, norb, norbco, iorb,
     1                  iholep, nqn, nk, xnel, xnval, xmag)
c     Gets orbital data for chosen element.  Input is:
c       iz - atomic number of desired element,
c       ihole - index of core-hole orbital
c       xion  - ionicity (usually zero)
c     other arguments are output.
c       norb - total number of orbitals
c       norbco - number of core orbitals
c       iorb - index of orbital for making projections (last occupied)
c       iholep - index of core hole orbital in compacted list
c       nqn - principal quantum number for each orbital
c       nk - quantum number kappa for each orbital
c       xnel - occupation for each orbital
c       xnval - valence occupation for each orbital
c       xmag - spin magnetization for each orbital
c     Feel free to change occupation numbers for element of interest.
c     ival(i) is necessary only for partly nonlocal exchange model.
c     iocc(i) and ival(i) can be fractional
c     But you have to keep the sum of iocc(i) equal to nuclear charge.
c     Also ival(i) should be equal to iocc(i) or zero.
c     Otherwise you have to change this subroutine or contact authors
c     for help.

      implicit double precision (a-h, o-z)

c     Written by Steven Zabinsky, July 1989
c     modified (20 aug 1989)  table increased to at no 99
c     Recipe for final state configuration is changed. Valence
c     electron occupations are added. ala 17.1.1996

c     Table for each element has occupation of the various levels.
c     The order of the levels in each array is:

c     element  level     principal qn (nqn), kappa qn (nk)
c           1  1s        1  -1
c           2  2s        2  -1
c           3  2p1/2     2   1
c           4  2p3/2     2  -2
c           5  3s        3  -1
c           6  3p1/2     3   1
c           7  3p3/2     3  -2
c           8  3d3/2     3   2
c           9  3d5/2     3  -3
c          10  4s        4  -1
c          11  4p1/2     4   1
c          12  4p3/2     4  -2
c          13  4d3/2     4   2
c          14  4d5/2     4  -3
c          15  4f5/2     4   3
c          16  4f7/2     4  -4
c          17  5s        5  -1
c          18  5p1/2     5   1
c          19  5p3/2     5  -2
c          20  5d3/2     5   2
c          21  5d5/2     5  -3
c          22  5f5/2     5   3
c          23  5f7/2     5  -4
c          24  6s        6  -1
c          25  6p1/2     6   1
c          26  6p3/2     6  -2
c          27  6d3/2     6   2
c          28  6d5/2     6  -3
c          29  7s        7  -1

      dimension nqn(30), nk(30), xnel(30), xnval(30), xmag(30)
      dimension kappa (29)
      real iocc, ival, ispn
      dimension iocc (100, 29), ival (100, 29), ispn (100, 29)
      dimension nnum (29), iorb(-4:3)
      character*512 slog

c     kappa quantum number for each orbital
c     k = - (j + 1/2)  if l = j - 1/2
c     k = + (j + 1/2)  if l = j + 1/2
      data kappa /-1,-1, 1,-2,-1,   1,-2, 2,-3,-1,   1,-2, 2,-3, 3,
     1            -4,-1, 1,-2, 2,  -3, 3,-4,-1, 1,  -2, 2,-3,-1/

c     principal quantum number (energy eigenvalue)
      data nnum  /1,2,2,2,3,  3,3,3,3,4,  4,4,4,4,4,
     1            4,5,5,5,5,  5,5,5,6,6,  6,6,6,7/

c     occupation of each level for z = 1, 99
      data (iocc( 1,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 1,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn( 1,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc( 2,i),i=1,29)  /2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 2,i),i=1,29)  /2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn( 2,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc( 3,i),i=1,29)  /2,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 3,i),i=1,29)  /0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn( 3,i),i=1,29)  /0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc( 4,i),i=1,29)  /2,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 4,i),i=1,29)  /0,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn( 4,i),i=1,29)  /0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc( 5,i),i=1,29)  /2,2,1,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 5,i),i=1,29)  /0,2,1,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn( 5,i),i=1,29)  /0,0,1,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

c     data (iocc( 6,i),i=1,29)  /2,2,2,0,0,  0,0,0,0,0,  0,0,0,0,0,
      data (iocc( 6,i),i=1,29)  /2,1,2,1,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
c     data (ival( 6,i),i=1,29)  /0,2,2,0,0,  0,0,0,0,0,  0,0,0,0,0,
      data (ival( 6,i),i=1,29)  /0,1,2,1,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn( 6,i),i=1,29)  /0,0,1,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc( 7,i),i=1,29)  /2,2,2,1,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 7,i),i=1,29)  /0,2,2,1,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn( 7,i),i=1,29)  /0,0,0,1,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc( 8,i),i=1,29)  /2,2,2,2,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 8,i),i=1,29)  /0,2,2,2,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn( 8,i),i=1,29)  /0,0,0,1,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc( 9,i),i=1,29)  /2,2,2,3,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 9,i),i=1,29)  /0,2,2,3,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn( 9,i),i=1,29)  /0,0,0,1,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(10,i),i=1,29)  /2,2,2,4,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(10,i),i=1,29)  /0,0,2,4,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(10,i),i=1,29)  /0,0,0,1,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(11,i),i=1,29)  /2,2,2,4,1,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(11,i),i=1,29)  /0,0,2,4,1,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(11,i),i=1,29)  /0,0,0,0,1,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(12,i),i=1,29)  /2,2,2,4,1,  1,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(12,i),i=1,29)  /0,0,0,0,1,  1,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(12,i),i=1,29)  /0,0,0,0,1,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(13,i),i=1,29)  /2,2,2,4,2,  1,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(13,i),i=1,29)  /0,0,0,0,2,  1,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(13,i),i=1,29)  /0,0,0,0,0,  1,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(14,i),i=1,29)  /2,2,2,4,2,  2,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(14,i),i=1,29)  /0,0,0,0,2,  2,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(14,i),i=1,29)  /0,0,0,0,0,  1,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(15,i),i=1,29)  /2,2,2,4,2,  2,1,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(15,i),i=1,29)  /0,0,0,0,2,  2,1,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(15,i),i=1,29)  /0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(16,i),i=1,29)  /2,2,2,4,2,  2,2,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(16,i),i=1,29)  /0,0,0,0,2,  2,2,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(16,i),i=1,29)  /0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(17,i),i=1,29)  /2,2,2,4,2,  2,3,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(17,i),i=1,29)  /0,0,0,0,2,  2,3,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(17,i),i=1,29)  /0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(18,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(18,i),i=1,29)  /0,0,0,0,2,  2,4,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(18,i),i=1,29)  /0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(19,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(19,i),i=1,29)  /0,0,0,0,2,  2,4,0,0,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(19,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(20,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(20,i),i=1,29)  /0,0,0,0,0,  2,4,0,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(20,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(21,i),i=1,29)  /2,2,2,4,2,  2,4,1,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(21,i),i=1,29)  /0,0,0,0,0,  2,4,1,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(21,i),i=1,29)  /0,0,0,0,0,  0,0,1,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(22,i),i=1,29)  /2,2,2,4,2,  2,4,2,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(22,i),i=1,29)  /0,0,0,0,0,  2,4,2,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(22,i),i=1,29)  /0,0,0,0,0,  0,0,2,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(23,i),i=1,29)  /2,2,2,4,2,  2,4,3,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(23,i),i=1,29)  /0,0,0,0,0,  2,4,3,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(23,i),i=1,29)  /0,0,0,0,0,  0,0,3,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(24,i),i=1,29)  /2,2,2,4,2,  2,4,4,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(24,i),i=1,29)  /0,0,0,0,0,  2,4,4,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(24,i),i=1,29)  /0,0,0,0,0,  0,0,4,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(25,i),i=1,29)  /2,2,2,4,2,  2,4,4,1,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(25,i),i=1,29)  /0,0,0,0,0,  0,0,4,1,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(25,i),i=1,29)  /0,0,0,0,0,  0,0,4,1,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(26,i),i=1,29)  /2,2,2,4,2,  2,4,4,2,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(26,i),i=1,29)  /0,0,0,0,0,  0,0,4,2,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(26,i),i=1,29)  /0,0,0,0,0,  0,0,2,2,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(27,i),i=1,29)  /2,2,2,4,2,  2,4,4,3,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(27,i),i=1,29)  /0,0,0,0,0,  0,0,4,3,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(27,i),i=1,29)  /0,0,0,0,0,  0,0,0,3,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(28,i),i=1,29)  /2,2,2,4,2,  2,4,4,4,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(28,i),i=1,29)  /0,0,0,0,0,  0,0,4,4,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(28,i),i=1,29)  /0,0,0,0,0,  0,0,0,1,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(29,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(29,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(29,i),i=1,29)  /0,0,0,0,0,  0,0,0,1,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(30,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(30,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(30,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(31,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(31,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,2,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(31,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(32,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(32,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,2,  2,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(32,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(33,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,1,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(33,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,1,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(33,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,1,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(34,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,2,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(34,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,2,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(34,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,1,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(35,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,3,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(35,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,3,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(35,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,1,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(36,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(36,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,4,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(36,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,1,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(37,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(37,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,4,0,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(37,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(38,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(38,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  2,4,0,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(38,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(39,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,1,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(39,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  2,4,1,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(39,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,1,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(40,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,2,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(40,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  2,4,2,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(40,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,2,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(41,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(41,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  2,4,4,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(41,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,3,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(42,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,1,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(42,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  2,4,4,1,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(42,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(43,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,1,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(43,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,1,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(43,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,1,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(44,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,3,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(44,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,3,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(44,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,2,2,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(45,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,4,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(45,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,4,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(45,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,2,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(46,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(46,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(46,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,1,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(47,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(47,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(47,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(48,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(48,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(48,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(49,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,1,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(49,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,
     1                           0,2,1,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(49,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,1,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(50,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(50,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,
     1                           0,2,2,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(50,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,1,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(51,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,1,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(51,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,
     1                           0,2,2,1,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(51,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,1,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(52,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,2,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(52,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,2,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(52,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,1,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(53,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,3,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(53,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,3,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(53,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,1,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(54,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,4,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(54,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,4,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(54,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,1,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(55,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,4,0,  0,0,0,1,0,  0,0,0,0/
      data (ival(55,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,4,0,  0,0,0,1,0,  0,0,0,0/
      data (ispn(55,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,1,0,  0,0,0,0/

      data (iocc(56,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(56,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ispn(56,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,1,0,  0,0,0,0/

      data (iocc(57,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(57,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(57,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,1,  0,0,0,0,0,  0,0,0,0/

      data (iocc(58,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,1,
     1                           0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(58,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,1,
     1                           0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(58,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,1,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(59,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,2,
     1                           0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(59,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,
     1                           0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(59,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(60,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,3,
     1                           0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(60,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,3,
     1                           0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(60,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,3,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(61,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,4,
     1                           0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(61,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,
     1                           0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(61,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(62,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,5,
     1                           0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(62,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,5,
     1                           0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(62,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,5,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(63,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(63,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(63,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(64,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           1,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(64,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           1,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(64,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           1,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(65,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           2,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(65,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           2,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(65,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,
     1                           2,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(66,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           3,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(66,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           3,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(66,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,
     1                           3,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(67,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           4,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(67,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           4,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(67,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           4,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(68,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           5,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(68,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           5,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(68,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           3,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(69,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           6,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(69,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           6,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(69,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           2,0,0,0,0,  0,0,0,2,0,  0,0,0,0/

      data (iocc(70,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           7,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(70,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           7,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(70,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           1,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc(71,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(71,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           8,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(71,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,1,  0,0,0,0,0,  0,0,0,0/

      data (iocc(72,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,2,  0,0,0,2,0,  0,0,0,0/
      data (ival(72,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           8,0,2,4,2,  0,0,0,2,0,  0,0,0,0/
      data (ispn(72,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,2,  0,0,0,0,0,  0,0,0,0/

      data (iocc(73,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,3,  0,0,0,2,0,  0,0,0,0/
      data (ival(73,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           8,0,0,0,3,  0,0,0,2,0,  0,0,0,0/
      data (ispn(73,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,3,  0,0,0,0,0,  0,0,0,0/

      data (iocc(74,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,3,  1,0,0,2,0,  0,0,0,0/
c    1                           8,2,2,4,4,  0,0,0,2,0,  0,0,0,0/
      data (ival(74,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           8,0,0,0,3,  1,0,0,2,0,  0,0,0,0/
c    1                           8,0,0,0,4,  0,0,0,2,0,  0,0,0,0/
      data (ispn(74,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  0,0,0,0,0,  0,0,0,0/

      data (iocc(75,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  1,0,0,2,0,  0,0,0,0/
      data (ival(75,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  1,0,0,2,0,  0,0,0,0/
      data (ispn(75,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  1,0,0,0,0,  0,0,0,0/

      data (iocc(76,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  2,0,0,2,0,  0,0,0,0/
      data (ival(76,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  2,0,0,2,0,  0,0,0,0/
      data (ispn(76,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,2,  2,0,0,0,0,  0,0,0,0/

      data (iocc(77,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  3,0,0,2,0,  0,0,0,0/
      data (ival(77,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  3,0,0,2,0,  0,0,0,0/
      data (ispn(77,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  3,0,0,0,0,  0,0,0,0/

      data (iocc(78,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  5,0,0,1,0,  0,0,0,0/
      data (ival(78,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  5,0,0,1,0,  0,0,0,0/
      data (ispn(78,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  2,0,0,0,0,  0,0,0,0/

      data (iocc(79,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,1,0,  0,0,0,0/
      data (ival(79,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  6,0,0,1,0,  0,0,0,0/
      data (ispn(79,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  1,0,0,0,0,  0,0,0,0/

      data (iocc(80,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,0,  0,0,0,0/
      data (ival(80,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  6,0,0,2,0,  0,0,0,0/
      data (ispn(80,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,1,0,  0,0,0,0/

      data (iocc(81,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,1,  0,0,0,0/
      data (ival(81,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  6,0,0,2,1,  0,0,0,0/
      data (ispn(81,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,1,  0,0,0,0/

      data (iocc(82,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  0,0,0,0/
      data (ival(82,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  6,0,0,2,2,  0,0,0,0/
      data (ispn(82,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,1,  0,0,0,0/

      data (iocc(83,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  1,0,0,0/
      data (ival(83,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  6,0,0,2,2,  1,0,0,0/
      data (ispn(83,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  1,0,0,0/

      data (iocc(84,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  2,0,0,0/
      data (ival(84,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  6,0,0,2,2,  2,0,0,0/
      data (ispn(84,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  1,0,0,0/

      data (iocc(85,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  3,0,0,0/
      data (ival(85,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,2,  3,0,0,0/
      data (ispn(85,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  1,0,0,0/

      data (iocc(86,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,0,0,0/
      data (ival(86,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,2,  4,0,0,0/
      data (ispn(86,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  1,0,0,0/

      data (iocc(87,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,0,0,1/
      data (ival(87,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,2,  4,0,0,1/
      data (ispn(87,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,1/

      data (iocc(88,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,0,0,2/
      data (ival(88,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,2,  4,0,0,2/
      data (ispn(88,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,1/

      data (iocc(89,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,1,0,2/
      data (ival(89,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,2,  4,1,0,2/
      data (ispn(89,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,1,0,0/

      data (iocc(90,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,2,0,2/
      data (ival(90,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,2,  4,2,0,2/
      data (ispn(90,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,2,0,0/

      data (iocc(91,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,2,0,2,2,  4,1,0,2/
      data (ival(91,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,2,0,0,2,  4,1,0,2/
      data (ispn(91,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,2,0,0,0,  0,0,0,0/

      data (iocc(92,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,3,0,2,2,  4,1,0,2/
      data (ival(92,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,3,0,0,2,  4,1,0,2/
      data (ispn(92,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,1.5,0,0,0,  0,0,0,0/

      data (iocc(93,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,4,0,2,2,  4,1,0,2/
      data (ival(93,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,4,0,0,2,  4,1,0,2/
      data (ispn(93,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,4,0,0,0,  0,0,0,0/

      data (iocc(94,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,0,2,2,  4,0,0,2/
      data (ival(94,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,0,0,2,  4,0,0,2/
      data (ispn(94,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,5,0,0,0,  0,0,0,0/

      data (iocc(95,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,1,2,2,  4,0,0,2/
      data (ival(95,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,1,0,2,  4,0,0,2/
      data (ispn(95,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,5,1,0,0,  0,0,0,0/

      data (iocc(96,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,2,2,2,  4,0,0,2/
      data (ival(96,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,2,0,2,  4,0,0,2/
      data (ispn(96,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,5,2,0,0,  0,0,0,0/

      data (iocc(97,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,3,2,2,  4,0,0,2/
      data (ival(97,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,3,0,2,  4,0,0,2/
      data (ispn(97,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,3,3,0,0,  0,0,0,0/

      data (iocc(98,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,4,2,2,  4,0,0,2/
      data (ival(98,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,4,0,2,  4,0,0,2/
      data (ispn(98,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,1,4,0,0,  0,0,0,0/

      data (iocc(99,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,5,2,2,  4,0,0,2/
      data (ival(99,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,5,0,2,  4,0,0,2/
      data (ispn(99,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,4,0,0,  0,0,0,0/

      data (iocc(100,i),i=1,29) /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,6,2,2,  4,0,0,2/
      data (ival(100,i),i=1,29) /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,6,0,2,  4,0,0,2/
      data (ispn(100,i),i=1,29) /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,3,0,0,  0,0,0,0/

      if (iz .lt. 1  .or.  iz .gt. 99)  then
    8    format(' Atomic number ', i5, ' not available.')
         write(slog,8)  iz
         call wlog(slog)
         call par_stop('GETORB-0')
      endif

      ion = nint(xion)
      delion=xion-ion
      index = iz - ion
      ilast = 0
      iscr = 0
      iion = 0
      iholep = ihole

c     find last occupied orbital (ilast) and iion for delion.ge.0
      do 30 i=29,1,-1
         if (iion.eq.0 .and. iocc(index,i).gt.delion) iion=i
         if (ilast.eq.0 .and. iocc(index,i).gt.0) ilast=i
 30   continue

      if (ihole.gt.0) then
         if ( iocc(index,ihole) .lt. 1 ) then
           call wlog(' Cannot remove an electron from this level')
           call par_stop('GETORB-1')
         endif
      endif
      if (ihole.eq.ilast) then
         if ( iocc(index,ihole)-delion.lt.1) then
           call wlog(' Cannot remove an electron from this level')
           call par_stop('GETORB-1')
        endif
      endif

c        the recipe for final state atomic configuration is changed
c        from iz+1 prescription, since sometimes it changed occupation
c        numbers in more than two orbitals. This could be consistent
c        only with s02=0.0. New recipe remedy this deficiency.

c     find where to put screening electron
      index1 = index + 1
      do 10  i = 1, 29
 10   if (iscr.eq.0 .and. (iocc(index1,i)-iocc(index,i)).gt.0.5) iscr=i
c     special case of hydrogen like ion
c     if (index.eq.1) iscr=2

c     find where to add or subtract charge delion (iion).
c     if (delion .ge. 0) then
c        removal of electron charge
c        iion is already found
      if (delion .lt. 0) then
c        addition of electron charge
         iion = iscr
c        except special cases
         if (ihole.ne.0 .and.
     1       iocc(index,iscr)+1-delion.gt.2*abs(kappa(iscr))) then
             iion = ilast
             if (ilast.eq.iscr .or. iocc(index,ilast)-delion.gt.
     1                          2*abs(kappa(ilast)) ) iion = ilast + 1
         endif
      endif

      norb = 0
      do 19 i=-4, 3
 19   iorb(i) = 0
      do 20  i = 1, 29
         if (iocc(index,i).gt.0 .or. (i.eq.iscr .and. ihole.gt.0)
     1       .or. (i.eq.iion .and. iocc(index,i)-delion.gt.0))  then
            if (i.ne.ihole .or. iocc(index,i).ge.1) then
               norb = norb + 1
               nqn(norb) = nnum(i)
               nk(norb)  = kappa(i)
               xnel(norb) = iocc(index,i)
               if (i.eq.ihole) then
                  xnel(norb) = xnel(norb) - 1
                  iholep = norb
               endif
               if (i.eq.iscr .and. ihole.gt.0)  xnel(norb)=xnel(norb)+1
               xnval(norb)= ival(index,i)
               if ((kappa(i).eq.-4 .or. kappa(i).eq.3) .and. iunf.eq.0)
     1           xnval(norb) = 0
               xmag(norb) = ispn(index,i)
               iorb(nk(norb)) = norb
               if (i.eq.ihole .and. xnval(norb).ge.1)
     1                         xnval(norb) = xnval(norb) - 1
               if (i.eq.iscr .and. ihole.gt.0)
     1                         xnval(norb) = xnval(norb) + 1
               if (i.eq.iion)  xnel(norb) = xnel(norb) - delion
               if (i.eq.iion)  xnval(norb) = xnval(norb) - delion
            endif
         endif
   20 continue
      norbco = norb

c     check that all occupation numbers are within limits
      do 50 i = 1, norb
         if ( xnel(i).lt.0 .or.  xnel(i).gt.2*abs(nk(i)) .or.
     1       xnval(i).lt.0 .or. xnval(i).gt.2*abs(nk(i)) ) then
            write (slog,55) i
   55       format(' error in getorb.f. Check occupation number for ',
     1      i3, '-th orbital. May be a problem with ionicity.')
            call wlog(slog)
            call par_stop('GETORB-99')
         endif
  50  continue
c      do 60 i=1,norb
c60    xnval(i) = 0.0d0
c60    xnval(i) = xnel(i)

      return
      end


      SUBROUTINE eqwidtbplatt(lmin,lmax,eqwidth)
*
*-----------------------------------------------------------------------
*
* eqwidtbplatt computes equivalent width for eqwidt, in PP geometry.
*  06/07-2000  BPz
*
*-----------------------------------------------------------------------
*
      include 'spectrum.inc'
*
      INTEGER    MAXNL
      PARAMETER (MAXNL=200)
      INTEGER    NLBL
      PARAMETER (NLBL=100)
*
      CHARACTER*20  LELE(100)
      character*50 mcode
      DIMENSION ION(100),SRXLAL(2*MAXNL),
     &          GFELOG(100),ABUND(100),ETAK(2*MAXNL),ETAR(ndp*2*MAXNL),
     &          ETAD(ndp),XC(ndp),CHIE(100),UTREC(103)
      dimension fluxme(nlbl)
      real mum,eqwidth
      doubleprecision XL1,XL2
      doubleprecision XLBEG,XLEND,DEL,XLB(100),XL(100),XLAL(2*MAXNL)
      COMMON/ATMOS/ T(NDP),PE(NDP),PG(NDP),XI(NDP),MUM(NDP),RO(NDP),
     &  nnNTAU
*
      COMMON /CTRAN/X(NDP),S(NDP),BPLAN(NDP),XJ(NDP),HFLUX(NDP),XK(NDP)
     & ,FJ(NDP),SOURCE(NDP),TAUS(NDP),DTAUS(NDP),JTAU0,JTAU1,ISCAT
      COMMON/CSURF/ HSURF,Y1(NRAYS)
      COMMON/CANGLE/ NMY,XMY(nrays),XMY2(nrays),WMY(nrays)
      COMMON/TAUC/ TAU(ndp),DTAULN(ndp),NTAU
      COMMON/PIECES/ XL1,XL2,DEL,EPS,NMX,NLBLDU,IINT,XMYC,IWEAK
*
* extension for large number of wavelengths and lines (monster II)
      doubleprecision xlambda
      common/large/ xlambda(lpoint),maxlam,ABSO(NDP,lpoint),
     & absos(ndp,lpoint),absocont(ndp,lpoint)
*
      dimension fcfc(lpoint),y1cy1c(lpoint),
     & xlm(lpoint),jlcont(lpoint)

      logical findtau1,hydrovelo,first
      real velocity
      common/velo/velocity(ndp),hydrovelo
*
* NLBLDU is a dummy, real val. of NLBL is set as parameter
*
      DATA first/.true./
*
      if (first) then
* Initiate angle quadrature points and number of wavelengths
* per block (NLBL)
*
        NMY=NMX
        CALL GAUSI(NMY,0.,1.,WMY,XMY)
        DO 1 I=1,NMY
          XMY2(I)=XMY(I)*XMY(I)
    1   CONTINUE
*
* Initiate mode of calculation
* IINT =1  : intensity at MY=XMYC
* IINT =0  : flux
* XL1      : wavelength where syntetic spectrum starts
* XL2      : wavelength where syntetic spectrum stops
* DEL      : wavelength step
* IWEAK =1 : weak line approximation for L/KAPPA le. EPS
* note  XL2.gt.XL1
*
        iweak=0
        IF(IINT.GT.0) THEN
          NMY=NMY+1
          XMY(NMY)=XMYC
          WRITE(7,200) XMYC,XL1,XL2,DEL
        END IF
        IF(IINT.EQ.0) WRITE(7,201) XL1,XL2,DEL
        IF(IWEAK.GT.0) WRITE(7,202) EPS
        first=.false.
      endif
      profold=0.e0
      eqwidth=0.e0
*
* Read model atmosphere
*
      REWIND 14
      READ(14) MCODE,nlcont,xlm(1),BPLAN,XC,S,XI
      REWIND 14
      WRITE(7,203) MCODE(1:lenstr(mcode))
*
* Continuum calculations:
*
      do 1963 jc=1,nlcont
        READ(14) MCODE,idum,xlm(jc),BPLAN,XC,S,XI
        DO 9 K=1,NTAU
          X(K)=XC(K)
    9   CONTINUE
        CALL traneqplatt(0)
        Y1CY1C(jc)=Y1(NMY)
        FCFC(jc)=4.*HSURF
        IF(IINT.LE.0) WRITE(7,204) fcFC(jc),xlm(jc)
        IF(IINT.GT.0) WRITE(7,205) Y1Cy1c(jc),xlm(jc)
1963  continue
*
*
        DO 39 j=lmin,lmax
          xlsingle=xlambda(j)
          IF(IWEAK.LE.0.OR.IINT.LE.0) THEN
            DO 30 K=1,NTAU
* the continuum opacity is already included in abso
ccc              X(K)=XC(K)+ABSO(K,J)
              X(K)=ABSO(K,J)
              s(k)=absos(k,j)
              BPLAN(k)=BPL(T(k),xlsingle)
   30       CONTINUE
            CALL traneqplatt(0)
* interpolate continuum flux
            do 3691 jc=2,nlcont
              if(xlm(jc)-xlsingle.gt.0.) then
                jjc=jc-1
                goto 3692
              endif
3691        continue
3692        continue
	    if (nlcont.gt.1) then
              jjc=min(jjc,nlcont-1)
              fc=(fcfc(jjc+1)-fcfc(jjc))/
     &           (xlm(jjc+1)-xlm(jjc))*(xlsingle-xlm(jjc)) + fcfc(jjc)
              y1c=(y1cy1c(jjc+1)-y1cy1c(jjc))/
     &           (xlm(jjc+1)-xlm(jjc))*(xlsingle-xlm(jjc)) + y1cy1c(jjc)
	    else
              fc=fcfc(1)
              y1c=y1cy1c(1)
            endif
            PRF=4.*HSURF/FC
            IF(IINT.GT.0) then
              PRF=Y1(NMY)/Y1C
            endif
            PROF=1.-PRF
          ELSE
            DO 31 K=1,NTAU
              ETAD(K)=ABSO(K,J)
              IF(ETAD(K).GT.EPS) GOTO 32
   31       CONTINUE
            CALL TRANW(NTAU,TAU,XMYC,BPLAN,XC,ETAD,DELI)
            PROF=DELI/Y1C
            GOTO 39
   32       DO 33 K=1,NTAU
              X(K)=ABSO(K,J)
              s(k)=absos(k,j)
              BPLAN(k)=BPL(T(k),xlsingle)
   33       CONTINUE
            CALL traneqplatt(0)
* interpolate continuum flux
            do 3693 jc=2,nlcont
              if(xlm(jc)-xlsingle.gt.0.) then
                jjc=jc-1
                goto 3694
              endif
3693        continue
3694        continue
	    if (nlcont.gt.1) then
              jjc=min(jjc,nlcont-1)
              fc=(fcfc(jjc+1)-fcfc(jjc))/
     &           (xlm(jjc+1)-xlm(jjc))*(xlsingle-xlm(jjc)) + fcfc(jjc)
              y1c=(y1cy1c(jjc+1)-y1cy1c(jjc))/
     &           (xlm(jjc+1)-xlm(jjc))*(xlsingle-xlm(jjc)) + y1cy1c(jjc)
            else
              fc=fcfc(1)
              y1c=y1cy1c(1)
	    endif
            PRF=4.*HSURF/FC
cc            fluxme(j)=hsurf*4.
            IF(IINT.GT.0) then
              PRF=Y1(NMY)/Y1C
              fluxme(j)=y1(nmy)
            endif
            PROF=1.-PRF
          END IF
          eqwidth=eqwidth+(prof+profold)*del/2.
          profold=prof
*
39      CONTINUE
ccc      print 1111,eqwidth*1000.
1111    format(' eqwidth: ',f9.1,' mA')
        call clock
      RETURN
*
  100 FORMAT(4X,I1,6X,I3)
  207 FORMAT(' SPECTRUM CALCULATED FOR THE FOLLOWING ',I3,' LINES'
     &      /' ELEMENT LAMBDA XI(EV) LOG(GF) LOG(ABUND) LINE NO')
  208 FORMAT('   ',A2,I2,F9.2,F5.2,1X,F6.2,3X,F7.2,4X,I5)
  200 FORMAT(' INTENSITY SPECTRUM AT MU=',F6.2,' BETWEEN',F10.3,
     &      ' AND',F10.3,' A WITH STEP',F6.3,' A')
  201 FORMAT(' FLUX SPECTRUM BETWEEN',F10.3,' A AND ',F10.3,' A WITH',
     &       ' STEP',F6.3,' A')
  202 FORMAT(' ***WEAK LINE APPROX FOR L/KAPPA L.T.',F7.4)
  203 FORMAT(' MODEL ATMOSPHERE:',A)
  204 FORMAT(' CONTINUUM FLUX=',E12.4, ' AT ',f10.2,'AA')
  205 FORMAT(' CONTINUUM INTENSITY=',E12.4,' at ',f10.2,'AA')
  206 FORMAT(1X,10F8.4)
 2341 FORMAT(1X,'Block number: ',I8)
*
      END


c$Id: scatter.f,v 1.26 2007/01/30 14:50:27 bleicher Exp $
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine scatter(id1,id2,ssigtot,sqrts,ccolfac)
c
c  Revision : 1.0
c
cinput id1   : index of particle 1
cinput id2   : index of particle 2
cinput ssigtot: total cross section
cinput sqrts : $sqrt{s}$ of collision
cinput ccolfac : scale factor for color fluctuations
c
c  This subroutine performs the scattering/annihilation
c  of two particles  or the decay
c  of one particle in the incoming channel.
c
c  Structure of this routine:
c  \begin{enumerate}
c       \item transform to NN system for proper kinematics
c       \item get collision class and number of exit-channels
c       \item loop over exit-channels and get partial cross sections
c       \item select exit-channel
c       \item save information in case of pauli-blocking
c       \item call kinematics routines
c       \item call output routine for collision file
c  \end{enumerate}
c
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      implicit none

      include 'coms.f'
      include 'comres.f'
      include 'newpart.f'
      include 'options.f'
      include 'boxinc.f'

c local variables
      real*8 sqrts,ssigtot,sigpart,sigma(0:maxpsig),sigsum,sigfac
      real*8 e1,e2,lambda,colldens,ccolfac
      integer ind1,ind2,ityp1,ityp2,isigline,nCh,ii
      integer i,j,itot1,itot2,iso31,iso32
      integer id1,id2
chp counter for new loop
      integer ict
c     functions and subroutines
      integer collclass,isoit

c
c     make local copies of particle indices
      ind1=id1
      ind2=id2
c     increment collision-counter
      ctag=ctag+1

c     save total cross section in sigma(0)
      sigma(0)=ssigtot

c     initialize some arrays (definitions are listed in newpart.f)
      do 13 j=1,mprt
         do 12 i=1,5
            pnew(i,j)=0.0
 12      continue
         inew(j)=0
         leadfac(j)=1.d0
 13   continue

c if ind2 is less than 0, a collision with a wall takes place
      if (ind2.lt.0) then

         call file15out(ind1,ind2,sqrts,ssigtot,sigpart)

c solid < 1 then periodic boundary conditions
            if (solid.lt.1) then
                iline = 80
                if (ind2.eq.-1) then
                        rx(ind1)=rx(ind1)-lbox
                elseif (ind2.eq.-4) then
                        rx(ind1)=rx(ind1)+lbox
                elseif (ind2.eq.-2) then
                        ry(ind1)=ry(ind1)-lbox
                elseif (ind2.eq.-5) then
                        ry(ind1)=ry(ind1)+lbox
                elseif (ind2.eq.-3) then
                        rz(ind1)=rz(ind1)-lbox
                else
                        rz(ind1)=rz(ind1)+lbox
                endif
            else
c solid walls
                iline = 81
                if (ind2.eq.-1) then
                        px(ind1)=-px(ind1)
                elseif (ind2.eq.-4) then
                        px(ind1)=-px(ind1)
                elseif (ind2.eq.-2) then
                        py(ind1)=-py(ind1)
                elseif (ind2.eq.-5) then
                        py(ind1)=-py(ind1)
                elseif (ind2.eq.-3) then
                        pz(ind1)=-pz(ind1)
                else
                        pz(ind1)=-pz(ind1)
                endif
            Endif

                nexit=1
                inew(1)=ind1

        call f15outch(0.d0)

        return
        endif
cc

c add fermi motion
      if (CTOption(30).eq.1) then
         call addfermi(ind1,peq1)
         call addfermi(ind2,peq2)
      endif

c     clear array of partial cross sections
      do 14 i=1,maxpsig
         sigma(i)=0.d0
 14   continue

c     save particle indices into pslot for later use (Danielewicz-Pratt delays)
      pslot(1)=ind1
      pslot(2)=ind2

c some abbreviations
      ityp1=ityp(ind1)
      itot1=isoit(ityp1)
      iso31=iso3(ind1)
      if(ind2.eq.0) then
         ityp2=0
         itot2=0
         iso32=0
      else
         ityp2=ityp(ind2)
         itot2=isoit(ityp2)
         iso32=iso3(ind2)
      endif

c     transform in to NN system for proper kinematics

      e1 = p0(ind1)

      if(ind2.eq.0) then
cccc DECAY cccccccccccccccccccccccc

c     increment decay counter
         dectag=dectag+1

c     prepare output to decay file
         call file16entry(ind1)

         sqrts=fmass(ind1)
         betax=px(ind1)/e1
         betay=py(ind1)/e1
         betaz=pz(ind1)/e1
         p0nn=p0(ind1)
         pxnn=px(ind1)
         pynn=py(ind1)
         pznn=pz(ind1)
         pnn=sqrt(pxnn*pxnn+pynn*pynn+pznn*pznn)

c     set tag for decay:
         iline=20

      else
cccc SCATTERING/ANNIHILATION  cccc
         e2 = p0(ind2)
c     transformation betas into two particle CMS system
         betax=(px(ind1)+px(ind2))/(e1+e2)
         betay=(py(ind1)+py(ind2))/(e1+e2)
         betaz=(pz(ind1)+pz(ind2))/(e1+e2)

c     calculate momenta in two particle CMS system
         pxnn=px(ind1)
         pynn=py(ind1)
         pznn=pz(ind1)
         p0nn=e1
c     call to Lorentz transformation
         call rotbos(0d0,0d0,-betax,-betay,-betaz,
     &        pxnn,pynn,pznn,p0nn)
         pnn=sqrt(pxnn*pxnn+pynn*pynn+pznn*pznn)

c     reduced cross section for leading hadrons of string fragmentation
c     sigfac is scaling factor for cross section
         sigfac=1.d0
         if(tform(ind1).le.acttime
     &           .and.tform(ind2).gt.acttime) then
            sigfac=xtotfac(ind2)
         else if(tform(ind2).le.acttime
     &           .and.tform(ind1).gt.acttime) then
            sigfac=xtotfac(ind1)
         elseif(tform(ind1).gt.acttime
     &        .and.tform(ind2).gt.acttime) then
            sigfac=xtotfac(ind1)*xtotfac(ind2)
         endif

c modify sigfac due to color fluctuations
         sigfac = sigfac*ccolfac

c now get line-number for sigmaLN array in blockres
         isigline=collclass(ityp1,iso31,ityp2,iso32)

c  number of exit-channels:
         nCh=SigmaLn(1,1,isigline)

         do 10 ii=3,nCh+2 ! loop over exit-channels
c           get  process-id (iline) from sigmaLN array in blockres
            iline=SigmaLn(ii,1,isigline)
            if(iline.gt.0) then ! normal cross sections:

               call crossx(iline,sqrts,ityp1,iso31,fmass(ind1),
     &                     ityp2,iso32,fmass(ind2),sigma(ii-2))

            else   !  detailed balance:
               call crossz(iline,sqrts,ityp1,iso31,fmass(ind1),
     &                     ityp2,iso32,fmass(ind2),sigma(ii-2))
            endif  ! end of detailed balance
c     ensure reduction of part. cross sections within formation time
            sigma(ii-2)=sigfac*sigma(ii-2)

 10      continue               ! end of exit channel loop

chp label if elastic scattering is disabled
         ict=0
 101     continue
chp
c     unitarize partial cross sections (rescale sum to match the total cross section)
         call normit (sigma,isigline)

c     select partial cross section ii
         call getbran(sigma,0,maxpsig,sigsum,1,nCh,ii)

         if(sigsum.lt.1d-10)then
c           write(6,*)'***(W) scatter: ',
c     ,     'no entry found for fin. state -> forced elastic scat. ',
c     ,     'particles:line=',isigline,'ecm=',sqrts
c           write(6,*)'     collision of    : ',
c     &                        ityp1,iso31,fmass(ind1),
c     &                        ityp2,iso32,fmass(ind2)
c           write(6,*)'                sigma=',sigma,ii
c     force elastic scattering
           sigpart=sigma(0)
           iline=13
        else
           sigpart=sigma(ii)    ! partial cross section
           iline=SigmaLN(ii+2,1,isigline) ! <- correct! ii has been redefined
        end if
chp no elastic scattering of initial pp pn and nn
       ict=ict+1
       if(CTOption(7).eq.1.and.(iline.eq.17.or.iline.eq.19))then
        if(ict.le.10)then
          goto 101
        else
c         write(6,*) 'in scatter.f: too many tries',
c     &    'elastic scattering happens despite cto 7 1'
        end if
       end if
chp

      endif
c.. take care sigpart in case of decay (no sigpart defined)
      if (iline.eq.20) sigpart=0d0

cccc end of scatter/decay if
      call file15out(ind1,ind2,sqrts,ssigtot,sigpart)

c     save old particle information in case of pauli blocking
c     or rejection due to energy non-conservation
      call saveinfo(ind1,1)
      call saveinfo(ind2,2)

c... prepare exit channel
      call scatprep(ind1,ind2,sqrts,sigpart)

      lambda=1.0d0
      call prescale(lambda)

      call scatfinal(colldens)

c     output to collision file
      call f15outch(colldens)
      call osc99_coll

c     write output to decay file
      if(ind2.eq.0) call file16write
c     in case of ctoption(13).ne.0 more output is written with the next call
      call f16outch

      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine scatprep(in1,in2,sqrts,sigpart)
c
c     Revision : 1.0
c
cinput ind1   : index of ingoing particle 1
cinput ind2   : index of ingoing particle 2
cinput sqrts  :  $sqrt{s}$ of collision
cinput sigpart: partial cross section for process
c
c {\tt scatprep, prescale} and {\tt scatfinal} handle the collision/decay
c kinematics and the book-keeping of the global particle vectors.
c In {\tt scatprep} the exit channel is generated via a call to
c {\tt make22}, the information is stored in common blocks of the
c {\tt newpart.f} file. Furthermore the new particle order including
c new slots for the exit channel are generated in {\tt scatprep}
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      implicit none
      include 'coms.f'
      include 'options.f'
      include 'comres.f'
      include 'newpart.f'

      integer i,ind1,ind2,k,in1,in2
      integer itmp(mprt),ipmp(mprt)
      real*8 sqrts,sigpart
      real*8 phi1,phi2
      real*8 pzi1,pzi2,pxi1,pxi2,pyi1,pyi2
      real*8 rstringx(2),rstringy(2),rstringz(2),tstring(2),tformold(2)
      real*8 rpott(2),rpotx(2),rpoty(2),rpotz(2)
      real*8 th,rdum, ctheta1
      integer bar,nb1,nb2,nm1,nm2,meslist2(mprt)
      integer barlist1(mprt),barlist2(mprt),meslist1(mprt)
      logical dnscall

c     functions:

      real*8 pcms
      common /scatcomr/rstringx,rstringy,rstringz,tstring,
     &                rpott,rpotx,rpoty,rpotz,
     &                pzi1,pzi2,pxi1,pxi2,pyi1,pyi2,
     &                ctheta1,phi1,th,phi2,tformold
      common /scatcomi/itmp,ipmp,ind1,ind2,nb1,nb2,
     &                 bar,nm1,nm2
      common /scatcoml/dnscall

c     call to paulibl for baryon-density
      dnscall=CTOption(39).ne.0

c     reset some pointer arrays
      do 10 i=1,mprt
         itmp(i)=0
         ipmp(i)=0
         barlist1(i)=0
         barlist2(i)=0
         meslist1(i)=0
 10   continue

      ind1=in1
      ind2=in2

c     reset xtotfacs
      if(tform(ind1).le.acttime) xtotfac(ind1)=1.d0
      if(ind2.gt.0) then
        if(tform(ind2).le.acttime) xtotfac(ind2)=1.d0
      endif

c     1. determine mass, ityp's, iso3's of outgoing channel
c
      if(ind2.ne.0) then ! scattering/annihilation
         call make22(iline,sqrts,
     &               ityp(ind1),iso3(ind1),fmass(ind1),xtotfac(ind1),
     &               ityp(ind2),iso3(ind2),fmass(ind2),xtotfac(ind2))

      elseif(ind2.eq.0) then ! decay
         call make22(iline,sqrts,
     &               ityp(ind1),iso3(ind1),fmass(ind1),xtotfac(ind1),
     &               0,0,0d0,1d0)
      endif

c set here the true nexit (number of particles in the exit channel):
      nexit=nstring1+nstring2

c
c     2a). annihilation/soft resonance production: store properties
c
      if(nstring2.eq.0) then
c     store average  time and position of particles (only one part/string coming out...)
         tstring(1)=(r0(ind1)+r0(ind2))/2.
         rstringx(1)=(rx(ind1)+rx(ind2))/2.
         rstringy(1)=(ry(ind1)+ry(ind2))/2.
         rstringz(1)=(rz(ind1)+rz(ind2))/2.
c     do the same for the MD trajectories
         rpott(1)=(r0_t(ind1)+r0_t(ind2))/2.
         rpotx(1)=(rx_t(ind1)+rx_t(ind2))/2.
         rpoty(1)=(ry_t(ind1)+ry_t(ind2))/2.
         rpotz(1)=(rz_t(ind1)+rz_t(ind2))/2.

         pnnout=pnn

c     store the incoming momenta for further use before the slots get erased/replaced
c     by outgoing particles
         pxi1=px(ind1)
         pxi2=px(ind2)
         pyi1=py(ind1)
         pyi2=py(ind2)
         pzi1=pz(ind1)
         pzi2=pz(ind2)

c     store old formation times
         tformold(1)=max(tform(ind1),tform(ind2))
         tformold(2)=max(tform(ind1),tform(ind2))
c two leading hadrons form s-channel -> the larger reduction factor
c of the incoming hadrons is maintained:
         xtotfacold(1)=max(xtotfac(ind1),xtotfac(ind2))
         xtotfacold(2)=max(xtotfac(ind1),xtotfac(ind2))
      else

c     2b) 1. scattering/decay/strings: store both locations for later use
c        store time and position of both incoming particles
         tstring(1)=r0(ind1)
         rstringx(1)=rx(ind1)
         rstringy(1)=ry(ind1)
         rstringz(1)=rz(ind1)
c        likewise for the MD trajectory arrays
         rpott(1)=r0_t(ind1)
         rpotx(1)=rx_t(ind1)
         rpoty(1)=ry_t(ind1)
         rpotz(1)=rz_t(ind1)

c        store old formation time and reduction factor
         tformold(1)=tform(ind1)
         xtotfacold(1)=xtotfac(ind1)

         if(ind2.eq.0) then !decay
c           likewise for particles 2,3,4...
            tstring(2)=r0(ind1)
            rstringx(2)=rx(ind1)
            rstringy(2)=ry(ind1)
            rstringz(2)=rz(ind1)
            rpott(2)=r0_t(ind1)
            rpotx(2)=rx_t(ind1)
            rpoty(2)=ry_t(ind1)
            rpotz(2)=rz_t(ind1)

            tformold(2)=tform(ind1)
            xtotfacold(2)=xtotfac(ind1)

         else
            tstring(2)=r0(ind2)
            rstringx(2)=rx(ind2)
            rstringy(2)=ry(ind2)
            rstringz(2)=rz(ind2)

            rpott(2)=r0_t(ind2)
            rpotx(2)=rx_t(ind2)
            rpoty(2)=ry_t(ind2)
            rpotz(2)=rz_t(ind2)

            tformold(2)=tform(ind2)
            xtotfacold(2)=xtotfac(ind2)

         endif
c
c     2b) 2. get relative momentum in 2 particle cms (only for ang. distrib.!)
c
         if(iline.gt.0) then
            pnnout=pcms(sqrts,mstring(1),mstring(2))
         endif

      endif    ! nstring2.eq.0
c
c     2b) 3.  get angular distribution
c

      if (ind2.ne.0) then
       call angdisnew(sqrts,fmass(ind1),fmass(ind2),iline,ctheta1,phi1)
      else
       call angdisnew(sqrts,fmass(ind1),0.0d0,iline,ctheta1,phi1)
      end if

c   for CTOption(2)<>0 phi1=0 and 2-part. scattering is in the scattering plane
      if(ind2.ne.0.and.CTOption(2).ne.0) then
         phi1=0.d0
      endif

c     get angles between two particle CMS and computational frame
      call getang(pxnn,pynn,pznn,th,phi2,rdum)

c     option for pure forward streaming
      if(CTOption(14).ne.0)then
         ctheta1=1d0
         th=0d0
      end if
c
c     3. generate slots for new particles
c
c     count baryons AND anti-baryons in old slots (NOT net-baryons!!)
      bar=0
      if(abs(ityp(ind1)).le.maxbar)then
         bar=bar+1
      endif
c
cccc in case of baryon-boson scattering, inew(1) contains the baryon,
cccc otherwise it does not matter
c
      if(ind2.ne.0) then
         if(abs(ityp(ind2)).le.maxbar) then
            bar=bar+1
         endif
         if(abs(ityp(ind2)).le.maxbar.and.
     &        abs(ityp(ind1)).ge.minmes) then
            inew(1)=ind2
            inew(2)=ind1
         else
            inew(1)=ind1
            inew(2)=ind2
         endif
      else
cccc decay: must create a second slot
         inew(1)=ind1
c     increment meson counter
         nmes=nmes+1
c     set new slot number
         inew(2)=nbar+nmes
c     create the slot
         call addpart(inew(2))
c     this is needed for delpart (to esure correct counters):
         ityp(inew(2))=999
c     three or four body decays
         if(nexit.gt.2) then
            do 91 i=3,nexit
               nmes=nmes+1
               inew(i)=nbar+nmes
               call addpart(inew(i))
               ityp(inew(i))=999
 91         continue
         endif
      endif

cccc soft resonance production (second slot must be deleted)
      if(nexit.eq.1) then
c        the smaller index automatically belongs to a baryon if there was one
         inew(1)=min0(ind1,ind2)
c        get index to be deleted
         inew(2)=max0(ind1,ind2)
c        delete second slot
         call delpart(inew(2))
      endif

c     generate sorting-order for new particles:
c      1. leading baryon of particle/string 1
c      2. leading baryon of particle/string 2
c      3. all other baryons of particle/string 1
c      4. all other baryons of particle/string 2
c      5. all mesons of particle/string 1
c      6. all mesons of particle/string 2
c     the itypnew-indices are stored into the itmp-array
c     the location-index (do the new particles "belong" to incident particle 1 or 2)
c      is stored in the ipmp-array

      nb1=0  ! number of baryons in string 1
      nb2=0  ! number of baryons in string 2
      nm1=0  ! number of mesons in string 1
      nm2=0  ! number of mesons in string 2
c     now get the number of baryons and mesons and their ityps from string/particle 1
      call instring(1,nstring1,nb1,nm1,barlist1,meslist1)
      if(nstring2.ne.0)
c     likewise from string/particle 2
     &     call instring(nstring1+1,nexit,nb2,nm2,barlist2,meslist2)

c now really generate the above described sorting-order
      if(  (bar.eq.0)
     & .or.(bar.eq.1.and.nb1.gt.0)
     & .or.(bar.eq.2.and.nb1.gt.0.and.nb2.eq.0)) then
c     loop over baryons in string/particle 1
         do 381 i=1,nb1
            itmp(i)=barlist1(i)
            ipmp(i)=1
 381     continue
c     loop over baryons in string/particle 2
         do 382 i=1,nb2
            itmp(nb1+i)=barlist2(i)
            ipmp(nb1+i)=2
 382     continue
      elseif((bar.eq.1.and.nb2.gt.0.and.nb1.eq.0)
     &   .or.(bar.eq.2.and.nb2.gt.0.and.nb1.eq.0)) then
c     loop over baryons in string/particle 2
         do 391 i=1,nb2
            itmp(i)=barlist2(i)
            ipmp(i)=2
 391     continue
      elseif(bar.eq.2.and.nb1.gt.0.and.nb2.gt.0) then
         itmp(1)=barlist1(1)
         ipmp(1)=1
         itmp(2)=barlist2(1)
         ipmp(2)=2
c     loop over baryons in string/particle 1
         do 371 i=2,nb1
            itmp(1+i)=barlist1(i)
            ipmp(1+i)=1
 371     continue
c     loop over baryons in string/particle 2
         do 372 i=2,nb2
            itmp(nb1+i)=barlist2(i)
            ipmp(nb1+i)=2
 372     continue
      endif
c     loop over mesons in string/particle 1
      do 383 i=1,nm1
         itmp(nb1+nb2+i)=meslist1(i)
         ipmp(nb1+nb2+i)=1
 383  continue
c     loop over mesons in string/particle 2
      do 384 i=1,nm2
         itmp(nb1+nb2+nm1+i)=meslist2(i)
         ipmp(nb1+nb2+nm1+i)=2
 384  continue

c in case of annihilation without baryon production
c or if a baryon-antibaryon pair is created via a meson-meson collision,
c delete old slots
c
c note: this sequence is needed to keep all baryons at the top
c       of the particle table. However, it destroys distinctive
c       projectile/target areas in the particle arrays.
c

      if((bar.eq.2.and.(nb1+nb2).eq.0)
     &   .or.
     &   (bar.eq.0.and.(nb1+nb2).gt.0)
     &  ) then

c     store average  time and position of particles
         tstring(1)=(r0(ind1)+r0(ind2))/2.
         rstringx(1)=(rx(ind1)+rx(ind2))/2.
         rstringy(1)=(ry(ind1)+ry(ind2))/2.
         rstringz(1)=(rz(ind1)+rz(ind2))/2.

         tstring(2)=tstring(1)
         rstringx(2)=rstringx(1)
         rstringy(2)=rstringy(1)
         rstringz(2)=rstringz(1)

c     do likewise for MD trajectories
         rpott(1)=(r0_t(ind1)+r0_t(ind2))/2.
         rpotx(1)=(rx_t(ind1)+rx_t(ind2))/2.
         rpoty(1)=(ry_t(ind1)+ry_t(ind2))/2.
         rpotz(1)=(rz_t(ind1)+rz_t(ind2))/2.
         rpott(2)=rpott(1)
         rpotx(2)=rpotx(1)
         rpoty(2)=rpoty(1)
         rpotz(2)=rpotz(1)

         call delpart(inew(1))
         call delpart(inew(2))
         inew(1)=0
         inew(2)=0
c in case of a meson-string with baryon-antibaryon creation
c the meson-slot must be deleted
      elseif(bar.eq.1.and.(nb1+nb2).gt.1) then
         call delpart(inew(2))
         inew(2)=0
      endif

c now create new slots:
      do 307 i=1,nexit
         if(inew(i).lt.1) then
c     the new particle ID is stored in itypnew
            if(iabs(itypnew(itmp(i))).le.maxbar) then
c     the particle is a baryon
               do 385 k=1,i
c     make sure that mesons in the inew array are shifted upwards
                  if(inew(k).gt.nbar)inew(k)=inew(k)+1
 385           continue
c     increment baryon counter
               nbar=nbar+1
c     this is the new particle slot
               inew(i)=nbar
            elseif(iabs(itypnew(itmp(i))).ge.minmes) then
c     the particle is a meson
               nmes=nmes+1
               inew(i)=nbar+nmes
            endif
c     create the slot
            call addpart(inew(i))
         endif
 307  continue

      return
      end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine prescale(lambda)
c
c     Revision : 1.0
c
cinput lambda : scaling factor for momenta of outgoing particles
c
c {\tt scatprep, prescale} and {\tt scatfinal} handle the collision/decay
c kinematics and the book-keeping of the global particle vectors.
c In {\tt prescale} the actual kinematics for the exit-channel, including
c a call to {\tt angdis} for the angular distribution and the transformation
c from the two particle restframe to the computational frame is being
c performed. Momenta and locations of exit channel particles are written
c to the global particle vectors. \\
c The scaling factor {\tt lambda} is needed to ensure global energy conservation
c in the case of momentum dependent interactions (MDI). In that case {\tt prescale}
c can be called several succesive times with different values of {\tt lambda}
c to minimize $E_{tot,in} - E_{tot,out}$.
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
      include 'coms.f'
      include 'options.f'
      include 'newpart.f'

      integer i,j,itmp(mprt),ipmp(mprt),ind1,ind2,nb1,nb2
      real*8 lambda,th,phi2,ctheta1,phi1,theta3,phi3,pabs
      real*8 pzi1,pzi2,pxi1,pxi2,pyi1,pyi2
      real*8 rstringx(2),rstringy(2),rstringz(2),tstring(2)
      real*8 rpott(2),rpotx(2),rpoty(2),rpotz(2)
      real*8 tauf(mprt),tformold(2)
      integer getspin,bar,nm1,nm2

      common /scatcomr/rstringx,rstringy,rstringz,tstring,
     &                 rpott,rpotx,rpoty,rpotz,
     &                 pzi1,pzi2,pxi1,pxi2,pyi1,pyi2,
     &                 ctheta1,phi1,th,phi2,tformold
      common /scatcomi/itmp,ipmp,ind1,ind2,nb1,nb2,
     &                 bar,nm1,nm2

      if(nexit.eq.1) then ! soft resonance production

c new momenta are stored in pnew
         pnew(1,1)=lambda*(pxi1+pxi2)
         pnew(2,1)=lambda*(pyi1+pyi2)
         pnew(3,1)=lambda*(pzi1+pzi2)
c this is the energy
         pnew(4,1)=dsqrt(pnew(5,1)**2+
     &             pnew(1,1)**2+pnew(2,1)**2+pnew(3,1)**2)
c formation time
         tauf(1)=0.d0
      else                      ! scattering/decay
         do 205 j=1,nexit
c compute formation time (as a eigentime)
            tauf(j)=xnew(4,j)*pnew(5,j)/pnew(4,j)

c     rescale momenta of particles
            call getang(pnew(1,j),pnew(2,j),pnew(3,j),theta3,phi3,pabs)
            pabs=lambda*pabs
            call putang(pnew(1,j),pnew(2,j),pnew(3,j),theta3,phi3,pabs)

c check for forward time-delay
c in case of delay the momenta are already in the comp. frame
            if(.not.(CTOption(34).eq.2.and.iline.eq.20.and.
     &         ityptd(1,pslot(1)).ne.0)) then

c     rotate in the from z-axis to th&phi given by angdis
               call rotbos(dacos(ctheta1),phi1,0d0,0d0,0d0,
     &                     pnew(1,j),pnew(2,j),pnew(3,j),pnew(4,j))

c     rotate from the NN to the comp. sys. and
c     transform particles to computational system

c     decays should not be rotated
               if (iline.eq.20) then
                  th = 0.d0
                  phi2 = 0.d0
               end if

               call rotbos(th,phi2,betax,betay,betaz,
     &                     pnew(1,j),pnew(2,j),pnew(3,j),pnew(4,j))

            endif
c end of delay-if

 205     continue
      endif

c     write coordinates for energy-check and pauli-blocking
c     correct particle/string-locations from relative to absolute

      do 215 i=1,nexit
c     write locations to global arrays
c     the ipmp values determine wether the new particle belongs to incoming slot 1 or 2
         r0(inew(i))=tstring(ipmp(i))
         rx(inew(i))=rstringx(ipmp(i))
         ry(inew(i))=rstringy(ipmp(i))
         rz(inew(i))=rstringz(ipmp(i))
cpot
c     likewise for MD trajectories
         r0_t(inew(i))=rpott(ipmp(i))
         rx_t(inew(i))=rpotx(ipmp(i))
         ry_t(inew(i))=rpoty(ipmp(i))
         rz_t(inew(i))=rpotz(ipmp(i))

c     write momenta to global arrays
         p0(inew(i))=pnew(4,itmp(i))
         px(inew(i))=pnew(1,itmp(i))
         py(inew(i))=pnew(2,itmp(i))
         pz(inew(i))=pnew(3,itmp(i))

c store formation time and leading hadron
         if(pnew(5,itmp(i)).gt.0d0)then
            tform(inew(i))=tstring(1)+tauf(itmp(i))*
     &                  pnew(4,itmp(i))/pnew(5,itmp(i))
         else
           tform(inew(i))=tstring(ipmp(i))
         endif

c     cross section reduction factor and string ID
         xtotfac(inew(i))=leadfac(itmp(i))

c additional reduction of the leading hadrons' cross section
c in case the incoming hadron x-sec was already reduced
c otherwise an elastic scattering would erase formation time...
         if(xtotfacold(ipmp(i)).lt.1d0) then
            xtotfac(inew(i))=xtotfacold(ipmp(i))*xtotfac(inew(i))
         endif
         if(tform(inew(i)).lt.tformold(ipmp(i))
     &      .and.xtotfac(inew(i)).gt.0) then
            tform(inew(i))=tformold(ipmp(i))
         endif

c     write mass, ID, I3 and spin to global arrays
         fmass(inew(i))=pnew(5,itmp(i))
         ityp(inew(i))=itypnew(itmp(i))
         iso3(inew(i))=i3new(itmp(i))
         spin(inew(i))=getspin(itypnew(itmp(i)),-1)

 215  continue

c set lstcoll:
c     lstcoll relates the outgoing particles of this scattering/decay interaction
c     to each other via the number of the collision - it is used to prevent them
c     from directly interacting again with each other because this would be unphysical.
      do i=1,nexit
         lstcoll(inew(i))=ctag
      end do
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine scatFinal(colldens)
c
c     Revision : 1.0
c
coutput colldens : baryon density at point of interaction
c
c {\tt scatprep, prescale} and {\tt scatfinal} handle the collision/decay
c kinematics and the book-keeping of the global particle vectors.
c In {\tt scatfinal} the interaction is checked for Pauli-blocking and all
c particle {\em quantum numbers} which so far have not been set are written
c to the global arrays. Some collision counters are incremented here, too.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      implicit none
      include 'coms.f'
      include 'comres.f'
      include 'newpart.f'
      include 'freezeout.f'
      include 'options.f'

      integer i,ind1,ind2,itmp(mprt),ipmp(mprt),nb1,nb2,j
      integer ikill1,ikill2,bar,nm1,nm2
      integer iloffset
      real*8 colldens
      logical dnscall,dnsdum

c     functions:
      integer fchg
      real*8 dectim
      logical paulibl

      common /scatcomi/itmp,ipmp,ind1,ind2,nb1,nb2,
     &                 bar,nm1,nm2
      common /scatcoml/dnscall

c     check pauli-blocking (only for nucleons and delta(1232)
c     loop over all baryons in exit-channel
      do 306 i=1,nb1+nb2
         if(itypnew(itmp(i)).eq.nucleon) then
            dnscall=.false.
            ikill1=0
            ikill2=0
c     call to Pauli-Blocker
            if(paulibl(inew(i),colldens,-1000)) then
c     pauli-blocked collision, restore information and return

c     first delete unnecessary slots
               if(nexit.gt.2) then
                  do 317 j=3,nexit
                     call delpart(inew(j))
 317              continue
               endif

c in case of blocked decay, delete second entry
               if(ind2.eq.0) then
                  call delpart(inew(2))
c only delete/create slots if something more than a mere
c swapping has happened
               elseif(.not.(((inew(1).eq.ind1).or.(inew(1).eq.ind2))
     &                .and.((inew(2).eq.ind1).or.(inew(2).eq.ind2))))
     &                 then
                  ikill1=max0(inew(1),inew(2))
                  ikill2=min0(inew(1),inew(2))
                  call delpart(ikill1)
                  if(ikill2.gt.0) call delpart(ikill2)
cgg make sure slot with the lower slotnumber is created first
                  if(ind2.gt.0) then
                    call addpart(min0(ind1,ind2))
                    call addpart(max0(ind1,ind2))
                  else
                    call addpart(ind1)
                  endif
               endif
c     restore old contents of slots ind1 and ind2
               call saveinfo(ind1,-1)
               call saveinfo(ind2,-2)
c     in case of blocked decay, sample new decay time
               if(ind2.eq.0) then
                  dectime(ind1)=dectim(ind1,iline)+acttime
               endif
c     restore frozen fermi state if necessary
               if (CTOption(30).eq.1) then
                  call savefermi(ind1,ind1,peq1)
                  call savefermi(ind2,ind2,peq2)
               endif
c     set lstcoll
               if(ind2.ne.0) then
                  lstcoll(ind1)=ctag
                  lstcoll(ind2)=ctag
               else
                  lstcoll(ind1)=ctag
               endif

c     set baryon and meson counters
               if(ikill1.ne.0) then
                  if(abs(ityp(ind1)).lt.minmes) then
                     nbar=nbar+1
                  else
                     nmes=nmes+1
                  endif
               endif
               if(ind2.gt.0.and.ikill2.ne.0) then
                  if(abs(ityp(ind2)).lt.minmes) then
                     nbar=nbar+1
                  else
                     nmes=nmes+1
                  endif
               endif

c     increment blocking counter
               NBlColl=NBlColl+1
c     set number of particles in exit-channel to zero
               nexit=0
               return
            endif
         endif
 306  continue

c     the collision was not blocked, proceed...

c     4. rewrite arrays, clear entries etc.
c     fill the rest of the slot

c     in case the Pauli-Blocker was not called, do it now in order to
c     get the baryon density at the interaction point, colldens
      if(dnscall) dnsdum=paulibl(inew(1),colldens,-1000)

c     write rest of the quantum numbers to global vectors
      do 312 i=1,nexit
c     number of collisions
         ncoll(inew(i))=ncoll(inew(i))+1
c     charge
         charge(inew(i))=fchg(iso3(inew(i)),ityp(inew(i)))
c     time of decay
         dectime(inew(i))=dectim(inew(i),iline)+tform(inew(i))
c     last process the particle was involved in
         if ( (iline.ne.13).and.(iline.ne.17).and.(iline.ne.19).and.
     $        (iline.ne.22).and.(iline.ne.26).and.(iline.ne.38)) then
            if (ind2.gt.0) then
               iloffset=0
               if ( (iline.eq.27).or.(iline.eq.28) ) then
                  if ( (CTOption(41).gt.1) ) then
                     if ( (abs(itypt(1)).gt.100).and.
     $                    (abs(itypt(2)).gt.100) ) then
                        iloffset=20
                     endif
                     if ( (itypt(1).eq.ityp(inew(i))).and.
     $                    (iso3t(1).eq.iso3(inew(i))) ) then
                        origin(inew(i))=origint(1)+100
                        uid(inew(i))=uidt(1)
                     elseif ( (itypt(2).eq.ityp(inew(i))).and.
     $                       (iso3t(2).eq.iso3(inew(i))) ) then
                        origin(inew(i))=origint(2)+100
                        uid(inew(i))=uidt(2)
                     else
                        origin(inew(i))=iline+iloffset
     $                       +1000*(iabs(itypt(1))+1000*iabs(itypt(2)))
                     endif
                  else
                     origin(inew(i))=iline+iloffset
     $                    +1000*(iabs(itypt(1))+1000*iabs(itypt(2)))
                  endif
               else
                  origin(inew(i))=iline
     $                 +1000*(iabs(itypt(1))+1000*iabs(itypt(2)))
               endif
            else
               origin(inew(i))=iline
     $              +1000*(iabs(itypt(1)))
            endif
c     unique ID tag
            uid_cnt=uid_cnt+1
            uid(inew(i))=uid_cnt
         else
            origin(inew(i))=origint(i)+100
            uid(inew(i))=uidt(i)
            if (ityp(inew(1)).ne.itypt(1)) then
               if (nexit.ne.2) then
                  write(6,*) "fatal error in scatter: nexit.ne.2!"
                  stop 137
               endif
               origin(inew(i))=origint(3-i)+100
               uid(inew(i))=uidt(3-i)
            endif
         endif
c     freeze-out coordinates
c     freeze-out coordinates
chp modify freeze-out coordinates
chp particles should not freeze out before they are formed
chp add tform and propagate accordingly
chp not used when visualization output is wanted, then freeze-out
chp coordinates are production points
        if(tform(inew(i)).gt.r0(inew(i)).and.CTOption(55).eq.0)then
         frr0(inew(i))=tform(inew(i))
         frrx(inew(i))=rx(inew(i))
     & +px(inew(i))/p0(inew(i))*(tform(inew(i))-r0(inew(i)))
         frry(inew(i))=ry(inew(i))
     & +py(inew(i))/p0(inew(i))*(tform(inew(i))-r0(inew(i)))
         frrz(inew(i))=rz(inew(i))
     & +pz(inew(i))/p0(inew(i))*(tform(inew(i))-r0(inew(i)))
chp otherwise just proceed normally
        else
         frr0(inew(i))=r0(inew(i))
         frrx(inew(i))=rx(inew(i))
         frry(inew(i))=ry(inew(i))
         frrz(inew(i))=rz(inew(i))
        end if
         frp0(inew(i))=p0(inew(i))
         frpx(inew(i))=px(inew(i))
         frpy(inew(i))=py(inew(i))
         frpz(inew(i))=pz(inew(i))

c forward time-delay
      if(CTOption(34).eq.2.and.(iline.eq.36.or.iline.eq.37)) then
         do 307 j=1,2
            p0td(j,inew(i))=pold(4,j)
            pxtd(j,inew(i))=pold(1,j)
            pytd(j,inew(i))=pold(2,j)
            pztd(j,inew(i))=pold(3,j)
            fmasstd(j,inew(i))=pold(5,j)
            ityptd(j,inew(i))=itypold(j)
            iso3td(j,inew(i))=iso3old(j)
 307     continue
      else
         do 308 j=1,2
            p0td(j,inew(i))=0.d0
            pxtd(j,inew(i))=0.d0
            pytd(j,inew(i))=0.d0
            pztd(j,inew(i))=0.d0
            fmasstd(j,inew(i))=0.d0
            ityptd(j,inew(i))=0
            iso3td(j,inew(i))=0
 308     continue
      endif

c     in a N particle exit channel the produced resonance
c     either comes from BB->B* ? ? or a String -> B* ? ?
         if(ityp(inew(i)).ge.minres.and.ityp(inew(i)).le.maxres) then
            if(iline.ne.20.or.iline.ne.10) then
c     B B -> ? ?
               NHardRes=NHardRes+1
            elseif(iline.eq.20) then
               NDecRes=NDecRes+1
            elseif(iline.eq.10) then
               NSoftRes=NSoftRes+1
            endif
         endif
 312  continue
c other counters for B-strings/M-strings could be added here...
      if(iline.eq.13.or.iline.eq.17
     &     .or.iline.eq.19.or.iline.eq.26) then
         NElColl=NElColl+1
      endif

      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      integer function collclass(ityp1,iso31,ityp2,iso32)
c
c     Revision : 1.0
c
c     This function links the ingoing collision channel to the
c     line number of the sigmaLN array in {\tt blockres.f} in which the
c     types of cross section parametrizations to perform are defined.
c
cinput ityp1  : ityp of particle 1
cinput iso31  : $I_3$ of particle 1
cinput ityp2  : ityp of particle 2
cinput iso32  : $I_3$ of particle 2
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
      include 'comres.f'
      include 'options.f'
      integer ityp1,ityp2,iso31,iso32,i1,i2,iz1,iz2
      real*8 d1,d2

c     copy to new variables MUST be done because of swpizm
c     (otherwise scatter will crash due to swapped particle properties)
      i1=iabs(ityp1)
      i2=iabs(ityp2)
      iz1=iso31
      iz2=iso32
      d1=0.d0
      d2=0.d0

c... blank out PYHTIA pdg-id's
c... define collclasses for specific reactions if needed
      if(i1.gt.1000 .or. i2.gt.1000) then
         collclass=0
         return
      endif

cJS    No rescattering of photons

      if((i1.eq.minmes).or.(i2.eq.minmes))then
         collclass=0
         return
      endif

      if(i1.lt.i2)call swpizm(i1,iz1,d1,i2,iz2,d2)

c baryon-antibaryon
      if(i1.le.maxbar.and.i2.le.maxbar.and.ityp1*ityp2.lt.0) then
         collclass=11
         if(CTOption(19).ne.0)collclass=0
         return
      end if

c nucleon nucleon
      if(i1.eq.nucleon.and.i2.eq.nucleon) then
         if(iz1.eq.iz2) then
c proton proton or neutron-neutron
            collclass=2
            return
         else
c proton neutron
            collclass=1
            return
         endif
      elseif(i1.eq.mindel.and.i2.eq.nucleon) then
c Delta(1232) nucleon
         collclass=3
         return
      elseif(i1.gt.minnuc.and.i1.le.maxnuc.and.
     &       i2.eq.nucleon) then
c N+ nucleon
         collclass=4
         return
      elseif(i1.ge.mindel.and.
     &       i1.le.maxdel.and.
     &       i2.eq.nucleon) then
c D* nucleon
         collclass=5
         return
      elseif(i1.eq.mindel.and.i2.eq.mindel) then
c Delta(1232)-Delta(1232)
         collclass=6
         return
      elseif(i1.eq.mindel.and.
     &       i2.gt.minnuc.and.
     &       i2.le.maxnuc) then
c Delta(1232)-N*
         collclass=7
         return
      elseif(i2.eq.mindel.and.
     &       i1.gt.mindel.and.
     &       i1.le.maxdel) then
c Delta(1232)-D*
         collclass=8
         return
      elseif(i1.ge.minmes.and.i1.lt.133.and.i2.le.maxbar) then
c Boson-Baryon
         collclass=9
         return
      elseif(i1.ge.minmes.and.i1.lt.133
     &        .and.i2.ge.minmes.and.i2.lt.133) then
c Boson-Boson
         collclass=10
         return
      elseif(i1.gt.minnuc.and.
     &       i1.le.maxdel.and.
     &       i2.gt.minnuc.and.
     &       i2.le.maxdel) then
c D*-D* or D*-N* or N*-N*
         collclass=12
         return
      elseif(i1.le.maxbar.and.i2.le.maxbar) then
c all remaining BB-collisions
         collclass=13
         return
      elseif(i1.ge.133.and.i2.ge.minmes) then
c M_c - Meson
         collclass=14
      elseif(i1.ge.133.and.i2.le.maxbar) then
c M_c - Baryon
         collclass=15
         return
c no charmonium-charmonium collisions
c (should not happen, see conditions for M_c - Meson scattering)
      elseif(i1.ge.135.and.i1.le.137.and.i2.ge.135.and.i2.le.137)then
         collclass=0
      else
c class not defined (sets sigtot to zero)
      write(*,*)'scatter: collclass of ',i1,i2,' not yet defined!'
         collclass=0
      endif
      return
      end

C####C##1#########2#########3#########4#########5#########6#########7##
      subroutine getang(x,y,z,th,ph,r)
c
c gives spherical coordinates of cartesian 3-vector $(x,y,z)$
c
c input : 3-vector x,y,z
c output: angles {\tt th}($\vartheta$), {\tt ph}($\varphi$) and radius {\tt r}
c
C####C##1#########2#########3#########4#########5#########6#########7##
      implicit none
      real*8 x,y,z,th,ph,cut,r
      parameter (cut=1d-9)
      if(abs(x).lt.cut.and.abs(y).lt.cut) then
         ph=0d0
      else
         ph=datan2(y,x)
      endif
      r=sqrt(x*x+y*y+z*z)
      th=dacos(z/max(r,cut))
      return
      end

C####C##1#########2#########3#########4#########5#########6#########7##
      subroutine putang(x,y,z,th,ph,r)
c
c  creates 3-vector $(x,y,z)$ out of  spherical coordinates
c  input: angles {\tt th}($\vartheta$), {\tt ph}($\varphi$) and radius {\tt r}
c  output: 3-vector x,y,z
C####C##1#########2#########3#########4#########5#########6#########7##
      implicit none
      real*8 x,y,z,th,ph,r
      x=r*sin(th)*cos(ph)
      y=r*sin(th)*sin(ph)
      z=r*cos(th)
      return
      end

C####C##1#########2#########3#########4#########5#########6#########7##
      SUBROUTINE rotbos(THE,PHI,BEX,BEY,BEZ,p1,p2,p3,p4)
c
c INPUT: the,phi,bex,bey,bez,p
c OUTPUT: p
c 1)rotate 4-vector p according to the and phi 2/ boost 4-vector p
C####C##1#########2#########3#########4#########5#########6#########7##
      implicit none
      real*8 P(4),BEX,BEY,BEZ,GA,BEP,GABEP,rot(3,3),the,phi
      real*8 p1,p2,p3,p4,bb2
      integer j

      IF(THE**2+PHI**2.GT.1E-20) THEN
C...ROTATE
        ROT(1,1)=COS(THE)*COS(PHI)
        ROT(1,2)=-SIN(PHI)
        ROT(1,3)=SIN(THE)*COS(PHI)
        ROT(2,1)=COS(THE)*SIN(PHI)
        ROT(2,2)=COS(PHI)
        ROT(2,3)=SIN(THE)*SIN(PHI)
        ROT(3,1)=-SIN(THE)
        ROT(3,2)=0.
        ROT(3,3)=COS(THE)
        DO 108 J=1,3
 108       P(J)=ROT(J,1)*P1+ROT(J,2)*P2+ROT(J,3)*P3
        p(4)=p4
      else
        p(1)=p1
        p(2)=p2
        p(3)=p3
        p(4)=p4
      ENDIF

      bb2=BEX**2+BEY**2+BEZ**2
      IF(bb2.GT.1E-20) THEN
C...LORENTZ BOOST (TYPICALLY FROM REST TO MOMENTUM/ENERGY=BETA)
        GA=1D0/DSQRT(1D0-bb2)
        BEP=BEX*P(1)+BEY*P(2)+BEZ*P(3)
        GABEP=GA*(GA*BEP/(1D0+GA)+P(4))
        P(1)=P(1)+GABEP*BEX
        P(2)=P(2)+GABEP*BEY
        P(3)=P(3)+GABEP*BEZ
        P(4)=GA*(P(4)+BEP)
      ENDIF

      p1=p(1)
      p2=p(2)
      p3=p(3)
      p4=p(4)

      RETURN
      END
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine instring(low,high,nb,nm,barlist,meslist)
c
c     version: 1.0
c
c     this subroutine returns arrays with the indices of the baryons/mesons
c     found in the itypnew-array of {\tt newpart.f}
c
cinput low:  lower search boundary
cinput high: upper search boundary
c
coutput nb : number of baryons in range
coutput nm : number of mesons in range
coutput barlist: list of indices for baryons
coutput meslist: list of indices for mesons
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      implicit none

      include 'newpart.f'
      include 'comres.f'

      integer i,low,high,nb,nm,barlist(mprt),meslist(mprt)

      nb=0
      nm=0

      do 10 i=low,high
         if(abs(itypnew(i)).le.maxbar) then
          nb=nb+1
          barlist(nb)=i
       else
          nm=nm+1
          meslist(nm)=i
       endif
 10   continue
      return
      end

C####C##1#########2#########3#########4#########5#########6#########7##
      subroutine leadhad(n1l,n2l,nbl)
c
cinput n1l : First index of this string in the newpart-arrays
cinput n2l : Last index of this string in the newpart-arrays
cinput nbl : Baryon number of string system, nbl=3 is e+e-
c
c output : via common-block {\tt newpart.f}
c
c This subroutine determines the position of the leading hadrons
c of a string fragmentation in the newpart-arrays and assigns the
c reduction factor for the total cross sections (for all non-leading
c hadrons this factor is zero, i.e. they have no cross-section during
c their formation time)
c
C####C##1#########2#########3#########4#########5#########6#########7##

      implicit none
      include 'newpart.f'
      include 'comres.f'
      include 'coms.f'
      integer n1l,n2l,nbl,ll

c default: no leading hadron at all
       do 1 ll=n1l,n2l
         leadfac(ll)=0.d0
 1    continue

c no leading quarks in e+e-
      if(nbl.eq.3) return

c full x-section, if there is only one particle
      if(n1l.eq.n2l)then
        leadfac(n1l)=1.d0
        return
      endif

c the last hadron contains always one leading quark
      if(iabs(itypnew(n2l)).le.maxbar)then
        leadfac(n2l)=0.33d0
      else
        leadfac(n2l)=0.5d0
      endif
c baryonic string: look for the first (=leading) baryon
      if(nbl.gt.0)then
        do 10 ll=n1l,n2l
         if(iabs(itypnew(ll)).le.maxbar)then
          leadfac(ll)=0.66d0
          goto 20
         endif
 10    continue
 20    continue
      else
c mesonic string: the first hadron contains one leading quark
        if(iabs(itypnew(n1l)).le.maxbar)then
          leadfac(n1l)=0.33d0
        else
          leadfac(n1l)=0.5d0
        endif
      endif

      return
      end