Subroutine lustrf(ip)
  Implicit Double Precision (D)
  Common /lujets/n, k(9000, 5), p(9000, 5), v(9000, 5)
  Save /lujets/
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  Common /ludat2/kchg(500, 3), pmas(500, 4), parf(2000), vckm(4, 4)
  Save /ludat2/
  Dimension dps(5), kfl(3), pmq(3), px(3), py(3), gam(3), ie(2), pr(2), in(9), dhm(4), dhg(4), dp(5, 5), irank(2), mju(4), iju(3), pju(5, 5), tju(5), kfjh(2), njs(2), kfjs(2), pjs(4, 5)
  four(i, j) = p(i, 4)*p(j, 4) - p(i, 1)*p(j, 1) - p(i, 2)*p(j, 2) - p(i, 3)*p(j, 3)
  dfour(i, j) = dp(i, 4)*dp(j, 4) - dp(i, 1)*dp(j, 1) - dp(i, 2)*dp(j, 2) - dp(i, 3)*dp(j, 3)
  mstj(91) = 0
  nsav = n
  np = 0
  kqsum = 0
  Do j = 1, 5
    dps(j) = 0D0
  End Do
  mju(1) = 0
  mju(2) = 0
  i = ip - 1
  110 i = i + 1
  If (i>min(n,mstu(4)-mstu(32))) Then
    Call luerrm(12, '(LUSTRF:) failed to reconstruct jet system')
    If (mstu(21)>=1) Return
  End If
  If (k(i,1)/=1 .And. k(i,1)/=2 .And. k(i,1)/=41) Goto 110
  kc = lucomp(k(i,2))
  If (kc==0) Goto 110
  kq = kchg(kc, 2)*isign(1, k(i,2))
  If (kq==0) Goto 110
  If (n+5*np+11>mstu(4)-mstu(32)-5) Then
    Call luerrm(11, '(LUSTRF:) no more memory left in LUJETS')
    If (mstu(21)>=1) Return
  End If
  np = np + 1
  Do j = 1, 5
    k(n+np, j) = k(i, j)
    p(n+np, j) = p(i, j)
    dps(j) = dps(j) + dble(p(i,j))
  End Do
  k(n+np, 3) = i
  If (p(n+np,4)**2<p(n+np,1)**2+p(n+np,2)**2+p(n+np,3)**2) Then
    p(n+np, 4) = sqrt(p(n+np,1)**2+p(n+np,2)**2+p(n+np,3)**2+p(n+np,5)**2)
    dps(4) = dps(4) + dble(max(0.,p(n+np,4)-p(i,4)))
  End If
  If (kq/=2) kqsum = kqsum + kq
  If (k(i,1)==41) Then
    kqsum = kqsum + 2*kq
    If (kqsum==kq) mju(1) = n + np
    If (kqsum/=kq) mju(2) = n + np
  End If
  If (k(i,1)==2 .Or. k(i,1)==41) Goto 110
  If (kqsum/=0) Then
    Call luerrm(12, '(LUSTRF:) unphysical flavour combination')
    If (mstu(21)>=1) Return
  End If
  Call ludbrb(n+1, n+np, 0., 0., -dps(1)/dps(4), -dps(2)/dps(4), -dps(3)/dps(4))
  ntryr = 0
  paru12 = paru(12)
  paru13 = paru(13)
  mju(3) = mju(1)
  mju(4) = mju(2)
  nr = np
  130 If (nr>=3) Then
    pdrmin = 2.*paru12
    Do i = n + 1, n + nr
      If (i==n+nr .And. iabs(k(n+1,2))/=21) Goto 140
      i1 = i + 1
      If (i==n+nr) i1 = n + 1
      If (k(i,1)==41 .Or. k(i1,1)==41) Goto 140
      If (mju(1)/=0 .And. i1<mju(1) .And. iabs(k(i1,2))/=21) Goto 140
      If (mju(2)/=0 .And. i>mju(2) .And. iabs(k(i,2))/=21) Goto 140
      pap = sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+p(i1,2)**2+p(i1,3)**2))
      pvp = p(i, 1)*p(i1, 1) + p(i, 2)*p(i1, 2) + p(i, 3)*p(i1, 3)
      pdr = 4.*(pap-pvp)**2/(paru13**2*pap+2.*(pap-pvp))
      If (pdr<pdrmin) Then
        ir = i
        pdrmin = pdr
      End If
    140 End Do
    If (pdrmin<paru12 .And. ir==n+nr) Then
      Do j = 1, 4
        p(n+1, j) = p(n+1, j) + p(n+nr, j)
      End Do
      p(n+1, 5) = sqrt(max(0.,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-p(n+1,3)**2))
      nr = nr - 1
      Goto 130
    Else If (pdrmin<paru12) Then
      Do j = 1, 4
        p(ir, j) = p(ir, j) + p(ir+1, j)
      End Do
      p(ir, 5) = sqrt(max(0.,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2-p(ir,3)**2))
      Do i = ir + 1, n + nr - 1
        k(i, 2) = k(i+1, 2)
        Do j = 1, 5
          p(i, j) = p(i+1, j)
        End Do
      End Do
      If (ir==n+nr-1) k(ir, 2) = k(n+nr, 2)
      nr = nr - 1
      If (mju(1)>ir) mju(1) = mju(1) - 1
      If (mju(2)>ir) mju(2) = mju(2) - 1
      Goto 130
    End If
  End If
  ntryr = ntryr + 1
  nrs = max(5*nr+11, np)
  ntry = 0
  180 ntry = ntry + 1
  If (ntry>100 .And. ntryr<=4) Then
    paru12 = 4.*paru12
    paru13 = 2.*paru13
    Goto 130
  Else If (ntry>100) Then
    Call luerrm(14, '(LUSTRF:) caught in infinite loop')
    If (mstu(21)>=1) Return
  End If
  i = n + nrs
  If (mju(1)==0 .And. mju(2)==0) Goto 500
  Do jt = 1, 2
    njs(jt) = 0
    If (mju(jt)==0) Goto 490
    js = 3 - 2*jt
    Do iu = 1, 3
      iju(iu) = 0
      Do j = 1, 5
        pju(iu, j) = 0.
      End Do
    End Do
    iu = 0
    Do i1 = n + 1 + (jt-1)*(nr-1), n + nr + (jt-1)*(1-nr), js
      If (k(i1,2)/=21 .And. iu<=2) Then
        iu = iu + 1
        iju(iu) = i1
      End If
      Do j = 1, 4
        pju(iu, j) = pju(iu, j) + p(i1, j)
      End Do
    End Do
    Do iu = 1, 3
      pju(iu, 5) = sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
    End Do
    If (k(iju(3),2)/100/=10*k(iju(1),2)+k(iju(2),2) .And. k(iju(3),2)/100/=10*k(iju(2),2)+k(iju(1),2)) Then
      Call luerrm(12, '(LUSTRF:) unphysical flavour combination')
      If (mstu(21)>=1) Return
    End If
    t12 = (pju(1,1)*pju(2,1)+pju(1,2)*pju(2,2)+pju(1,3)*pju(2,3))/(pju(1,5)*pju(2,5))
    t13 = (pju(1,1)*pju(3,1)+pju(1,2)*pju(3,2)+pju(1,3)*pju(3,3))/(pju(1,5)*pju(3,5))
    t23 = (pju(2,1)*pju(3,1)+pju(2,2)*pju(3,2)+pju(2,3)*pju(3,3))/(pju(2,5)*pju(3,5))
    t11 = sqrt((2./3.)*(1.-t12)*(1.-t13)/(1.-t23))
    t22 = sqrt((2./3.)*(1.-t12)*(1.-t23)/(1.-t13))
    tsq = sqrt((2.*t11*t22+t12-1.)*(1.+t12))
    t1f = (tsq-t22*(1.+t12))/(1.-t12**2)
    t2f = (tsq-t11*(1.+t12))/(1.-t12**2)
    Do j = 1, 3
      tju(j) = -(t1f*pju(1,j)/pju(1,5)+t2f*pju(2,j)/pju(2,5))
    End Do
    tju(4) = sqrt(1.+tju(1)**2+tju(2)**2+tju(3)**2)
    Do iu = 1, 3
      pju(iu, 5) = tju(4)*pju(iu, 4) - tju(1)*pju(iu, 1) - tju(2)*pju(iu, 2) - tju(3)*pju(iu, 3)
    End Do
    If (pju(1,5)+pju(2,5)>pju(1,4)+pju(2,4)) Then
      Do j = 1, 3
        tju(j) = 0.
      End Do
      tju(4) = 1.
      pju(1, 5) = pju(1, 4)
      pju(2, 5) = pju(2, 4)
      pju(3, 5) = pju(3, 4)
    End If
    ista = i
    Do iu = 1, 2
      ns = iju(iu+1) - iju(iu)
      Do is = 1, ns
        is1 = iju(iu) + is - 1
        is2 = iju(iu) + is
        Do j = 1, 5
          dp(1, j) = dble(0.5*p(is1,j))
          If (is==1) dp(1, j) = dble(p(is1,j))
          dp(2, j) = dble(0.5*p(is2,j))
          If (is==ns) dp(2, j) = -dble(pju(iu,j))
        End Do
        If (is==ns) dp(2, 4) = dble(sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2))
        If (is==ns) dp(2, 5) = 0D0
        dp(3, 5) = dfour(1, 1)
        dp(4, 5) = dfour(2, 2)
        dhkc = dfour(1, 2)
        If (dp(3,5)+2D0*dhkc+dp(4,5)<=0D0) Then
          dp(1, 4) = sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
          dp(2, 4) = sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
          dp(3, 5) = 0D0
          dp(4, 5) = 0D0
          dhkc = dfour(1, 2)
        End If
        dhks = sqrt(dhkc**2-dp(3,5)*dp(4,5))
        dhk1 = 0.5D0*((dp(4,5)+dhkc)/dhks-1D0)
        dhk2 = 0.5D0*((dp(3,5)+dhkc)/dhks-1D0)
        in1 = n + nr + 4*is - 3
        p(in1, 5) = sngl(sqrt(dp(3,5)+2D0*dhkc+dp(4,5)))
        Do j = 1, 4
          p(in1, j) = sngl((1D0+dhk1)*dp(1,j)-dhk2*dp(2,j))
          p(in1+1, j) = sngl((1D0+dhk2)*dp(2,j)-dhk1*dp(1,j))
        End Do
      End Do
      isav = i
      270 ntry = ntry + 1
      If (ntry>100 .And. ntryr<=4) Then
        paru12 = 4.*paru12
        paru13 = 2.*paru13
        Goto 130
      Else If (ntry>100) Then
        Call luerrm(14, '(LUSTRF:) caught in infinite loop')
        If (mstu(21)>=1) Return
      End If
      i = isav
      irankj = 0
      ie(1) = k(n+1+(jt/2)*(np-1), 3)
      in(4) = n + nr + 1
      in(5) = in(4) + 1
      in(6) = n + nr + 4*ns + 1
      Do jq = 1, 2
        Do in1 = n + nr + 2 + jq, n + nr + 4*ns - 2 + jq, 4
          p(in1, 1) = 2 - jq
          p(in1, 2) = jq - 1
          p(in1, 3) = 1.
        End Do
      End Do
      kfl(1) = k(iju(iu), 2)
      px(1) = 0.
      py(1) = 0.
      gam(1) = 0.
      Do j = 1, 5
        pju(iu+3, j) = 0.
      End Do
      Do j = 1, 4
        dp(1, j) = dble(p(in(4),j))
        dp(2, j) = dble(p(in(4)+1,j))
        dp(3, j) = 0D0
        dp(4, j) = 0D0
      End Do
      dp(1, 4) = sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
      dp(2, 4) = sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
      dp(5, 1) = dp(1, 1)/dp(1, 4) - dp(2, 1)/dp(2, 4)
      dp(5, 2) = dp(1, 2)/dp(1, 4) - dp(2, 2)/dp(2, 4)
      dp(5, 3) = dp(1, 3)/dp(1, 4) - dp(2, 3)/dp(2, 4)
      If (dp(5,1)**2<=dp(5,2)**2+dp(5,3)**2) dp(3, 1) = 1D0
      If (dp(5,1)**2>dp(5,2)**2+dp(5,3)**2) dp(3, 3) = 1D0
      If (dp(5,2)**2<=dp(5,1)**2+dp(5,3)**2) dp(4, 2) = 1D0
      If (dp(5,2)**2>dp(5,1)**2+dp(5,3)**2) dp(4, 3) = 1D0
      dhc12 = dfour(1, 2)
      dhcx1 = dfour(3, 1)/dhc12
      dhcx2 = dfour(3, 2)/dhc12
      dhcxx = 1D0/sqrt(1D0+2D0*dhcx1*dhcx2*dhc12)
      dhcy1 = dfour(4, 1)/dhc12
      dhcy2 = dfour(4, 2)/dhc12
      dhcyx = dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
      dhcyy = 1D0/sqrt(1D0+2D0*dhcy1*dhcy2*dhc12-dhcyx**2)
      Do j = 1, 4
        dp(3, j) = dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
        p(in(6), j) = sngl(dp(3,j))
        p(in(6)+1, j) = sngl(dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-dhcyx*dp(3,j)))
      End Do
      320 i = i + 1
      If (2*i-nsav>=mstu(4)-mstu(32)-5) Then
        Call luerrm(11, '(LUSTRF:) no more memory left in LUJETS')
        If (mstu(21)>=1) Return
      End If
      irankj = irankj + 1
      k(i, 1) = 1
      k(i, 3) = ie(1)
      k(i, 4) = 0
      k(i, 5) = 0
      330 Call lukfdi(kfl(1), 0, kfl(3), k(i,2))
      If (k(i,2)==0) Goto 270
      If (mstj(12)>=3 .And. irankj==1 .And. iabs(kfl(1))<=10 .And. iabs(kfl(3))>10) Then
        If (rlu(0)>parj(19)) Goto 330
      End If
      p(i, 5) = ulmass(k(i,2))
      Call luptdi(kfl(1), px(3), py(3))
      pr(1) = p(i, 5)**2 + (px(1)+px(3))**2 + (py(1)+py(3))**2
      Call luzdis(kfl(1), kfl(3), pr(1), z)
      gam(3) = (1.-z)*(gam(1)+pr(1)/z)
      Do j = 1, 3
        in(j) = in(3+j)
      End Do
      If (in(1)+1==in(2) .And. z*p(in(1)+2,3)*p(in(2)+2,3)*p(in(1),5)**2>=pr(1)) Then
        p(in(1)+2, 4) = z*p(in(1)+2, 3)
        p(in(2)+2, 4) = pr(1)/(p(in(1)+2,4)*p(in(1),5)**2)
        Do j = 1, 4
          p(i, j) = (px(1)+px(3))*p(in(3), j) + (py(1)+py(3))*p(in(3)+1, j)
        End Do
        Goto 420
      Else If (in(1)+1==in(2)) Then
        p(in(2)+2, 4) = p(in(2)+2, 3)
        p(in(2)+2, 1) = 1.
        in(2) = in(2) + 4
        If (in(2)>n+nr+4*ns) Goto 270
        If (four(in(1),in(2))<=1E-2) Then
          p(in(1)+2, 4) = p(in(1)+2, 3)
          p(in(1)+2, 1) = 0.
          in(1) = in(1) + 4
        End If
      End If
      360 If (in(1)>n+nr+4*ns .Or. in(2)>n+nr+4*ns .Or. in(1)>in(2)) Goto 270
      If (in(1)/=in(4) .Or. in(2)/=in(5)) Then
        Do j = 1, 4
          dp(1, j) = dble(p(in(1),j))
          dp(2, j) = dble(p(in(2),j))
          dp(3, j) = 0D0
          dp(4, j) = 0D0
        End Do
        dp(1, 4) = sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
        dp(2, 4) = sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
        dhc12 = dfour(1, 2)
        If (dhc12<=1D-2) Then
          p(in(1)+2, 4) = p(in(1)+2, 3)
          p(in(1)+2, 1) = 0.
          in(1) = in(1) + 4
          Goto 360
        End If
        in(3) = n + nr + 4*ns + 5
        dp(5, 1) = dp(1, 1)/dp(1, 4) - dp(2, 1)/dp(2, 4)
        dp(5, 2) = dp(1, 2)/dp(1, 4) - dp(2, 2)/dp(2, 4)
        dp(5, 3) = dp(1, 3)/dp(1, 4) - dp(2, 3)/dp(2, 4)
        If (dp(5,1)**2<=dp(5,2)**2+dp(5,3)**2) dp(3, 1) = 1D0
        If (dp(5,1)**2>dp(5,2)**2+dp(5,3)**2) dp(3, 3) = 1D0
        If (dp(5,2)**2<=dp(5,1)**2+dp(5,3)**2) dp(4, 2) = 1D0
        If (dp(5,2)**2>dp(5,1)**2+dp(5,3)**2) dp(4, 3) = 1D0
        dhcx1 = dfour(3, 1)/dhc12
        dhcx2 = dfour(3, 2)/dhc12
        dhcxx = 1D0/sqrt(1D0+2D0*dhcx1*dhcx2*dhc12)
        dhcy1 = dfour(4, 1)/dhc12
        dhcy2 = dfour(4, 2)/dhc12
        dhcyx = dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
        dhcyy = 1D0/sqrt(1D0+2D0*dhcy1*dhcy2*dhc12-dhcyx**2)
        Do j = 1, 4
          dp(3, j) = dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
          p(in(3), j) = sngl(dp(3,j))
          p(in(3)+1, j) = sngl(dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-dhcyx*dp(3,j)))
        End Do
        pxp = -(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))
        pyp = -(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1))
        If (abs(pxp**2+pyp**2-px(3)**2-py(3)**2)<0.01) Then
          px(3) = pxp
          py(3) = pyp
        End If
      End If
      Do j = 1, 4
        dhg(j) = 0D0
        p(i, j) = px(1)*p(in(6), j) + py(1)*p(in(6)+1, j) + px(3)*p(in(3), j) + py(3)*p(in(3)+1, j)
        Do in1 = in(4), in(1) - 4, 4
          p(i, j) = p(i, j) + p(in1+2, 3)*p(in1, j)
        End Do
        Do in2 = in(5), in(2) - 4, 4
          p(i, j) = p(i, j) + p(in2+2, 3)*p(in2, j)
        End Do
      End Do
      dhm(1) = dble(four(i,i))
      dhm(2) = dble(2.*four(i,in(1)))
      dhm(3) = dble(2.*four(i,in(2)))
      dhm(4) = dble(2.*four(in(1),in(2)))
      Do in2 = in(1) + 1, in(2), 4
        Do in1 = in(1), in2 - 1, 4
          dhc = dble(2.*four(in1,in2))
          dhg(1) = dhg(1) + dble(p(in1+2,1)*p(in2+2,1))*dhc
          If (in1==in(1)) dhg(2) = dhg(2) - dble(p(in2+2,1))*dhc
          If (in2==in(2)) dhg(3) = dhg(3) + dble(p(in1+2,1))*dhc
          If (in1==in(1) .And. in2==in(2)) dhg(4) = dhg(4) - dhc
        End Do
      End Do
      dhs1 = dhm(3)*dhg(4) - dhm(4)*dhg(3)
      If (dabs(dhs1)<1D-4) Goto 270
      dhs2 = dhm(4)*(dble(gam(3))-dhg(1)) - dhm(2)*dhg(3) - dhg(4)*(dble(p(i,5))**2-dhm(1)) + dhg(2)*dhm(3)
      dhs3 = dhm(2)*(dble(gam(3))-dhg(1)) - dhg(2)*(dble(p(i,5))**2-dhm(1))
      p(in(2)+2, 4) = 0.5*sngl(sqrt(max(0D0,dhs2**2-4D0*dhs1*dhs3))/abs(dhs1)-dhs2/dhs1)
      If (dhm(2)+dhm(4)*dble(p(in(2)+2,4))<=0D0) Goto 270
      p(in(1)+2, 4) = (p(i,5)**2-sngl(dhm(1))-sngl(dhm(3))*p(in(2)+2,4))/(sngl(dhm(2))+sngl(dhm(4))*p(in(2)+2,4))
      If (p(in(2)+2,4)>p(in(2)+2,3)) Then
        p(in(2)+2, 4) = p(in(2)+2, 3)
        p(in(2)+2, 1) = 1.
        in(2) = in(2) + 4
        If (in(2)>n+nr+4*ns) Goto 270
        If (four(in(1),in(2))<=1E-2) Then
          p(in(1)+2, 4) = p(in(1)+2, 3)
          p(in(1)+2, 1) = 0.
          in(1) = in(1) + 4
        End If
        Goto 360
      Else If (p(in(1)+2,4)>p(in(1)+2,3)) Then
        p(in(1)+2, 4) = p(in(1)+2, 3)
        p(in(1)+2, 1) = 0.
        in(1) = in(1) + js
        Goto 710
      End If
      420 Do j = 1, 4
        p(i, j) = p(i, j) + p(in(1)+2, 4)*p(in(1), j) + p(in(2)+2, 4)*p(in(2), j)
        pju(iu+3, j) = pju(iu+3, j) + p(i, j)
      End Do
      If (p(i,4)<=0.) Goto 270
      pju(iu+3, 5) = tju(4)*pju(iu+3, 4) - tju(1)*pju(iu+3, 1) - tju(2)*pju(iu+3, 2) - tju(3)*pju(iu+3, 3)
      If (pju(iu+3,5)<pju(iu,5)) Then
        kfl(1) = -kfl(3)
        px(1) = -px(3)
        py(1) = -py(3)
        gam(1) = gam(3)
        If (in(3)/=in(6)) Then
          Do j = 1, 4
            p(in(6), j) = p(in(3), j)
            p(in(6)+1, j) = p(in(3)+1, j)
          End Do
        End If
        Do jq = 1, 2
          in(3+jq) = in(jq)
          p(in(jq)+2, 3) = p(in(jq)+2, 3) - p(in(jq)+2, 4)
          p(in(jq)+2, 1) = p(in(jq)+2, 1) - (3-2*jq)*p(in(jq)+2, 4)
        End Do
        Goto 320
      End If
      If (iabs(kfl(1))>10) Goto 270
      i = i - 1
      kfjh(iu) = kfl(1)
      Do j = 1, 4
        pju(iu+3, j) = pju(iu+3, j) - p(i+1, j)
      End Do
    End Do
    njs(jt) = i - ista
    kfjs(jt) = k(k(mju(jt+2),3), 2)
    kfls = 2*int(rlu(0)+3.*parj(4)/(1.+3.*parj(4))) + 1
    If (kfjh(1)==kfjh(2)) kfls = 3
    If (ista/=i) kfjs(jt) = isign(1000*max(iabs(kfjh(1)),iabs(kfjh(2)))+100*min(iabs(kfjh(1)),iabs(kfjh(2)))+kfls, kfjh(1))
    Do j = 1, 4
      pjs(jt, j) = pju(1, j) + pju(2, j) + p(mju(jt), j)
      pjs(jt+2, j) = pju(4, j) + pju(5, j)
    End Do
    pjs(jt, 5) = sqrt(max(0.,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2-pjs(jt,3)**2))
  490 End Do
  500 If (mju(1)/=0 .And. mju(2)/=0) Then
    ns = mju(2) - mju(1)
    nb = mju(1) - n
  Else If (mju(1)/=0) Then
    ns = n + nr - mju(1)
    nb = mju(1) - n
  Else If (mju(2)/=0) Then
    ns = mju(2) - n
    nb = 1
  Else If (iabs(k(n+1,2))/=21) Then
    ns = nr - 1
    nb = 1
  Else
    ns = nr + 1
    w2sum = 0.
    Do is = 1, nr
      p(n+nr+is, 1) = 0.5*four(n+is, n+is+1-nr*(is/nr))
      w2sum = w2sum + p(n+nr+is, 1)
    End Do
    w2ran = rlu(0)*w2sum
    nb = 0
    520 nb = nb + 1
    w2sum = w2sum - p(n+nr+nb, 1)
    If (w2sum>w2ran .And. nb<nr) Goto 520
  End If
  Do is = 1, ns
    is1 = n + is + nb - 1 - nr*((is+nb-2)/nr)
    is2 = n + is + nb - nr*((is+nb-1)/nr)
    Do j = 1, 5
      dp(1, j) = dble(p(is1,j))
      If (iabs(k(is1,2))==21) dp(1, j) = 0.5D0*dp(1, j)
      If (is1==mju(1)) dp(1, j) = dble(pjs(1,j)-pjs(3,j))
      dp(2, j) = dble(p(is2,j))
      If (iabs(k(is2,2))==21) dp(2, j) = 0.5D0*dp(2, j)
      If (is2==mju(2)) dp(2, j) = dble(pjs(2,j)-pjs(4,j))
    End Do
    dp(3, 5) = dfour(1, 1)
    dp(4, 5) = dfour(2, 2)
    dhkc = dfour(1, 2)
    If (dp(3,5)+2.D0*dhkc+dp(4,5)<=0.D0) Then
      dp(3, 5) = dp(1, 5)**2
      dp(4, 5) = dp(2, 5)**2
      dp(1, 4) = sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2+dp(1,5)**2)
      dp(2, 4) = sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2+dp(2,5)**2)
      dhkc = dfour(1, 2)
    End If
    dhks = sqrt(dhkc**2-dp(3,5)*dp(4,5))
    dhk1 = 0.5D0*((dp(4,5)+dhkc)/dhks-1.D0)
    dhk2 = 0.5D0*((dp(3,5)+dhkc)/dhks-1.D0)
    in1 = n + nr + 4*is - 3
    p(in1, 5) = sqrt(sngl(dp(3,5)+2.D0*dhkc+dp(4,5)))
    Do j = 1, 4
      p(in1, j) = sngl((1.D0+dhk1)*dp(1,j)-dhk2*dp(2,j))
      p(in1+1, j) = sngl((1.D0+dhk2)*dp(2,j)-dhk1*dp(1,j))
    End Do
  End Do
  isav = i
  550 ntry = ntry + 1
  If (ntry>100 .And. ntryr<=4) Then
    paru12 = 4.*paru12
    paru13 = 2.*paru13
    Goto 130
  Else If (ntry>100) Then
    Call luerrm(14, '(LUSTRF:) caught in infinite loop')
    If (mstu(21)>=1) Return
  End If
  i = isav
  Do j = 1, 4
    p(n+nrs, j) = 0.
    Do is = 1, nr
      p(n+nrs, j) = p(n+nrs, j) + p(n+is, j)
    End Do
  End Do
  Do jt = 1, 2
    irank(jt) = 0
    If (mju(jt)/=0) irank(jt) = njs(jt)
    If (ns>nr) irank(jt) = 1
    ie(jt) = k(n+1+(jt/2)*(np-1), 3)
    in(3*jt+1) = n + nr + 1 + 4*(jt/2)*(ns-1)
    in(3*jt+2) = in(3*jt+1) + 1
    in(3*jt+3) = n + nr + 4*ns + 2*jt - 1
    Do in1 = n + nr + 2 + jt, n + nr + 4*ns - 2 + jt, 4
      p(in1, 1) = 2 - jt
      p(in1, 2) = jt - 1
      p(in1, 3) = 1.
    End Do
  End Do
  If (ns<nr) Then
    px(1) = 0.
    py(1) = 0.
    If (ns==1 .And. mju(1)+mju(2)==0) Call luptdi(0, px(1), py(1))
    px(2) = -px(1)
    py(2) = -py(1)
    Do jt = 1, 2
      kfl(jt) = k(ie(jt), 2)
      If (mju(jt)/=0) kfl(jt) = kfjs(jt)
      mstj(93) = 1
      pmq(jt) = ulmass(kfl(jt))
      gam(jt) = 0.
    End Do
  Else
    kfl(3) = int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
    Call lukfdi(kfl(3), 0, kfl(1), kdump)
    kfl(2) = -kfl(1)
    If (iabs(kfl(1))>10 .And. rlu(0)>0.5) Then
      kfl(2) = -(kfl(1)+isign(10000,kfl(1)))
    Else If (iabs(kfl(1))>10) Then
      kfl(1) = -(kfl(2)+isign(10000,kfl(2)))
    End If
    Call luptdi(kfl(1), px(1), py(1))
    px(2) = -px(1)
    py(2) = -py(1)
    pr3 = min(25., 0.1*p(n+nr+1,5)**2)
    590 Call luzdis(kfl(1), kfl(2), pr3, z)
    zr = pr3/(z*p(n+nr+1,5)**2)
    If (zr>=1.) Goto 590
    Do jt = 1, 2
      mstj(93) = 1
      pmq(jt) = ulmass(kfl(jt))
      gam(jt) = pr3*(1.-z)/z
      in1 = n + nr + 3 + 4*(jt/2)*(ns-1)
      p(in1, jt) = 1. - z
      p(in1, 3-jt) = jt - 1
      p(in1, 3) = (2-jt)*(1.-z) + (jt-1)*z
      p(in1+1, jt) = zr
      p(in1+1, 3-jt) = 2 - jt
      p(in1+1, 3) = (2-jt)*(1.-zr) + (jt-1)*zr
    End Do
  End If
  Do jt = 1, 2
    If (jt==1 .Or. ns==nr-1) Then
      in1 = in(3*jt+1)
      in3 = in(3*jt+3)
      Do j = 1, 4
        dp(1, j) = dble(p(in1,j))
        dp(2, j) = dble(p(in1+1,j))
        dp(3, j) = 0.D0
        dp(4, j) = 0.D0
      End Do
      dp(1, 4) = dsqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
      dp(2, 4) = dsqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
      dp(5, 1) = dp(1, 1)/dp(1, 4) - dp(2, 1)/dp(2, 4)
      dp(5, 2) = dp(1, 2)/dp(1, 4) - dp(2, 2)/dp(2, 4)
      dp(5, 3) = dp(1, 3)/dp(1, 4) - dp(2, 3)/dp(2, 4)
      If (dp(5,1)**2<=dp(5,2)**2+dp(5,3)**2) dp(3, 1) = 1.D0
      If (dp(5,1)**2>dp(5,2)**2+dp(5,3)**2) dp(3, 3) = 1.D0
      If (dp(5,2)**2<=dp(5,1)**2+dp(5,3)**2) dp(4, 2) = 1.D0
      If (dp(5,2)**2>dp(5,1)**2+dp(5,3)**2) dp(4, 3) = 1.D0
      dhc12 = dfour(1, 2)
      dhcx1 = dfour(3, 1)/dhc12
      dhcx2 = dfour(3, 2)/dhc12
      dhcxx = 1D0/sqrt(1D0+2D0*dhcx1*dhcx2*dhc12)
      dhcy1 = dfour(4, 1)/dhc12
      dhcy2 = dfour(4, 2)/dhc12
      dhcyx = dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
      dhcyy = 1D0/sqrt(1D0+2D0*dhcy1*dhcy2*dhc12-dhcyx**2)
      Do j = 1, 4
        dp(3, j) = dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
        p(in3, j) = sngl(dp(3,j))
        p(in3+1, j) = sngl(dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-dhcyx*dp(3,j)))
      End Do
    Else
      Do j = 1, 4
        p(in3+2, j) = p(in3, j)
        p(in3+3, j) = p(in3+1, j)
      End Do
    End If
  End Do
  If (mju(1)+mju(2)>0) Then
    Do jt = 1, 2
      If (njs(jt)==0) Goto 660
      Do j = 1, 4
        p(n+nrs, j) = p(n+nrs, j) - pjs(jt+2, j)
      End Do
    660 End Do
  End If
  670 i = i + 1
  If (2*i-nsav>=mstu(4)-mstu(32)-5) Then
    Call luerrm(11, '(LUSTRF:) no more memory left in LUJETS')
    If (mstu(21)>=1) Return
  End If
  jt = int(1.5+rlu(0))
  If (iabs(kfl(3-jt))>10) jt = 3 - jt
  jr = 3 - jt
  js = 3 - 2*jt
  irank(jt) = irank(jt) + 1
  k(i, 1) = 1
  k(i, 3) = ie(jt)
  k(i, 4) = 0
  k(i, 5) = 0
  680 Call lukfdi(kfl(jt), 0, kfl(3), k(i,2))
  If (k(i,2)==0) Goto 550
  If (mstj(12)>=3 .And. irank(jt)==1 .And. iabs(kfl(jt))<=10 .And. iabs(kfl(3))>10) Then
    If (rlu(0)>parj(19)) Goto 680
  End If
  p(i, 5) = ulmass(k(i,2))
  Call luptdi(kfl(jt), px(3), py(3))
  pr(jt) = p(i, 5)**2 + (px(jt)+px(3))**2 + (py(jt)+py(3))**2
  mstj(93) = 1
  pmq(3) = ulmass(kfl(3))
  wmin = parj(32+mstj(11)) + pmq(1) + pmq(2) + parj(36)*pmq(3)
  If (iabs(kfl(jt))>10 .And. iabs(kfl(3))>10) wmin = wmin - 0.5*parj(36)*pmq(3)
  wrem2 = four(n+nrs, n+nrs)
  If (wrem2<0.10) Goto 550
  If (wrem2<max(wmin*(1.+(2.*rlu(0)-1.)*parj(37)),parj(32)+pmq(1)+pmq(2))**2) Goto 810
  Call luzdis(kfl(jt), kfl(3), pr(jt), z)
  kfl1a = iabs(kfl(1))
  kfl2a = iabs(kfl(2))
  If (max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),mod(kfl2a/1000,10))>=4) Then
    pr(jr) = (pmq(jr)+pmq(3))**2 + (px(jr)-px(3))**2 + (py(jr)-py(3))**2
    pw12 = sqrt(max(0.,(wrem2-pr(1)-pr(2))**2-4.*pr(1)*pr(2)))
    z = (wrem2+pr(jt)-pr(jr)+pw12*(2.*z-1.))/(2.*wrem2)
    pr(jr) = (pmq(jr)+parj(32+mstj(11)))**2 + (px(jr)-px(3))**2 + (py(jr)-py(3))**2
    If ((1.-z)*(wrem2-pr(jt)/z)<pr(jr)) Goto 810
  End If
  gam(3) = (1.-z)*(gam(jt)+pr(jt)/z)
  Do j = 1, 3
    in(j) = in(3*jt+j)
  End Do
  If (in(1)+1==in(2) .And. z*p(in(1)+2,3)*p(in(2)+2,3)*p(in(1),5)**2>=pr(jt)) Then
    p(in(jt)+2, 4) = z*p(in(jt)+2, 3)
    p(in(jr)+2, 4) = pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)
    Do j = 1, 4
      p(i, j) = (px(jt)+px(3))*p(in(3), j) + (py(jt)+py(3))*p(in(3)+1, j)
    End Do
    Goto 770
  Else If (in(1)+1==in(2)) Then
    p(in(jr)+2, 4) = p(in(jr)+2, 3)
    p(in(jr)+2, jt) = 1.
    in(jr) = in(jr) + 4*js
    If (js*in(jr)>js*in(4*jr)) Goto 550
    If (four(in(1),in(2))<=1E-2) Then
      p(in(jt)+2, 4) = p(in(jt)+2, 3)
      p(in(jt)+2, jt) = 0.
      in(jt) = in(jt) + 4*js
    End If
  End If
  710 If (js*in(1)>js*in(3*jr+1) .Or. js*in(2)>js*in(3*jr+2) .Or. in(1)>in(2)) Goto 550
  If (in(1)/=in(3*jt+1) .Or. in(2)/=in(3*jt+2)) Then
    Do j = 1, 4
      dp(1, j) = dble(p(in(1),j))
      dp(2, j) = dble(p(in(2),j))
      dp(3, j) = 0.D0
      dp(4, j) = 0.D0
    End Do
    dp(1, 4) = dsqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
    dp(2, 4) = dsqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
    dhc12 = dfour(1, 2)
    If (dhc12<=1D-2) Then
      p(in(jt)+2, 4) = p(in(jt)+2, 3)
      p(in(jt)+2, jt) = 0.
      in(jt) = in(jt) + 4*js
      Goto 710
    End If
    in(3) = n + nr + 4*ns + 5
    dp(5, 1) = dp(1, 1)/dp(1, 4) - dp(2, 1)/dp(2, 4)
    dp(5, 2) = dp(1, 2)/dp(1, 4) - dp(2, 2)/dp(2, 4)
    dp(5, 3) = dp(1, 3)/dp(1, 4) - dp(2, 3)/dp(2, 4)
    If (dp(5,1)**2<=dp(5,2)**2+dp(5,3)**2) dp(3, 1) = 1.D0
    If (dp(5,1)**2>dp(5,2)**2+dp(5,3)**2) dp(3, 3) = 1.D0
    If (dp(5,2)**2<=dp(5,1)**2+dp(5,3)**2) dp(4, 2) = 1.D0
    If (dp(5,2)**2>dp(5,1)**2+dp(5,3)**2) dp(4, 3) = 1.D0
    dhcx1 = dfour(3, 1)/dhc12
    dhcx2 = dfour(3, 2)/dhc12
    dhcxx = 1D0/sqrt(1D0+2D0*dhcx1*dhcx2*dhc12)
    dhcy1 = dfour(4, 1)/dhc12
    dhcy2 = dfour(4, 2)/dhc12
    dhcyx = dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
    dhcyy = 1D0/sqrt(1D0+2D0*dhcy1*dhcy2*dhc12-dhcyx**2)
    Do j = 1, 4
      dp(3, j) = dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
      p(in(3), j) = sngl(dp(3,j))
      p(in(3)+1, j) = sngl(dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-dhcyx*dp(3,j)))
    End Do
    pxp = -(px(3)*four(in(3*jt+3),in(3))+py(3)*four(in(3*jt+3)+1,in(3)))
    pyp = -(px(3)*four(in(3*jt+3),in(3)+1)+py(3)*four(in(3*jt+3)+1,in(3)+1))
    If (abs(pxp**2+pyp**2-px(3)**2-py(3)**2)<0.01) Then
      px(3) = pxp
      py(3) = pyp
    End If
  End If
  Do j = 1, 4
    dhg(j) = 0.D0
    p(i, j) = px(jt)*p(in(3*jt+3), j) + py(jt)*p(in(3*jt+3)+1, j) + px(3)*p(in(3), j) + py(3)*p(in(3)+1, j)
    Do in1 = in(3*jt+1), in(1) - 4*js, 4*js
      p(i, j) = p(i, j) + p(in1+2, 3)*p(in1, j)
    End Do
    Do in2 = in(3*jt+2), in(2) - 4*js, 4*js
      p(i, j) = p(i, j) + p(in2+2, 3)*p(in2, j)
    End Do
  End Do
  dhm(1) = dble(four(i,i))
  dhm(2) = dble(2.*four(i,in(1)))
  dhm(3) = dble(2.*four(i,in(2)))
  dhm(4) = dble(2.*four(in(1),in(2)))
  Do in2 = in(1) + 1, in(2), 4
    Do in1 = in(1), in2 - 1, 4
      dhc = dble(2.*four(in1,in2))
      dhg(1) = dhg(1) + dble(p(in1+2,jt)*p(in2+2,jt))*dhc
      If (in1==in(1)) dhg(2) = dhg(2) - dble(float(js)*p(in2+2,jt))*dhc
      If (in2==in(2)) dhg(3) = dhg(3) + dble(float(js)*p(in1+2,jt))*dhc
      If (in1==in(1) .And. in2==in(2)) dhg(4) = dhg(4) - dhc
    End Do
  End Do
  dhs1 = dhm(jr+1)*dhg(4) - dhm(4)*dhg(jr+1)
  If (dabs(dhs1)<1D-4) Goto 550
  dhs2 = dhm(4)*(dble(gam(3))-dhg(1)) - dhm(jt+1)*dhg(jr+1) - dhg(4)*(dble(p(i,5))**2-dhm(1)) + dhg(jt+1)*dhm(jr+1)
  dhs3 = dhm(jt+1)*(dble(gam(3))-dhg(1)) - dhg(jt+1)*(dble(p(i,5))**2-dhm(1))
  p(in(jr)+2, 4) = 0.5*sngl((sqrt(max(0D0,dhs2**2-4.D0*dhs1*dhs3)))/abs(dhs1)-dhs2/dhs1)
  If (dhm(jt+1)+dhm(4)*dble(p(in(jr)+2,4))<=0.D0) Goto 550
  p(in(jt)+2, 4) = (p(i,5)**2-sngl(dhm(1))-sngl(dhm(jr+1))*p(in(jr)+2,4))/(sngl(dhm(jt+1))+sngl(dhm(4))*p(in(jr)+2,4))
  If (p(in(jr)+2,4)>p(in(jr)+2,3)) Then
    p(in(jr)+2, 4) = p(in(jr)+2, 3)
    p(in(jr)+2, jt) = 1.
    in(jr) = in(jr) + 4*js
    If (js*in(jr)>js*in(4*jr)) Goto 550
    If (four(in(1),in(2))<=1E-2) Then
      p(in(jt)+2, 4) = p(in(jt)+2, 3)
      p(in(jt)+2, jt) = 0.
      in(jt) = in(jt) + 4*js
    End If
    Goto 710
  Else If (p(in(jt)+2,4)>p(in(jt)+2,3)) Then
    p(in(jt)+2, 4) = p(in(jt)+2, 3)
    p(in(jt)+2, jt) = 0.
    in(jt) = in(jt) + 4*js
    Goto 710
  End If
  770 Do j = 1, 4
    p(i, j) = p(i, j) + p(in(1)+2, 4)*p(in(1), j) + p(in(2)+2, 4)*p(in(2), j)
    p(n+nrs, j) = p(n+nrs, j) - p(i, j)
  End Do
  If (p(i,4)<=0.) Goto 550
  kfl(jt) = -kfl(3)
  pmq(jt) = pmq(3)
  px(jt) = -px(3)
  py(jt) = -py(3)
  gam(jt) = gam(3)
  If (in(3)/=in(3*jt+3)) Then
    Do j = 1, 4
      p(in(3*jt+3), j) = p(in(3), j)
      p(in(3*jt+3)+1, j) = p(in(3)+1, j)
    End Do
  End If
  Do jq = 1, 2
    in(3*jt+jq) = in(jq)
    p(in(jq)+2, 3) = p(in(jq)+2, 3) - p(in(jq)+2, 4)
    p(in(jq)+2, jt) = p(in(jq)+2, jt) - js*(3-2*jq)*p(in(jq)+2, 4)
  End Do
  Goto 670
  810 i = i + 1
  k(i, 1) = 1
  k(i, 3) = ie(jr)
  k(i, 4) = 0
  k(i, 5) = 0
  Call lukfdi(kfl(jr), -kfl(3), kfldmp, k(i,2))
  If (k(i,2)==0) Goto 550
  p(i, 5) = ulmass(k(i,2))
  pr(jr) = p(i, 5)**2 + (px(jr)-px(3))**2 + (py(jr)-py(3))**2
  jq = 1
  If (p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5))<p(in(7),3)*p(in(8),3)*four(in(7),in(8))) jq = 2
  dhc12 = dble(four(in(3*jq+1),in(3*jq+2)))
  dhr1 = dble(four(n+nrs,in(3*jq+2)))/dhc12
  dhr2 = dble(four(n+nrs,in(3*jq+1)))/dhc12
  If (in(4)/=in(7) .Or. in(5)/=in(8)) Then
    px(3-jq) = -four(n+nrs, in(3*jq+3)) - px(jq)
    py(3-jq) = -four(n+nrs, in(3*jq+3)+1) - py(jq)
    pr(3-jq) = p(i+(jt+jq-3)**2-1, 5)**2 + (px(3-jq)+(2*jq-3)*js*px(3))**2 + (py(3-jq)+(2*jq-3)*js*py(3))**2
  End If
  wrem2 = wrem2 + (px(1)+px(2))**2 + (py(1)+py(2))**2
  fd = (sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)
  If (mju(1)+mju(2)/=0 .And. i==isav+2 .And. fd>=1.) Goto 180
  If (fd>=1.) Goto 550
  fa = wrem2 + pr(jt) - pr(jr)
  If (mstj(11)==2) prev = 0.5*fd**parj(37+mstj(11))
  If (mstj(11)/=2) prev = 0.5*exp(max(-100.,log(fd)*parj(37+mstj(11))*(pr(1)+pr(2))**2))
  fb = sign(sqrt(max(0.,fa**2-4.*wrem2*pr(jt))), js*(rlu(0)-prev))
  kfl1a = iabs(kfl(1))
  kfl2a = iabs(kfl(2))
  If (max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),mod(kfl2a/1000,10))>=6) fb = sign(sqrt(max(0.,fa**2-4.*wrem2*pr(jt))), float(js))
  Do j = 1, 4
    p(i-1, j) = (px(jt)+px(3))*p(in(3*jq+3), j) + (py(jt)+py(3))*p(in(3*jq+3)+1, j) + 0.5*(sngl(dhr1)*(fa+fb)*p(in(3*jq+1),j)+sngl(dhr2)*(fa-fb)*p(in(3*jq+2),j))/wrem2
    p(i, j) = p(n+nrs, j) - p(i-1, j)
  End Do
  n = i - nrs + 1
  Do i = nsav + 1, nsav + np
    im = k(i, 3)
    k(im, 1) = k(im, 1) + 10
    If (mstu(16)/=2) Then
      k(im, 4) = nsav + 1
      k(im, 5) = nsav + 1
    Else
      k(im, 4) = nsav + 2
      k(im, 5) = n
    End If
  End Do
  nsav = nsav + 1
  k(nsav, 1) = 11
  k(nsav, 2) = 92
  k(nsav, 3) = ip
  k(nsav, 4) = nsav + 1
  k(nsav, 5) = n
  Do j = 1, 4
    p(nsav, j) = sngl(dps(j))
    v(nsav, j) = v(ip, j)
  End Do
  p(nsav, 5) = sqrt(sngl(max(0D0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2)))
  v(nsav, 5) = 0.
  Do i = nsav + 1, n
    Do j = 1, 5
      k(i, j) = k(i+nrs-1, j)
      p(i, j) = p(i+nrs-1, j)
      v(i, j) = 0.
    End Do
  End Do
  Do i = nsav + 1, n
    Do j = 1, 5
      k(i-nsav+n, j) = k(i, j)
      p(i-nsav+n, j) = p(i, j)
    End Do
  End Do
  i1 = nsav
  Do i = n + 1, 2*n - nsav
    If (k(i,3)/=ie(1)) Goto 880
    i1 = i1 + 1
    Do j = 1, 5
      k(i1, j) = k(i, j)
      p(i1, j) = p(i, j)
    End Do
    If (mstu(16)/=2) k(i1, 3) = nsav
  880 End Do
  Do i = 2*n - nsav, n + 1, -1
    If (k(i,3)==ie(1)) Goto 900
    i1 = i1 + 1
    Do j = 1, 5
      k(i1, j) = k(i, j)
      p(i1, j) = p(i, j)
    End Do
    If (mstu(16)/=2) k(i1, 3) = nsav
  900 End Do
  Call ludbrb(nsav+1, n, 0., 0., dps(1)/dps(4), dps(2)/dps(4), dps(3)/dps(4))
  Do i = nsav + 1, n
    Do j = 1, 4
      v(i, j) = v(ip, j)
    End Do
  End Do
  Return
End Subroutine lustrf


*DECK SPINCW
      SUBROUTINE SPINCW (MRELAS, NVARS, LMX, LBM, NPP, JSTRT, IBASIS,
     +   IMAT, IBRC, IPR, IWR, IND, IBB, COSTSC, GG, ERDNRM, DULNRM,
     +   AMAT, BASMAT, CSC, WR, WW, RZ, RG, COSTS, COLNRM, DUALS,
     +   STPEDG)
C***BEGIN PROLOGUE  SPINCW
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SPLP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (SPINCW-S, DPINCW-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/,
C     REAL (12 BLANKS)/DOUBLE PRECISION/,/SCOPY/DCOPY/,/SDOT/DDOT/.
C
C     THIS SUBPROGRAM IS PART OF THE SPLP( ) PACKAGE.
C     IT IMPLEMENTS THE PROCEDURE (INITIALIZE REDUCED COSTS AND
C     STEEPEST EDGE WEIGHTS).
C
C***SEE ALSO  SPLP
C***ROUTINES CALLED  IPLOC, LA05BS, PRWPGE, SCOPY, SDOT
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  SPINCW
      INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*)
      REAL             AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),RZ(*),RG(*),
     * COSTS(*),COLNRM(*),DUALS(*),COSTSC,ERDNRM,DULNRM,GG,ONE,RZJ,
     * SCALR,ZERO,RCOST
      LOGICAL STPEDG,PAGEPL,TRANS
C***FIRST EXECUTABLE STATEMENT  SPINCW
      LPG=LMX-(NVARS+4)
      ZERO=0.
      ONE=1.
C
C     FORM REDUCED COSTS, RZ(*), AND STEEPEST EDGE WEIGHTS, RG(*).
      PAGEPL=.TRUE.
      RZ(1)=ZERO
      CALL SCOPY(NVARS+MRELAS,RZ,0,RZ,1)
      RG(1)=ONE
      CALL SCOPY(NVARS+MRELAS,RG,0,RG,1)
      NNEGRC=0
      J=JSTRT
20002 IF (.NOT.(IBB(J).LE.0)) GO TO 20004
      PAGEPL=.TRUE.
      GO TO 20005
C
C     THESE ARE NONBASIC INDEPENDENT VARIABLES. THE COLS. ARE IN SPARSE
C     MATRIX FORMAT.
20004 IF (.NOT.(J.LE.NVARS)) GO TO 20007
      RZJ=COSTSC*COSTS(J)
      WW(1)=ZERO
      CALL SCOPY(MRELAS,WW,0,WW,1)
      IF (.NOT.(J.EQ.1)) GO TO 20010
      ILOW=NVARS+5
      GO TO 20011
20010 ILOW=IMAT(J+3)+1
20011 CONTINUE
      IF (.NOT.(PAGEPL)) GO TO 20013
      IL1=IPLOC(ILOW,AMAT,IMAT)
      IF (.NOT.(IL1.GE.LMX-1)) GO TO 20016
      ILOW=ILOW+2
      IL1=IPLOC(ILOW,AMAT,IMAT)
20016 CONTINUE
      IPAGE=ABS(IMAT(LMX-1))
      GO TO 20014
20013 IL1=IHI+1
20014 CONTINUE
      IHI=IMAT(J+4)-(ILOW-IL1)
20019 IU1=MIN(LMX-2,IHI)
      IF (.NOT.(IL1.GT.IU1)) GO TO 20021
      GO TO 20020
20021 CONTINUE
      DO 60 I=IL1,IU1
      RZJ=RZJ-AMAT(I)*DUALS(IMAT(I))
      WW(IMAT(I))=AMAT(I)*CSC(J)
60    CONTINUE
      IF (.NOT.(IHI.LE.LMX-2)) GO TO 20024
      GO TO 20020
20024 CONTINUE
      IPAGE=IPAGE+1
      KEY=1
      CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT)
      IL1=NVARS+5
      IHI=IHI-LPG
      GO TO 20019
20020 PAGEPL=IHI.EQ.(LMX-2)
      RZ(J)=RZJ*CSC(J)
      IF (.NOT.(STPEDG)) GO TO 20027
      TRANS=.FALSE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      RG(J)=SDOT(MRELAS,WW,1,WW,1)+ONE
20027 CONTINUE
C
C     THESE ARE NONBASIC DEPENDENT VARIABLES. THE COLS. ARE IMPLICITLY
C     DEFINED.
      GO TO 20008
20007 PAGEPL=.TRUE.
      WW(1)=ZERO
      CALL SCOPY(MRELAS,WW,0,WW,1)
      SCALR=-ONE
      IF (IND(J).EQ.2) SCALR=ONE
      I=J-NVARS
      RZ(J)=-SCALR*DUALS(I)
      WW(I)=SCALR
      IF (.NOT.(STPEDG)) GO TO 20030
      TRANS=.FALSE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      RG(J)=SDOT(MRELAS,WW,1,WW,1)+ONE
20030 CONTINUE
      CONTINUE
20008 CONTINUE
C
20005 RCOST=RZ(J)
      IF (MOD(IBB(J),2).EQ.0) RCOST=-RCOST
      IF (IND(J).EQ.4) RCOST=-ABS(RCOST)
      CNORM=ONE
      IF (J.LE.NVARS) CNORM=COLNRM(J)
      IF (RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO) NNEGRC=NNEGRC+1
      J=MOD(J,MRELAS+NVARS)+1
      IF (.NOT.(NNEGRC.GE.NPP .OR. J.EQ.JSTRT)) GO TO 20033
      GO TO 20003
20033 GO TO 20002
20003 JSTRT=J
      RETURN
      END


module stars_module
use rtglobal_module
use amr_module
use amrray_module
use mathroutines_module
use constants_module

integer :: nstars=0,nillum=0
integer :: stellarsrc_nrtemplates
logical :: star_sphere=.false.
doubleprecision,allocatable :: star_spec(:,:)
doubleprecision,allocatable :: star_spec_cum(:,:)
doubleprecision,allocatable :: star_lum(:)
doubleprecision,allocatable :: star_lumcum(:)
doubleprecision,allocatable :: star_r(:)
doubleprecision,allocatable :: star_m(:)
doubleprecision,allocatable :: star_pos(:,:)
doubleprecision,allocatable :: star_fraclum(:)
integer,allocatable         :: star_cellindex(:)
doubleprecision,allocatable :: stellarsrc_dens(:,:)
doubleprecision,allocatable :: stellarsrc_mass(:)
doubleprecision,allocatable :: stellarsrc_templates(:,:)
doubleprecision,allocatable :: stellarsrc_templateslum(:)
doubleprecision,allocatable :: stellarsrc_cum(:)
doubleprecision,allocatable :: stellarsrc_speccum(:,:)
doubleprecision,allocatable :: stellarsrc_lumcum(:)
doubleprecision,allocatable :: extlum_intens(:)
doubleprecision,allocatable :: extlum_intens_cum(:)
doubleprecision,allocatable :: heatsource(:)
doubleprecision,allocatable :: heatsource_cum(:)
doubleprecision :: starlumtot,stellarsrclumtot,extlumtot,heatsourcelumtot
!!doubleprecision :: extlum_rsphere,extlum_xsphere,extlum_ysphere,extlum_zsphere
doubleprecision :: stellarsrc_masstot,star_maxexterndist
doubleprecision,allocatable :: illum_costheta(:),illum_phi(:)
doubleprecision,allocatable :: illum_flux_unprojected(:,:)
doubleprecision,allocatable :: illum_flux_unprojected_cum(:,:)
doubleprecision,allocatable :: illum_fluxtot(:)
doubleprecision,allocatable :: illum_fluxtot_cum(:)

!$OMP THREADPRIVATE(stellarsrc_cum)
!$OMP THREADPRIVATE(star_fraclum)

contains

!-------------------------------------------------------------------------
!                 MAIN ROUTINE FOR STAR READING
!-------------------------------------------------------------------------
subroutine read_stars()
  use constants_module
  implicit none
  logical :: fex,warn,warn_star_in_grid,warn_star_must_be_sphere,fexill
  integer :: iformat,ierr,inu,istar,inupeak,illum
  double precision :: dummy,frq,lam,rpos
  character*80 :: str1
  !
  ! Check if frequency array is already read in
  !
  if(freq_nr.le.0) then
     write(stdo,*) 'ERROR: Internal error in stars_module'
     stop
  endif
  !
  ! Reset some stuff
  !
  if(allocated(amrray_spheres_r)) deallocate(amrray_spheres_r)
  if(allocated(amrray_spheres_pos)) deallocate(amrray_spheres_pos)
  if(allocated(amrray_spheres_outsidegrid)) deallocate(amrray_spheres_outsidegrid)
  if(allocated(amrray_spheres_sphidx)) deallocate(amrray_spheres_sphidx)
  !
  ! Check existence of the stars.inp file
  !
  inquire(file='stars.inp',exist=fex)
  !
  ! Specially for the cartesian 1-D plane-parallel or 2-D pencil-parallel mode
  ! we have illum.inp
  !
  inquire(file='illum.inp',exist=fexill)
  !
  ! If we have cartesian 1-D plane-parallel or 2-D pencil-parallel mode, then stars
  ! are not allowed, as they have no meaning in that context
  !
  if(fex.and.((igrid_coord.eq.10).or.(igrid_coord.eq.20))) then
     write(stdo,*) 'ERROR in stars module: When using cartesian 1-D plane-parallel or 2-D pencil-parallel mode'
     write(stdo,*) '      you are not allowed to use stars in the model, because that has no physical meaning.'
     write(stdo,*) '      Please remove the stars.inp file.'
     stop
  endif
  !
  ! If we do NOT have cartesian 1-D plane-parallel or 2-D pencil-parallel mode, then
  ! the illum.inp file is not allowed.
  !
  if(fexill.and.((igrid_coord.ne.10).and.(igrid_coord.ne.20))) then
     write(stdo,*) 'ERROR in stars module: The illum.inp file is only meaningful for cartesian 1-D plane-parallel'
     write(stdo,*) '      or 2-D pencil-parallel mode, which you do not use right now.'
     write(stdo,*) '      Please remove the illum.inp file.'
     stop
  endif
  !
  ! Temporarily switch off the possibility of using illumination fluxes
  ! for the 2-D pencil-parallel mode, because this requires a bit of
  ! subtle implementation to the get total fluxes (luminosities per length)
  ! right. Not sure if I will have the time to implement this.
  !
  if(fexill.and.(igrid_coord.eq.20)) then
     write(stdo,*) 'For the moment I am not sure if the illum.inp is consistent'
     write(stdo,*) '  with the cartesian 2-D pencil-parallel geometry. Check this...'
     stop
  endif
  !
  ! Defaults
  !
  nstars = 0
  nillum = 0
  !
  ! Read
  !
  if(fex) then
     !
     ! Open and read the stars.inp file
     !
     open(unit=1,file='stars.inp')
     read(1,*) iformat
     if((iformat.ne.1).and.(iformat.ne.2)) then
        write(stdo,*) 'ERROR: Format number of stars.inp not implemented.'
        stop
     endif
     read(1,*) nstars,inu
     if(nstars.lt.0) then
        write(stdo,*) 'ERROR: Negative nr of stars unallowed.'
        stop
     endif
     if(nstars.gt.0) then
        !
        ! OK, there are stars, so read them
        !
        ! First another check
        !
        if(inu.ne.freq_nr) then
           write(stdo,*) 'ERROR: Nr of frequency points in stars.inp is ',&
                'unequal to that in frequency.inp'
           stop
        endif
        !
        ! Allocate the arrays
        !
        allocate(star_spec(1:freq_nr,1:nstars),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for stellar spectrum'
           stop
        endif
        allocate(star_spec_cum(1:freq_nr+1,1:nstars),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for cumulative stellar spectrum'
           stop
        endif
        allocate(star_lum(1:nstars),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for stellar luminosity'
           stop
        endif
        allocate(star_lumcum(1:nstars+1),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for cumul stellar luminosity'
           stop
        endif
        allocate(star_r(1:nstars),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for stellar radius'
           stop
        endif
        allocate(star_m(1:nstars),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for stellar mass'
           stop
        endif
        allocate(star_pos(1:3,1:nstars),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for stellar position'
           stop
        endif
        allocate(star_cellindex(1:nstars),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for stellar cell index'
           stop
        endif
        !$OMP PARALLEL
        allocate(star_fraclum(1:nstars),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for fraclum array'
           stop
        endif
        star_fraclum(:) = 1.d0
        !$OMP END PARALLEL
        !
        ! Read the stellar information
        !
        do istar=1,nstars
           read(1,*) star_r(istar),star_m(istar),star_pos(1:3,istar)
        enddo
        !
        ! If we have symmetries in our grid, then we should check that the star
        ! position(s) are not located wrongly.
        !
        if(igrid_type.lt.100) then
           !
           ! AMR-type grid (or regular grid)
           !
           if((amr_coordsystem.ge.100).and.(amr_coordsystem.lt.200)) then
              !
              ! Spherical coordinates
              !
              if((amr_zdim.eq.0).and.(amr_ydim.eq.1)) then
                 do istar=1,nstars
                    if((star_pos(1,istar).ne.0.d0).or.(star_pos(2,istar).ne.0.d0)) then
                       write(stdo,*) 'ERROR in star position: In axial symmetry a star is only'
                       write(stdo,*) '      allowed to be located on the z-axis.'
                       stop
                    endif
                 enddo
              endif
              if((amr_zdim.eq.0).and.(amr_ydim.eq.0)) then
                 if(nstars.gt.1) then
                    write(stdo,*) 'ERROR in star position: In spherical symmetry at most 1 star'
                    write(stdo,*) '      is allowed.'
                    stop
                 endif
                 if((star_pos(1,1).ne.0.d0).or.(star_pos(2,1).ne.0.d0).or. &
                      (star_pos(3,1).ne.0.d0)) then
                    write(stdo,*) 'ERROR in star position: In spherical symmetry a star is only'
                    write(stdo,*) '      allowed to be located at (0,0,0).'
                    stop
                 endif
              endif
              warn_star_in_grid = .false.
              warn_star_must_be_sphere = .false.
              do istar=1,nstars
                 rpos = sqrt(star_pos(1,istar)**2+star_pos(2,istar)**2+star_pos(3,istar)**2)
                 if((rpos.ge.amr_grid_xi(1,1)).and. &
                    (rpos.le.amr_grid_xi(amr_grid_nx+1,1))) then
                    warn_star_in_grid = .true.
                 endif
                 if(rpos.lt.amr_grid_xi(1,1)) then
                    if(star_r(istar).ge.0.1d0*amr_grid_xi(1,1)) then
                       warn_star_must_be_sphere = .true.
                    endif
                 endif
              enddo
              if(warn_star_in_grid) then
                 write(stdo,*) 'Notice: Found a star inside the spherical coordinate grid.'
                 write(stdo,*) '        That is perfectly fine, just be aware of this.'
              endif
              if(.not.star_sphere) then
                 if(warn_star_must_be_sphere) then
                    write(stdo,*) '*****************************************************'
                    write(stdo,*) 'WARNING: Central star size is more than 10% of'
                    write(stdo,*) '         inner grid radius. But you still treat'
                    write(stdo,*) '         stars in point-source mode.'
                    write(stdo,*) '         Recommendation: In radmc3d.inp'
                    write(stdo,*) '         set istar_sphere = 1.'
                    write(stdo,*) '*****************************************************'
                 else
                    write(stdo,*) 'Note: Please be aware that you treat the star(s) as'
                    write(stdo,*) '      point source(s) while using spherical coordinate mode.'
                    write(stdo,*) '      Since R_*<<R_in this is probably OK, but if you want'
                    write(stdo,*) '      to play safe, then set istar_sphere = 1 in radmc3d.inp.'
                 endif
              endif
           endif
        endif
        !
        ! Now read the radiation frequencies and check if they are the same
        ! as those of the frequency.inp file.
        !
        if(iformat.eq.1) then
           do inu=1,freq_nr
              read(1,*) frq
              if(abs(frq-freq_nu(inu))/(frq+freq_nu(inu)).gt.1.d-3) then
                 write(stdo,*) 'PROBLEM: Frequency grid of stellar ',             &
                      'spectrum unequal to frequency.inp or wavelength_micron.inp'
                 write(stdo,*) frq,freq_nu(inu)
                 stop
              endif
           enddo
        else
           do inu=1,freq_nr
              read(1,*) lam
              frq = 1d4*cc/lam
              if(abs(frq-freq_nu(inu))/(frq+freq_nu(inu)).gt.1.d-3) then
                 write(stdo,*) 'PROBLEM: Frequency grid of stellar spectrum ',             &
                      'unequal to frequency.inp or wavelength_micron.inp'
                 write(stdo,*) frq,freq_nu(inu)
                 stop
              endif
           enddo
        endif
        !
        ! Now read all the spectra
        !
        ! IMPORTANT: If the first number is negative, then instead of reading
        !            the entire spectrum, a blackbody is taken with a temperature
        !            equal to the absolute value of that first number.
        !
        do istar=1,nstars
           !
           ! First read the first number. If positive, then read on, else make
           ! planck function.
           !
           read(1,*) dummy
           if(dummy.lt.0.d0) then
              !
              ! Make a simple blackbody star
              !
              if(nstars.lt.10) then
                 write(stdo,202) ' Note: Star ',istar,&
                      ' is taken to be a blackbody star'
202              format(a12,I1,a32)
                 write(str1,275) abs(dummy)
275              format(F9.0)
                 write(stdo,*) '      at a temperature T = ',trim(adjustl(str1)),' Kelvin'
              endif
              do inu=1,freq_nr
                 star_spec(inu,istar) = bplanck(abs(dummy),freq_nu(inu))
              enddo
           else
              !
              ! Read the full intensity spectrum. Note that the spectrum
              ! is given in the usual flux-at-one-parsec format, so we have
              ! to translate this here to intensity-at-stellar-surface.
              !
              star_spec(1,istar) = 3.0308410d36 * dummy / star_r(istar)**2
              do inu=2,freq_nr
                 read(1,*) dummy
                 ! NOTE: pc^2/pi = 3.0308410d36
                 star_spec(inu,istar) = 3.0308410d36 * dummy / star_r(istar)**2
              enddo
           endif
        enddo
     endif ! if(nstars.gt.0)
     !
     ! Close file
     !
     close(1)
     !
     ! Now compute the cumulative spectrum
     !
     do istar=1,nstars
        star_spec_cum(1,istar) = 0.d0
        do inu=1,freq_nr
           star_spec_cum(inu+1,istar) = star_spec_cum(inu,istar) + &
                     star_spec(inu,istar) * freq_dnu(inu)
        enddo
        if(star_spec_cum(freq_nr+1,istar).le.0.d0) then
           write(stdo,*) 'ERROR in stars module: Zero or negative stellar luminosity.'
           stop
        endif
        !!!star_lum(istar) = pi * star_spec_cum(freq_nr+1,istar) *    &
        !!!                  fourpi * star_r(istar)**2
        star_lum(istar) = -1d99 ! Should not matter - if it does, there is a bug
        do inu=1,freq_nr+1
           star_spec_cum(inu,istar) = star_spec_cum(inu,istar) /   &
                                      star_spec_cum(freq_nr+1,istar)
        enddo
     enddo
     !
     ! Check if the wavelength range is OK.
     !
     do istar=1,nstars
        !
        ! Determine location of the peak of the spectrum
        !
        dummy = 0.d0
        inupeak = 1
        do inu=1,freq_nr
           if(star_spec(inu,istar).gt.dummy) then
              inupeak=inu
              dummy = star_spec(inu,istar)
           endif
        enddo
        !
        ! Now check if this is far enough from the smallest wavelength
        !
        warn = .false.
        if(freq_nu(1).gt.freq_nu(freq_nr)) then
           if(freq_nu(1).lt.3.d0*freq_nu(inupeak)) warn=.true.
        else
           if(freq_nu(freq_nr).lt.3.d0*freq_nu(inupeak)) warn=.true.
        endif
        if(warn) then
           write(stdo,*) '**************************************************************'
           write(stdo,*) 'WARNING: It looks as though the stellar spectrum'
           write(stdo,*) '         does not have its peak well within the wavelength'
           write(stdo,*) '         domain! This could result in wrong dust temperatures.'
           write(stdo,*) '    Tip: extend the wavelength domain to shorter values.'
           write(stdo,*) '**************************************************************'
        endif
     enddo
     !
     ! If the stars should be treated as spheres, then initialize the
     ! spheres
     !
     if(star_sphere) then
        if(nstars.gt.0) then
           !
           ! Switch on the star sphere mode
           !
           write(stdo,*) 'Treating stars as finite-size spheres...'
           call flush(stdo)
           allocate(amrray_spheres_r(1:nstars),STAT=ierr)
           if(ierr.ne.0) stop 7349
           allocate(amrray_spheres_pos(1:3,1:nstars),STAT=ierr)
           if(ierr.ne.0) stop 7349
           amrray_spheres_nr = nstars
           do istar=1,nstars
              !
              ! Copy information to Amrray module
              !
              amrray_spheres_r(istar)     = star_r(istar)
              amrray_spheres_pos(1,istar) = star_pos(1,istar)
              amrray_spheres_pos(2,istar) = star_pos(2,istar)
              amrray_spheres_pos(3,istar) = star_pos(3,istar)
              !
              ! Check if the stellar radius is not rediculously small,
              ! which would point to a user error
              !
              if(star_r(istar).lt.1d5) then
                 write(stdo,*) 'ERROR: Stellar radius appears to be smaller than 1 km.'
                 write(stdo,*) '       This must be a user-error. Aborting.'
                 stop
              endif
           enddo
           call amrray_install_spheres()
        endif
     else
        amrray_spheres_nr = 0
     endif
  endif
  !
  ! If there is an illum.inp file, read that
  !
  if(fexill) then
     !
     ! Open and read the illum.inp file
     !
     open(unit=1,file='illum.inp')
     read(1,*) iformat
     if((iformat.ne.1).and.(iformat.ne.2)) then
        write(stdo,*) 'ERROR: Format number of illum.inp not implemented.'
        stop
     endif
     read(1,*) nillum,inu
     if(nillum.lt.0) then
        write(stdo,*) 'ERROR: Negative nr of illumination fluxes not allowed.'
        stop
     endif
     if(nillum.gt.0) then
        !
        ! OK, there are illumination fluxes, so read them
        !
        ! First another check
        !
        if(inu.ne.freq_nr) then
           write(stdo,*) 'ERROR: Nr of frequency points in illum.inp is ',&
                'unequal to that in frequency.inp'
           stop
        endif
        !
        ! Allocate the arrays
        !
        allocate(illum_flux_unprojected(1:freq_nr,1:nillum),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for illumination flux spectra'
           stop
        endif
        allocate(illum_flux_unprojected_cum(1:freq_nr+1,1:nillum),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for cumulative illumination flux spectra'
           stop
        endif
        allocate(illum_fluxtot(1:nillum),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for total illumination fluxes'
           stop
        endif
        allocate(illum_fluxtot_cum(1:nillum+1),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for total cumulative illumination fluxes'
           stop
        endif
        allocate(illum_costheta(1:nillum),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for angles of incidence of illumination fluxes'
           stop
        endif
        allocate(illum_phi(1:nillum),STAT=ierr)
        if(ierr.ne.0) then
           write(stdo,*) 'ERROR: Could not allocate space for angles of incidence of illumination fluxes'
           stop
        endif
        !
        ! Read the angles of incidence of the illumination fluxes
        ! NOTE: For 1-D plane parallel the second angle is irrelevant; can keep it 0.
        !
        do illum=1,nillum
           read(1,*) illum_costheta(illum),illum_phi(illum)
           illum_costheta(illum) = cos(illum_costheta(illum)*pi/180.d0)
           illum_phi(illum)      = illum_phi(illum)*pi/180.d0
           if(illum_costheta(illum).eq.0.d0) then
              write(stdo,*) 'ERROR: Cannot put an illumination flux at incl = 90 degrees.'
              stop
           endif
        enddo
        !
        ! Now read the radiation frequencies and check if they are the same
        ! as those of the frequency.inp file.
        !
        if(iformat.eq.1) then
           do inu=1,freq_nr
              read(1,*) frq
              if(abs(frq-freq_nu(inu))/(frq+freq_nu(inu)).gt.1.d-3) then
                 write(stdo,*) 'PROBLEM: Frequency grid of illumination ',             &
                      'spectrum unequal to frequency.inp or wavelength_micron.inp'
                 write(stdo,*) frq,freq_nu(inu)
                 stop
              endif
           enddo
        else
           do inu=1,freq_nr
              read(1,*) lam
              frq = 1d4*cc/lam
              if(abs(frq-freq_nu(inu))/(frq+freq_nu(inu)).gt.1.d-3) then
                 write(stdo,*) 'PROBLEM: Frequency grid of illumination spectrum ',    &
                      'unequal to frequency.inp or wavelength_micron.inp'
                 write(stdo,*) frq,freq_nu(inu)
                 stop
              endif
           enddo
        endif
        !
        ! Now read all the spectra
        !
        do illum=1,nillum
           do inu=1,freq_nr
              read(1,*) dummy
              illum_flux_unprojected(inu,illum) = dummy
           enddo
        enddo
     endif
     !
     ! Close file
     !
     close(1)
     !
     ! Now compute the cumulative spectrum
     !
     do illum=1,nillum
        illum_flux_unprojected_cum(1,illum) = 0.d0
        do inu=1,freq_nr
           illum_flux_unprojected_cum(inu+1,illum) = illum_flux_unprojected_cum(inu,illum) + &
                     illum_flux_unprojected(inu,illum) * freq_dnu(inu)
        enddo
        if(illum_flux_unprojected_cum(freq_nr+1,illum).le.0.d0) then
           write(stdo,*) 'ERROR in stars module: Zero or negative illumination flux.'
           stop
        endif
        do inu=1,freq_nr+1
           illum_flux_unprojected_cum(inu,illum) = illum_flux_unprojected_cum(inu,illum) /   &
                                     illum_flux_unprojected_cum(freq_nr+1,illum)
       enddo
     enddo
     !
     ! Check if the wavelength range is OK.
     !
     do illum=1,nillum
        !
        ! Determine location of the peak of the spectrum
        !
        dummy = 0.d0
        inupeak = 1
        do inu=1,freq_nr
           if(illum_flux_unprojected(inu,illum).gt.dummy) then
              inupeak=inu
              dummy = illum_flux_unprojected(inu,illum)
           endif
        enddo
        !
        ! Now check if this is far enough from the smallest wavelength
        !
        warn = .false.
        if(freq_nu(1).gt.freq_nu(freq_nr)) then
           if(freq_nu(1).lt.3.d0*freq_nu(inupeak)) warn=.true.
        else
           if(freq_nu(freq_nr).lt.3.d0*freq_nu(inupeak)) warn=.true.
        endif
        if(warn) then
           write(stdo,*) '**************************************************************'
           write(stdo,*) 'WARNING: It looks as though the illumination spectrum'
           write(stdo,*) '         does not have its peak well within the wavelength'
           write(stdo,*) '         domain! This could result in wrong dust temperatures.'
           write(stdo,*) '    Tip: extend the wavelength domain to shorter values.'
           write(stdo,*) '**************************************************************'
        endif
     enddo
  endif
  !
  ! If there are no stars, then definitely switch off the star sphere mode
  !
  if(nstars.eq.0) then
     star_sphere = .false.
     amrray_spheres_nr = 0
  endif
  !
end subroutine read_stars

!-------------------------------------------------------------------------
!                   FIND THE STARS THEIR CELLS
!-------------------------------------------------------------------------
subroutine stars_findcell()
  implicit none
  integer :: istar
  double precision :: r,theta,phi
  type(amr_branch), pointer :: a
  integer :: ix,iy,iz
  !
  if(nstars.ge.1) then
     if(igrid_type.lt.100) then
        !
        ! AMR-style grid
        !
        if(amr_coordsystem.lt.100) then
           !
           ! Cartesian coordinates
           !
           do istar=1,nstars
              if(amr_tree_present) then
                 call amr_findcell(star_pos(1,istar),star_pos(2,istar),star_pos(3,istar),a)
                 if(associated(a)) then
                    star_cellindex(istar) = a%leafindex
                 else
                    star_cellindex(istar) = 0
                 endif
              else
                 call amr_findbasecell(star_pos(1,istar),star_pos(2,istar),star_pos(3,istar),ix,iy,iz)
                 if(ix.gt.0) then
                    star_cellindex(istar) = ix+(iy-1)*amr_grid_nx+(iz-1)*amr_grid_nx*amr_grid_ny
                 else
                    star_cellindex(istar) = 0
                 endif
              endif
           enddo
        elseif((amr_coordsystem.ge.100).and.(amr_coordsystem.lt.200)) then
           !
           ! Spherical coordinates
           !
           do istar=1,nstars
              !
              ! Do some sanity checks
              !
              ! If largest theta == pihalf, then we have, by rule,
              ! equatorial mirroring.
              !
              if((amr_coordsystem.ge.100).and.(amr_coordsystem.lt.200).and. &
                   (amr_grid_xi(amr_grid_ny+1,2).eq.pihalf).and.            &
                   (amr_ydim.eq.1)) then
                 !
                 ! Yes, mirror symmetry in the equatorial plane. This means
                 ! that the non-central stars MUST be EXACTLY on the
                 ! equatorial plane.
                 !
                 r = sqrt(star_pos(1,istar)**2+star_pos(2,istar)**2)
                 if(abs(star_pos(3,istar)).gt.1d-8*r) then
                    write(stdo,*) 'ERROR: In spherical coordinates with mirror symmetry'
                    write(stdo,*) '       in the equatorial plane, all stars must have '
                    write(stdo,*) '       EXACTLY z=0 (i.e. they must reside on the '
                    write(stdo,*) '       equatorial plane).'
                    stop
                 endif
                 if(abs(star_pos(3,istar)).gt.0.d0) then
                    star_pos(3,istar) = 0.d0
                 endif
              else
                 !
                 ! No, no mirror symmetry in the equatorial plane. This
                 ! means that non-central stars should NOT be exactly on
                 ! the equatorial plane.
                 !
                 r = sqrt(star_pos(1,istar)**2+star_pos(2,istar)**2)
                 if(abs(star_pos(3,istar)).lt.1d-8*r) then
                    !
                    ! Star exactly on equatorial plane. This is asking for
                    ! trouble! So raise it a tiny bit.
                    !
                    star_pos(3,istar) = 1d-8 * r
                 endif
              endif
              !
              ! Check that in 3-D we don't put non-(0,0,0) stars exactly
              ! at phi=0 or phi=twopi.
              !
              if((amr_zdim.eq.1).and.(star_pos(1,istar).gt.0.d0)) then
                 if(abs(star_pos(2,istar)).lt.1d-8*star_pos(1,istar)) then
                    star_pos(2,istar) = 1d-8*star_pos(1,istar)
                 endif
              endif
              !
              ! Convert x,y,z to spherical coordinates
              !
              call amr_xyz_to_rthphi(star_pos(1,istar),star_pos(2,istar),&
                                     star_pos(3,istar),r,theta,phi)
              !
              ! Find the cell in which the star resides
              !
              if(theta.eq.pihalf) then
                 theta = pihalf - 1d-8   ! Only for cell searching
              endif
              if(amr_tree_present) then
                 call amr_findcell(r,theta,phi,a)
                 if(associated(a)) then
                    star_cellindex(istar) = a%leafindex
                 else
                    star_cellindex(istar) = 0
                 endif
              else
                 call amr_findbasecell(r,theta,phi,ix,iy,iz)
                 if(ix.gt.0) then
                    star_cellindex(istar) = ix+(iy-1)*amr_grid_nx+(iz-1)*amr_grid_nx*amr_grid_ny
                 else
                    star_cellindex(istar) = 0
                 endif
              endif
           enddo
        else
           write(stdo,*) 'ERROR: Other coordinate not yet implemented'
           stop 6491
        endif
     else
        write(stdo,*) 'ERROR: Other grid types not yet implemented'
        stop 2230
     endif
  endif
end subroutine stars_findcell

!-------------------------------------------------------------------------
!                 READ CONTINUUUM STELLAR SOURCE
!-------------------------------------------------------------------------
subroutine read_stellarsource(action)
  use constants_module
  implicit none
  integer :: action
  logical :: fex1,fex2,fex3
  integer :: nrfr,itempl,ierr,inu,i,index,irec,style
  integer :: ileaf,leafindex,idum,precis,reclenn
  double precision :: frq,lam,mstr,rstr,factor,dummy
  character*80 :: str1
  integer(kind=8) :: iiformat,reclen,nn,ik
  !
  ! Action=0 means do nothing, action=1 means read if not yet read,
  ! action=2 means re-read.
  !
  if(action.eq.0) then
     return
  elseif(action.eq.1) then
     if(allocated(stellarsrc_dens)) return
  endif
  !
  ! Check
  !
  if(.not.(allocated(freq_nu))) then
     write(stdo,*) 'ERROR: freq_nu not allocated when reading stellar source files'
     stop
  endif
  !
  ! Check if we can use the cellindex list
  !
  if(.not.allocated(cellindex)) then
     write(stdo,*) 'ERROR while computing stellar sources mass: The cellindex list is not yet made.'
     stop
  endif
  !
  ! Check if we have the cell volume allocated
  !
  if(.not.allocated(cellvolume)) then
     write(stdo,*) 'ERROR while computing stellar sources mass: The cellvolume list is not yet made.'
     stop
  endif
  !
  ! Reset
  !
  if(allocated(stellarsrc_dens)) deallocate(stellarsrc_dens)
  if(allocated(stellarsrc_mass)) deallocate(stellarsrc_mass)
  if(allocated(stellarsrc_templates)) deallocate(stellarsrc_templates)
  if(allocated(stellarsrc_templateslum)) deallocate(stellarsrc_templateslum)
  !$OMP PARALLEL
  if(allocated(stellarsrc_cum)) deallocate(stellarsrc_cum)
  !$OMP END PARALLEL
  if(allocated(stellarsrc_speccum)) deallocate(stellarsrc_speccum)
  if(allocated(stellarsrc_lumcum)) deallocate(stellarsrc_lumcum)
  !
  ! Read the stellar templates. These are the discrete stellar types
  ! that you can distribute independently. For instance, for a simple
  ! model of a galaxy you want to have old red stars and blue young stars.
  ! So you would need at least 2 templates.
  !
  inquire(file='stellarsrc_templates.inp',exist=fex1)
  if(fex1) then
     !
     ! Found stellar templates, so now we assume that stellar source
     ! are used. Check this.
     !
     inquire(file='stellarsrc_density.inp',exist=fex1)
     inquire(file='stellarsrc_density.uinp',exist=fex2)
     inquire(file='stellarsrc_density.binp',exist=fex3)
     idum=0
     if(fex1) idum=idum+1
     if(fex2) idum=idum+1
     if(fex3) idum=idum+1
     if(idum.gt.1) then
        write(stdo,*) 'ERROR: Found more than one file stellarsrc_density.*inp'
        stop
     endif
     if(idum.eq.0) then
        write(stdo,*) 'ERROR: Found stellarsrc_templates.inp, but not'
        write(stdo,*) '       stellarsrc_density.inp or stellarsrc_density.*inp'
        stop
     endif
     !
     ! Message
     !
     write(stdo,*) 'Reading continuously distributed stellar sources...'
     call flush(stdo)
     !
     ! Now read the templates
     !
     open(unit=1,file='stellarsrc_templates.inp')
     read(1,*) iiformat
     if((iiformat.lt.1).or.(iiformat.gt.2)) then
        write(stdo,*) 'ERROR: in stellarsrc_templates.inp: iformat not known'
        stop
     endif
     read(1,*) stellarsrc_nrtemplates
     if(stellarsrc_nrtemplates.le.0) then
        write(stdo,*) 'ERROR: nr of templates 0 or negative'
        stop
     endif
     read(1,*) nrfr
     if(nrfr.ne.freq_nr) then
        write(stdo,*) 'ERROR while reading stellarsrc_templates.inp:'
        write(stdo,*) '      The number of wavelengths unequal to that of '
        write(stdo,*) '      the global array of wavelengths_micron.inp'
        stop
     endif
     !
     ! Allocate the arrays
     !
     allocate(stellarsrc_dens(1:stellarsrc_nrtemplates,1:nrcells),STAT=ierr)
     if(ierr.ne.0) then
        write(stdo,*) 'ERROR: Could not allocate space for stellarsrc density'
        stop
     endif
     allocate(stellarsrc_mass(1:stellarsrc_nrtemplates),STAT=ierr)
     if(ierr.ne.0) then
        write(stdo,*) 'ERROR: Could not allocate space for stellarsrc masses'
        stop
     endif
     allocate(stellarsrc_templates(1:freq_nr,1:stellarsrc_nrtemplates),STAT=ierr)
     if(ierr.ne.0) then
        write(stdo,*) 'ERROR: Could not allocate space for stellarsrc templates'
        stop
     endif
     allocate(stellarsrc_templateslum(1:stellarsrc_nrtemplates),STAT=ierr)
     if(ierr.ne.0) then
        write(stdo,*) 'ERROR: Could not allocate space for stellarsrc templateslum'
        stop
     endif
     !$OMP PARALLEL
     allocate(stellarsrc_cum(1:stellarsrc_nrtemplates+1),STAT=ierr)
     if(ierr.ne.0) then
        write(stdo,*) 'ERROR: Could not allocate space for stellarsrc cum'
        stop
     endif
     !$OMP END PARALLEL
     allocate(stellarsrc_speccum(1:freq_nr+1,1:stellarsrc_nrtemplates),STAT=ierr)
     if(ierr.ne.0) then
        write(stdo,*) 'ERROR: Could not allocate space for stellarsrc speccum'
        stop
     endif
     allocate(stellarsrc_lumcum(1:nrcells+1),STAT=ierr)
     if(ierr.ne.0) then
        write(stdo,*) 'ERROR: Could not allocate space for stellarsrc lumcum'
        stop
     endif
     !
     ! Now read the radiation frequencies and check if they are the same
     ! as those of the frequency.inp or wavelenth_micron.inp file.
     !
     if(iiformat.eq.1) then
        do inu=1,freq_nr
           read(1,*) frq
           if(abs(frq-freq_nu(inu))/(frq+freq_nu(inu)).gt.1.d-3) then
              write(stdo,*) 'PROBLEM: Frequency grid of stellar source ',             &
                   'spectrum unequal to frequency.inp or wavelength_micron.inp'
              write(stdo,*) frq,freq_nu(inu)
              stop
           endif
        enddo
     else
        do inu=1,freq_nr
           read(1,*) lam
           frq = 1d4*cc/lam
           if(abs(frq-freq_nu(inu))/(frq+freq_nu(inu)).gt.1.d-3) then
              write(stdo,*) 'PROBLEM: Frequency grid of stellar source spectrum ',             &
                   'unequal to frequency.inp or wavelength_micron.inp'
              write(stdo,*) frq,freq_nu(inu)
              stop
           endif
        enddo
     endif
     !
     ! Now read all the spectra
     !
     ! IMPORTANT: If the first number is negative, then instead of reading
     !            the entire spectrum, a blackbody is taken with a temperature
     !            equal to the absolute value of that first number.
     !
     do itempl=1,stellarsrc_nrtemplates
        !
        ! First read the first number. If positive, then read on, else make
        ! planck function.
        !
        read(1,*) dummy
        if(dummy.lt.0.d0) then
           !
           ! Make a simple blackbody star.
           !
           if(stellarsrc_nrtemplates.lt.10) then
              write(stdo,202) ' Note: Stellar template ',itempl,      &
                   ' is taken to be a blackbody star'
202           format(a24,I1,a32)
              write(str1,275) abs(dummy)
275           format(F9.0)
              write(stdo,*) '      at a temperature T = ',trim(adjustl(str1)),' Kelvin'
           endif
           !
           ! But we need more information: the stellar mass and its radius
           !
           read(1,*) rstr
           read(1,*) mstr
           !
           ! The template is: stellar surface * pi*B_nu(T_star) / mass of star / ster
           ! The factor converts from the planck function to the luminosity
           ! per gram of star divided by 4pi (because the j_nu is always per ster).
           !
           factor = 4*pi*rstr**2 * pi / ( 4*pi*mstr )
           !
           ! Now make the template
           !
           do inu=1,freq_nr
              stellarsrc_templates(inu,itempl) = factor *             &
                     bplanck(abs(dummy),freq_nu(inu))
           enddo
        else
           !
           ! Read the full spectrum. Here it is given in units of erg / sec
           ! / Hz / gram-of-star . So multiply this by the density of stars
           ! in units of gram-of-star / cm^3, and divide by 4*pi to get the
           ! stellar source function in units of erg / src / Hz / cm^3 /
           ! steradian.
           !
           stellarsrc_templates(1,itempl) = dummy / fourpi
           do inu=2,freq_nr
              read(1,*) dummy
              stellarsrc_templates(inu,itempl) = dummy / fourpi
           enddo
        endif
        !
        ! Calculate the stellarsrc_templateslum(). Here we must multiply by 4 pi to get
        ! rid of the "per steradian".
        !
        dummy = 0.d0
        do inu=1,freq_nr
           dummy = dummy + fourpi * freq_dnu(inu) * stellarsrc_templates(inu,itempl)
        enddo
        stellarsrc_templateslum(itempl) = dummy
        !
        ! Calculate the stellarsrc_speccum
        !
        dummy = 0.d0
        do inu=1,freq_nr
           stellarsrc_speccum(inu,itempl) = dummy
           dummy = dummy + fourpi * freq_dnu(inu) * stellarsrc_templates(inu,itempl) / &
                           stellarsrc_templateslum(itempl)
        enddo
        stellarsrc_speccum(freq_nr+1,itempl) = 1.d0
     enddo
     !
     ! Close file
     !
     close(1)
     !
     ! Now read the stellar source spatial distributions
     !
     write(stdo,*) 'Reading smooth stellar source distribution...'
     call flush(stdo)
     if(fex1) then
        !
        ! Formatted input
        !
        style = 1
        open(unit=1,file='stellarsrc_density.inp',status='old')
        read(1,*) iiformat
        if(iiformat.ne.1) then
           write(stdo,*) 'ERROR: Format number of stellarsrc_density.inp is invalid/unknown.'
           stop
        endif
        read(1,*) nn
        read(1,*) ik
     elseif(fex2) then
        !
        ! F77-Unformatted input
        !
        style = 2
        open(unit=1,file='stellarsrc_density.uinp',status='old',form='unformatted')
        read(1) iiformat,reclen
        if(iiformat.ne.1) then
           write(stdo,*) 'ERROR: Format number of stellarsrc_density.uinp is invalid/unknown.'
           write(stdo,*) 'Format number = ',iiformat
           write(stdo,*) 'Record length = ',reclen
           stop
        endif
        reclenn=reclen
        read(1) nn,ik
     elseif(fex3) then
        !
        ! C-compliant binary
        !
        style = 3
        open(unit=1,file='stellarsrc_density.binp',status='old',access='stream')
        read(1) iiformat
        if(iiformat.ne.1) then
           write(stdo,*) 'ERROR: Format number of stellarsrc_density.uinp is invalid/unknown.'
           write(stdo,*) 'Format number = ',iiformat
           stop
        endif
        read(1) nn
        precis = nn
        read(1) nn,ik
     endif
     !
     ! Do some checks
     !
     if(nn.ne.nrcells) then
        write(stdo,*) 'ERROR: stellarsrc_density.inp does not have same number'
        write(stdo,*) '       of cells as the grid.'
        write(stdo,*) nn,nrcells
        stop
     endif
     if(ik.ne.stellarsrc_nrtemplates) then
        write(stdo,*) 'ERROR: In the stellarsrc_density.inp file the number'
        write(stdo,*) '  of stellar templates is different from that '
        write(stdo,*) '  specified in stellarsrc_templates.inp'
        write(stdo,*) ik,stellarsrc_nrtemplates
        stop
     endif
     !
     ! Read the data
     !
     do itempl=1,stellarsrc_nrtemplates
        call read_scalarfield(1,style,precis,nrcells,          &
             stellarsrc_nrtemplates,1,itempl,1,1d-99,reclenn,  &
             scalar1=stellarsrc_dens)
     enddo
     !
     ! Close the file
     !
     close(1)
     !
     ! Reset the stellar sources masses
     !
     do itempl=1,stellarsrc_nrtemplates
        stellarsrc_mass(itempl) = 0.d0
     enddo
     !
     ! Now do a loop over the leafs and stellar templates
     !
     do ileaf=1,nrcells
        leafindex = cellindex(ileaf)
        do itempl=1,stellarsrc_nrtemplates
           stellarsrc_mass(itempl) = stellarsrc_mass(itempl) +   &
             cellvolume(leafindex)*stellarsrc_dens(itempl,leafindex)
        enddo
     enddo
     !
     ! Now compute total star mass in the smooth stellar source distributions
     !
     stellarsrc_masstot = 0.d0
     do itempl=1,stellarsrc_nrtemplates
        stellarsrc_masstot = stellarsrc_masstot + stellarsrc_mass(itempl)
     enddo
     !
     ! Switch on stellar sources
     !
     incl_stellarsrc = 1
     !
  else
     !
     ! Switch off stellar sources
     !
     incl_stellarsrc = 0
     !
  endif
end subroutine read_stellarsource

!-------------------------------------------------------------------------
!                       READ EXTERNAL SOURCE
!-------------------------------------------------------------------------
subroutine read_externalsource(action)
  use constants_module
  implicit none
  integer :: action
  logical :: fex1
  integer :: iformat,nrfr,itempl,ierr,inu
  double precision :: frq,lam,mstr,rstr,factor,dummy
  character*80 :: str1
  !
  ! Action=0 means do nothing, action=1 means read if not yet read,
  ! action=2 means re-read.
  !
  if(action.eq.0) then
     return
  elseif(action.eq.1) then
     if(allocated(extlum_intens)) return
  endif
  !
  ! Check
  !
  if(.not.(allocated(freq_nu))) then
     write(stdo,*) 'ERROR: freq_nu not allocated when reading external source files'
     stop
  endif
  !
  ! Reset
  !
  if(allocated(extlum_intens)) deallocate(extlum_intens)
  if(allocated(extlum_intens_cum)) deallocate(extlum_intens_cum)
  !
  ! Read the external source
  !
  inquire(file='external_source.inp',exist=fex1)
  if(fex1) then
     !
     ! Message
     !
     write(stdo,*) 'Reading external luminosity source...'
     call flush(stdo)
     !
     ! Now read the templates
     !
     open(unit=1,file='external_source.inp')
     read(1,*) iformat
     if((iformat.lt.1).or.(iformat.gt.2)) then
        write(stdo,*) 'ERROR: in external_source.inp: iformat not known'
        stop
     endif
     read(1,*) nrfr
     if(nrfr.ne.freq_nr) then
        write(stdo,*) 'ERROR while reading stellarsrc_templates.inp:'
        write(stdo,*) '      The number of wavelengths unequal to that of '
        write(stdo,*) '      the global array of wavelengths_micron.inp'
        stop
     endif
     !
     ! Allocate the arrays
     !
     allocate(extlum_intens(1:freq_nr),STAT=ierr)
     if(ierr.ne.0) then
        write(stdo,*) 'ERROR: Could not allocate space for extlum_intens'
        stop
     endif
     allocate(extlum_intens_cum(1:freq_nr+1),STAT=ierr)
     if(ierr.ne.0) then
        write(stdo,*) 'ERROR: Could not allocate space for extlum_intens_cum'
        stop
     endif
     !
     ! Now read the radiation frequencies and check if they are the same
     ! as those of the frequency.inp or wavelenth_micron.inp file.
     !
     if(iformat.eq.1) then
        do inu=1,freq_nr
           read(1,*) frq
           if(abs(frq-freq_nu(inu))/(frq+freq_nu(inu)).gt.1.d-3) then
              write(stdo,*) 'PROBLEM: Frequency grid of external source ',          &
                   'spectrum unequal to frequency.inp or wavelength_micron.inp'
              write(stdo,*) frq,freq_nu(inu)
              stop
           endif
        enddo
     else
        do inu=1,freq_nr
           read(1,*) lam
           frq = 1d4*cc/lam
           if(abs(frq-freq_nu(inu))/(frq+freq_nu(inu)).gt.1.d-3) then
              write(stdo,*) 'PROBLEM: Frequency grid of external source spectrum ', &
                   'unequal to frequency.inp or wavelength_micron.inp'
              write(stdo,*) frq,freq_nu(inu)
              stop
           endif
        enddo
     endif
     !
     ! Now read the spectrum of the external source. This is the intensity
     ! I [erg/s/cm^2/Hz/ster].
     !
     do inu=1,freq_nr
        read(1,*) dummy
        extlum_intens(inu) = dummy
     enddo
     !
     ! Close file
     !
     close(1)
     !
     ! Now determine the location and radius of the sphere
     !
     if(grid_contsph_r.lt.0.d0) then
        write(stdo,*) 'INTERNAL ERROR: Somehow the containing sphere is not set up yet...'
        stop 3407
     endif
!!     if(igrid_type.lt.100) then
!!        !
!!        ! AMR grid
!!        !
!!        if(amr_coordsystem.lt.100) then
!!           !
!!           ! Cartesian coordinates
!!           !
!!           grid_contsph_x = 0.5d0 * ( amr_grid_xi(amr_grid_nx+1,1) + amr_grid_xi(1,1) )
!!           grid_contsph_y = 0.5d0 * ( amr_grid_xi(amr_grid_ny+1,2) + amr_grid_xi(1,2) )
!!           grid_contsph_z = 0.5d0 * ( amr_grid_xi(amr_grid_nz+1,3) + amr_grid_xi(1,3) )
!!           grid_contsph_r = 0.5001d0 * sqrt( ( amr_grid_xi(amr_grid_nx+1,1) - amr_grid_xi(1,1) )**2 +  &
!!                            ( amr_grid_xi(amr_grid_ny+1,2) - amr_grid_xi(1,2) )**2 +  &
!!                            ( amr_grid_xi(amr_grid_nz+1,3) - amr_grid_xi(1,3) )**2 )
!!        elseif(amr_coordsystem.lt.200) then
!!           !
!!           ! Spherical coordinates
!!           !
!!           grid_contsph_x = 0.d0
!!           grid_contsph_y = 0.d0
!!           grid_contsph_z = 0.d0
!!           grid_contsph_r = 1.001 * amr_grid_xi(amr_grid_nx+1,1)
!!        else
!!           !
!!           ! These coordiantes not yet active
!!           !
!!           stop 7871
!!        endif
!!     else
!!        !
!!        ! Unstructured grids not yet active
!!        !
!!        write(stdo,*) 'INTERNAL ERROR: Unstructured grids not yet implemented'
!!        stop
!!     endif
     !
     ! Swith on this source
     !
     incl_extlum = 1
     !
  else
     !
     ! Switch off this source
     !
     incl_extlum = 0
     !
  endif
end subroutine read_externalsource

!-------------------------------------------------------------------------
!                    CLEANUP ALL STAR ARRAYS
!-------------------------------------------------------------------------
subroutine stars_cleanup
  implicit none
  if(allocated(star_spec)) deallocate(star_spec)
  if(allocated(star_spec_cum)) deallocate(star_spec_cum)
  if(allocated(star_lum)) deallocate(star_lum)
  if(allocated(star_lumcum)) deallocate(star_lumcum)
  if(allocated(star_r)) deallocate(star_r)
  if(allocated(star_m)) deallocate(star_m)
  if(allocated(star_pos)) deallocate(star_pos)
  if(allocated(star_cellindex)) deallocate(star_cellindex)
  if(allocated(stellarsrc_dens)) deallocate(stellarsrc_dens)
  if(allocated(stellarsrc_mass)) deallocate(stellarsrc_mass)
  if(allocated(stellarsrc_templates)) deallocate(stellarsrc_templates)
  if(allocated(stellarsrc_templateslum)) deallocate(stellarsrc_templateslum)
  if(allocated(stellarsrc_speccum)) deallocate(stellarsrc_speccum)
  if(allocated(stellarsrc_lumcum)) deallocate(stellarsrc_lumcum)
  if(allocated(extlum_intens)) deallocate(extlum_intens)
  if(allocated(extlum_intens_cum)) deallocate(extlum_intens_cum)
  if(allocated(heatsource)) deallocate(heatsource)
  if(allocated(heatsource_cum)) deallocate(heatsource_cum)
  if(allocated(illum_costheta)) deallocate(illum_costheta)
  if(allocated(illum_phi)) deallocate(illum_phi)
  if(allocated(illum_flux_unprojected)) deallocate(illum_flux_unprojected)
  if(allocated(illum_flux_unprojected_cum)) deallocate(illum_flux_unprojected_cum)
  if(allocated(illum_fluxtot)) deallocate(illum_fluxtot)
  if(allocated(illum_fluxtot_cum)) deallocate(illum_fluxtot_cum)
  !$OMP PARALLEL
  if(allocated(star_fraclum)) deallocate(star_fraclum)
  if(allocated(stellarsrc_cum)) deallocate(stellarsrc_cum)
  !$OMP END PARALLEL
  incl_stellarsrc           = 0
  stellarsrc_nrtemplates    = 0
  nstars                    = 0
end subroutine stars_cleanup

!-------------------------------------------------------------------
!              FIND STAR INTENSITY BETWEEN FREQ POINTS
!-------------------------------------------------------------------
function find_starlight_interpol(freq,istar)
  implicit none
  doubleprecision :: find_starlight_interpol,freq,eps
  integer :: inu,istar
  if(freq_nu(freq_nr).gt.freq_nu(1)) then
     if((freq.le.freq_nu(1)).or.(freq.ge.freq_nu(freq_nr))) then
        find_starlight_interpol = 0.d0
        return
     endif
  else
     if((freq.ge.freq_nu(1)).or.(freq.le.freq_nu(freq_nr))) then
        find_starlight_interpol = 0.d0
        return
     endif
  endif
  call hunt(freq_nu,freq_nr,freq,inu)
  if((inu.lt.1).or.(inu.ge.freq_nr)) stop 7201
  eps = (freq-freq_nu(inu)) / (freq_nu(inu+1)-freq_nu(inu))
  if((eps.lt.0.d0).or.(eps.gt.1.d0)) stop 7202
  find_starlight_interpol =  (1.d0-eps) * star_spec(inu,istar) +    &
                                    eps * star_spec(inu+1,istar)
  return
end function find_starlight_interpol

!-------------------------------------------------------------------
!       FIND EXTERNAL LUMINOSITY INTENSITY BETWEEN FREQ POINTS
!-------------------------------------------------------------------
function find_extlumintens_interpol(freq)
  implicit none
  doubleprecision :: find_extlumintens_interpol,freq,eps
  integer :: inu
  if(freq_nu(freq_nr).gt.freq_nu(1)) then
     if((freq.le.freq_nu(1)).or.(freq.ge.freq_nu(freq_nr))) then
        find_extlumintens_interpol = 0.d0
        return
     endif
  else
     if((freq.ge.freq_nu(1)).or.(freq.le.freq_nu(freq_nr))) then
        find_extlumintens_interpol = 0.d0
        return
     endif
  endif
  call hunt(freq_nu,freq_nr,freq,inu)
  if((inu.lt.1).or.(inu.ge.freq_nr)) stop 7201
  eps = (freq-freq_nu(inu)) / (freq_nu(inu+1)-freq_nu(inu))
  if((eps.lt.0.d0).or.(eps.gt.1.d0)) stop 7203
  find_extlumintens_interpol =  (1.d0-eps) * extlum_intens(inu) +    &
                                       eps * extlum_intens(inu+1)
  return
end function find_extlumintens_interpol

!-------------------------------------------------------------------------
!                    JITTER THE STARS A TINY BIT
!
! Note: Tiny bug: for spherical coordinates the jitter in theta and
!       phi does not go correctly (because star_pos is always in
!       cartesian). But so far this has not caused problems, and
!       since I don't want (for now) to break the automatic test suite,
!       I'll keep it for now. 2017.03.21
!-------------------------------------------------------------------------
subroutine jitter_stars(fact)
  implicit none
  integer :: istar
  double precision :: szx,szy,szz,fact
  double precision :: smallnumberx,smallnumbery,smallnumberz
  parameter(smallnumberx=0.48957949203816064943d-12)
  parameter(smallnumbery=0.38160649492048957394d-12)
  parameter(smallnumberz=0.64943484920957938160d-12)
  !
  if(nstars.ge.1) then
     szx = amr_grid_xi(amr_grid_nx+1,1) - amr_grid_xi(1,1)
     szy = amr_grid_xi(amr_grid_ny+1,2) - amr_grid_xi(1,2)
     szz = amr_grid_xi(amr_grid_nz+1,3) - amr_grid_xi(1,3)
     do istar=1,nstars
        star_pos(1,istar) = star_pos(1,istar) + fact*szx*smallnumberx
        star_pos(2,istar) = star_pos(2,istar) + fact*szy*smallnumbery
        star_pos(3,istar) = star_pos(3,istar) + fact*szz*smallnumberz
     enddo
  endif
end subroutine jitter_stars

!-------------------------------------------------------------------------
!                    READ INTERNAL HEAT SOURCE
!-------------------------------------------------------------------------
subroutine read_internal_heatsource(action)
  use constants_module
  implicit none
  integer :: action
  logical :: fex1,fex2,fex3
  integer :: nrfr,itempl,ierr,inu,i,index,irec,style
  integer :: ileaf,leafindex,idum,precis,reclenn
  double precision :: mstr,rstr,factor,dummy
  character*80 :: str1
  integer(kind=8) :: iiformat,reclen,nn,ik
  !
  ! Action=0 means do nothing, action=1 means read if not yet read,
  ! action=2 means re-read.
  !
  if(action.eq.0) then
     return
  elseif(action.eq.1) then
     if(allocated(heatsource)) return
  endif
  !
  ! Check if we can use the cellindex list
  !
  if(.not.allocated(cellindex)) then
     write(stdo,*) 'ERROR while computing stellar sources mass: The cellindex list is not yet made.'
     stop
  endif
  !
  ! Check if we have the cell volume allocated
  !
  if(.not.allocated(cellvolume)) then
     write(stdo,*) 'ERROR while computing stellar sources mass: The cellvolume list is not yet made.'
     stop
  endif
  !
  ! Reset
  !
  if(allocated(heatsource)) deallocate(heatsource)
  !
  ! Now read the heat source spatial distribution
  !
  write(stdo,*) 'Reading the heat source spatial distribution...'
  call flush(stdo)
  inquire(file='heatsource.inp',exist=fex1)
  inquire(file='heatsource.uinp',exist=fex2)
  inquire(file='heatsource.binp',exist=fex3)
  !
  ! If the file exists, then allocate the array
  !
  if(fex1.or.fex2.or.fex3) then
     allocate(heatsource(1:nrcells),STAT=ierr)
     if(ierr.gt.0) then
        write(stdo,*) 'ERROR: Could not allocate heatsource(:)'
        stop
     endif
  endif
  !
  ! Read
  !
  if(fex1) then
     !
     ! Formatted input
     !
     style = 1
     open(unit=1,file='heatsource.inp',status='old')
     read(1,*) iiformat
     if(iiformat.ne.1) then
        write(stdo,*) 'ERROR: Format number of heatsource.inp is invalid/unknown.'
        stop
     endif
     read(1,*) nn
  elseif(fex2) then
     !
     ! F77-Unformatted input
     !
     style = 2
     open(unit=1,file='heatsource.uinp',status='old',form='unformatted')
     read(1) iiformat,reclen
     if(iiformat.ne.1) then
        write(stdo,*) 'ERROR: Format number of heatsource.uinp is invalid/unknown.'
        write(stdo,*) 'Format number = ',iiformat
        write(stdo,*) 'Record length = ',reclen
        stop
     endif
     reclenn=reclen
     read(1) nn
  elseif(fex3) then
     !
     ! C-compliant binary
     !
     style = 3
     open(unit=1,file='heatsource.binp',status='old',access='stream')
     read(1) iiformat
     if(iiformat.ne.1) then
        write(stdo,*) 'ERROR: Format number of heatsource.uinp is invalid/unknown.'
        write(stdo,*) 'Format number = ',iiformat
        stop
     endif
     read(1) nn
     precis = nn
     read(1) nn
  else
     !
     ! No heatsource file
     !
     return
  endif
  !
  ! Do some checks
  !
  if(nn.ne.nrcells) then
     write(stdo,*) 'ERROR: heatsource.inp does not have same number'
     write(stdo,*) '       of cells as the grid.'
     write(stdo,*) nn,nrcells
     stop
  endif
  !
  ! Read the data
  !
  call read_scalarfield(1,style,precis,nrcells,     &
             1,1,1,1,1d-99,reclenn,scalar0=heatsource)
  !
  ! Close the file
  !
  close(1)
  !
  ! Switch on the heat source
  !
  incl_heatsource = 1
  !
end subroutine read_internal_heatsource

end module stars_module