      subroutine boost(q,pboost,qprime)
      implicit real*8 (a-h,o-z)

c this subroutine performs the boost according to the vector pboost of
c  the fourvector q to the fourvector qprime. The vector q and the
c   resulting qprime might also have the same name in the call
c  Let's call rmboost the mass of pboost. With this transformation
c  if q= (rmboost,0,0,0), qprime=pboost

      dimension q(0:3), pboost(0:3), qprime (0:3)

      rmboost=pboost(0)**2-pboost(1)**2-pboost(2)**2-pboost(3)**2
      rmboost=sqrt(max(rmboost,0.d0))
      aux=(q(0)*pboost(0)+q(1)*pboost(1)+q(2)*pboost(2)+q(3)*pboost(3))
     &      /rmboost
      aaux=(aux+q(0))/(pboost(0)+rmboost)
      qprime(0)=aux
      qprime(1)=q(1)+aaux*pboost(1)
      qprime(2)=q(2)+aaux*pboost(2)
      qprime(3)=q(3)+aaux*pboost(3)

      return
      end

      subroutine boostinv(q,pboost,qprime)
      implicit real*8 (a-h,o-z)

c this subroutine performs the inverse boost according to the vector
c  pboost  ( which corresponds to the boost according to pboost(0),
c  -pboost(i) ) of the fourvector q to the fourvector qprime.
c  The vector q and the resulting qprime might also have the same
c  name in the call
c  Let's call rmboost the mass of pboost. With this transformation
c  if q=pboost, qprime= (rmboost,0,0,0),

      dimension q(0:3), pboost(0:3), qprime (0:3)

      rmboost=pboost(0)**2-pboost(1)**2-pboost(2)**2-pboost(3)**2
      rmboost=sqrt(max(rmboost,0.d0))
      aux=(q(0)*pboost(0)-q(1)*pboost(1)-q(2)*pboost(2)-q(3)*pboost(3))
     &      /rmboost
      aaux=(aux+q(0))/(pboost(0)+rmboost)
      qprime(0)=aux
      qprime(1)=q(1)-aaux*pboost(1)
      qprime(2)=q(2)-aaux*pboost(2)
      qprime(3)=q(3)-aaux*pboost(3)

      return
      end

      subroutine rot(p,q,pp)

* the subroutine performs a rotation such that the 3-vector p goes into
* the 3-vector pp. The rotation is such that the vector q', of the same
*  lenght as q but along the z axis, becomes q after the rotation

      implicit real*8 (a-h,o-z)

      dimension pp(3), p(3), q(3)

      qmod=sqrt(q(1)**2+q(2)**2+q(3)**2)
      if (qmod.eq.0.d0) then
        print*, ' ERROR in subroutine rot '
        print*, ' spatial q components are 0.d0 ! '
        stop
      endif

      cth=q(3)/qmod
      sth=1.d0-cth**2
      if (sth.eq.0.d0) then
        pp(1)=p(1)
        pp(2)=p(2)
        pp(3)=p(3)
        return
      endif
      sth=sqrt(sth)

      qmodt=sqrt(q(1)**2+q(2)**2)
      if (qmodt.eq.0.d0) then
        pp(1)=p(1)
        pp(2)=p(2)
        pp(3)=p(3)
        return
      endif

      cfi=q(1)/qmodt
      sfi=q(2)/qmodt

c  avoid possible problems if p and pp are the same vector:

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

c  perform the rotation

      pp(1)=cth*cfi*p1-sfi*p2+sth*cfi*p3
      pp(2)=cth*sfi*p1+cfi*p2+sth*sfi*p3
      pp(3)=-sth   *p1       +cth*    p3

      return
      end

      subroutine rotinv(p,q,pp)
* the subroutine performs a rotation such that the 3-vector p goes into
* the 3-vector pp. The rotation is such that the vector q goes to the z axis.
* It performs first a rotation around z which brings the vectot in the xz-plane and
* then a rotaion around y which brings the vector along the z axis

      implicit real*8 (a-h,o-z)
      dimension pp(3), p(3), q(3)

      qmodt=q(1)**2+q(2)**2
      qmod=qmodt+q(3)**2
      qmodt=sqrt(qmodt)
      qmod=sqrt(qmod)

      if (qmod.eq.0.d0) then
        print*, ' ERROR in subroutine rot '
        print*, ' spatial q components are 0.d0 ! '
        stop
      endif

      cth=q(3)/qmod
      sth=1.d0-cth**2
      if (sth.eq.0.d0) then
        pp(1)=p(1)
        pp(2)=p(2)
        pp(3)=p(3)
        return
      endif
      sth=sqrt(sth)

      if (qmodt.eq.0.d0) then
        pp(1)=p(1)
        pp(2)=p(2)
        pp(3)=p(3)
        return
      endif

      cfi=q(1)/qmodt
      sfi=q(2)/qmodt

c  avoid possible problems if p and pp are the same vector:
      p1=p(1)
      p2=p(2)
      p3=p(3)

c  perform the rotation
      pp(1)=cth*cfi*p1+cth*sfi*p2-sth*p3
      pp(2)=-sfi*p1   +cfi*p2
      pp(3)=+sth*cfi*p1+sth*sfi*p2+cth*    p3

      return
      end

*****************************************************************************
* Auxiliary subroutine
* INPUT:
*       pbst        : intermediate particle momentum
*       shat        : the corresponding mass (assumed positive)
*       pmod        : the absolute value of the 3-momentum of the two
*                     daughter particles in the decay CM
*       xm1sq,xm2sq : the squared masses of the daughter particles
*       x1,x2       : two random numbers uniformly distributed in [0,1]
* OUTPUT:
*       p1,p2       : the momenta of the two daughters in the frame in
*                     which the intermediate particle has momentum pbst
*                             p1 + p2 = pbst
*
* If pbst=(sqrt(shat),0,0,0) the boost reduces to the identity
* Ezio May 2 2007
* A rotation of the generated momentum has been added in such a way to assume as
* z-axis the boost momentum
*
*****************************************************************************
      SUBROUTINE TWOBODY(pbst,shat,pmod,xm1sq,xm2sq,x1,x2,p1,p2)
      IMPLICIT NONE
      REAL*8 pbst(0:3),shat,pmod,xm1sq,xm2sq,x1,x2,p1(0:3),p2(0:3)
* Local variables
      REAL*8 app,costh,sinth,ph,rmboost,aapp,pi,twopi
      INTEGER i
      PARAMETER (pi=3.141592653589793238462643d0,twopi=2.d0*pi)

      costh=min(x1*2.d0-1.d0,1.d0)
      costh=max(costh,-1.d0)
      sinth=sqrt(1.d0-costh*costh)
      ph=x2*twopi
* p1
      p1(0)=sqrt(pmod*pmod+xm1sq)
      p1(1)=pmod*sinth*cos(ph)
      p1(2)=pmod*sinth*sin(ph)
      p1(3)=pmod*costh
* rotate in such a way that angles are relative to the direction of pbst
      call rot(p1(1),pbst(1),p1(1))
* boost back
      rmboost=sqrt(shat)
      app=(p1(0)*pbst(0)+p1(1)*pbst(1)+p1(2)*pbst(2)+p1(3)*pbst(3))
     &      /rmboost
      aapp=(app+p1(0))/(pbst(0)+rmboost)
      p1(0)=app
      p1(1)=p1(1)+aapp*pbst(1)
      p1(2)=p1(2)+aapp*pbst(2)
      p1(3)=p1(3)+aapp*pbst(3)
      DO i=0,3
        p2(i)=pbst(i)-p1(i)
      ENDDO

      RETURN
      END

*****************************************************************************
* Auxiliary subroutine. Defines extrema for flat+Breit-Wigner+flat mapping
* of resonances. Checks for position of estrsup,estrinf with respect to
* spm1lo,spm1hi
* INPUT:
*   estrsup,estrinf: upper and lower limit for the generated mass
*   spm1lo,spm1hi  : lower and upper limit of the Breit-Wigner region
*   rmx1,gamx1       : mass and width of the resonance
* OUTPUT:
*  alfa1,alfa2       : separation points in [0,1] between the three regions
*                      Can also be 0 or 1. Some care necessary in this cases
*  auxalfa2,xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max
*                    : auxiliary quantities used for generating the mass
*                      and computing the jacobian
*****************************************************************************
      SUBROUTINE PHSP_INI(estrsup,estrinf,spm1lo,spm1hi,
     &                       rmx1,gamx1,
     &                           alfa1,alfa2,auxalfa2,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max)

      IMPLICIT REAL*8(a-h,o-z)

      IF(estrsup.LE.spm1lo)THEN ! only flat1
        alfa2=1.d0
        alfa1=1.d0
        auxalfa2=alfa2
        xf1_max=estrsup
        xf1_min=estrinf
      ELSEIF(estrsup.LE.spm1hi)THEN ! flat1 + W/Z ?
        alfa2=1.d0
        auxalfa2=alfa2
        IF((estrinf.GE.spm1lo))THEN  ! W/Z only
          alfa1=0.d0
          xw1_max=atan((estrsup**2-rmx1**2)/(gamx1*rmx1))
          xw1_min=atan((estrinf**2-rmx1**2)/(gamx1*rmx1))
        ELSE !  flat1 + W/Z !
          xw1_min=atan((spm1lo**2-rmx1**2)/(gamx1*rmx1))
          xw1_max=atan((estrsup**2-rmx1**2)/(gamx1*rmx1))

          rkappa2low=(xw1_max-xw1_min)*
     &          ((spm1lo**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          xf1_max=spm1lo
          xf1_min=estrinf
          rkappa1=(xf1_max-xf1_min)*2.d0*spm1lo
* If rkappa2low=0 then estrsup is numerically indistinguishable from spm1lo
          IF(rkappa2low.LE.0.d0)THEN
            alfa1=1.d0
            auxalfa2=alfa2
            xf1_max=estrsup
            xf1_min=estrinf
	    RETURN
	  ENDIF
          rkappa=rkappa1/rkappa2low
          alfa1=rkappa/(rkappa+1.d0)
        ENDIF
      ELSE ! estrsup.GT.spm1hi: flat1 + W/Z + flat2 ?
        IF(estrinf.GE.spm1hi)THEN  ! only flat2
          alfa1=0.d0
          alfa2=0.d0
          auxalfa2=alfa2
          xf2_max=estrsup
          xf2_min=estrinf
        ELSEIF((estrinf.GE.spm1lo))THEN !  W/Z + flat2
          alfa1=0.d0
          xf2_max=estrsup
          xf2_min=spm1hi
          rkappa3=(xf2_max-xf2_min)*2.d0*spm1hi
          xw1_max=atan((spm1hi**2-rmx1**2)/(gamx1*rmx1))
          xw1_min=atan((estrinf**2-rmx1**2)/(gamx1*rmx1))
          rkappa2high=(xw1_max-xw1_min)*
     &          ((spm1hi**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          rk2=rkappa2high/rkappa3
c          alfa2=rk2/(rk2+1.d0)
          alfa2=0.5d0
          auxalfa2=alfa2
        ELSE !  flat + W/Z + flat
          xf2_max=estrsup
          xf2_min=spm1hi
          rkappa3=(xf2_max-xf2_min)*2.d0*spm1hi
          xw1_min=atan((spm1lo**2-rmx1**2)/(gamx1*rmx1))
          xw1_max=atan((spm1hi**2-rmx1**2)/(gamx1*rmx1))
          rkappa2high=(xw1_max-xw1_min)*
     &          ((spm1hi**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          rkappa2low=(xw1_max-xw1_min)*
     &          ((spm1lo**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          rk2=rkappa2high/rkappa3
c          auxalfa2=rk2/(rk2+1.d0)
          auxalfa2=0.5d0
c          auxalfa2=8.d0/9.d0
          xf1_min=estrinf
          xf1_max=spm1lo
          rkappa1=(xf1_max-xf1_min)*2.d0*spm1lo
          rk1=rkappa1/rkappa2low*auxalfa2
c          alfa1=rk1/(rk1+1.d0)
          alfa1=1.d0/3.d0
c          alfa1=1.d0/10.d0
          alfa2=auxalfa2*(1.d0-alfa1)+alfa1
        ENDIF
      ENDIF

      RETURN
      END

*****************************************************************************
* Auxiliary subroutine. Defines extrema for flat+Breit-Wigner+flat
*                                              +Breit-Wigner+flat mapping
* of resonances. Checks for position of estrsup,estrinf with respect to
* spm1lo,spm1hi
* INPUT:
*   estrsup,estrinf: upper and lower limit for the generated mass
*   spm1lo,spm1hi  : lower and upper limit of first Breit-Wigner region
*   rmx1,gamx1       : mass and width of first resonance
*   spm2lo,spm2hi  : lower and upper limit of second Breit-Wigner region
*   rmx2,gamx2       : mass and width of second resonance
* OUTPUT:
*  alfa1,alfa2,alfa3,alfa4: separation points in [0,1] between the five regions
*                      Can also be 0 or 1. Some care necessary in this cases
*  auxalfa2,xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,xw2_min,xw2_max,
*  xf3_min,xf3_max,auxalfa3,auxalfa4
*                    : auxiliary quantities used for generating the mass
*                      and computing the jacobian
*****************************************************************************
      SUBROUTINE PHSP_INI5(estrsup,estrinf,
     &                     spm1lo,spm1hi,rmx1,gamx1,
     &                     spm2lo,spm2hi,rmx2,gamx2,
     &                     alfa1,alfa2,auxalfa2,
     &                     alfa3,auxalfa3,alfa4,auxalfa4,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max)

      IMPLICIT REAL*8(a-h,o-z)

      IF(estrsup.LE.spm1lo)THEN ! only flat1
        alfa1=1.d0
        alfa2=1.d0
        alfa3=1.d0
        alfa4=1.d0
        auxalfa4=alfa4
        auxalfa3=alfa3
        auxalfa2=alfa2
        xf1_max=estrsup
        xf1_min=estrinf
      ELSEIF(estrsup.LE.spm1hi)THEN ! flat1 + res1 ?
        alfa2=1.d0
        alfa3=1.d0
        alfa4=1.d0
        auxalfa4=alfa4
        auxalfa3=alfa3
        auxalfa2=alfa2
        IF((estrinf.GE.spm1lo))THEN  ! res1 only
          alfa1=0.d0
          xw1_max=atan((estrsup**2-rmx1**2)/(gamx1*rmx1))
          xw1_min=atan((estrinf**2-rmx1**2)/(gamx1*rmx1))
        ELSE !  flat1 + res1 !
          xw1_min=atan((spm1lo**2-rmx1**2)/(gamx1*rmx1))
          xw1_max=atan((estrsup**2-rmx1**2)/(gamx1*rmx1))
          rkappa2low=(xw1_max-xw1_min)*
     &          ((spm1lo**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          xf1_max=spm1lo
          xf1_min=estrinf
          rkappa1=(xf1_max-xf1_min)*2.d0*spm1lo
* If rkappa2low=0 then estrsup is numerically indistinguishable from spm1lo
          IF(rkappa2low.LE.0.d0)THEN
            alfa1=1.d0
            xf1_max=estrsup
            xf1_min=estrinf
            RETURN
          ENDIF
          rk1=rkappa1/rkappa2low
          alfa1=rk1/(rk1+1.d0)
        ENDIF
      ELSEIF(estrsup.LE.spm2lo)THEN ! estrsup.GT.spm1hi: flat1 + res1 + flat2 ?
        alfa3=1.d0
        alfa4=1.d0
        auxalfa4=alfa4
        auxalfa3=alfa3
        IF(estrinf.GE.spm1hi)THEN  ! only flat2
          alfa1=0.d0
          alfa2=0.d0
          auxalfa2=alfa2
          xf2_max=estrsup
          xf2_min=estrinf
        ELSEIF((estrinf.GE.spm1lo))THEN !  res1 + flat2
          alfa1=0.d0
          xf2_max=estrsup
          xf2_min=spm1hi
          rkappa3low=(xf2_max-xf2_min)*2.d0*spm1hi
          xw1_max=atan((spm1hi**2-rmx1**2)/(gamx1*rmx1))
          xw1_min=atan((estrinf**2-rmx1**2)/(gamx1*rmx1))
          rkappa2high=(xw1_max-xw1_min)*
     &          ((spm1hi**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          rk2=rkappa2high/rkappa3low
          alfa2=rk2/(rk2+1.d0)
          auxalfa2=alfa2
        ELSE !  flat1 + res1 + flat2
          xf2_max=estrsup
          xf2_min=spm1hi
          rkappa3low=(xf2_max-xf2_min)*2.d0*spm1hi
          xw1_min=atan((spm1lo**2-rmx1**2)/(gamx1*rmx1))
          xw1_max=atan((spm1hi**2-rmx1**2)/(gamx1*rmx1))
          rkappa2low=(xw1_max-xw1_min)*
     &          ((spm1lo**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          rkappa2high=(xw1_max-xw1_min)*
     &          ((spm1hi**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          rk2=rkappa2high/rkappa3low
ccc          auxalfa2=rk2/(rk2+1.d0)
          auxalfa2=0.5d0
          xf1_min=estrinf
          xf1_max=spm1lo
          rkappa1=(xf1_max-xf1_min)*2.d0*spm1lo
          rk1=rkappa1/rkappa2low*auxalfa2
CCC          alfa1=rk1/(rk1+1.d0)
          alfa1=1.d0/3.d0
          alfa2=auxalfa2*(1.d0-alfa1)+alfa1
        ENDIF
      ELSEIF(estrsup.LE.spm2hi)THEN
             ! estrsup.GT.spm2lo: flat1 + res1 + flat2 + res2?
        alfa4=1.d0
        auxalfa4=alfa4
        IF(estrinf.GE.spm2lo)THEN  ! only res2
          alfa1=0.d0
          alfa2=0.d0
          alfa3=0.d0
          auxalfa3=alfa3
          auxalfa2=alfa2
          xw2_max=atan((estrsup**2-rmx2**2)/(gamx2*rmx2))
          xw2_min=atan((estrinf**2-rmx2**2)/(gamx2*rmx2))
        ELSEIF(estrinf.GE.spm1hi)THEN  ! flat2 + res2
          alfa1=0.d0
          alfa2=0.d0
          auxalfa2=alfa2
          xw2_min=atan((spm2lo**2-rmx2**2)/(gamx2*rmx2))
          xw2_max=atan((estrsup**2-rmx2**2)/(gamx2*rmx2))
          rkappa4low=(xw2_max-xw2_min)*
     &          ((spm2lo**2-rmx2**2)**2+(gamx2*rmx2)**2)
     &                /(gamx2*rmx2)
* If rkappa4low=0 then estrsup is numerically indistinguishable from spm2lo
          IF(rkappa4low.LE.0.d0)THEN
            alfa3=1.d0
            auxalfa3=alfa3
            xf2_max=estrsup
            xf2_min=estrinf
            RETURN
          ENDIF
          xf2_max=spm2lo
          xf2_min=estrinf
          rkappa3high=(xf2_max-xf2_min)*2.d0*spm2lo
          rk3=rkappa3high/rkappa4low
          alfa3=rk3/(rk3+1.d0)
          auxalfa3=alfa3
        ELSEIF(estrinf.GE.spm1lo)THEN  ! res1 + flat2 + res2
          alfa1=0.d0
          xw2_min=atan((spm2lo**2-rmx2**2)/(gamx2*rmx2))
          xw2_max=atan((estrsup**2-rmx2**2)/(gamx2*rmx2))
          rkappa4low=(xw2_max-xw2_min)*
     &          ((spm2lo**2-rmx2**2)**2+(gamx2*rmx2)**2)
     &                /(gamx2*rmx2)
* If rkappa4low=0 then estrsup is numerically indistinguishable from spm2lo
          IF(rkappa4low.LE.0.d0)THEN
            auxalfa3=1.d0
            xf2_max=estrsup
          ELSE
            xf2_max=spm2lo
            rkappa3high=(xf2_max-xf2_min)*2.d0*spm2lo
            rk3=rkappa3high/rkappa4low
ccc            auxalfa3=rk3/(rk3+1.d0)
            auxalfa3=0.5d0
          ENDIF
          xf2_min=spm1hi
          rkappa3low=(xf2_max-xf2_min)*2.d0*spm1hi
          xw1_max=atan((spm1hi**2-rmx1**2)/(gamx1*rmx1))
          xw1_min=atan((estrinf**2-rmx1**2)/(gamx1*rmx1))
          rkappa2high=(xw1_max-xw1_min)*
     &          ((spm1hi**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          rk2=rkappa2high/rkappa3low*auxalfa3
ccc          alfa2=rk2/(rk2+1.d0)
          alfa2=1.d0/3.d0
          auxalfa2=alfa2
          alfa3=auxalfa3*(1.d0-alfa2)+alfa2
          IF(rkappa4low.LE.0.d0) alfa3=1.d0
        ELSE  ! flat1 + res1 + flat2 + res2
          xw2_min=atan((spm2lo**2-rmx2**2)/(gamx2*rmx2))
          xw2_max=atan((estrsup**2-rmx2**2)/(gamx2*rmx2))
          rkappa4low=(xw2_max-xw2_min)*
     &          ((spm2lo**2-rmx2**2)**2+(gamx2*rmx2)**2)
     &                /(gamx2*rmx2)
* If rkappa4low=0 then estrsup is numerically indistinguishable from spm2lo
          IF(rkappa4low.LE.0.d0)THEN
            auxalfa3=1.d0
            xf2_max=estrsup
          ELSE
            xf2_max=spm2lo
            rkappa3high=(xf2_max-xf2_min)*2.d0*spm2lo
            rk3=rkappa3high/rkappa4low
ccc            auxalfa3=rk3/(rk3+1.d0)
            auxalfa3=0.5d0
          ENDIF
          xf2_min=spm1hi
          rkappa3low=(xf2_max-xf2_min)*2.d0*spm1hi
          xw1_max=atan((spm1hi**2-rmx1**2)/(gamx1*rmx1))
          xw1_min=atan((spm1lo**2-rmx1**2)/(gamx1*rmx1))
          rkappa2low=(xw1_max-xw1_min)*
     &          ((spm1lo**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          rkappa2high=(xw1_max-xw1_min)*
     &          ((spm1hi**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          rk2=rkappa2high/rkappa3low*auxalfa3
ccc          auxalfa2=rk2/(rk2+1.d0)
          auxalfa2=1.d0/3.d0
          xf1_max=spm1lo
          xf1_min=estrinf
          rkappa1=(xf1_max-xf1_min)*2.d0*spm1lo
          rk1=rkappa1/rkappa2low*auxalfa2
ccc          alfa1=rk1/(rk1+1.d0)
          alfa1=1.d0/4.d0
          alfa2=auxalfa2*(1.d0-alfa1)+alfa1
          alfa3=auxalfa3*(1.d0-auxalfa2)*(1.d0-alfa1)+alfa2
          IF(rkappa4low.LE.0.d0) alfa3=1.d0
        ENDIF
      ELSE ! estrsup.GT.spm2hi: flat1 + res1 + flat2 + res2 + flat3?
        IF(estrinf.GE.spm2hi)THEN  ! only flat3
          alfa1=0.d0
          alfa2=0.d0
          alfa3=0.d0
          alfa4=0.d0
          auxalfa4=alfa4
          auxalfa3=alfa3
          auxalfa2=alfa2
          xf3_max=estrsup
          xf3_min=estrinf
        ELSEIF(estrinf.GE.spm2lo)THEN  ! res2 + flat3
          alfa1=0.d0
          alfa2=0.d0
          alfa3=0.d0
          auxalfa3=alfa3
          auxalfa2=alfa2
          xf3_max=estrsup
          xf3_min=spm2hi
          rkappa5=(xf3_max-xf3_min)*2.d0*spm2hi
          xw2_min=atan((estrinf**2-rmx2**2)/(gamx2*rmx2))
          xw2_max=atan((spm2hi**2-rmx2**2)/(gamx2*rmx2))
          rkappa4high=(xw2_max-xw2_min)*
     &          ((spm2hi**2-rmx2**2)**2+(gamx2*rmx2)**2)
     &                /(gamx2*rmx2)
          rk4=rkappa4high/rkappa5
ccc          alfa4=rk4/(rk4+1.d0)
          alfa4=0.5d0
          auxalfa4=alfa4
        ELSEIF(estrinf.GE.spm1hi)THEN  ! flat2 + res2 + flat3
          alfa1=0.d0
          alfa2=0.d0
          auxalfa2=alfa2
          xf3_max=estrsup
          xf3_min=spm2hi
          rkappa5=(xf3_max-xf3_min)*2.d0*spm2hi
          xw2_min=atan((spm2lo**2-rmx2**2)/(gamx2*rmx2))
          xw2_max=atan((spm2hi**2-rmx2**2)/(gamx2*rmx2))
          rkappa4high=(xw2_max-xw2_min)*
     &          ((spm2hi**2-rmx2**2)**2+(gamx2*rmx2)**2)
     &                /(gamx2*rmx2)
          rkappa4low=(xw2_max-xw2_min)*
     &          ((spm2lo**2-rmx2**2)**2+(gamx2*rmx2)**2)
     &                /(gamx2*rmx2)
          rk4=rkappa4high/rkappa5
ccc          auxalfa4=rk4/(rk4+1.d0)
          auxalfa4=0.5d0
          xf2_max=spm2lo
          xf2_min=estrinf
          rkappa3high=(xf2_max-xf2_min)*2.d0*spm2lo
          rk3=rkappa3high/rkappa4low*auxalfa4
ccc          alfa3=rk3/(rk3+1.d0)
          alfa3=1.d0/3.d0
          auxalfa3=alfa3
          alfa4=auxalfa4*(1.d0-alfa3)+alfa3
        ELSEIF(estrinf.GE.spm1lo)THEN  ! res1 + flat2 + res2 + flat3
          alfa1=0.d0
          xf3_max=estrsup
          xf3_min=spm2hi
          rkappa5=(xf3_max-xf3_min)*2.d0*spm2hi
          xw2_min=atan((spm2lo**2-rmx2**2)/(gamx2*rmx2))
          xw2_max=atan((spm2hi**2-rmx2**2)/(gamx2*rmx2))
          rkappa4high=(xw2_max-xw2_min)*
     &          ((spm2hi**2-rmx2**2)**2+(gamx2*rmx2)**2)
     &                /(gamx2*rmx2)
          rkappa4low=(xw2_max-xw2_min)*
     &          ((spm2lo**2-rmx2**2)**2+(gamx2*rmx2)**2)
     &                /(gamx2*rmx2)
          rk4=rkappa4high/rkappa5
ccc          auxalfa4=rk4/(rk4+1.d0)
          auxalfa4=0.5d0
          xf2_max=spm2lo
          xf2_min=spm1hi
          rkappa3high=(xf2_max-xf2_min)*2.d0*spm2lo
          rkappa3low=(xf2_max-xf2_min)*2.d0*spm1hi
          rk3=rkappa3high/rkappa4low*auxalfa4
ccc          auxalfa3=rk3/(rk3+1.d0)
          auxalfa3=1.d0/3.d0
          xw1_max=atan((spm1hi**2-rmx1**2)/(gamx1*rmx1))
          xw1_min=atan((estrinf**2-rmx1**2)/(gamx1*rmx1))
          rkappa2high=(xw1_max-xw1_min)*
     &          ((spm1hi**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          rk2=rkappa2high/rkappa3low*auxalfa3
ccc          alfa2=rk2/(rk2+1.d0)
          alfa2=1.d0/4.d0
          auxalfa2=alfa2
          alfa3=auxalfa3*(1.d0-alfa2)+alfa2
          alfa4=auxalfa4*(1.d0-auxalfa3)*(1.d0-alfa2)+alfa3
        ELSE ! estrinf.GT.spm1lo: flat1 + res1 + flat2 + res2+ flat3
          xf3_max=estrsup
          xf3_min=spm2hi
          rkappa5=(xf3_max-xf3_min)*2.d0*spm2hi
          xw2_min=atan((spm2lo**2-rmx2**2)/(gamx2*rmx2))
          xw2_max=atan((spm2hi**2-rmx2**2)/(gamx2*rmx2))
          rkappa4high=(xw2_max-xw2_min)*
     &          ((spm2hi**2-rmx2**2)**2+(gamx2*rmx2)**2)
     &                /(gamx2*rmx2)
          rkappa4low=(xw2_max-xw2_min)*
     &          ((spm2lo**2-rmx2**2)**2+(gamx2*rmx2)**2)
     &                /(gamx2*rmx2)
          rk4=rkappa4high/rkappa5
ccc          auxalfa4=rk4/(rk4+1.d0)
          auxalfa4=0.5d0
          xf2_max=spm2lo
          xf2_min=spm1hi
          rkappa3high=(xf2_max-xf2_min)*2.d0*spm2lo
          rkappa3low=(xf2_max-xf2_min)*2.d0*spm1hi
          rk3=rkappa3high/rkappa4low*auxalfa4
ccc          auxalfa3=rk3/(rk3+1.d0)
          auxalfa3=1.d0/3.d0
          xw1_max=atan((spm1hi**2-rmx1**2)/(gamx1*rmx1))
          xw1_min=atan((spm1lo**2-rmx1**2)/(gamx1*rmx1))
          rkappa2high=(xw1_max-xw1_min)*
     &          ((spm1hi**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          rkappa2low=(xw1_max-xw1_min)*
     &          ((spm1lo**2-rmx1**2)**2+(gamx1*rmx1)**2)
     &                /(gamx1*rmx1)
          rk2=rkappa2high/rkappa3low*auxalfa3
ccc          auxalfa2=rk2/(rk2+1.d0)
          auxalfa2=1.d0/4.d0
          xf1_max=spm1lo
          xf1_min=estrinf
          rkappa1=(xf1_max-xf1_min)*2.d0*spm1lo
          rk1=rkappa1/rkappa2low*auxalfa2
ccc          alfa1=rk1/(rk1+1.d0)
          alfa1=1.d0/5.d0
          alfa2=auxalfa2*(1.d0-alfa1)+alfa1
          alfa3=auxalfa3*(1.d0-auxalfa2)*(1.d0-alfa1)+alfa2
          alfa4=auxalfa4*(1.d0-auxalfa3)*(1.d0-auxalfa2)*(1.d0-alfa1)
     &                               +alfa3
        ENDIF
      ENDIF

      RETURN
      END

*****************************************************************************
* Auxiliary subroutine. Defines extrema for flat+t**alfa mapping of t-channel
* Propagator. Checks for position of t_sup,t_inf with respect to spt1
* INPUT:
*   t_sup,t_inf      : upper and lower limit for t
*   spt1             : separation point between flat and mapped regions
*   exp1             : exponent of the mapping
* OUTPUT:
*  alfa              : separation points in [0,1] between flat and mapped regions
*                      Can also be 0 or 1. Some care necessary in this cases
*  xt1_min,xt1_max,xt2_min,xt2_max
*                    : auxiliary quantities used for generating t
*                      and computing the jacobian
*****************************************************************************
* a --> c, b --> d

      SUBROUTINE T_INI(t_inf,t_sup,spt1,exp1,
     &                 alfa,xt1_min,xt1_max,xt2_min,xt2_max)
      IMPLICIT REAL*8(a-h,o-z)

      IF(t_sup.LE.spt1)THEN      ! only flat
        alfa=1.d0
        xt1_min=t_inf
        xt1_max=t_sup
      ELSE                       ! flat + mapped?
        IF(t_inf.GE.spt1)THEN    ! only mapped
          alfa=0.d0
          IF(exp1.eq.0.d0)THEN
            xt2_min=t_inf
            xt2_max=t_sup
          ELSEIF(exp1.ne.1.d0)THEN
            xt2_min=(-t_sup)**(1.d0-exp1)
            xt2_max=(-t_inf)**(1.d0-exp1)
          ELSE
            xt2_min=log((-t_sup))
	    xt2_max=log((-t_inf))
          ENDIF
	ELSE                     ! flat + mapped!
          xt1_min=t_inf
          xt1_max=spt1
          rkappa1=(xt1_max-xt1_min)
          IF(exp1.eq.0.d0)THEN
            xt2_min=spt1
            xt2_max=t_sup
            rkappa2=(xt2_max-xt2_min)
          ELSEIF(exp1.ne.1.d0)THEN
            xt2_min=(-t_sup)**(1.d0-exp1)
            xt2_max=(-spt1)**(1.d0-exp1)
	    rkappa2=(xt2_max-xt2_min)/(1.d0-exp1)*(-spt1)**exp1
          ELSE
            xt2_min=log((-t_sup))
	    xt2_max=log((-spt1))
	    rkappa2=(xt2_max-xt2_min)*(-spt1)
          ENDIF
          rkappa=rkappa1/rkappa2
          alfa=rkappa/(rkappa+1.d0)
	ENDIF
      ENDIF

      RETURN
      END

*****************************************************************************
* Auxiliary subroutine. Defines extrema for flat+flat mapping
* of shat. Checks for position of estrsup,estrinf with respect to
* spm1lo,spm1hi
* INPUT:
*   estrsup,estrinf: upper and lower limit for the generated mass
*   spm1  : separation point of the two regions region
* OUTPUT:
*  alfa1             : separation point in [0,1] between the two regions
*                      Can also be 0 or 1. Some care necessary in this cases.
*                      At present set to 2/3.
*  xf1_min,xf1_max,xf2_min,xf2_max
*                    : auxiliary quantities used for generating the mass
*                      and computing the jacobian
*****************************************************************************
      SUBROUTINE PHSP_INI2(estrsup,estrinf,spm1,
     &                           alfa1,
     &               xf1_min,xf1_max,xf2_min,xf2_max)

      IMPLICIT REAL*8(a-h,o-z)

      IF(estrsup.LE.spm1)THEN ! only flat1
        alfa1=1.d0
        xf1_max=estrsup
        xf1_min=estrinf
      ELSE ! estrsup.GT.spm1: flat1 + flat2 ?
        IF(estrinf.GE.spm1)THEN  ! only flat2
          alfa1=0.d0
          xf2_max=estrsup
          xf2_min=estrinf
        ELSE !  flat1 + flat2
          xf2_max=estrsup
          xf2_min=spm1
          rkappa2=(xf2_max-xf2_min)*2.d0*spm1
          xf1_min=estrinf
          xf1_max=spm1
          rkappa1=(xf1_max-xf1_min)*2.d0*spm1
          rk1=rkappa1/rkappa2
c          alfa1=rk1/(rk1+1.d0)
          alfa1=0.85d0
        ENDIF
      ENDIF

      RETURN
      END

*****************************************************************************
* Auxiliary subroutine
* INPUT:
*       pbst        : intermediate particle momentum
*       shat        : the corresponding mass (assumed positive)
*       pmod        : the absolute value of the 3-momentum of the two
*                     daughter particles in the decay CM
*       xm1sq,xm2sq : the squared masses of the daughter particles
*       x1,x2       : two random numbers uniformly distributed in [0,1]
* OUTPUT:
*       p1,p2       : the momenta of the two daughters in the frame in
*                     which the intermediate particle has momentum pbst
*                             p1 + p2 = pbst
*
* If pbst=(sqrt(shat),0,0,0) the boost reduces to the identity
* Ezio May 7 2007
* A rotation of the generated momentum has been added in such a way to assume as
* z-axis the direction of a massless particle along the z-axis in the overall
* center of mass
*
*****************************************************************************
      SUBROUTINE TWOBODY_Z(pbst,shat,pmod,xm1sq,xm2sq,x1,x2,p1,p2)
      IMPLICIT NONE
      REAL*8 pbst(0:3),shat,pmod,xm1sq,xm2sq,x1,x2,p1(0:3),p2(0:3)
* Local variables
      REAL*8 app,costh,sinth,ph,rmboost,aapp,pi,twopi
      REAL*8 pz(0:3)
      INTEGER i
      PARAMETER (pi=3.141592653589793238462643d0,twopi=2.d0*pi)

      costh=min(x1*2.d0-1.d0,1.d0)
      costh=max(costh,-1.d0)
      sinth=sqrt(1.d0-costh*costh)
      ph=x2*twopi
* p1
      p1(0)=sqrt(pmod*pmod+xm1sq)
      p1(1)=pmod*sinth*cos(ph)
      p1(2)=pmod*sinth*sin(ph)
      p1(3)=pmod*costh
* pz
      pz(0)=1.d0
      pz(1)=0.d0
      pz(2)=0.d0
      pz(3)=1.d0
* boost to pbst center of mass
      call boostinv(pz,pbst,pz)
* rotate in such a way that angles are relative to the direction of pz (bbosted)
      call rot(p1(1),pz(1),p1(1))
* boost back
      rmboost=sqrt(shat)
      app=(p1(0)*pbst(0)+p1(1)*pbst(1)+p1(2)*pbst(2)+p1(3)*pbst(3))
     &      /rmboost
      aapp=(app+p1(0))/(pbst(0)+rmboost)
      p1(0)=app
      p1(1)=p1(1)+aapp*pbst(1)
      p1(2)=p1(2)+aapp*pbst(2)
      p1(3)=p1(3)+aapp*pbst(3)
      DO i=0,3
        p2(i)=pbst(i)-p1(i)
      ENDDO

      RETURN
      END

*****************************************************************************
* Auxiliary subroutine. Determines the invariant mass squared of a branching.
* The mass is supposed to resonate at two different masses rmx1 and rmx2.
* INPUT:
*   xvar: a random number in [0,1]
*   rmx1,gamx1     : mass and width of first resonance
*   rmx2,gamx2     : mass and width of second resonance
*   iregion        : index for filling the iphsp_fxn COMMON
*
*  alfa1,alfa2,alfa3,alfa4: separation points in [0,1] between the five regions
*                      Can also be 0 or 1. Some care necessary in this cases
*  auxalfa2,xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,xw2_min,xw2_max,
*  xf3_min,xf3_max,auxalfa3,auxalfa4
*                    : auxiliary quantities used for generating the mass
*                      and computing the jacobian
* OUTPUT:
*   svar: the generated invariant mass squared
*   xjacvar: the jacobian
*****************************************************************************
      SUBROUTINE PHSP_5(xvar,
     &                     rmx1,gamx1,rmx2,gamx2,
     &                     alfa1,alfa2,auxalfa2,
     &                     alfa3,auxalfa3,alfa4,auxalfa4,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max,
     &                     iregion,
     &                     svar,xjacvar)

      IMPLICIT REAL*8(a-h,o-z)
c giuseppe 29/09/2007
      INTEGER maxnresonant
      PARAMETER (maxnresonant=4)
      INTEGER isresonant(maxnresonant),imapregion(maxnresonant)
      COMMON /iphsp_fxn/ isresonant,imapregion
      PARAMETER (pi=3.141592653589793238462643d0,twopi=2.d0*pi,
     &           fourpi=4.d0*pi)

* Compute the invariant mass squared and the corresponding jacobian

      xjacvar=1.d0

      IF(xvar.LE.alfa1.AND.alfa1.GT.0.d0)THEN
        vegas_x=xvar/alfa1
        evar=(xf1_max-xf1_min)*vegas_x+xf1_min
        svar=evar*evar
        xjacvar=xjacvar*(xf1_max-xf1_min)*2.d0*evar/alfa1
      ELSEIF(xvar.LE.alfa2.AND.alfa2.GT.0.d0)THEN
        vegas_x=(xvar-alfa1)/(1.d0-alfa1)/auxalfa2
        x_max=xw1_max
        x_min=xw1_min
        svar=(gamx1*rmx1*tan((x_max-x_min)*vegas_x+x_min)+rmx1**2)
        IF(svar.LE.0.d0)THEN
          xjacvar=0.d0
          RETURN
        ENDIF
        xjacvar=xjacvar*(x_max-x_min)*((svar-rmx1**2)**2+
     &      (gamx1*rmx1)**2)/(gamx1*rmx1)/(1.d0-alfa1)/auxalfa2
c giuseppe 29/09/2007
        isresonant(iregion)=1
        imapregion(iregion)=2
c end giuseppe 29/09/2007
      ELSEIF(xvar.LE.alfa3.AND.alfa3.GT.0.d0)THEN
        vegas_x=(xvar-alfa2)/(1.d0-alfa1)/(1.d0-auxalfa2)/auxalfa3
        evar=(xf2_max-xf2_min)*vegas_x+xf2_min
        svar=evar*evar
        xjacvar=xjacvar*(xf2_max-xf2_min)*2.d0*evar
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)/auxalfa3
      ELSEIF(xvar.LE.alfa4.AND.alfa4.GT.0.d0)THEN
        vegas_x=(xvar-alfa3)/(1.d0-alfa1)/(1.d0-auxalfa2)
     &                      /(1.d0-auxalfa3)/auxalfa4
        x_max=xw2_max
        x_min=xw2_min
        svar=(gamx2*rmx2*tan((x_max-x_min)*vegas_x+x_min)+rmx2**2)
        IF(svar.LE.0.d0)THEN
          xjacvar=0.d0
          RETURN
        ENDIF
        xjacvar=xjacvar*(x_max-x_min)*((svar-rmx2**2)**2+
     &      (gamx2*rmx2)**2)/(gamx2*rmx2)/(1.d0-alfa1)
     &       /(1.d0-auxalfa2)/(1.d0-auxalfa3)/auxalfa4
c giuseppe 29/09/2007
        isresonant(iregion)=1
        imapregion(iregion)=4
c end giuseppe 29/09/2007
      ELSE
        vegas_x=(xvar-alfa4)/(1.d0-alfa1)/(1.d0-auxalfa2)
     &                      /(1.d0-auxalfa3)/(1.d0-auxalfa4)
        evar=(xf3_max-xf3_min)*vegas_x+xf3_min
        svar=evar*evar
        xjacvar=xjacvar*(xf3_max-xf3_min)*2.d0*evar
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)
     &                      /(1.d0-auxalfa3)/(1.d0-auxalfa4)
      ENDIF
      xjacvar=xjacvar/twopi

      RETURN
      END


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine invert  --  gauss-jordan matrix inversion  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "invert" inverts a matrix using the Gauss-Jordan method
c
c     variables and parameters:
c
c     n     dimension of the matrix to be inverted
c     a     matrix to invert; contains inverse on exit
c
c
      subroutine invert (n,a)
      implicit none
      include 'iounit.i'
      integer i,j,k,n
      integer icol,irow
      integer, allocatable :: ipivot(:)
      integer, allocatable :: indxc(:)
      integer, allocatable :: indxr(:)
      real*8 big,temp
      real*8 pivot
      real*8 a(n,*)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (ipivot(n))
      allocate (indxc(n))
      allocate (indxr(n))
c
c     perform matrix inversion via the Gauss-Jordan algorithm
c
      do i = 1, n
         ipivot(i) = 0
      end do
      do i = 1, n
         big = 0.0d0
         do j = 1, n
            if (ipivot(j) .ne. 1) then
               do k = 1, n
                  if (ipivot(k) .eq. 0) then
                     if (abs(a(j,k)) .ge. big) then
                        big = abs(a(j,k))
                        irow = j
                        icol = k
                     end if
                  else if (ipivot(k) .gt. 1) then
                     write (iout,10)
   10                format (/,' INVERT  --  Cannot Invert',
     &                          ' a Singular Matrix')
                     call fatal
                  end if
               end do
            end if
         end do
         ipivot(icol) = ipivot(icol) + 1
         if (irow .ne. icol) then
            do j = 1, n
               temp = a(irow,j)
               a(irow,j) = a(icol,j)
               a(icol,j) = temp
            end do
         end if
         indxr(i) = irow
         indxc(i) = icol
         if (a(icol,icol) .eq. 0.0d0) then
            write (iout,20)
   20       format (/,' INVERT  --  Cannot Invert a Singular Matrix')
            call fatal
         end if
         pivot = a(icol,icol)
         a(icol,icol) = 1.0d0
         do j = 1, n
            a(icol,j) = a(icol,j) / pivot
         end do
         do j = 1, n
            if (j .ne. icol) then
               temp = a(j,icol)
               a(j,icol) = 0.0d0
               do k = 1, n
                  a(j,k) = a(j,k) - a(icol,k)*temp
               end do
            end if
         end do
      end do
      do i = n, 1, -1
         if (indxr(i) .ne. indxc(i)) then
            do k = 1, n
               temp = a(k,indxr(i))
               a(k,indxr(i)) = a(k,indxc(i))
               a(k,indxc(i)) = temp
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (ipivot)
      deallocate (indxc)
      deallocate (indxr)
      return
      end


program newton
    implicit none
    character(len=32) :: arg
    integer :: iter = 100
    real ::  fx, number,x
    call getarg(1, arg)
    read (arg, '(f10.0)') number
    !do 20 i=1, 2, 1
    !20 continue
    fx = number /2
    !fx = number

    do while (iter  >= 0)
       fx = (fx + (number / fx))/2
       !fx =  fx - ( (fx*fx) / (fx * 2) )

        iter = iter - 1
    end do
print '("A raiz é: "(f0.2))' , fx
end program newton


      INCLUDE 'VICMAIN_FOR'

      SUBROUTINE MAIN44
      DOUBLE PRECISION X(2,2), QR(5,3)
      INTEGER I, M, N, IP, J, IFAIL, IPIV(2)
      DOUBLE PRECISION A(3,2) ! Presets: / 1.1,1.2,1.0,  0.9,1.0,1.0 /
      DOUBLE PRECISION B(3,2) ! Presets: / 2.2,2.3,2.1,  4.4,4.6,4.2 /
      CHARACTER*132 TBUF

      DATA A / 1.1,1.2,1.0,  0.9,1.0,1.0/
      DATA B / 2.2,2.3,2.1,  4.4,4.6,4.2  /

C  1.1  0.9  2.2
C  1.2  1.0  2.3
C  1.0  1.0  2.1

      M = 3
      N = 2
      IP = 2
      IFAIL = 1

! Call DLLSQ to calculat the least squares solution for test values
      CALL DLLSQ(A,B,M,N,IP,X,IPIV,1.D-15,IFAIL,QR)

! If a failure was detected then print contents of array and terminate
      IF (IFAIL.EQ.0) GO TO 20
      WRITE (TBUF,99996) IFAIL
99996 FORMAT ('ERROR IN DLLSQ IFAIL = ', I2)
      CALL XVMESSAGE (TBUF, ' ')
      RETURN

! DLLSQ was successful ... print results of least squares computatin
   20 WRITE (TBUF,90010)
90010 FORMAT ('SOLUTIONS')
      CALL XVMESSAGE (TBUF, ' ')

      DO 40 J = 1, IP
      DO 40 I = 1, N
      WRITE (TBUF,99920) X(I,J)
99920 FORMAT (F7.4)
      CALL XVMESSAGE (TBUF, ' ')
40    END DO

C     Test DLLSQ error processing
      WRITE (TBUF, 90100)
90100 FORMAT ('TEST ERROR HANDLING. SHOULD GET IER=1')
      CALL XVMESSAGE (TBUF, ' ')

C     Set first 24 (6*4) bytes of memory occupied by matrix A to zero
      CALL ZIA(A,6)

      CALL DLLSQ(A,B,M,N,IP,X,IPIV,1.D-15,IFAIL,QR)
      WRITE (TBUF,99996) IFAIL
      CALL XVMESSAGE (TBUF, ' ')

! Initiate Call to the C bridge for DLLSQ and the DLLSQ bridge test driver
      CALL tzdllsq

      RETURN
      END


program problem50
  use euler
  implicit none
  integer, parameter             :: limit=1000000
  integer*8, dimension(limit/10) :: primes,sums
  integer*8                      :: i,j,sum,count
  integer*8                      :: best_prime,best_gap,gap,prime

  count=0
  do i=2,limit
     if (is_prime(int8(i))) then
        count=count+1
        primes(count)=i
     end if
  end do

  sum=0
  do i=1,count
     sum=sum+primes(i)
     sums(i)=sum
  end do

  best_gap=21
  do i=count,1,-1 ! index of end of sequence
     do j=1,i-1   ! length of the gap
        gap=i-j+1
        if (gap<best_gap) exit
        prime=sums(i)-sums(j)
        if (prime<limit .and. is_prime(prime)) then
           best_prime=sums(i)-sums(j)
           best_gap=i-j+1
           print *, i,j,sums(i),sums(j),best_prime, best_gap
        end if
     end do
  end do

print *, best_prime, best_gap

contains

end program problem50


      SUBROUTINE ZLAPR1( BASE, K, S, A, INCA, ALPHA, BETA, SCAL )
      IMPLICIT NONE
C
C     PURPOSE
C
C     Computes the general product of K complex scalars trying to avoid
C     over- and underflow.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     BASE    (input)  DOUBLE PRECISION
C             Machine base.
C
C     K       (input)  INTEGER
C             The number of scalars.  K >= 0.
C
C     S       (input)  INTEGER array, dimension (K)
C             The signature array. Each entry of S must be 1 or -1.
C
C     A       (input)  COMPLEX*16 array, dimension (K)
C             Vector of real scalars.
C
C     INCA    (input)  INTEGER
C             Increment for the array A. incA <> 0.
C
C     ALPHA   (output)  COMPLEX*16
C             ALPHA is a real scalar with 1.0 <= ABS(ALPHA) < BASE such
C             that
C
C                  ALPHA / BETA * BASE**(SCAL)
C
C             is the general product of A.
C
C     BETA    (output)  COMPLEX*16
C             BETA is either 0.0 or 1.0.
C             See also the description of ALPHA.
C
C     SCAL    (output)  INTEGER
C             Scaling factor, see ALPHA.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, Dec. 2002.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      COMPLEX*16        CONE, CZERO
      PARAMETER         ( CONE = ( 1.0D+0, 0.0D+0 ),
     $                  CZERO = ( 0.0D+0, 0.0D+0 ) )
C     .. Array Arguments ..
      INTEGER           S(*)
      COMPLEX*16        A(*)
C     .. Scalar Arguments ..
      INTEGER           INCA, K, SCAL
      DOUBLE PRECISION  BASE
      COMPLEX*16        ALPHA, BETA
C     .. Local Scalars ..
      INTEGER           I, INDA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DCMPLX
C
C     .. Executable Statements ..
C
      ALPHA = CONE
      BETA = CONE
      SCAL = 0
      INDA = 1
      DO 50  I = 1, K
         IF ( S(I).EQ.1 ) THEN
            ALPHA = ALPHA * A(INDA)
         ELSE
            IF ( A(INDA).EQ.CZERO ) THEN
               BETA = CZERO
            ELSE
               ALPHA = ALPHA / A(INDA)
            END IF
         END IF
         IF ( ABS( ALPHA ).EQ.ZERO ) THEN
            SCAL = 0
            ALPHA = CZERO
         ELSE
   10       IF ( ABS( ALPHA ).GE.ONE )  GO TO 20
               ALPHA = DCMPLX( BASE, ZERO )*ALPHA
               SCAL = SCAL - 1
            GO TO 10
   20       CONTINUE
   30       IF ( ABS( ALPHA ).LT.BASE ) GO TO 40
               ALPHA = ALPHA / DCMPLX( BASE, ZERO )
               SCAL = SCAL + 1
            GO TO 30
   40       CONTINUE
         END IF
         INDA = INDA + INCA
   50 CONTINUE
C
      RETURN
C
C *** Last line of ZLAPR1 ***
      END


program Five_weekends
  implicit none

  integer :: m, year, nfives = 0, not5 = 0
  logical :: no5weekend

  type month
    integer :: n
    character(3) :: name
  end type month

  type(month) :: month31(7)

  month31(1) = month(13, "Jan")
  month31(2) = month(3,  "Mar")
  month31(3) = month(5,  "May")
  month31(4) = month(7,  "Jul")
  month31(5) = month(8,  "Aug")
  month31(6) = month(10, "Oct")
  month31(7) = month(12, "Dec")

  do year = 1900, 2100
    no5weekend = .true.
    do m = 1, size(month31)
      if(month31(m)%n == 13) then
        if(Day_of_week(1, month31(m)%n, year-1) == 6) then
          write(*, "(a3, i5)") month31(m)%name, year
          nfives = nfives + 1
          no5weekend = .false.
        end if
      else
        if(Day_of_week(1, month31(m)%n, year) == 6) then
          write(*,"(a3, i5)") month31(m)%name, year
          nfives = nfives + 1
          no5weekend = .false.
        end if
      end if
    end do
    if(no5weekend) not5 = not5 + 1
  end do

  write(*, "(a, i0)") "Number of months with five weekends between 1900 and 2100 = ", nfives
  write(*, "(a, i0)") "Number of years between 1900 and 2100 with no five weekend months = ", not5

contains

function Day_of_week(d, m, y)
  integer :: Day_of_week
  integer, intent(in) :: d, m, y
  integer :: j, k

  j = y / 100
  k = mod(y, 100)
  Day_of_week = mod(d + (m+1)*26/10 + k + k/4 + j/4 + 5*j, 7)

end function Day_of_week
end program Five_weekends


c***************************************************************************
c			OBL_ACC_TP.F
c*************************************************************************
c OBL_ACC returns the BARYCENTRIC x,y,z components of the acc. on NTP
c test particles due to the oblateness of mass(1) using
c the values of J2RP2 and J4RP4 passed into the routine.
c (J2RP2 for example is the product of
c J_2 times the square of the central body's radius)
c Here we return the net acc. produced
c only by the J2 and J4 terms (i.e. including
c neither the monopole nor higher order terms).
c
c
c             Input:
c                 ntp      ==>  number of massive bodies (incl. central one)
c                 istat    ==>  status of the test paricles
c                                    (integer array)
c                                istat(i) = 0 ==> active:  = 1 not
c                                NOTE: it is really a 2d array but
c                                      we only use the 1st row
c                 msun     ==>  mass of the central particle (real*8 scalar)
c                 j2rp2    ==>  scaled value of j2 moment (real*8 scalar)
c                 j4rp4    ==>  scaled value of j4 moment (real*8 scalar)
c   xht(*),yht(*),zht(*)   ==>  HELIO. positions of particles
c                irht(*)   ==> 1./ magnitude of radius vector (real*8 vector)
c                                (passed in to save calcs.)
c             Output:
c  aoblxt(*),aoblyt(*),aoblzt(*)  ==>  BARY. components of accel
c                                        (real*8 vectors)
c
c Remarks:  Based on Martin's OBL_ACC.F
c Authors:  Hal Levison
c Date:    3/4/94
c Last revision:

      subroutine obl_acc_tp(ntp,istat,msun,j2rp2,j4rp4,xht,yht,zht,
     &        irht,aoblxt,aoblyt,aoblzt)

      include '../swift.inc'

c...  Inputs Only:
      integer ntp,istat(ntp)
      real*8 msun,j2rp2,j4rp4
      real*8 xht(ntp),yht(ntp),zht(ntp),irht(NPLMAX)

c...  Output
      real*8 aoblxt(ntp),aoblyt(ntp),aoblzt(ntp)

c...  Internals
      integer n
      real*8 rinv2,t0,t1,t2,t3
      real*8 fac1,fac2

c----
c...  executable code

c First get the bary acc. of each tp due to central oblate "sun"

      do n =1,ntp

         rinv2= irht(n)**2
         t0 = -msun*rinv2*rinv2*irht(n)
         t1 = 1.5d0 *j2rp2
         t2 = zht(n)*zht(n)*rinv2
         t3 = 1.875d0 *j4rp4*rinv2

         fac1 = t0*(t1 - t3 - (5.d0*t1 - (14.d0 - 21.d0*t2)*t3)*t2)
         fac2 = 2.d0*t0*(t1 - (2.d0 - (14.d0*t2/3.d0))*t3)

         aoblxt(n) = fac1*xht(n)
         aoblyt(n) = fac1*yht(n)
         aoblzt(n) = (fac1 + fac2)*zht(n)

      enddo

      return
      end                       !  obl_acc_tp.f
c____________________________________________________________________________


      SUBROUTINE MB04ZD( COMPU, N, A, LDA, QG, LDQG, U, LDU, DWORK, INFO
     $                 )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To transform a Hamiltonian matrix
C
C               ( A   G  )
C           H = (      T )                                           (1)
C               ( Q  -A  )
C
C     into a square-reduced Hamiltonian matrix
C
C                ( A'  G'  )
C           H' = (       T )                                         (2)
C                ( Q' -A'  )
C                                                                 T
C     by an orthogonal symplectic similarity transformation H' = U H U,
C     where
C               (  U1   U2 )
C           U = (          ).                                        (3)
C               ( -U2   U1 )
C                                                              T
C     The square-reduced Hamiltonian matrix satisfies Q'A' - A' Q' = 0,
C     and
C
C           2       T     2     ( A''   G''  )
C         H'  :=  (U  H U)   =  (          T ).
C                               ( 0     A''  )
C
C     In addition, A'' is upper Hessenberg and G'' is skew symmetric.
C     The square roots of the eigenvalues of A'' = A'*A' + G'*Q' are the
C     eigenvalues of H.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPU   CHARACTER*1
C             Indicates whether the orthogonal symplectic similarity
C             transformation matrix U in (3) is returned or
C             accumulated into an orthogonal symplectic matrix, or if
C             the transformation matrix is not required, as follows:
C             = 'N':         U is not required;
C             = 'I' or 'F':  on entry, U need not be set;
C                            on exit, U contains the orthogonal
C                            symplectic matrix U from (3);
C             = 'V' or 'A':  the orthogonal symplectic similarity
C                            transformations are accumulated into U;
C                            on input, U must contain an orthogonal
C                            symplectic matrix S;
C                            on exit, U contains S*U with U from (3).
C             See the description of U below for details.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, G, and Q.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On input, the leading N-by-N part of this array must
C             contain the upper left block A of the Hamiltonian matrix H
C             in (1).
C             On output, the leading N-by-N part of this array contains
C             the upper left block A' of the square-reduced Hamiltonian
C             matrix H' in (2).
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     QG      (input/output) DOUBLE PRECISION array, dimension
C             (LDQG,N+1)
C             On input, the leading N-by-N lower triangular part of this
C             array must contain the lower triangle of the lower left
C             symmetric block Q of the Hamiltonian matrix H in (1), and
C             the N-by-N upper triangular part of the submatrix in the
C             columns 2 to N+1 of this array must contain the upper
C             triangle of the upper right symmetric block G of H in (1).
C             So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j)
C             and G(i,j) = G(j,i) is stored in QG(j,i+1).
C             On output, the leading N-by-N lower triangular part of
C             this array contains the lower triangle of the lower left
C             symmetric block Q', and the N-by-N upper triangular part
C             of the submatrix in the columns 2 to N+1 of this array
C             contains the upper triangle of the upper right symmetric
C             block G' of the square-reduced Hamiltonian matrix H'
C             in (2).
C
C     LDQG    INTEGER
C             The leading dimension of the array QG.  LDQG >= MAX(1,N).
C
C     U       (input/output) DOUBLE PRECISION array, dimension (LDU,2*N)
C             If COMPU = 'N', then this array is not referenced.
C             If COMPU = 'I' or 'F', then the input contents of this
C             array are not specified.  On output, the leading
C             N-by-(2*N) part of this array contains the first N rows
C             of the orthogonal symplectic matrix U in (3).
C             If COMPU = 'V' or 'A', then, on input, the leading
C             N-by-(2*N) part of this array must contain the first N
C             rows of an orthogonal symplectic matrix S. On output, the
C             leading N-by-(2*N) part of this array contains the first N
C             rows of the product S*U where U is the orthogonal
C             symplectic matrix from (3).
C             The storage scheme implied by (3) is used for orthogonal
C             symplectic matrices, i.e., only the first N rows are
C             stored, as they contain all relevant information.
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= MAX(1,N), if COMPU <> 'N';
C             LDU >= 1,        if COMPU =  'N'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (2*N)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, then the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The Hamiltonian matrix H is transformed into a square-reduced
C     Hamiltonian matrix H' using the implicit version of Van Loan's
C     method as proposed in [1,2,3].
C
C     REFERENCES
C
C     [1] Van Loan, C. F.
C         A Symplectic Method for Approximating All the Eigenvalues of
C         a Hamiltonian Matrix.
C         Linear Algebra and its Applications, 61, pp. 233-251, 1984.
C
C     [2] Byers, R.
C         Hamiltonian and Symplectic Algorithms for the Algebraic
C         Riccati Equation.
C         Ph. D. Thesis, Cornell University, Ithaca, NY, January 1983.
C
C     [3] Benner, P., Byers, R., and Barth, E.
C         Fortran 77 Subroutines for Computing the Eigenvalues of
C         Hamiltonian Matrices. I: The Square-Reduced Method.
C         ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000.
C
C     NUMERICAL ASPECTS
C
C     This algorithm requires approximately 20*N**3 flops for
C     transforming H into square-reduced form. If the transformations
C     are required, this adds another 8*N**3 flops. The method is
C     strongly backward stable in the sense that if H' and U are the
C     computed square-reduced Hamiltonian and computed orthogonal
C     symplectic similarity transformation, then there is an orthogonal
C     symplectic matrix T and a Hamiltonian matrix M such that
C
C                  H T  =  T M
C
C        || T - U ||   <=  c1 * eps
C
C        || H' - M ||  <=  c2 * eps * || H ||
C
C     where c1, c2 are modest constants depending on the dimension N and
C     eps is the machine precision.
C
C     Eigenvalues computed by explicitly forming the upper Hessenberg
C     matrix  A'' = A'A' + G'Q', with A', G', and Q' as in (2), and
C     applying the Hessenberg QR iteration to A'' are exactly
C     eigenvalues of a perturbed Hamiltonian matrix H + E,  where
C
C        || E ||  <=  c3 * sqrt(eps) * || H ||,
C
C     and c3 is a modest constant depending on the dimension N and eps
C     is the machine precision.  Moreover, if the norm of H and an
C     eigenvalue lambda are of roughly the same magnitude, the computed
C     eigenvalue is essentially as accurate as the computed eigenvalue
C     from traditional methods.  See [1] or [2].
C
C     CONTRIBUTOR
C
C     P. Benner, Universitaet Bremen, Germany,
C     R. Byers, University of Kansas, Lawrence, USA, and
C     E. Barth, Kalamazoo College, Kalamazoo, USA,
C     Aug. 1998, routine DHASRD.
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Oct. 1998, SLICOT Library version.
C
C     REVISIONS
C
C     May 2001, A. Varga, German Aeropsce Center, DLR Oberpfaffenhofen.
C     May 2009, V. Sima, Research Institute for Informatics, Bucharest.
C
C     KEYWORDS
C
C     Orthogonal transformation, (square-reduced) Hamiltonian matrix,
C     symplectic similarity transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
C
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDQG, LDU, N
      CHARACTER         COMPU
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), QG(LDQG,*), U(LDU,*)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION  COSINE, SINE, TAU, TEMP, X, Y
      INTEGER           J
      LOGICAL           ACCUM, FORGET, FORM
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION  DUMMY(1), T(2,2)
C     ..
C     .. External Functions ..
      DOUBLE PRECISION  DDOT
      LOGICAL           LSAME
      EXTERNAL          DDOT, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMV, DLARFG, DLARFX, DLARTG,
     $                  DROT, DSYMV, DSYR2, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     ..
C     .. Executable Statements ..
C
      INFO   = 0
      ACCUM  = LSAME( COMPU, 'A' ) .OR. LSAME( COMPU, 'V' )
      FORM   = LSAME( COMPU, 'F' ) .OR. LSAME( COMPU, 'I' )
      FORGET = LSAME( COMPU, 'N' )
C
      IF ( .NOT.ACCUM .AND. .NOT.FORM .AND. .NOT.FORGET ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDQG.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDU.LT.1 .OR. ( .NOT.FORGET .AND. LDU.LT.MAX( 1, N ) ) )
     $      THEN
         INFO = -8
      END IF
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04ZD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
C     Transform to square-reduced form.
C
      DO 10 J = 1, N - 1
C                         T
C        DWORK <- (Q*A - A *Q)(J+1:N,J).
C
         CALL DCOPY( J-1, QG(J,1), LDQG, DWORK(N+1), 1 )
         CALL DCOPY( N-J+1, QG(J,J), 1, DWORK(N+J), 1 )
         CALL DGEMV( 'Transpose', N, N-J, -ONE, A(1,J+1), LDA,
     $               DWORK(N+1), 1, ZERO, DWORK(J+1), 1 )
         CALL DGEMV( 'NoTranspose', N-J, J, ONE, QG(J+1,1), LDQG,
     $               A(1,J), 1, ONE, DWORK(J+1), 1 )
         CALL DSYMV( 'Lower', N-J, ONE, QG(J+1,J+1), LDQG, A(J+1,J), 1,
     $               ONE, DWORK(J+1), 1 )
C
C        Symplectic reflection to zero (H*H)((N+J+2):2N,J).
C
         CALL DLARFG( N-J, DWORK(J+1), DWORK(J+2), 1, TAU )
         Y = DWORK(J+1)
         DWORK(J+1) = ONE
C
         CALL DLARFX( 'Left', N-J, N, DWORK(J+1), TAU, A(J+1,1), LDA,
     $                DWORK(N+1) )
         CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, A(1,J+1), LDA,
     $                DWORK(N+1) )
C
         CALL DLARFX( 'Left', N-J, J, DWORK(J+1), TAU, QG(J+1,1), LDQG,
     $                DWORK(N+1) )
         CALL DSYMV( 'Lower', N-J, TAU, QG(J+1,J+1), LDQG, DWORK(J+1),
     $               1, ZERO, DWORK(N+J+1), 1 )
         CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1),
     $               1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 )
         CALL DSYR2( 'Lower', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1,
     $               QG(J+1,J+1), LDQG )
C
         CALL DLARFX( 'Right', J, N-J, DWORK(J+1), TAU, QG(1,J+2), LDQG,
     $                DWORK(N+1) )
         CALL DSYMV( 'Upper', N-J, TAU, QG(J+1,J+2), LDQG, DWORK(J+1),
     $               1, ZERO, DWORK(N+J+1), 1 )
         CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1),
     $               1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 )
         CALL DSYR2( 'Upper', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1,
     $               QG(J+1,J+2), LDQG )
C
         IF ( FORM ) THEN
C
C           Save reflection.
C
            CALL DCOPY( N-J, DWORK(J+1), 1, U(J+1,J), 1 )
            U(J+1,J) = TAU
C
         ELSE IF ( ACCUM ) THEN
C
C           Accumulate reflection.
C
            CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,J+1),
     $                   LDU, DWORK(N+1) )
            CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,N+J+1),
     $                   LDU, DWORK(N+1) )
         END IF
C
C        (X,Y) := ((J+1,J),(N+J+1,J)) component of H*H.
C
         X = DDOT( J, QG(1,J+2), 1, QG(J,1), LDQG ) +
     $       DDOT( N-J, QG(J+1,J+2), LDQG, QG(J+1,J), 1 ) +
     $       DDOT( N, A(J+1,1), LDA, A(1,J), 1 )
C
C        Symplectic rotation to zero (H*H)(N+J+1,J).
C
         CALL DLARTG( X, Y, COSINE, SINE, TEMP )
C
         CALL DROT( J, A(J+1,1), LDA, QG(J+1,1), LDQG, COSINE, SINE )
         CALL DROT( J, A(1,J+1), 1, QG(1,J+2), 1, COSINE, SINE )
         IF( J.LT.N-1 ) THEN
            CALL DROT( N-J-1, A(J+1,J+2), LDA, QG(J+2,J+1), 1,
     $                 COSINE, SINE )
            CALL DROT( N-J-1, A(J+2,J+1), 1, QG(J+1,J+3), LDQG,
     $                 COSINE, SINE )
         END IF
C
         T(1,1) = A(J+1,J+1)
         T(1,2) = QG(J+1,J+2)
         T(2,1) = QG(J+1,J+1)
         T(2,2) = -T(1,1)
         CALL DROT( 2, T(1,1), 1, T(1,2), 1, COSINE, SINE )
         CALL DROT( 2, T(1,1), 2, T(2,1), 2, COSINE, SINE )
         A(J+1,J+1)  = T(1,1)
         QG(J+1,J+2) = T(1,2)
         QG(J+1,J+1) = T(2,1)
C
         IF ( FORM ) THEN
C
C           Save rotation.
C
            U(J,J)   = COSINE
            U(J,N+J) = SINE
C
         ELSE IF ( ACCUM ) THEN
C
C           Accumulate rotation.
C
            CALL DROT( N, U(1,J+1), 1, U(1,N+J+1), 1, COSINE, SINE )
         END IF
C
C        DWORK := (A*A  + G*Q)(J+1:N,J).
C
         CALL DGEMV( 'NoTranspose', N-J, N, ONE, A(J+1,1), LDA, A(1,J),
     $               1, ZERO, DWORK(J+1), 1 )
         CALL DGEMV( 'Transpose', J, N-J, ONE, QG(1,J+2), LDQG, QG(J,1),
     $               LDQG, ONE, DWORK(J+1), 1 )
         CALL DSYMV( 'Upper', N-J, ONE, QG(J+1,J+2), LDQG, QG(J+1,J), 1,
     $               ONE, DWORK(J+1), 1 )
C
C        Symplectic reflection to zero (H*H)(J+2:N,J).
C
         CALL DLARFG( N-J, DWORK(J+1), DWORK(J+2), 1, TAU )
         DWORK(J+1) = ONE
C
         CALL DLARFX( 'Left', N-J, N, DWORK(J+1), TAU, A(J+1,1), LDA,
     $                DWORK(N+1) )
         CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, A(1,J+1), LDA,
     $                DWORK(N+1) )
C
         CALL DLARFX( 'Left', N-J, J, DWORK(J+1), TAU, QG(J+1,1), LDQG,
     $                DWORK(N+1) )
         CALL DSYMV( 'Lower', N-J, TAU, QG(J+1,J+1), LDQG, DWORK(J+1),
     $               1, ZERO, DWORK(N+J+1), 1 )
         CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1),
     $               1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 )
         CALL DSYR2( 'Lower', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1,
     $               QG(J+1,J+1), LDQG )
C
         CALL DLARFX( 'Right', J, N-J, DWORK(J+1), TAU, QG(1,J+2), LDQG,
     $                DWORK(N+1) )
         CALL DSYMV( 'Upper', N-J, TAU, QG(J+1,J+2), LDQG, DWORK(J+1),
     $               1, ZERO, DWORK(N+J+1), 1 )
         CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1),
     $               1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 )
         CALL DSYR2( 'Upper', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1,
     $               QG(J+1,J+2), LDQG )
C
         IF ( FORM ) THEN
C
C           Save reflection.
C
            CALL DCOPY( N-J, DWORK(J+1), 1, U(J+1,N+J), 1 )
            U(J+1,N+J) = TAU
C
         ELSE IF ( ACCUM ) THEN
C
C           Accumulate reflection.
C
            CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,J+1),
     $                   LDU, DWORK(N+1) )
            CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,N+J+1),
     $                   LDU, DWORK(N+1) )
         END IF
C
   10 CONTINUE
C
      IF ( FORM ) THEN
         DUMMY(1) = ZERO
C
C        Form S by accumulating transformations.
C
         DO 20 J = N - 1, 1, -1
C
C           Initialize (J+1)st column of S.
C
            CALL DCOPY( N, DUMMY, 0, U(1,J+1), 1 )
            U(J+1,J+1) = ONE
            CALL DCOPY( N, DUMMY, 0, U(1,N+J+1), 1 )
C
C           Second reflection.
C
            TAU = U(J+1,N+J)
            U(J+1,N+J) = ONE
            CALL DLARFX( 'Left', N-J, N-J, U(J+1,N+J), TAU,
     $                   U(J+1,J+1), LDU, DWORK(N+1) )
            CALL DLARFX( 'Left', N-J, N-J, U(J+1,N+J), TAU,
     $                   U(J+1,N+J+1), LDU, DWORK(N+1) )
C
C           Rotation.
C
            CALL DROT( N-J, U(J+1,J+1), LDU, U(J+1,N+J+1), LDU,
     $                 U(J,J), U(J,N+J) )
C
C           First reflection.
C
            TAU = U(J+1,J)
            U(J+1,J) = ONE
            CALL DLARFX( 'Left', N-J, N-J, U(J+1,J), TAU, U(J+1,J+1),
     $                   LDU, DWORK(N+1) )
            CALL DLARFX( 'Left', N-J, N-J, U(J+1,J), TAU,
     $                   U(J+1,N+J+1), LDU, DWORK(N+1) )
   20    CONTINUE
C
C        The first column is the first column of identity.
C
         CALL DCOPY( N, DUMMY, 0, U, 1 )
         U(1,1) = ONE
         CALL DCOPY( N, DUMMY, 0, U(1,N+1), 1 )
      END IF
C
      RETURN
C     *** Last line of MB04ZD ***
      END


!  *********************************************************************
!  *                                                                   *
!  *                         subroutine dcvit3                         *
!  *                                                                   *
!  *********************************************************************
!  Double Precision Version 2.0
!  Written by Gordon A. Fenton, TUNS, Aug. 2, 1993
!
!  PURPOSE  computes the initial k1*k2*k3 x k1*k2*k3 covariance matrix (and a
!           27x27 submatrix) between local averages. Used by LAS3G.
!
!
!  This routine forms the covariance matrix R0 between local averages arranged
!  on a k1 x k2 x k3 grid using a user provided variance function "dvarfn" that
!  returns the variance of a local average (note that this is the point
!  variance sigma^2 times the traditionally "variance" function, as defined
!  by Vanmarcke in "Random Fields", MIT Press, 1984). The grid and element
!  numbering schemes appear as follows (for k1 = k2 = 5, k3 = 1 plane shown)
!
!          | Dx |
!     ---  --------------------------
!      Dy  | 21 | 22 | 23 | 24 | 25 |
!     ---  --------------------------
!          | 16 | 17 | 18 | 19 | 20 |
!          --------------------------           ----------------
!          | 11 | 12 | 13 | 14 | 15 |           |  7 |  8 |  9 |
!          --------------------------           ----------------
!          |  6 |  7 |  8 |  9 | 10 |           |  4 |  5 |  6 |
!          --------------------------           ----------------
!          |  1 |  2 |  3 |  4 |  5 |           |  1 |  2 |  3 |
!          --------------------------           ----------------
!
!                  R0 Array                          R Array
!
!  with the k1 x k2 array numbering on the left and a basic 3 x 3 subarray
!  shown on the right. In the depth direction (not shown), the numbering
!  continues; ie the element immediately behind element 1 on the left is
!  element number 26, etc. If we call Z_i the local average of a random process
!  over the i'th cell, then for E[Z] = 0, the elements of R0 are defined by
!
!           R0(i,j) = E[Z_i*Z_j]
!
!  Note that the elements of R are simply extracted directly from the
!  appropriate elements of R0 (for example, R(1,5) = R0(1,7)) if k1, k2 and k3
!  are greater than 2. Note also that since both R0 and R are symmetric, ONLY
!  THE UPPER TRIANGULAR VALUES are stored herein. Finally note that
!  the random process is assumed to be quadrant symmetric (that is the
!  covariance function is even in each individual lag component) to reduce
!  the total number of covariance calculations.
!
!  Arguments to this routine are as follows;
!
!    dvarfn     external double precision function which returns the
!               variance of a local average of size X x Y x Z. This function
!               is referenced using the call "V = dvarfn(X,Y,Z)" (other
!               parameters to the function must be passed via common blocks).
!
!    R0          double precision array of size at least k1*k2*k3 x k1*k2*k3
!               which on output will contain the covariance matrix between
!               the local average elements shown above on the left. Note
!               that since R0 is symmetric, only the upper triangular values
!               are actually stored (compatible with DCHOL2). (output)
!
!    iq         leading dimension of the array R0 as specified in the calling
!               routine. (input)
!
!    R          double precision array of size at least 27 x 27 which on output
!               will contain the covariance matrix between the local average
!               elements shown above on the right. Note that since R is
!               symmetric, only the upper triangular values are actually
!               stored (compatible with DSIFA). (output)
!
!    ir         leading dimension of the array R as specified in the calling
!               routine. (input)
!
!    k1         number of local average cells in the x direction
!               (horizontally). (input)
!
!    k2         number of local average cells in the y direction
!               (vertically). (input)
!
!    k3         number of local average cells in the z direction
!               (depth). (input)
!
!    Dx         x-dimension of the local average cells. (input)
!
!    Dy         y-dimension of the local average cells. (input)
!
!    Dz         z-dimension of the local average cells. (input)
!
!  Required:
!   1) from libGAFsim:	DCVAA3
!----------------------------------------------------------------------------
      subroutine dcvit3( dvarfn, R0, iq, R, ir, k1, k2, k3, Dx, Dy, Dz )
      implicit real*8 (a-h,o-z)
      dimension R0(iq,*), R(ir,*)
      external dvarfn
!					first form the essential elements of R0
      ii = 0
      do 30 k = 1, k3
         tz = dble(k-1)
         do 20 j = 1, k2
            ty = dble(j-1)
            do 10 i = 1, k1
               ii = ii + 1
               tx = dble(i-1)
               R0(1,ii) = dcvaa3( dvarfn, Dx, Dy, Dz, tx, ty, tz )
  10        continue
  20     continue
  30  continue
!					now distribute into the upper triangle
      kk  = k1*k2*k3
      k12 = k1*k2
      do 50 n = 2, kk
         n3 = (n-1)/k12
         n2 = (n - k12*n3 - 1)/k1
         do 40 m = 2, n
            m3 = (m-1)/k12
            m2 = (m - k12*m3 - 1)/k1
            i3 = m3 - n3
            i2 = m2 - n2
            i1 = (m-n) - k1*i2 - k12*i3
            k  = 1 + iabs(i1) + k1*iabs(i2) + k12*iabs(i3)
            R0(m,n) = R0(1,k)
  40     continue
  50  continue
!					form R (27 x 27)

      if( k1 .lt. 3 .or. k2 .lt. 3 .or. k3 .lt. 3 ) then
!						find essential elements of R
         ii = 0
         do 80 k = 1, 3
            tz = dble(k-1)
            do 70 j = 1, 3
               ty = dble(j-1)
               do 60 i = 1, 3
                  tx = dble(i-1)
                  ii = ii + 1
                  R(1,ii) = dcvaa3( dvarfn, Dx, Dy, Dz, tx, ty, tz )
  60           continue
  70        continue
  80     continue
!						and distribute into upper tri.
         do 100 n = 2, 27
            n3 = (n-1)/9
            n2 = (n - 9*n3 - 1)/3
            do 90 m = 2, n
               m3 = (m-1)/9
               m2 = (m - 9*m3 - 1)/3
               i3 = m3 - n3
               i2 = m2 - n2
               i1 = (m-n) - 3*i2 - 9*i3
               k  = 1 + iabs(i1) + 3*iabs(i2) + 9*iabs(i3)
               R(m,n) = R(1,k)
  90        continue
 100     continue
      else
!						or extract R from R0
         do 120 n = 1, 27
            n3 = (n-1)/9
            n2 = (n - 9*n3 - 1)/3
            do 110 m = 1, n
               m3 = (m-1)/9
               m2 = (m - 9*m3 - 1)/3
               i3 = m3 - n3
               i2 = m2 - n2
               i1 = (m-n) - 3*i2 - 9*i3
               k  = 1 + iabs(i1) + k1*iabs(i2) + k12*iabs(i3)
               R(m,n) = R0(1,k)
 110        continue
 120     continue
      endif

      return
      end


      subroutine mann(q0, ichan, slp, chnn, ishp, bw, s, y)

      implicit none
c
c     + + + PURPOSE + + +
c     SR Mann solves depth y from Manning's equation.
c
c     Called from: SR WSHCHR
c     Author(s): L. Wang
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by:
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real q0, slp, chnn, y, bw, s
      integer ichan, ishp
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     bw    - channel width
c     chnn  - Manning's roughness coefficient n
c     q0    - known discharge
c     s     - inverse slope of the channel banks
c     slp   - channel slope
c     y     - depth of water flow
c     ichan - channel number
c     ishp  - shape of the channel
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
      real area, rh, ay, ry, qi, dy, q0x, yx, eps, ap
      integer i, ichanx
c
c
c     + + + LOCAL DEFINITIONS + + +
c
c     area  - cross-sectional area of channel water flow
c     ay    - derivative, AY = dA / dY
c     qi    - calculated discharge
c     rh    - hydraulic radius
c     ry    - derivative, RY = dR / dY
c     ichanx - channel number
c
c     + + + SAVES + + +
      save ichanx, q0x, yx
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      eps = 1.e-6
      if(ichan /= ichanx .or. abs(q0 - q0x) > eps)then
c--------------------------------------------------
	   if(ishp == 1) then
c
c Triangular-shape channel
c Calculate y explicitly.
c
            y = 2.**0.25*(1.+s*s)**0.125*(chnn*q0)**0.375/
     1          (slp**0.1875*s**0.625)
c
c--------------------------------------------------
	   elseif(ishp == 2) then
c
c Rectangular-shape channel
c Calculate y iteratively using Newton's method.
c
c First guess of y assuming bw >> y.
c            y = (chnn*q0/(sqrt(slp)*bw))**0.6
            y = 1.
c
	      i = 0
400         i = i + 1
	      area = bw * y
	      rh = area / (bw + 2. * y)
	      ay = bw                                      ! ay = dA / dy
	      ry = (bw / (bw + 2. * y))**2                 ! ry = dR / dy
            qi = sqrt(slp) / chnn * area * rh ** (2./3.)
	      dy = (q0/qi-1.) / (ay/area + 2./3.*ry/rh)
	      y = y + dy
	      if(y > 1) dy = dy / y
            if(abs(dy) > eps .and. i < 20) goto 400
c--------------------------------------------------
c--------------------------------------------------
	   elseif(ishp == 3) then
c
c Parabolic-shape channel
c Calculate y iteratively using Newton's method.
c s = parabolic focal height
c
            y = 1.
c
	      i = 0
300         i = i + 1
            bw = 4. * sqrt(y * s)                             ! top width
	      area = 2. * bw * y / 3.
	      ap = 2.*sqrt(y*(s+y))+2.*s*log(sqrt(1.+y/s)+sqrt(y/s)) ! wetted perimeter
	      rh = area / ap                                    ! hydraulic radius
	      ay = bw                                           ! ay = dA / dy
	      ry = bw/ap - 2.*area/(ap*ap)*sqrt(1.+s/y)       ! ry = dR / dy
            qi = sqrt(slp) / chnn * area * rh ** (2./3.)
	      dy = (q0/qi-1.) / (ay/area + 2./3.*ry/rh)
	      y = y + dy
	      if(y > 1) dy = dy / y
            if(abs(dy) > eps .and. i < 20) goto 300
c--------------------------------------------------
c--------------------------------------------------
	   elseif(ishp >= 4) then
c
c Tropezoidal-shape channel
c Calculate y iteratively using Newton's method.
c
            y = 1.
c
	      i = 0
200         i = i + 1
	      area = (bw + s * y) * y
	      rh = area / (bw + 2. * y * sqrt(1. + s * s))
	      ay = bw + 2. * s * y
	      ry = (bw*bw + 2.*bw*s*y + 2.*s*y*y*sqrt(1.+s*s))
     1           / (bw + 2. * y * sqrt(1. + s * s))**2
            qi = sqrt(slp) / chnn * area * rh ** (2./3.)
	      dy = (q0/qi-1.) / (ay/area + 2./3.*ry/rh)
	      y = y + dy
	      if(y > 1) dy = dy / y
            if(abs(dy) > eps .and. i < 20) goto 200
c--------------------------------------------------
c--------------------------------------------------
	   endif
c--------------------------------------------------
	   ichanx = ichan
	   q0x = q0
	   yx = y
	else
	   y = yx
	endif
c
      return
	end


program sobol_index_test

  use mo_kind,        only: dp,i4, i8
  use mo_ansi_colors, only: color, c_red, c_green
  use mo_sobol,       only: sobol
  use mo_model,       only: getrange, model
  use mo_sobol_index, only: sobol_index

  implicit none

  integer(i4), parameter                 :: npara = 3                       ! number of parameter
  integer(i4), parameter                 :: nsets = 1000                    ! number of parametersets
  integer(i4), parameter                 :: nx = 100                        ! number of variable values
  integer(i8)                            :: skip = 30000_i8                 ! used for generating parameter sets
  !                                                                         ! via sobol sequences

  ! Samples and Model Output
  real(dp),    dimension(npara,2)        :: ParaRange                       ! array: Parameter ranges (Min, Max)
  real(dp),    dimension(nx)             :: x                               ! array: variable values

  ! Sobol index
  real(dp),    dimension(2*npara)        :: sample_sobol                    ! sobol sequence
  real(dp),    dimension(npara)          :: sample_a                        ! parameter sample A
  real(dp),    dimension(npara)          :: sample_b                        ! parameter sample B
  real(dp),    dimension(npara)          :: sample_ci                       ! parameter sample Ci
  real(dp),    dimension(nsets,nx)       :: ya, yb                          ! model output A and B,
  !                                                                         !    i.e. time series with nx time points
  real(dp),    dimension(nsets,npara,nx) :: yc                              ! model output C(i), i=1,npara,
  !                                                                         !    i.e. time series with nx time points
  real(dp),    dimension(npara,nx)       :: si                              ! Sobol index (main effect)  per time point and param.
  !                                                                         !    based on ya, yb, and yc
  real(dp),    dimension(npara,nx)       :: sti                             ! Sobol index (total effect) per time point and param.
  !                                                                         !    based on ya, yb, and yc
  real(dp),    dimension(npara,2)        :: smean                           ! Mean SI and STI
  real(dp),    dimension(npara,2)        :: wmean                           ! Variance weighted mean SI and STI

  integer(i8) :: seed

  ! Dummy variables
  integer(i4)                            :: set, para, i
  logical                                :: isgood = .true.

  ParaRange = GetRange()

  ! ------------------------------------------------------------------
  ! variable values, e.g. time points
  ! ------------------------------------------------------------------
  do i=1,nx
     x(i) = real(i-1,dp) * 1.0_dp + 50.0_dp
  end do

  ! ------------------------------------------------------------------
  ! Generating model outputs for parameter sets A, B, and C(i)
  ! ------------------------------------------------------------------
  seed = 0_i8
  call sobol(int(2*npara,i8), seed, sample_sobol)
  do set = 1,nsets
     ! sobol sequence
     call sobol(int(2*npara,i8), skip, sample_sobol)
     sample_a = sample_sobol(1:npara)
     sample_b = sample_sobol(npara+1:2*npara)
     ! scaling
     sample_a = ParaRange(:,1) + sample_a * (ParaRange(:,2) - ParaRange(:,1))
     sample_b = ParaRange(:,1) + sample_b * (ParaRange(:,2) - ParaRange(:,1))

     ya(set,:) = model(sample_a,x)
     yb(set,:) = model(sample_b,x)

     do para=1,npara
        sample_ci       = sample_b
        sample_ci(para) = sample_a(para)
        yc(set,para,:)  = model(sample_ci,x)
     end do
  end do

  ! ------------------------------------------------------------------
  ! Calculate Sobol index: Main Effect (Si) and Total Effect (STi)
  ! ------------------------------------------------------------------
  call sobol_index(ya, yb, yc, si, sti, method=6, smean=smean, wmean=wmean)

  ! ------------------------------------------------------------------
  ! Printing and checking
  ! ------------------------------------------------------------------
  write(*,'(A40)')         '----------------------------------------'
  write(*,'(A24,F5.1,A8)') '     Sobol index   (x = ',x(3),')       '
  write(*,'(A40)')         '----------------------------------------'
  write(*,'(A40)')         'para  SI         STI                    '
  do para=1,npara
     write(*,'(I4,A2,F7.4,A4,F7.4)') para, '   ', si(para,3),'  ', sti(para,3)
  end do
  write(*,'(A40)') '----------------------------------------'
  write(*,*) ' '

  if (nint(si(1,3)*10000._dp)      .ne.  3226_i4)  isgood = .false.
  if (nint(si(2,3)*10000._dp)      .ne.  1404_i4)  isgood = .false.
  if (nint(si(3,3)*10000._dp)      .ne. -  58_i4)  isgood = .false.
  if (nint(sti(1,3)*10000._dp)     .ne.  7826_i4)  isgood = .false.
  if (nint(sti(2,3)*10000._dp)     .ne.  1490_i4)  isgood = .false.
  if (nint(sti(3,3)*10000._dp)     .ne.  5348_i4)  isgood = .false.

  write(*,'(A40)')         '----------------------------------------'
  write(*,'(A40)')         '     Mean Sobol index                   '
  write(*,'(A40)')         '----------------------------------------'
  write(*,'(A40)')         'para  SI         STI                    '
  do para=1,npara
     write(*,'(I4,A2,F7.4,A4,F7.4)') para, '   ', smean(para,1),'  ', smean(para,2)
  end do
  write(*,'(A40)') '----------------------------------------'
  write(*,*) ' '

  if (nint(smean(1,1)*10000._dp)     .ne.  2417_i4)  isgood = .false.
  if (nint(smean(2,1)*10000._dp)     .ne.  3689_i4)  isgood = .false.
  if (nint(smean(3,1)*10000._dp)     .ne.    13_i4)  isgood = .false.
  if (nint(smean(1,2)*10000._dp)     .ne.  5784_i4)  isgood = .false.
  if (nint(smean(2,2)*10000._dp)     .ne.  3820_i4)  isgood = .false.
  if (nint(smean(3,2)*10000._dp)     .ne.  3980_i4)  isgood = .false.

  write(*,'(A40)')         '----------------------------------------'
  write(*,'(A40)')         '     Var. weighted mean Sobol index     '
  write(*,'(A40)')         '----------------------------------------'
  write(*,'(A40)')         'para  SI         STI                    '
  do para=1,npara
     write(*,'(I4,A2,F7.4,A4,F7.4)') para, '   ', wmean(para,1),'  ', wmean(para,2)
  end do
  write(*,'(A40)') '----------------------------------------'
  write(*,*) ' '

  if (nint(wmean(1,1)*10000._dp)     .ne.  2319_i4)  isgood = .false.
  if (nint(wmean(2,1)*10000._dp)     .ne.  3963_i4)  isgood = .false.
  if (nint(wmean(3,1)*10000._dp)     .ne.    20_i4)  isgood = .false.
  if (nint(wmean(1,2)*10000._dp)     .ne.  5535_i4)  isgood = .false.
  if (nint(wmean(2,2)*10000._dp)     .ne.  4102_i4)  isgood = .false.
  if (nint(wmean(3,2)*10000._dp)     .ne.  3813_i4)  isgood = .false.

  if (isgood) then
     write(*,*) 'mo_sobol_index ', color('o.k.', c_green)
  else
     write(*,*) 'mo_sobol_index ', color('failed', c_red)
  end if

end program sobol_index_test


      SUBROUTINE SB01BX( REIG, N, XR, XI, WR, WI, S, P )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To choose a real eigenvalue or a pair of complex conjugate
C     eigenvalues at "minimal" distance to a given real or complex
C     value.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     REIG    LOGICAL
C             Specifies the type of eigenvalues as follows:
C             = .TRUE.,  a real eigenvalue is to be selected;
C             = .FALSE., a pair of complex eigenvalues is to be
C                        selected.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of eigenvalues contained in the arrays WR
C             and WI.  N >= 1.
C
C     XR,XI   (input) DOUBLE PRECISION
C             If REIG = .TRUE., XR must contain the real value and XI
C             is assumed zero and therefore not referenced.
C             If REIG = .FALSE., XR must contain the real part and XI
C             the imaginary part, respectively, of the complex value.
C
C     WR,WI   (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, if REIG = .TRUE., WR must contain the real
C             eigenvalues from which an eigenvalue at minimal distance
C             to XR is to be selected. In this case, WI is considered
C             zero and therefore not referenced.
C             On entry, if REIG = .FALSE., WR and WI must contain the
C             real and imaginary parts, respectively, of the eigenvalues
C             from which a pair of complex conjugate eigenvalues at
C             minimal "distance" to XR + jXI is to be selected.
C             The eigenvalues of each pair of complex conjugate
C             eigenvalues must appear consecutively.
C             On exit, the elements of these arrays are reordered such
C             that the selected eigenvalue(s) is (are) found in the
C             last element(s) of these arrays.
C
C     S,P     (output) DOUBLE PRECISION
C             If REIG = .TRUE., S (and also P) contains the value of
C             the selected real eigenvalue.
C             If REIG = .FALSE., S and P contain the sum and product,
C             respectively, of the selected complex conjugate pair of
C             eigenvalues.
C
C     FURTHER COMMENTS
C
C     For efficiency reasons, |x| + |y| is used for a complex number
C     x + jy, instead of its modulus.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     February 1999. Based on the RASP routine PMDIST.
C
C     REVISIONS
C
C     March 30, 1999, V. Sima, Research Institute for Informatics,
C     Bucharest.
C     Feb. 15, 2004, V. Sima, Research Institute for Informatics,
C     Bucharest.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      LOGICAL          REIG
      INTEGER          N
      DOUBLE PRECISION P, S, XI ,XR
C     .. Array Arguments ..
      DOUBLE PRECISION WI(*), WR(*)
C     .. Local Scalars ..
      INTEGER          I, J, K
      DOUBLE PRECISION X, Y
C     .. Intrinsic Functions ..
      INTRINSIC        ABS
C     .. Executable Statements ..
C
      J = 1
      IF( REIG ) THEN
         Y = ABS( WR(1)-XR )
         DO 10 I = 2, N
            X = ABS( WR(I)-XR )
            IF( X .LT. Y ) THEN
               Y = X
               J = I
            END IF
   10    CONTINUE
         S = WR(J)
         K = N - J
         IF( K .GT. 0 ) THEN
            DO 20 I = J, J + K - 1
               WR(I) = WR(I+1)
   20       CONTINUE
            WR(N) = S
         END IF
         P = S
      ELSE
         Y = ABS( WR(1)-XR ) + ABS( WI(1)-XI )
         DO 30 I = 3, N, 2
            X = ABS( WR(I)-XR ) + ABS( WI(I)-XI )
            IF( X .LT. Y ) THEN
               Y = X
               J = I
            END IF
   30    CONTINUE
         X = WR(J)
         Y = WI(J)
         K = N - J - 1
         IF( K .GT. 0 ) THEN
            DO 40 I = J, J + K - 1
               WR(I) = WR(I+2)
               WI(I) = WI(I+2)
   40       CONTINUE
            WR(N-1) = X
            WI(N-1) = Y
            WR(N) = X
            WI(N) = -Y
         END IF
         S = X + X
         P = X * X + Y * Y
      END IF
C
      RETURN
C *** End of SB01BX ***
      END


	SUBROUTINE VC_PONZ  ( z, zt, zb, tt, tb, rlnpt, rlnpb,
     +			      nxy, p, iret )
C************************************************************************
C* VC_PONZ								*
C*									*
C* This subroutine computes pressure on a height surface given		*
C* pressure, temperature and height on bounding surfaces.		*
C*									*
C* VC_PONZ ( Z, ZT, ZB, TT, TB, RLNPT, RLNPB, NXY, P, IRET )		*
C*									*
C* Input parameters:							*
C*	Z		REAL		Height coordinate value		*
C*	ZT(*)		REAL		Top height			*
C*	ZB(*)		REAL		Bottom height			*
C*	TT(*)		REAL		Top temperature			*
C*	TB(*)		REAL		Bottom temperature		*
C*	RLNPT(*)	REAL		Top ln (p)			*
C*	RLNPB(*)	REAL		Bottom ln (p)			*
C*	NXY		INTEGER		Number of points		*
C*									*
C* Output parameters:							*
C*	P    (NXY)	REAL		Output pressure values		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 +1 = all missing		*
C**									*
C* Log:									*
C* K. Brill/NMC      07/92						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	REAL		zt (*), zb (*), tt (*), tb (*), rlnpt (*),
     +			rlnpb (*), p (*)
C*
	PARAMETER	( govr = 2. * GRAVTY / RDGAS )
	LOGICAL		betwen
C*
	INCLUDE		'ERMISS.FNC'
C*
	BETWEN ( rlev, rlo, rhi ) =
     +     ( ( rlev .ge. rlo .and. rlev .le. rhi )   .or.
     +       ( rlev .le. rlo .and. rlev .ge. rhi ) )
C-----------------------------------------------------------------------
	iret = 0
C*
	icnt = 0
	DO i = 1, nxy
	    IF ( .not. BETWEN ( z, zb (i), zt (i) ) .or.
     +		 ERMISS ( zt   (i) ) .or. ERMISS ( zb   (i) ) .or.
     +		 ERMISS ( tt    (i) ) .or. ERMISS ( tb    (i) ) .or.
     +		 ERMISS ( rlnpt (i) ) .or. ERMISS ( rlnpb (i) ) .or.
     +		 ( zb (i) .gt. zt (i) ) .or.
     +		 ( rlnpt (i) .eq. rlnpb (i) ) ) THEN
		p (i) = RMISSD
		icnt = icnt + 1
	    ELSE
		gama = ( tt (i) - tb (i) ) / ( rlnpt (i) - rlnpb (i) )
		dzt = zt (i) - z
		IF ( gama .eq. 0.0 ) THEN
		    pln = rlnpt (i) + .5 * govr * dzt / tt (i)
		ELSE
		    sq = tt (i) * tt (i) + govr * gama * dzt
		    sq = ( SQRT ( sq ) - tt (i) ) / gama
		    pln = rlnpt (i) + sq
		END IF
		p (i) = EXP ( pln )
	    END IF
	END DO
C*
	IF ( icnt .eq. nxy ) iret = +1
C*
	RETURN
	END


! { dg-do run }
! { dg-options "-ffrontend-optimize -fdump-tree-original" }
! PR 57071 - Check that 2**k is transformed into ishift(1,k).
program main
  implicit none
  integer :: i,m,v
  integer, parameter :: n=30
  integer, dimension(-n:n) :: a,b,c,d,e
  m = n

  v = 2
  ! Test scalar expressions.
  do i=-n,n
     if (2**i /= v**i) STOP 1
  end do

  ! Test array constructors
  b = [(2**i,i=-m,m)]
  c = [(v**i,i=-m,m)]
  if (any(b /= c)) STOP 2

  ! Test array expressions
  a = [(i,i=-m,m)]
  d = 2**a
  e = v**a
  if (any(d /= e)) STOP 3
end program main
! { dg-final { scan-tree-dump-times "_gfortran_pow_i4_i4" 3 "original" } }


! demo rotating a 2-D array 90 degrees clockwise
use rotflip, only: rot90, flipud, fliplr

implicit none

integer, parameter :: N=3
integer :: i, iarr(N,N),  Barr(0:2, 0:2)
real :: rarr(N,N)

iarr = reshape( &
  [0, 1, 2, &
   3, 4, 5, &
   6, 7, 8], &
   shape(iarr), order=[2,1])

rarr = iarr

call printarr(iarr,'before rot90')

call rot90(iarr, 0)
call printarr(iarr, 'rot90(0)')

call rot90(iarr, 1)
call printarr(iarr, 'rot90(1)')
call rot90(iarr, -1)

call rot90(iarr, 2)
call printarr(iarr, 'rot90(2)')
call rot90(iarr, -2)

call rot90(iarr, 3)
call printarr(iarr, 'rot90(3)')
call rot90(iarr, -3)

call flipud(iarr)
call printarr(iarr, 'flipud()')
call flipud(iarr)

call fliplr(iarr)
call printarr(iarr, 'fliplr()')
call fliplr(iarr)

! -- test non-default bounds
Barr = iarr
if (lbound(Barr,1) /= 0) error stop 'lbound should be 0'

call rot90(Barr)
if (lbound(Barr,1) /= 0) error stop 'lbound should be 0'

! -- Fortran polymorphic type
rarr = iarr
call rot90(rarr)

contains

subroutine printarr(arr, msg)

integer, intent(in) :: arr(:,:)
character(*), intent(in), optional :: msg
character(5) :: frmt

write(frmt,'(A1,I1,A3)') '(',size(arr,1),'I1)'

if(present(msg)) print *,msg
do i = 1, size(arr,1)
  print frmt, arr(i,:)
enddo

end subroutine printarr
end program