c
c Last update: Oct 30, 2007
c
c Added check that EW resonances are color singlet when decaying hadronically
c
************************************************************************
* SUBROUTINE store_LH_information                                      *
*                                                                      *
* Purpose: store information in Les Houches Event File (LHEF) format   *
************************************************************************

      subroutine store_LH_information(iphsp,idp0,idp0_inout,xm,pcoll,
     &     iordamp,ichargeconj,PDFscale)

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

      include 'common.h'
      include 'common_subproc.h'

      integer maxNmothers,maxNparticles
      parameter (maxNmothers=4) ! up to 4 intermediate particles
      parameter (maxNparticles=12)

      integer idp0(8),idp0_inout(8),iordamp(8),index_pythia(8),
     &     ichargeconj,i_mother,isconsistent,ichain,iskip,
     &     i,k,mu,i_outgoing,icolorline,iaux,i_odd,
     &     ismother,index,NUP_aux,IDUP_aux(maxNparticles),
     &     ISTUP_aux(maxNparticles),MOTHUP_aux(2,maxNparticles),
     &     ICOLUP_aux(2,maxNparticles),iord_daughters_LH(6),
     &     itemp(8)

      real *8 xm(8),pcoll(0:3,8),PDFscale,
     &     PUP_aux(5,maxNparticles),VTIMUP_aux(maxNparticles),
     &     SPINUP_aux(maxNparticles)

* Parameters of phase-space multimapping
      COMMON/phspinput_proc/
     &  rm0a(mxnphs),gam0a(mxnphs),spm0alo(mxnphs),spm0ahi(mxnphs),
     &  rm0b(mxnphs),gam0b(mxnphs),spm0blo(mxnphs),spm0bhi(mxnphs),
     &  rm1(mxnphs),gam1(mxnphs),spm1lo(mxnphs),spm1hi(mxnphs),
     &  rm1a(mxnphs),gam1a(mxnphs),spm1alo(mxnphs),spm1ahi(mxnphs),
     &  rm1b(mxnphs),gam1b(mxnphs),spm1blo(mxnphs),spm1bhi(mxnphs),
     &  rm11(mxnphs),gam11(mxnphs),spm11lo(mxnphs),spm11hi(mxnphs),
     &  rm11a(mxnphs),gam11a(mxnphs),spm11alo(mxnphs),spm11ahi(mxnphs),
     &  rm11b(mxnphs),gam11b(mxnphs),spm11blo(mxnphs),spm11bhi(mxnphs),
     &  rm11c(mxnphs),gam11c(mxnphs),spm11clo(mxnphs),spm11chi(mxnphs),
     &  rm12a(mxnphs),gam12a(mxnphs),spm12alo(mxnphs),spm12ahi(mxnphs),
     &  rm12b(mxnphs),gam12b(mxnphs),spm12blo(mxnphs),spm12bhi(mxnphs),
     &  rm12c(mxnphs),gam12c(mxnphs),spm12clo(mxnphs),spm12chi(mxnphs),
     &  rm2(mxnphs),gam2(mxnphs),spm2lo(mxnphs),spm2hi(mxnphs),
     &  rm2a(mxnphs),gam2a(mxnphs),spm2alo(mxnphs),spm2ahi(mxnphs),
     &  rm2b(mxnphs),gam2b(mxnphs),spm2blo(mxnphs),spm2bhi(mxnphs),
     &  rm2c(mxnphs),gam2c(mxnphs),spm2clo(mxnphs),spm2chi(mxnphs),
     &  rm21a(mxnphs),gam21a(mxnphs),spm21alo(mxnphs),spm21ahi(mxnphs),
     &  rm21b(mxnphs),gam21b(mxnphs),spm21blo(mxnphs),spm21bhi(mxnphs),
     &  rm111(mxnphs),gam111(mxnphs),spm111lo(mxnphs),spm111hi(mxnphs),
     &  rm111a(mxnphs),gam111a(mxnphs),spm111alo(mxnphs),
     &     spm111ahi(mxnphs),
     &  rm111b(mxnphs),gam111b(mxnphs),spm111blo(mxnphs),
     &     spm111bhi(mxnphs),
     &  rm1111(mxnphs),gam1111(mxnphs),spm1111lo(mxnphs),
     &     spm1111hi(mxnphs),
     &  rmta(mxnphs),expa(mxnphs),spta,rmtb(mxnphs),expb(mxnphs),sptb

      parameter (maxnresonant=4)
      COMMON/iphsp_fxn/isresonant(maxnresonant),imapregion(maxnresonant)

* Les Houches User Process Event common block
      integer MAXNUP
      parameter (MAXNUP=500)
      integer NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
      real*8 XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
      common/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
     &   ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
     &   VTIMUP(MAXNUP),SPINUP(MAXNUP)

* Store information in Les Houches format (LHEF).
* Incoming particles are expected in the first two positions.

c At most 4 intermediate resonances are possible
      NUP_aux=maxNparticles

c Initialize to zero LHEF commons
      DO i=1,NUP_aux
         IDUP_aux(i)=0
         ISTUP_aux(i)=0
         DO mu=1,5
            PUP_aux(mu,i)=0.d0
         ENDDO
         DO k=1,2
            MOTHUP_aux(k,i)=0
            ICOLUP_aux(k,i)=0
         ENDDO
         VTIMUP_aux(i)=0.d0
         SPINUP_aux(i)=0.d0
      ENDDO

c The LHEF list of final-state particles is intended to begin with
c (possible) mothers.
c First, assign Les Houches commons to EXTERNAL final-state particles.
c LH information about mothers will be reconstructed by their daughters.

      i_outgoing = 3 + maxNmothers
      DO i=1,8
         IF(idp0_inout(i).EQ.-1)THEN
            IF(pcoll(3,i).GT.0.d0)THEN
               index_pythia(i)=1
            ELSE
               index_pythia(i)=2
            ENDIF
         ELSE
            index_pythia(i)=i_outgoing
            i_outgoing=i_outgoing+1
         ENDIF
      ENDDO

c Assign colour flow to all external particles
      icolorline=500

c     all momenta outgoing, fermionic flow from right to left
c     q ----<-(g,gg)----q~
c     start from the quark, moving against fermionic flow
      i_odd=1

      DO i=1,8
         IF(idp0(i).LE.16)THEN
            IDUP_aux(index_pythia(i))=idp0(i)*idp0_inout(i)
         ELSE
            IDUP_aux(index_pythia(i))=idp0(i)
         ENDIF
         ISTUP_aux(index_pythia(i))=idp0_inout(i)
         DO j=1,3
            PUP_aux(j,index_pythia(i))=pcoll(j,i)
         ENDDO
         PUP_aux(4,index_pythia(i))=pcoll(0,i)
c Ezio 16/06/2018
c         PUP_aux(5,index_pythia(i))=xm(i)
         PUP_aux(5,index_pythia(i))=rmass(IDUP_aux(index_pythia(i)))

         IF(abs(idp0(i)).le.5)THEN ! quark or antiquark

            IF(i_odd.EQ.1)THEN  ! quark, if outgoing
               icolorline=icolorline+1
               IF(idp0_inout(i).EQ.1)THEN ! = (q)-
                  ICOLUP_aux(1,index_pythia(i))=icolorline
                  ICOLUP_aux(2,index_pythia(i))=0
               ELSE             ! = (q~)-
                  ICOLUP_aux(1,index_pythia(i))=0
                  ICOLUP_aux(2,index_pythia(i))=icolorline
               ENDIF
               i_odd=0          !next fermion will be an antiquark

            ELSE                ! antiquark, if outgoing
               IF(idp0_inout(i).EQ.1)THEN ! = -(q~)
                  ICOLUP_aux(1,index_pythia(i))=0
                  ICOLUP_aux(2,index_pythia(i))=icolorline
               ELSE             ! = -(q)
                  ICOLUP_aux(1,index_pythia(i))=icolorline
                  ICOLUP_aux(2,index_pythia(i))=0
               ENDIF
               i_odd=1          !next fermion will be a quark
            ENDIF

         ELSEIF(idp0(i).EQ.21)THEN ! gluon = -(q~)|(q)- if outgoing

            IF(idp0_inout(i).EQ.1)THEN ! = -(q~)|(q)-
               ICOLUP_aux(2,index_pythia(i))=icolorline
               icolorline=icolorline+1
               ICOLUP_aux(1,index_pythia(i))=icolorline
            ELSE                ! = -(q)|(q~)-
               ICOLUP_aux(1,index_pythia(i))=icolorline
               icolorline=icolorline+1
               ICOLUP_aux(2,index_pythia(i))=icolorline
            ENDIF

         ELSE                   ! lepton
            ICOLUP_aux(1,index_pythia(i))=0
            ICOLUP_aux(2,index_pythia(i))=0
         ENDIF
      ENDDO

      IF (ichargeconj.eq.1) THEN
         DO i=1,8
            iaux=ICOLUP_aux(1,index_pythia(i))
            ICOLUP_aux(1,index_pythia(i))=ICOLUP_aux(2,index_pythia(i))
            ICOLUP_aux(2,index_pythia(i))=iaux
         ENDDO
      ENDIF

c Start by assigning the relationship of all external particles to the
c initial state (i.e. 1,2 as mothers). This relationship will be
c eventually updated later on if intermediate resonances (mothers) are
c found.
      DO k=1,2
c incoming particles have no mother
         MOTHUP_aux(1,k)=0
         MOTHUP_aux(2,k)=0
      ENDDO
      DO k=3+maxNmothers,NUP_aux
         MOTHUP_aux(1,k)=1
         MOTHUP_aux(2,k)=2
      ENDDO

      DO k=3+maxNmothers,NUP_aux
         SPINUP_aux(k)=9.d0
         VTIMUP_aux(k)=0.d0
      ENDDO

* Complete Les Houches commons
      SCALUP=PDFscale
      AQEDUP=1.d0/alfainv
      AQCDUP=alfa_s
      IDPRUP=661
      XWGTUP=1.d0

      if(iwrite_mothers.eq.1)then

* Now look for possible intermediate particles (interpreted as
* resonances in multiparticle invariant mass). The identification
* procedure is stricly dependent on the phase-space routine called.

      i_mother=2
      ichain=1
      iskip=0
      isconsistent=1

      DO i=1,8
        itemp(i)=index_pythia(iordamp(iorder(i,iphs_ind)))
      ENDDO

      if(iphsp.eq.1)then        ! phsp1_1_4

        igranmoth1=1
        igranmoth2=2
        if(isresonant(1).eq.1)then ! rm1[a,b]
          i_mother=i_mother+1
          ndaughters=4
          iord_daughters_LH(1)=itemp(3)
          iord_daughters_LH(2)=itemp(4)
          iord_daughters_LH(3)=itemp(5)
          iord_daughters_LH(4)=itemp(6)
          if(imapregion(1).eq.2)then
              rmass_mapping=rm1a(iphs_ind)
          elseif(imapregion(1).eq.4)then
              rmass_mapping=rm1b(iphs_ind)
          endif

          call add_LH_mother2(ndaughters,iord_daughters_LH,
     &          rmass_mapping,i_mother,igranmoth1,igranmoth2,
     &          IDUP_aux,ISTUP_aux,
     &          MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &          isconsistent)

          igranmoth1=i_mother
          igranmoth2=i_mother
        endif

c Check if colorflow is consistent with presence of a resonance
      issinglet=1
      IF(abs(IDUP_aux(itemp(3))).le.5)THEN ! quark or antiquark

      IF(IDUP_aux(itemp(3)).GT.0)THEN
       ico1=ICOLUP_aux(1,itemp(3))
      ELSE
       ico1=ICOLUP_aux(2,itemp(3))
      ENDIF

      IF(IDUP_aux(itemp(4)).GT.0)THEN
       ico2=ICOLUP_aux(1,itemp(4))
      ELSE
       ico2=ICOLUP_aux(2,itemp(4))
      ENDIF

      IF(ico1.NE.ico2) issinglet=0

      ENDIF

         if(isresonant(3).eq.1 .AND. issinglet.EQ.1)then ! rm11[a,b,c]
            i_mother=i_mother+1
            ndaughters=2
            iord_daughters_LH(1)=itemp(3)
            iord_daughters_LH(2)=itemp(4)
            if(imapregion(3).eq.2)then
               rmass_mapping=rm11a(iphs_ind)
            elseif(imapregion(3).eq.4)then
               rmass_mapping=rm11b(iphs_ind)
            elseif(imapregion(3).eq.6)then
               rmass_mapping=rm11c(iphs_ind)
            endif

            call add_LH_mother2(ndaughters,iord_daughters_LH,
     &           rmass_mapping,i_mother,igranmoth1,igranmoth2,
     &           IDUP_aux,ISTUP_aux,
     &           MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &           isconsistent)
         endif

c Check if colorflow is consistent with presence of a resonance
      issinglet=1
      IF(abs(IDUP_aux(itemp(5))).le.5)THEN ! quark or antiquark

      IF(IDUP_aux(itemp(5)).GT.0)THEN
       ico1=ICOLUP_aux(1,itemp(5))
      ELSE
       ico1=ICOLUP_aux(2,itemp(5))
      ENDIF

      IF(IDUP_aux(itemp(6)).GT.0)THEN
       ico2=ICOLUP_aux(1,itemp(6))
      ELSE
       ico2=ICOLUP_aux(2,itemp(6))
      ENDIF

      IF(ico1.NE.ico2) issinglet=0

      ENDIF

         if(isresonant(4).eq.1 .AND. issinglet.EQ.1)then ! rm12[a,b,c]
            i_mother=i_mother+1
            ndaughters=2
            iord_daughters_LH(1)=itemp(5)
            iord_daughters_LH(2)=itemp(6)
            if(imapregion(4).eq.2)then
               rmass_mapping=rm12a(iphs_ind)
            elseif(imapregion(4).eq.4)then
               rmass_mapping=rm12b(iphs_ind)
            elseif(imapregion(4).eq.6)then
               rmass_mapping=rm12c(iphs_ind)
            endif

            call add_LH_mother2(ndaughters,iord_daughters_LH,
     &           rmass_mapping,i_mother,igranmoth1,igranmoth2,
     &           IDUP_aux,ISTUP_aux,
     &           MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &           isconsistent)
         endif

      elseif(iphsp.eq.2)then    ! phsp2_4

c      write(23,'(A12,4(4I,1X),A13,4I)') 'isresonant: ',
c     &              (isresonant(k),k=1,4),'  iphs_ind : ',iphs_ind
cccc      Write(23,'(A9,8(I4,1X))')'iorder  :',(iorder(k,iphs_ind),k=1,8)
        igranmoth1=1
        igranmoth2=2
        if(isresonant(1).eq.1)then ! rm1
          i_mother=i_mother+1
          ndaughters=4
          iord_daughters_LH(1)=itemp(3)
          iord_daughters_LH(2)=itemp(4)
          iord_daughters_LH(3)=itemp(5)
          iord_daughters_LH(4)=itemp(6)
          if(imapregion(1).eq.2)then
             rmass_mapping=rm1a(iphs_ind)
          elseif(imapregion(1).eq.4)then
             rmass_mapping=rm1b(iphs_ind)
          endif

          call add_LH_mother2(ndaughters,iord_daughters_LH,
     &          rmass_mapping,i_mother,igranmoth1,igranmoth2,
     &          IDUP_aux,ISTUP_aux,
     &          MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &          isconsistent)

          igranmoth1=i_mother
          igranmoth2=i_mother
         endif

c Check if colorflow is consistent with presence of a resonance
      issinglet=1
      IF(abs(IDUP_aux(itemp(3))).le.5)THEN ! quark or antiquark

      IF(IDUP_aux(itemp(3)).GT.0)THEN
       ico1=ICOLUP_aux(1,itemp(3))
      ELSE
       ico1=ICOLUP_aux(2,itemp(3))
      ENDIF

      IF(IDUP_aux(itemp(4)).GT.0)THEN
       ico2=ICOLUP_aux(1,itemp(4))
      ELSE
       ico2=ICOLUP_aux(2,itemp(4))
      ENDIF

      IF(ico1.NE.ico2) issinglet=0

      ENDIF

         if(isresonant(3).eq.1 .AND. issinglet.EQ.1)then ! rm11[a,b,c]
            i_mother=i_mother+1
            ndaughters=2
            iord_daughters_LH(1)=itemp(3)
            iord_daughters_LH(2)=itemp(4)
            if(imapregion(3).eq.2)then
               rmass_mapping=rm11a(iphs_ind)
            elseif(imapregion(3).eq.4)then
               rmass_mapping=rm11b(iphs_ind)
            elseif(imapregion(3).eq.6)then
               rmass_mapping=rm11c(iphs_ind)
            endif

            call add_LH_mother2(ndaughters,iord_daughters_LH,
     &          rmass_mapping,i_mother,igranmoth1,igranmoth2,
     &          IDUP_aux,ISTUP_aux,
     &          MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &          isconsistent)
          endif

c Check if colorflow is consistent with presence of a resonance
      issinglet=1
      IF(abs(IDUP_aux(itemp(5))).le.5)THEN ! quark or antiquark

      IF(IDUP_aux(itemp(5)).GT.0)THEN
       ico1=ICOLUP_aux(1,itemp(5))
      ELSE
       ico1=ICOLUP_aux(2,itemp(5))
      ENDIF

      IF(IDUP_aux(itemp(6)).GT.0)THEN
       ico2=ICOLUP_aux(1,itemp(6))
      ELSE
       ico2=ICOLUP_aux(2,itemp(6))
      ENDIF

      IF(ico1.NE.ico2) issinglet=0

      ENDIF

         if(isresonant(4).eq.1 .AND. issinglet.EQ.1)then ! rm12[a,b]
            i_mother=i_mother+1
            ndaughters=2
            iord_daughters_LH(1)=itemp(5)
            iord_daughters_LH(2)=itemp(6)
            if(imapregion(4).eq.2)then
               rmass_mapping=rm12a(iphs_ind)
            elseif(imapregion(4).eq.4)then
               rmass_mapping=rm12b(iphs_ind)
            elseif(imapregion(4).eq.6)then
               rmass_mapping=rm12c(iphs_ind)
            endif

            call add_LH_mother2(ndaughters,iord_daughters_LH,
     &          rmass_mapping,i_mother,igranmoth1,igranmoth2,
     &          IDUP_aux,ISTUP_aux,
     &          MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &          isconsistent)
          endif

c Check if colorflow is consistent with presence of a resonance
      issinglet=1
      IF(abs(IDUP_aux(itemp(7))).le.5)THEN ! quark or antiquark

      IF(IDUP_aux(itemp(7)).GT.0)THEN
       ico1=ICOLUP_aux(1,itemp(7))
      ELSE
       ico1=ICOLUP_aux(2,itemp(7))
      ENDIF

      IF(IDUP_aux(itemp(8)).GT.0)THEN
       ico2=ICOLUP_aux(1,itemp(8))
      ELSE
       ico2=ICOLUP_aux(2,itemp(8))
      ENDIF

      IF(ico1.NE.ico2) issinglet=0

      ENDIF

         if(isresonant(2).eq.1 .AND. issinglet.EQ.1)then ! rm2[a,b,c]
            i_mother=i_mother+1
            ndaughters=2
            iord_daughters_LH(1)=itemp(7)
            iord_daughters_LH(2)=itemp(8)
            if(imapregion(2).eq.2)then
               rmass_mapping=rm2a(iphs_ind)
            elseif(imapregion(2).eq.4)then
               rmass_mapping=rm2b(iphs_ind)
            elseif(imapregion(2).eq.6)then
               rmass_mapping=rm2c(iphs_ind)
            endif

            call add_LH_mother(ndaughters,iord_daughters_LH,
     &           rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &           MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &           isconsistent)
         endif

      elseif(iphsp.eq.3)then    ! phsp1_1_31

c Check if colorflow is consistent with presence of a resonance
      issinglet=1
      IF(abs(IDUP_aux(itemp(3))).le.5)THEN ! quark or antiquark

      IF(IDUP_aux(itemp(3)).GT.0)THEN
       ico1=ICOLUP_aux(1,itemp(3))
      ELSE
       ico1=ICOLUP_aux(2,itemp(3))
      ENDIF

      IF(IDUP_aux(itemp(4)).GT.0)THEN
       ico2=ICOLUP_aux(1,itemp(4))
      ELSE
       ico2=ICOLUP_aux(2,itemp(4))
      ENDIF

      IF(ico1.NE.ico2) issinglet=0

      ENDIF

         if(isresonant(3).eq.1 .AND. issinglet.EQ.1)then ! rm111[a,b]
            i_mother=i_mother+1
            ndaughters=2
            iord_daughters_LH(1) = itemp(3)
            iord_daughters_LH(2) = itemp(4)
            if(imapregion(3).eq.2)then
               rmass_mapping=rm111a(iphs_ind)
            elseif(imapregion(3).eq.4)then
               rmass_mapping=rm111b(iphs_ind)
            endif

            call add_LH_mother(ndaughters,iord_daughters_LH,
     &           rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &           MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &           isconsistent)
         endif

c Avoid double counting of intermediate particles due to possible
c multiple resonances in presence of gluons (e.g. both {q-qbar} and
c {q-qbar-g} resonant in the W/Z range)
         if(rm111a(iphs_ind).eq.rm11a(iphs_ind) .and.
     &        rm111b(iphs_ind).eq.rm11b(iphs_ind))then
           ichain=ichain+1
         else
           ichain=1
           iskip=0
         endif
         if(ichain.gt.1 .and.
     &        (isresonant(3).eq.1 .and. isconsistent.eq.1))then
           iskip=1
         endif
c giuseppe 08/09/2007
         if(isresonant(3).ne.1 .or. isconsistent.eq.0)then
           iskip=1
         endif
c end giuseppe 08/09/2007

         if(isresonant(2).eq.1)then ! rm11[a,b]
           i_mother=i_mother+1
           if(iskip.eq.0)then
             ndaughters=3
             iord_daughters_LH(1) =  itemp(3)
             iord_daughters_LH(2) =  itemp(4)
             iord_daughters_LH(3) =  itemp(5)
             if(imapregion(2).eq.2)then
               rmass_mapping=rm11a(iphs_ind)
             elseif(imapregion(2).eq.4)then
               rmass_mapping=rm11b(iphs_ind)
             endif

             call add_LH_mother(ndaughters,iord_daughters_LH,
     &            rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &            MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &            isconsistent)
           endif
         endif

c Avoid double counting of intermediate particles due to possible
c multiple resonances in presence of gluons
         if(rm11a(iphs_ind).eq.rm1a(iphs_ind) .and.
     &        rm11b(iphs_ind).eq.rm1b(iphs_ind))then
           ichain=ichain+1
         else
           ichain=1
c giuseppe 08/09/2007
c            iskip=0
c end giuseppe 08/09/2007
         endif
         if(ichain.gt.1 .and. (iskip.eq.1 .or.
     &        (isresonant(2).eq.1 .and. isconsistent.eq.1)))then
           iskip=1
         endif

         if(isresonant(1).eq.1)then ! rm1[a,b]
           i_mother=i_mother+1
           if(iskip.eq.0)then
             ndaughters=4
             iord_daughters_LH(1) =  itemp(3)
             iord_daughters_LH(2) =  itemp(4)
             iord_daughters_LH(3) =  itemp(5)
             iord_daughters_LH(4) =  itemp(6)
             if(imapregion(1).eq.2)then
               rmass_mapping=rm1a(iphs_ind)
             elseif(imapregion(1).eq.4)then
               rmass_mapping=rm1b(iphs_ind)
             endif

             call add_LH_mother(ndaughters,iord_daughters_LH,
     &            rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &            MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &            isconsistent)
           endif
         endif

      elseif(iphsp.eq.4)then    ! phsp1_2_3

c Check if colorflow is consistent with presence of a resonance
      issinglet=1
      IF(abs(IDUP_aux(itemp(3))).le.5)THEN ! quark or antiquark

      IF(IDUP_aux(itemp(3)).GT.0)THEN
       ico1=ICOLUP_aux(1,itemp(3))
      ELSE
       ico1=ICOLUP_aux(2,itemp(3))
      ENDIF

      IF(IDUP_aux(itemp(4)).GT.0)THEN
       ico2=ICOLUP_aux(1,itemp(4))
      ELSE
       ico2=ICOLUP_aux(2,itemp(4))
      ENDIF

      IF(ico1.NE.ico2) issinglet=0

      ENDIF

         if(isresonant(4).eq.1 .AND. issinglet.EQ.1)then ! rm11[a,b]
            i_mother=i_mother+1
            ndaughters=2
            iord_daughters_LH(1) = itemp(3)
            iord_daughters_LH(2) = itemp(4)
           if(imapregion(4).eq.2)then
               rmass_mapping=rm11a(iphs_ind)
            elseif(imapregion(4).eq.4)then
               rmass_mapping=rm11b(iphs_ind)
            endif

            call add_LH_mother(ndaughters,iord_daughters_LH,
     &           rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &           MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &           isconsistent)
         endif

c Avoid double counting of intermediate particles due to possible
c multiple resonances in presence of gluons
         if(rm11a(iphs_ind).eq.rm1a(iphs_ind) .and.
     &        rm11b(iphs_ind).eq.rm1b(iphs_ind))then
            ichain=ichain+1
         else
            ichain=1
            iskip=0
         endif
         if(ichain.gt.1 .and.
     &        (isresonant(4).eq.1 .and. isconsistent.eq.1))then
            iskip=1
         endif
c giuseppe 08/09/2007
         if(isresonant(4).ne.1 .or. isconsistent.eq.0)then
           iskip=1
         endif
c end giuseppe 08/09/2007

         if(isresonant(2).eq.1)then ! rm1[a,b]
            i_mother=i_mother+1
            if(iskip.eq.0)then
               ndaughters=3
               iord_daughters_LH(1) = itemp(3)
               iord_daughters_LH(2) = itemp(4)
               iord_daughters_LH(3) = itemp(5)
               if(imapregion(2).eq.2)then
                  rmass_mapping=rm1a(iphs_ind)
               elseif(imapregion(2).eq.4)then
                  rmass_mapping=rm1b(iphs_ind)
               endif

               call add_LH_mother(ndaughters,iord_daughters_LH,
     &              rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &              MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &              isconsistent)
            endif
         endif

c Check if colorflow is consistent with presence of a resonance
      issinglet=1
      IF(abs(IDUP_aux(itemp(7))).le.5)THEN ! quark or antiquark

      IF(IDUP_aux(itemp(7)).GT.0)THEN
       ico1=ICOLUP_aux(1,itemp(7))
      ELSE
       ico1=ICOLUP_aux(2,itemp(7))
      ENDIF

      IF(IDUP_aux(itemp(6)).GT.0)THEN
       ico2=ICOLUP_aux(1,itemp(6))
      ELSE
       ico2=ICOLUP_aux(2,itemp(6))
      ENDIF

      IF(ico1.NE.ico2) issinglet=0

      ENDIF

         if(isresonant(3).eq.1 .AND. issinglet.EQ.1)then ! rm2[a,b]
            i_mother=i_mother+1
            ndaughters=2
            iord_daughters_LH(1) = itemp(6)
            iord_daughters_LH(2) = itemp(7)
           if(imapregion(3).eq.2)then
               rmass_mapping=rm2a(iphs_ind)
            elseif(imapregion(3).eq.4)then
               rmass_mapping=rm2b(iphs_ind)
            endif

            call add_LH_mother(ndaughters,iord_daughters_LH,
     &           rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &           MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &           isconsistent)
         endif

c giuseppe 08/09/2007
         if(isresonant(3).ne.1 .or. isconsistent.eq.0)then
           iskip=1
         endif
c end giuseppe 08/09/2007

         if(isresonant(1).eq.1)then ! rm0[a,b]
           i_mother=i_mother+1
c giuseppe 08/09/2007
           if(iskip.eq.0)then
c end giuseppe 08/09/2007
             ndaughters=5
             iord_daughters_LH(1) = itemp(3)
             iord_daughters_LH(2) = itemp(4)
             iord_daughters_LH(3) = itemp(5)
             iord_daughters_LH(4) = itemp(6)
             iord_daughters_LH(5) = itemp(7)
             if(imapregion(1).eq.2)then
               rmass_mapping=rm0a(iphs_ind)
             elseif(imapregion(1).eq.4)then
               rmass_mapping=rm0b(iphs_ind)
             endif

             call add_LH_mother(ndaughters,iord_daughters_LH,
     &            rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &            MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &            isconsistent)
c giuseppe 08/09/2007
           endif
c end giuseppe 08/09/2007
         endif

      elseif(iphsp.eq.5)then    ! phsp3_3

c Check if colorflow is consistent with presence of a resonance
      issinglet=1
      IF(abs(IDUP_aux(itemp(3))).le.5)THEN ! quark or antiquark

      IF(IDUP_aux(itemp(3)).GT.0)THEN
       ico1=ICOLUP_aux(1,itemp(3))
      ELSE
       ico1=ICOLUP_aux(2,itemp(3))
      ENDIF

      IF(IDUP_aux(itemp(4)).GT.0)THEN
       ico2=ICOLUP_aux(1,itemp(4))
      ELSE
       ico2=ICOLUP_aux(2,itemp(4))
      ENDIF

      IF(ico1.NE.ico2) issinglet=0

      ENDIF

         if(isresonant(3).eq.1 .AND. issinglet.EQ.1)then ! rm11[a,b]
            i_mother=i_mother+1
            ndaughters=2
            iord_daughters_LH(1) = itemp(3)
            iord_daughters_LH(2) = itemp(4)
            if(imapregion(3).eq.2)then
               rmass_mapping=rm11a(iphs_ind)
            elseif(imapregion(3).eq.4)then
               rmass_mapping=rm11b(iphs_ind)
            endif

            call add_LH_mother(ndaughters,iord_daughters_LH,
     &           rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &           MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &           isconsistent)
         endif

c Avoid double counting of intermediate particles due to possible
c multiple resonances in presence of gluons
         if(rm11a(iphs_ind).eq.rm1a(iphs_ind) .and.
     &        rm11b(iphs_ind).eq.rm1b(iphs_ind))then
           ichain=ichain+1
         else
           ichain=1
           iskip=0
         endif
         if(ichain.gt.1 .and.
     &        (isresonant(3).eq.1 .and. isconsistent.eq.1))then
           iskip=1
         endif
c giuseppe 08/09/2007
         if(isresonant(3).ne.1 .or. isconsistent.eq.0)then
           iskip=1
         endif
c end giuseppe 08/09/2007

         if(isresonant(1).eq.1)then ! rm1[a,b]
           i_mother=i_mother+1
           if(iskip.eq.0)then
             ndaughters=3
             iord_daughters_LH(1) = itemp(3)
             iord_daughters_LH(2) = itemp(4)
             iord_daughters_LH(3) = itemp(7)
             if(imapregion(1).eq.2)then
               rmass_mapping=rm1a(iphs_ind)
             elseif(imapregion(1).eq.4)then
               rmass_mapping=rm1b(iphs_ind)
             endif

             call add_LH_mother(ndaughters,iord_daughters_LH,
     &            rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &            MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &            isconsistent)
           endif
         endif

c Check if colorflow is consistent with presence of a resonance
      issinglet=1
      IF(abs(IDUP_aux(itemp(5))).le.5)THEN ! quark or antiquark

      IF(IDUP_aux(itemp(5)).GT.0)THEN
       ico1=ICOLUP_aux(1,itemp(5))
      ELSE
       ico1=ICOLUP_aux(2,itemp(5))
      ENDIF

      IF(IDUP_aux(itemp(6)).GT.0)THEN
       ico2=ICOLUP_aux(1,itemp(6))
      ELSE
       ico2=ICOLUP_aux(2,itemp(6))
      ENDIF

      IF(ico1.NE.ico2) issinglet=0

      ENDIF

         if(isresonant(4).eq.1 .AND. issinglet.EQ.1)then ! rm21[a,b]
            i_mother=i_mother+1
            ndaughters=2
            iord_daughters_LH(1) = itemp(5)
            iord_daughters_LH(2) = itemp(6)
            if(imapregion(4).eq.2)then
               rmass_mapping=rm21a(iphs_ind)
            elseif(imapregion(4).eq.4)then
               rmass_mapping=rm21b(iphs_ind)
            endif

            call add_LH_mother(ndaughters,iord_daughters_LH,
     &           rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &           MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &           isconsistent)
         endif

c Avoid double counting of intermediate particles due to possible
c multiple resonances in presence of gluons
         ichain=1
         iskip=0
         if(rm21a(iphs_ind).eq.rm2a(iphs_ind) .and.
     &        rm21b(iphs_ind).eq.rm2b(iphs_ind))then
           ichain=ichain+1
         else
           ichain=1
           iskip=0
         endif
         if(ichain.gt.1 .and.
     &        (isresonant(4).eq.1  .and. isconsistent.eq.1))then
           iskip=1
         endif
c giuseppe 08/09/2007
         if(isresonant(4).ne.1 .or. isconsistent.eq.0)then
           iskip=1
         endif
c end giuseppe 08/09/2007

         if(isresonant(2).eq.1)then ! rm2[a,b]
            i_mother=i_mother+1
            if(iskip.eq.0)then
               ndaughters=3
               iord_daughters_LH(1) = itemp(5)
               iord_daughters_LH(2) = itemp(6)
               iord_daughters_LH(3) = itemp(8)
               if(imapregion(2).eq.2)then
                  rmass_mapping=rm2a(iphs_ind)
               elseif(imapregion(2).eq.4)then
                  rmass_mapping=rm2b(iphs_ind)
               endif

               call add_LH_mother(ndaughters,iord_daughters_LH,
     &              rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &              MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &              isconsistent)
            endif
         endif

      elseif(iphsp.eq.6)then    ! phsp2_4to31

c Check if colorflow is consistent with presence of a resonance
      issinglet=1
      IF(abs(IDUP_aux(itemp(3))).le.5)THEN ! quark or antiquark

      IF(IDUP_aux(itemp(3)).GT.0)THEN
       ico1=ICOLUP_aux(1,itemp(3))
      ELSE
       ico1=ICOLUP_aux(2,itemp(3))
      ENDIF

      IF(IDUP_aux(itemp(4)).GT.0)THEN
       ico2=ICOLUP_aux(1,itemp(4))
      ELSE
       ico2=ICOLUP_aux(2,itemp(4))
      ENDIF

      IF(ico1.NE.ico2) issinglet=0

      ENDIF

         if(isresonant(4).eq.1)then ! rm111[a,b]
            i_mother=i_mother+1
            ndaughters=2
            iord_daughters_LH(1) = itemp(3)
            iord_daughters_LH(2) = itemp(4)
            if(imapregion(4).eq.2)then
               rmass_mapping=rm111a(iphs_ind)
            elseif(imapregion(4).eq.4)then
               rmass_mapping=rm111b(iphs_ind)
            endif

            call add_LH_mother(ndaughters,iord_daughters_LH,
     &           rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &           MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &           isconsistent)
         endif

c Avoid double counting of intermediate particles due to possible
c multiple resonances in presence of gluons
         if(rm111a(iphs_ind).eq.rm11a(iphs_ind) .and.
     &        rm111b(iphs_ind).eq.rm11b(iphs_ind))then
           ichain=ichain+1
         else
           ichain=1
           iskip=0
         endif
         if(ichain.gt.1 .and.
     &        (isresonant(4).eq.1 .and. isconsistent.eq.1))then
           iskip=1
         endif
c giuseppe 08/09/2007
         if(isresonant(4).ne.1 .or. isconsistent.eq.0)then
           iskip=1
         endif
c end giuseppe 08/09/2007

         if(isresonant(3).eq.1)then ! rm11[a,b]
            i_mother=i_mother+1
            if(iskip.eq.0)then
               ndaughters=3
               iord_daughters_LH(1) = itemp(3)
               iord_daughters_LH(2) = itemp(4)
               iord_daughters_LH(3) = itemp(5)
               if(imapregion(3).eq.2)then
                  rmass_mapping=rm11a(iphs_ind)
               elseif(imapregion(3).eq.4)then
                  rmass_mapping=rm11b(iphs_ind)
               endif

               call add_LH_mother(ndaughters,iord_daughters_LH,
     &              rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &              MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &              isconsistent)
            endif
         endif

c Avoid double counting of intermediate particles due to possible
c multiple resonances in presence of gluons
         if(rm11a(iphs_ind).eq.rm1a(iphs_ind) .and.
     &        rm11b(iphs_ind).eq.rm1b(iphs_ind))then
            ichain=ichain+1
         else
            ichain=1
c giuseppe 08/09/2007
c            iskip=0
c end giuseppe 08/09/2007
         endif
         if(ichain.gt.1 .and. (iskip.eq.1 .or.
     &        (isresonant(3).eq.1 .and. isconsistent.eq.1)))then
           iskip=1
         endif

         if(isresonant(1).eq.1)then ! rm1[a,b]
            i_mother=i_mother+1
            if(iskip.eq.0)then
               ndaughters=4
               iord_daughters_LH(1) = itemp(3)
               iord_daughters_LH(2) = itemp(4)
               iord_daughters_LH(3) = itemp(5)
               iord_daughters_LH(4) = itemp(6)
               if(imapregion(1).eq.2)then
                  rmass_mapping=rm1a(iphs_ind)
               elseif(imapregion(1).eq.4)then
                  rmass_mapping=rm1b(iphs_ind)
               endif

               call add_LH_mother(ndaughters,iord_daughters_LH,
     &              rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &              MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &              isconsistent)
            endif
         endif

c Check if colorflow is consistent with presence of a resonance
      issinglet=1
      IF(abs(IDUP_aux(itemp(7))).le.5)THEN ! quark or antiquark

      IF(IDUP_aux(itemp(7)).GT.0)THEN
       ico1=ICOLUP_aux(1,itemp(7))
      ELSE
       ico1=ICOLUP_aux(2,itemp(7))
      ENDIF

      IF(IDUP_aux(itemp(8)).GT.0)THEN
       ico2=ICOLUP_aux(1,itemp(8))
      ELSE
       ico2=ICOLUP_aux(2,itemp(8))
      ENDIF

      IF(ico1.NE.ico2) issinglet=0

      ENDIF

         if(isresonant(2).eq.1 .AND. issinglet.EQ.1)then ! rm2[a,b]
            i_mother=i_mother+1
            ndaughters=2
            iord_daughters_LH(1) = itemp(7)
            iord_daughters_LH(2) = itemp(8)
            if(imapregion(2).eq.2)then
               rmass_mapping=rm2a(iphs_ind)
            elseif(imapregion(2).eq.4)then
               rmass_mapping=rm2b(iphs_ind)
            endif

            call add_LH_mother(ndaughters,iord_daughters_LH,
     &           rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &           MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &           isconsistent)
         endif

      elseif(iphsp.eq.7)then    ! phsp1_5to1_4to31

c Check if colorflow is consistent with presence of a resonance
      issinglet=1
      IF(abs(IDUP_aux(itemp(3))).le.5)THEN ! quark or antiquark

      IF(IDUP_aux(itemp(3)).GT.0)THEN
       ico1=ICOLUP_aux(1,itemp(3))
      ELSE
       ico1=ICOLUP_aux(2,itemp(3))
      ENDIF

      IF(IDUP_aux(itemp(4)).GT.0)THEN
       ico2=ICOLUP_aux(1,itemp(4))
      ELSE
       ico2=ICOLUP_aux(2,itemp(4))
      ENDIF

      IF(ico1.NE.ico2) issinglet=0

      ENDIF

         if(isresonant(4).eq.1 .AND. issinglet.EQ.1)then ! rm1111
            i_mother=i_mother+1
            ndaughters=2
            iord_daughters_LH(1) = itemp(3)
            iord_daughters_LH(2) = itemp(4)
            rmass_mapping=rm1111(iphs_ind)

            call add_LH_mother(ndaughters,iord_daughters_LH,
     &           rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &           MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &           isconsistent)
         endif

c Avoid double counting of intermediate particles due to possible
c multiple resonances in presence of gluons
         if(rm1111(iphs_ind).eq.rm111(iphs_ind))then
            ichain=ichain+1
         else
            ichain=1
            iskip=0
         endif
         if(ichain.gt.1 .and.
     &        (isresonant(4).eq.1 .and. isconsistent.eq.1))then
            iskip=1
         endif
c giuseppe 08/09/2007
         if(isresonant(4).ne.1 .or. isconsistent.eq.0)then
           iskip=1
         endif
c end giuseppe 08/09/2007

         if(isresonant(3).eq.1)then ! rm111
            i_mother=i_mother+1
            if(iskip.eq.0)then
               ndaughters=3
               iord_daughters_LH(1) = itemp(3)
               iord_daughters_LH(2) = itemp(4)
               iord_daughters_LH(3) = itemp(5)
               rmass_mapping=rm111(iphs_ind)

               call add_LH_mother(ndaughters,iord_daughters_LH,
     &              rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &              MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &              isconsistent)
            endif
         endif

c Avoid double counting of intermediate particles due to possible
c multiple resonances in presence of gluons
         if(rm111(iphs_ind).eq.rm11(iphs_ind))then
           ichain=ichain+1
         else
           ichain=1
c giuseppe 08/09/2007
c            iskip=0
c end giuseppe 08/09/2007
         endif
         if(ichain.gt.1 .and. (iskip.eq.1 .or.
     &        (isresonant(3).eq.1 .and. isconsistent.eq.1)))then
           iskip=1
         endif

         if(isresonant(2).eq.1)then ! rm11
            i_mother=i_mother+1
            if(iskip.eq.0)then
               ndaughters=4
               iord_daughters_LH(1) = itemp(3)
               iord_daughters_LH(2) = itemp(4)
               iord_daughters_LH(3) = itemp(5)
               iord_daughters_LH(4) = itemp(6)
              rmass_mapping=rm11(iphs_ind)

               call add_LH_mother(ndaughters,iord_daughters_LH,
     &              rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &              MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &              isconsistent)
            endif
         endif

c Avoid double counting of intermediate particles due to possible
c multiple resonances in presence of gluons
         if(rm11(iphs_ind).eq.rm1(iphs_ind))then
            ichain=ichain+1
         else
            ichain=1
c giuseppe 08/09/2007
c            iskip=0
c end giuseppe 08/09/2007
         endif
         if(ichain.gt.1 .and. (iskip.eq.1 .or.
     &        (isresonant(2).eq.1 .and. isconsistent.eq.1)))then
            iskip=1
         endif

         if(isresonant(1).eq.1)then ! rm1
            i_mother=i_mother+1
            if(iskip.eq.0)then
               ndaughters=5
               iord_daughters_LH(1) = itemp(3)
               iord_daughters_LH(2) = itemp(4)
               iord_daughters_LH(3) = itemp(5)
               iord_daughters_LH(4) = itemp(6)
               iord_daughters_LH(5) = itemp(7)
               rmass_mapping=rm1(iphs_ind)

               call add_LH_mother(ndaughters,iord_daughters_LH,
     &              rmass_mapping,i_mother,IDUP_aux,ISTUP_aux,
     &              MOTHUP_aux,PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux,
     &              isconsistent)
            endif
         endif

      endif                     ! if(iphsp.eq.1)then

      endif                     ! if(iwrite_mothers.eq.1)then

* Finally initialize Les Houches commons.

      if(iwrite_mothers.eq.1)then

         NUP=maxNparticles

         do i=1,NUP_aux
            do while(IDUP_aux(i).eq.0)
               NUP=NUP-1
               call shift_LH_stack(i,IDUP_aux,ISTUP_aux,MOTHUP_aux,
     &              PUP_aux,ICOLUP_aux,VTIMUP_aux,SPINUP_aux)
            enddo
         enddo

         do i=1,NUP
            IDUP(i)=IDUP_aux(i)
            ISTUP(i)=ISTUP_aux(i)
            do mu=1,5
               PUP(mu,i)=PUP_aux(mu,i)
            enddo
            do k=1,2
               ICOLUP(k,i)=ICOLUP_aux(k,i)
            enddo
            VTIMUP(i)=VTIMUP_aux(i)
            SPINUP(i)=SPINUP_aux(i)
            do k=1,2
               MOTHUP(k,i)=MOTHUP_aux(k,i)
            enddo
         enddo

      else

         NUP=maxNparticles-maxNmothers

         do i=1,NUP
            if(i.le.2)then
               index=i
            else
               index=i+maxNmothers
            endif

            IDUP(i)=IDUP_aux(index)
            ISTUP(i)=ISTUP_aux(index)
            do mu=1,5
               PUP(mu,i)=PUP_aux(mu,index)
            enddo
            do k=1,2
               ICOLUP(k,i)=ICOLUP_aux(k,index)
            enddo
            VTIMUP(i)=VTIMUP_aux(index)
            SPINUP(i)=SPINUP_aux(index)
            do k=1,2
               MOTHUP(k,i)=MOTHUP_aux(k,index)
            enddo
         enddo

      endif                     ! if(iwrite_mothers.eq.1)then

      return
      end

***********************************************************************
* SUBROUTINE add_LH_mother                                            *
*                                                                     *
* Purpuse: fill LH commons for the candidate mother (if consistent    *
*          with colour flow configuration chosen for the event at     *
*          hand)                                                      *
***********************************************************************

      subroutine add_LH_mother(ndaughters,iord_daughters_LH,
     &     rmass_mapping,i_mother,IDUP,ISTUP,MOTHUP,PUP,ICOLUP,
     &     VTIMUP,SPINUP,isconsistent)

      implicit real*8 (a-b,d-h,o-z)
c common.h is required to know the value of boson and top masses
      include 'common.h'

      integer maxNUP
      parameter (maxNUP=12)
      integer ndaughters,iord_daughters_LH(6),
     &     i,k,idaux,nf,nb,mu,imoth1,imoth2,
     &     i_mother,IDUP(maxNUP),ISTUP(maxNUP),MOTHUP(2,maxNUP),
     &     ICOLUP(2,maxNUP)
      real*8 rmass_mapping,PUP(5,maxNUP),VTIMUP(maxNUP),SPINUP(maxNUP)

c Determine the ID of the candidate mother (W+/-, Z, H or top) combining
c information from flavour of fermions and multimapping.
c
c   PDG  convention:
c   1=d, 2=u, 3=s, 4=c, 5=b, 6=t
c   11=e-, 12=v_e, 13=mu-, 14=v_mu, 15=tau-, 16=v_tau
c   all antiparticles have the same number but opposite sign
c   moreover: 21=gluon, 22=gamma, 23=Z0, 24=W+, 25=h

      idaux=0
      nf=0
      nb=0
      do i=1,ndaughters
         if(IDUP(iord_daughters_LH(i)).eq.0)then
            print*,'***add_LH_mother: ERROR 0'
            STOP
         endif
         if(abs(IDUP(iord_daughters_LH(i))).le.16)then ! fermion
            nf=nf+1
            idaux = idaux + IDUP(iord_daughters_LH(i))
            if(abs(IDUP(iord_daughters_LH(i))).eq.5)then ! b
               nb=nb+1
            endif
         endif
      enddo

      if(nf.gt.0)then
         if(idaux.eq.0)then     ! neutral boson
            if(rmass_mapping.eq.rmz)then ! Z
               IDUP(i_mother)=23
            elseif(rmass_mapping.eq.rmh .and. rmh.ge.0.d0)then ! H
               IDUP(i_mother)=25
            elseif(rmass_mapping.eq.rmhh .and. rmhh.ge.0.d0)then ! Heavy H
               IDUP(i_mother)=625
            else
               print*,'***add_LH_mother: ERROR 11'
               STOP
            endif
         elseif(idaux.eq.1 .and. rmass_mapping.eq.rmw)then ! W+
            IDUP(i_mother)=24
         elseif(idaux.eq.-1 .and. rmass_mapping.eq.rmw)then ! W-
            IDUP(i_mother)=-24
         elseif(nb.gt.0 .and. rmass_mapping.eq.rmt)then
            if(idaux.eq.6)then  ! t
               IDUP(i_mother)=6
            elseif(idaux.eq.-6)then ! tbar
               IDUP(i_mother)=-6
            else
               print*,'***add_LH_mother: ERROR 12'
               STOP
            endif
         else
            print*,'***add_LH_mother: ERROR 13'
            STOP
         endif
      else
         print*,'***add_LH_mother: ERROR 1'
      endif

c giuseppe 30/10/2007
c In case of a resonance candidate for Higgs decaying in two fermions
c (+ n gluons possibly), one must check for consistency that the
c daughter fermions are b quarks.
      isconsistent=1
      if( (IDUP(i_mother).eq.25 .or. IDUP(i_mother).eq.625)
     &                     .and. nf.eq.2)then
        if(nb.ne.2)then
          isconsistent=0
        endif
      endif
c end giuseppe 30/10/2007

c giuseppe 30/10/2007
      if(isconsistent.eq.1)then
c end giuseppe 30/10/2007

c Check consistency with the colour flow configuration chosen in the
c amplitude
        call set_LH_color(ndaughters,iord_daughters_LH,i_mother,
     &       IDUP,ICOLUP,isconsistent)

        if(isconsistent.eq.1)then

c Reconstruct momentum of the intermediate particle
          do mu=1,5
            PUP(mu,i_mother)=0.d0
          enddo
          do i=1,ndaughters
            PUP(1,i_mother)=PUP(1,i_mother)+PUP(1,iord_daughters_LH(i))
            PUP(2,i_mother)=PUP(2,i_mother)+PUP(2,iord_daughters_LH(i))
            PUP(3,i_mother)=PUP(3,i_mother)+PUP(3,iord_daughters_LH(i))
            PUP(4,i_mother)=PUP(4,i_mother)+PUP(4,iord_daughters_LH(i))
          enddo
          auxpx2 = PUP(1,i_mother)*PUP(1,i_mother)
          auxpy2 = PUP(2,i_mother)*PUP(2,i_mother)
          auxpz2 = PUP(3,i_mother)*PUP(3,i_mother)
          auxE2  = PUP(4,i_mother)*PUP(4,i_mother)
          PUP(5,i_mother) = sqrt(auxE2-auxpx2-auxpy2-auxpz2)

          MOTHUP(1,i_mother)=1
          MOTHUP(2,i_mother)=2

c Assign correct relationship with this mother
          do i=1,ndaughters

            imoth1=MOTHUP(1,iord_daughters_LH(i))
            imoth2=MOTHUP(2,iord_daughters_LH(i))

            if(imoth1.eq.1 .and. imoth2.eq.2)then
c External particle has not yet a mother. Assign to this.
              MOTHUP(1,iord_daughters_LH(i))=i_mother
              MOTHUP(2,iord_daughters_LH(i))=i_mother
            else
c External particle has already a mother. Then follow backwards the
c chain of decays to eventually update the relationship of intermediate
c particles involved.
              k=0
              do while(imoth1.ne.1 .and. imoth2.ne.2)
                k=imoth1
                if(imoth1.eq.0 .or. imoth2.eq.0 .or.
     &               imoth1.ne.imoth2)then
                  print*,'***add_LH_mother: ERROR 2'
                  STOP
                endif
                imoth1=MOTHUP(1,imoth1)
                imoth2=MOTHUP(2,imoth2)
              enddo
              if(k.lt.i_mother)then
                MOTHUP(1,k)=i_mother
                MOTHUP(2,k)=i_mother
              endif
            endif
          enddo

c Complete Les Houches information for LHEF
c Notice: ICOLUP has been already determined inside subroutine
c set_LH_color.
          ISTUP(i_mother)=2
          VTIMUP(i_mother)=0.d0
          SPINUP(i_mother)=9.d0

        else
          IDUP(i_mother)=0
        endif                   ! if(isconsistent.eq.1)then
c giuseppe 30/10/2007
      else
        IDUP(i_mother)=0
      endif                     ! if(isconsistent.eq.1)then
c end giuseppe 30/10/2007

      return
      end

***********************************************************************
* SUBROUTINE add_LH_mother2                                           *
*                                                                     *
* Purpuse: fill LH commons for the candidate mother (if consistent    *
*          with colour flow configuration chosen for the event at     *
*          hand)                                                      *
*          Grandmothers are given in input                            *
***********************************************************************

      subroutine add_LH_mother2(ndaughters,iord_daughters_LH,
     &     rmass_mapping,i_mother,igranmoth1,igranmoth2,
     &     IDUP,ISTUP,MOTHUP,PUP,ICOLUP,
     &     VTIMUP,SPINUP,isconsistent)

      implicit real*8 (a-b,d-h,o-z)
c common.h is required to know the value of boson and top masses
      include 'common.h'

      integer maxNUP
      parameter (maxNUP=12)
      integer ndaughters,iord_daughters_LH(6),
     &     i,k,idaux,nf,nb,mu,imoth1,imoth2,igranmoth1,igranmoth2,
     &     i_mother,IDUP(maxNUP),ISTUP(maxNUP),MOTHUP(2,maxNUP),
     &     ICOLUP(2,maxNUP)
      real*8 rmass_mapping,PUP(5,maxNUP),VTIMUP(maxNUP),SPINUP(maxNUP)

c Determine the ID of the candidate mother (W+/-, Z, H or top) combining
c information from flavour of fermions and multimapping.
c
c   PDG  convention:
c   1=d, 2=u, 3=s, 4=c, 5=b, 6=t
c   11=e-, 12=v_e, 13=mu-, 14=v_mu, 15=tau-, 16=v_tau
c   all antiparticles have the same number but opposite sign
c   moreover: 21=gluon, 22=gamma, 23=Z0, 24=W+, 25=h

      idaux=0
      nf=0
      nb=0
      do i=1,ndaughters
         if(IDUP(iord_daughters_LH(i)).eq.0)then
            print*,'***add_LH_mother: ERROR 0'
            STOP
         endif
         if(abs(IDUP(iord_daughters_LH(i))).le.16)then ! fermion
            nf=nf+1
            idaux = idaux + IDUP(iord_daughters_LH(i))
            if(abs(IDUP(iord_daughters_LH(i))).eq.5)then ! b
               nb=nb+1
            endif
         endif
      enddo

      if(nf.gt.0)then
         if(idaux.eq.0)then     ! neutral boson
            if(rmass_mapping.eq.rmz)then ! Z
               IDUP(i_mother)=23
            elseif(rmass_mapping.eq.rmh .and. rmh.ge.0.d0)then ! H
               IDUP(i_mother)=25
            elseif(rmass_mapping.eq.rmhh .and. rmhh.ge.0.d0)then ! Heavy H
               IDUP(i_mother)=625
            else
               print*,'***add_LH_mother: ERROR 11'
               STOP
            endif
         elseif(idaux.eq.1 .and. rmass_mapping.eq.rmw)then ! W+
            IDUP(i_mother)=24
         elseif(idaux.eq.-1 .and. rmass_mapping.eq.rmw)then ! W-
            IDUP(i_mother)=-24
         elseif(nb.gt.0 .and. rmass_mapping.eq.rmt)then
            if(idaux.eq.6)then  ! t
               IDUP(i_mother)=6
            elseif(idaux.eq.-6)then ! tbar
               IDUP(i_mother)=-6
            else
               print*,'***add_LH_mother: ERROR 12'
               STOP
            endif
         else
            print*,'***add_LH_mother: ERROR 13'
            STOP
         endif
      else
         print*,'***add_LH_mother: ERROR 1'
      endif

c giuseppe 30/10/2007
c In case of a resonance candidate for Higgs decaying in two fermions
c (+ n gluons possibly), one must check for consistency that the
c daughter fermions are b quarks.
      isconsistent=1
      if( (IDUP(i_mother).eq.25 .or. IDUP(i_mother).eq.625)
     &                     .and. nf.eq.2)then
        if(nb.ne.2)then
          isconsistent=0
        endif
      endif
c end giuseppe 30/10/2007

c giuseppe 30/10/2007
      if(isconsistent.eq.1)then
c end giuseppe 30/10/2007

c Check consistency with the colour flow configuration chosen in the
c amplitude
        call set_LH_color(ndaughters,iord_daughters_LH,i_mother,
     &       IDUP,ICOLUP,isconsistent)

c Reconstruct momentum of the intermediate particle
        do mu=1,5
          PUP(mu,i_mother)=0.d0
        enddo
        do i=1,ndaughters
          PUP(1,i_mother)=PUP(1,i_mother)+PUP(1,iord_daughters_LH(i))
          PUP(2,i_mother)=PUP(2,i_mother)+PUP(2,iord_daughters_LH(i))
          PUP(3,i_mother)=PUP(3,i_mother)+PUP(3,iord_daughters_LH(i))
          PUP(4,i_mother)=PUP(4,i_mother)+PUP(4,iord_daughters_LH(i))
        enddo
        auxpx2 = PUP(1,i_mother)*PUP(1,i_mother)
        auxpy2 = PUP(2,i_mother)*PUP(2,i_mother)
        auxpz2 = PUP(3,i_mother)*PUP(3,i_mother)
        auxE2  = PUP(4,i_mother)*PUP(4,i_mother)
        PUP(5,i_mother) = sqrt(auxE2-auxpx2-auxpy2-auxpz2)

        MOTHUP(1,i_mother)=igranmoth1
        MOTHUP(2,i_mother)=igranmoth2

c Assign correct relationship with this mother
        do i=1,ndaughters
          MOTHUP(1,iord_daughters_LH(i))=i_mother
          MOTHUP(2,iord_daughters_LH(i))=i_mother
        enddo

c Complete Les Houches information for LHEF
c Notice: ICOLUP has been already determined inside subroutine
c set_LH_color.
        ISTUP(i_mother)=2
        VTIMUP(i_mother)=0.d0
        SPINUP(i_mother)=9.d0

      else
        IDUP(i_mother)=0
      endif                     ! if(isconsistent.eq.1)then
c end giuseppe 30/10/2007

      return
      end

************************************************************************
* SUBROUTINE set_LH_color                                              *
*                                                                      *
* Purpose: Check colour consistency and assign colour flow information *
*          (ICOLUP) to a candidate mother                              *
************************************************************************

      subroutine set_LH_color(ndaughters,iord_daughters_LH,i_mother,
     &     IDUP,ICOLUP,isconsistent)

      implicit none

      integer maxNUP
      parameter (maxNUP=12)

      integer ndaughters,iord_daughters_LH(6),i_mother,
     &     IDUP(maxNUP),ICOLUP(2,maxNUP),isconsistent,i,j,ifound,
     &     nfound,istop,imatch

      isconsistent=1

      if(IDUP(i_mother).eq.23 .or. abs(IDUP(i_mother)).eq.24 .or.
     &     IDUP(i_mother).eq.25)then ! EW boson

c Check if the mother has a colour configuration consistent with the
c one chosen in the amplitude: the daughters must form a colour singlet.
c All nonzero LEFT and RIGHT colour flow lines (i.e. ICOLUP(1,.) and
c ICOLUP(2,.)) must be shared between daughter particles.
c This means that for each nonzero ICOLUP(1,i) there must be an
c ICOLUP(2,j) with the same value, where i,j indicate two particles in
c the set of daughters. The same yelds for 2<->1.

         nfound=0
         istop=0
         i=1
         do while(i.le.ndaughters .and. istop.eq.0)
            j=1
            if(ICOLUP(1,iord_daughters_LH(i)).ne.0)then
               imatch=0
               do while(imatch.eq.0 .and. j.le.ndaughters)
                  if(i.ne.j .and. ICOLUP(2,iord_daughters_LH(j)).eq.
     &                 ICOLUP(1,iord_daughters_LH(i)))then
                     imatch=1
                  endif
                  j=j+1
               enddo
               if(j.eq.(ndaughters+1) .and. imatch.eq.0)then
                  nfound=nfound+1
                  if(nfound.gt.0)then
                     istop=1
                  endif
               endif
            endif

            j=1
            if(ICOLUP(2,iord_daughters_LH(i)).ne.0)then
               imatch=0
               do while(imatch.eq.0 .and. j.le.ndaughters)
                  if(i.ne.j .and. ICOLUP(1,iord_daughters_LH(j)).eq.
     &                 ICOLUP(2,iord_daughters_LH(i)))then
                     imatch=1
                  endif
                  j=j+1
               enddo
               if(j.eq.(ndaughters+1) .and. imatch.eq.0)then
                  nfound=nfound+1
                  if(nfound.gt.0)then
                     istop=1
                  endif
               endif
            endif
            i=i+1
         enddo

         if(nfound.ne.0)then
c If there is one or more colour flow lines not shared between
c daughters, then consistency with the colour configuration chosen in
c the amplitude is lost.
            isconsistent=0
         endif

         if(isconsistent.eq.1)then
            ICOLUP(1,i_mother)=0
            ICOLUP(2,i_mother)=0
         endif

      elseif(IDUP(i_mother).eq.6)then ! top

c In case of 3 daughters only [i.e. t -> W b], the colour configuration
c (ICOLUP) of the top quark is identical to that of the b quark:
c
c                              \ /
c                               |
c                               |W
c                           t___|___b
c
c In the general case of n daughters [i.e. t-> W b + (n-3)gluons],
c top ICOLUP is reconstructed by finding the (only) daughter which
c does not share a nonzero LEFT colour flow line (i.e. ICOLUP(1,.))
c with other daughter particles. It is indicated as g* in the picture
c below:
c
c                g*  g  g     g    \ /   g     g
c                 |  |  |     |     |    |     |
c                 |  |  | ... |     |W   | ... |
c             t___|__|__|_____|_____|____|_____|___b
c

         ifound=0
         nfound=0
         istop=0
         i=1
         do while(i.le.ndaughters .and. istop.eq.0)
            j=1
            if(ICOLUP(1,iord_daughters_LH(i)).ne.0)then
               imatch=0
               do while(imatch.eq.0 .and. j.le.ndaughters)
                  if(i.ne.j .and. ICOLUP(2,iord_daughters_LH(j)).eq.
     &                 ICOLUP(1,iord_daughters_LH(i)))then
                     imatch=1
                  endif
                  j=j+1
               enddo
               if(j.eq.(ndaughters+1) .and. imatch.eq.0)then
c a candidate for top ICOLUP has been found.
                  nfound=nfound+1
                  ifound=i
                  if(nfound.gt.1)then
                     istop=1
                  endif
               endif
            endif
            i=i+1
         enddo

         if(nfound.ne.1)then
c If there is more than one candidate for top colour flow, i.e. more
c than one colour flow line not shared between daughters, then
c consistency with the colour configuration chosen in the amplitude
c is lost.
            isconsistent=0
         endif

         if(isconsistent.eq.1)then
            ICOLUP(1,i_mother)=ICOLUP(1,iord_daughters_LH(ifound))
            ICOLUP(2,i_mother)=ICOLUP(2,iord_daughters_LH(ifound))
         endif

      elseif(IDUP(i_mother).eq.-6)then ! antitop

c In the general case of n daughters [i.e. tbar-> W bbar + (n-3)gluons],
c top ICOLUP is reconstructed by finding the (only) daughter which
c does not share a nonzero RIGHT colour flow line (i.e. ICOLUP(2,.))
c with other daughter particles. It is indicated as g* in the picture
c below:
c
c                g*  g  g     g    \ /   g     g
c                 |  |  |     |     |    |     |
c                 |  |  | ... |     |W   | ... |
c          tbar___|__|__|_____|_____|____|_____|___bbar
c

         ifound=0
         nfound=0
         istop=0
         i=1
         do while(i.le.ndaughters .and. istop.eq.0)
            j=1
            if(ICOLUP(2,iord_daughters_LH(i)).ne.0)then
               imatch=0
               do while(imatch.eq.0 .and. j.le.ndaughters)
                  if(i.ne.j .and. ICOLUP(1,iord_daughters_LH(j)).eq.
     &                 ICOLUP(2,iord_daughters_LH(i)))then
                     imatch=1
                  endif
                  j=j+1
               enddo
               if(j.eq.(ndaughters+1) .and. imatch.eq.0)then
c a candidate for top ICOLUP has been found.
                  nfound=nfound+1
                  ifound=i
                  if(nfound.gt.1)then
                     istop=1
                  endif
               endif
            endif
            i=i+1
         enddo

         if(nfound.ne.1)then
c If there is more than one candidate for antitop colour flow, i.e. more
c than one colour flow line not shared between daughters, then
c consistency with the colour configuration chosen in the amplitude
c is lost.
            isconsistent=0
         endif

         if(isconsistent.eq.1)then
            ICOLUP(1,i_mother)=ICOLUP(1,iord_daughters_LH(ifound))
            ICOLUP(2,i_mother)=ICOLUP(2,iord_daughters_LH(ifound))
         endif

      endif                     ! if(IDUP(i_mother).eq. ...)

      return
      end

************************************************************************
* SUBROUTINE shift_LH_stack                                            *
*                                                                      *
* Purpose: shift of one unit, from index_shift on, a stack of LHEF-like*
* arrays with fixed dimension.                                         *
************************************************************************

      subroutine shift_LH_stack(index_shift,IDUP,ISTUP,MOTHUP,PUP,
     &     ICOLUP,VTIMUP,SPINUP)

      implicit none

      integer maxNUP
      parameter (maxNUP=12)

      integer index_shift,NUP,IDUP(maxNUP),ISTUP(maxNUP),
     &     MOTHUP(2,maxNUP),ICOLUP(2,maxNUP),i,mu,k

      real*8 PUP(5,maxNUP),VTIMUP(maxNUP),SPINUP(maxNUP)

      do i=index_shift+1,maxNUP
         IDUP(i-1)=IDUP(i)
         ISTUP(i-1)=ISTUP(i)
         do mu=1,5
            PUP(mu,i-1)=PUP(mu,i)
         enddo
         do k=1,2
            ICOLUP(k,i-1)=ICOLUP(k,i)
         enddo
         VTIMUP(i-1)=VTIMUP(i)
         SPINUP(i-1)=SPINUP(i)
         do k=1,2
            MOTHUP(k,i-1)=MOTHUP(k,i)
         enddo
      enddo

c At this point the shift has been accomplished.
c As MOTHUP information is connected with the ordering in LHEF particle
c list, after a shift one must update the values of MOTHUP's when
c required.

      do i=index_shift,maxNUP
         do k=1,2
            if(MOTHUP(k,i).GE.index_shift)then
               MOTHUP(k,i)=MOTHUP(k,i)-1
            endif
         enddo
      enddo

      return
      end


Subroutine decay(irun, i, nnn, iseed, wid, nt)
  Parameter (maxstr=150001, maxr=1, amn=0.939457, etam=0.5475, amp=0.93828, ap1=0.13496, ap2=0.13957, am0=1.232, pi=3.1415926)
  Common /aa/r(3, maxstr)
  Common /bb/p(3, maxstr)
  Common /cc/e(maxstr)
  Common /ee/id(maxstr), lb(maxstr)
  Common /run/num
  Common /pa/rpion(3, maxstr, maxr)
  Common /pb/ppion(3, maxstr, maxr)
  Common /pc/epion(maxstr, maxr)
  Common /pd/lpion(maxstr, maxr)
  Common /input2/ilab, manyb, ntmax, icoll, insys, ipot, mode, imomen, nfreq, icflow, icrho, icou, kpoten, kmul
  Common /rndf77/nseed
  Common /dpert/dpertt(maxstr, maxr), dpertp(maxstr), dplast(maxstr), dpdcy(maxstr), dpdpi(maxstr, maxr), dpt(maxstr, maxr), dpp1(maxstr, maxr), dppion(maxstr, maxr)
  Save
  lbanti = lb(i)
  dm = e(i)
  If (iabs(lb(i))==11) Then
     x3 = ranart(nseed)
     If (x3>(1./3.)) Then
        lb(i) = 2
        nlab = 2
        lpion(nnn, irun) = 5
        epion(nnn, irun) = ap2
     Else
        lb(i) = 1
        nlab = 1
        lpion(nnn, irun) = 4
        epion(nnn, irun) = ap1
     End If
  Else If (iabs(lb(i))==10) Then
     x4 = ranart(nseed)
     If (x4>(1./3.)) Then
        lb(i) = 1
        nlab = 1
        lpion(nnn, irun) = 3
        epion(nnn, irun) = ap2
     Else
        lb(i) = 2
        nalb = 2
        lpion(nnn, irun) = 4
        epion(nnn, irun) = ap1
     End If
  Else If (iabs(lb(i))==12) Then
     ctrl = 0.65
     If (dm<=1.49) ctrl = -1.
     x5 = ranart(nseed)
     If (x5>=ctrl) Then
        x6 = ranart(nseed)
        If (x6>(1./3.)) Then
           lb(i) = 1
           nlab = 1
           lpion(nnn, irun) = 3
           epion(nnn, irun) = ap2
        Else
           lb(i) = 2
           nalb = 2
           lpion(nnn, irun) = 4
           epion(nnn, irun) = ap1
        End If
     Else
        lb(i) = 2
        nlab = 2
        lpion(nnn, irun) = 0
        epion(nnn, irun) = etam
     End If
  Else If (iabs(lb(i))==13) Then
     ctrl = 0.65
     If (dm<=1.49) ctrl = -1.
     x5 = ranart(nseed)
     If (x5>=ctrl) Then
        x8 = ranart(nseed)
        If (x8>(1./3.)) Then
           lb(i) = 2
           nlab = 2
           lpion(nnn, irun) = 5
           epion(nnn, irun) = ap2
        Else
           lb(i) = 1
           nlab = 1
           lpion(nnn, irun) = 4
           epion(nnn, irun) = ap1
        End If
     Else
        lb(i) = 1
        nlab = 1
        lpion(nnn, irun) = 0
        epion(nnn, irun) = etam
     End If
  End If
  Call dkine(irun, i, nnn, nlab, iseed, wid, nt)
  If (lbanti<0) Then
     lbi = lb(i)
     If (lbi==1 .Or. lbi==2) Then
        lbi = -lbi
     Else If (lbi==3) Then
        lbi = 5
     Else If (lbi==5) Then
        lbi = 3
     End If
     lb(i) = lbi
     lbi = lpion(nnn, irun)
     If (lbi==3) Then
        lbi = 5
     Else If (lbi==5) Then
        lbi = 3
     Else If (lbi==1 .Or. lbi==2) Then
        lbi = -lbi
     End If
     lpion(nnn, irun) = lbi
  End If
  If (nt==ntmax) Then
     lbm = lpion(nnn, irun)
     If (lbm==0 .Or. lbm==25 .Or. lbm==26 .Or. lbm==27) Then
        lbsave = lbm
        xmsave = epion(nnn, irun)
        pxsave = ppion(1, nnn, irun)
        pysave = ppion(2, nnn, irun)
        pzsave = ppion(3, nnn, irun)
        dpsave = dppion(nnn, irun)
        lpion(nnn, irun) = lb(i)
        epion(nnn, irun) = e(i)
        ppion(1, nnn, irun) = p(1, i)
        ppion(2, nnn, irun) = p(2, i)
        ppion(3, nnn, irun) = p(3, i)
        dppion(nnn, irun) = dpertp(i)
        lb(i) = lbsave
        e(i) = xmsave
        p(1, i) = pxsave
        p(2, i) = pysave
        p(3, i) = pzsave
        dpertp(i) = dpsave
     End If
  End If
  Return
End Subroutine decay


subroutine phenolbn(aepa,antss,pdepth,bhfwsf,cots,cliname,cname,daa,dae,dap,    &
                  & daynum,ddae,ddap,dgdde,dgdds,dummy2,emrgflg,ems,endphenol,  &
                  & epods,eseeds,first7,gdda,gdde,gdds,gddwsf,gmethod,hrs,lf1s, &
                  & lf2s,lf3s,lf4s,lnpout,mats,mffls,mpods,mseeds,pchron,pdate, &
                  & seedbed,year)
!
!  the phenolbn subroutine ... finish description here.
!
!  inputs: aepasf(r), antes(c,r), antss(c,r), aspasf(r),
!          boots(c,r), btpasf(r), dae(r), dap(r), dav(r), daynum(r),
!          ddae(c), ddap(c), ddav(c), dgdde(c), dgdds(c), dgddv(c),
!          drpasf(r), drs(c,r), empasf(r), ems(c), first7(c,r),
!          fps(c,r), gdde(r), gdds(r), gddv(r), hdpasf(r), heads(c,r),
!          hrpasf(r), hrs(c,r), iepasf(r), ies(c,r), joints(c,r),
!          jtpasf(r), mats(c,r), mtpasf(r), pchron(r), srpasf(r),
!          srs(c,r), tipasf(r), tis(c,r), tspasf(r), tss(c,r)

! outputs: antes(c,r), antss(c,r), boots(c,r), ddae((20)c), ddap(20)(c),
!          ddav(20)(c), dgdde(20)(c), dgdds(20)(c), dgddv(20)(c),
!          drs(c,r), first7(c,r), fps(c,r), heads(c,r), hrs(c,r),
!          ies(c,r), joints(c,r), mats(c,r), srs(c,r), tis(c,r),
!          tss(c,r)
!
implicit none
!
include 'file.fi'
!
! Dummy arguments
!
real :: aepa,bhfwsf,gdda,gdde,gdds,pchron,pdepth
character(80) :: cliname
character(80) :: cname,seedbed
integer :: daa,dae,dap,daynum,emrgflg,first7,gmethod,pdate,year
logical :: endphenol
integer,dimension(4) :: antss,cots,ems,epods,eseeds,hrs,lf1s,lf2s,lf3s,lf4s,    &
                      & mats,mffls,mpods,mseeds
integer,dimension(20) :: ddae,ddap
real,dimension(20) :: dgdde,dgdds
real,dimension(30) :: dummy2
real,dimension(15,5) :: gddwsf
real,dimension(100,2) :: lnpout
!
! Local variables
!
real :: adjgdd
integer :: i,j,row
integer,dimension(4) :: pdatearr
!
!debe changed upgm variable name 'bc0growdepth' to phenologymms variable name
!of 'pdepth' to maintain consistency with phenologymms code.
!debe added for writing out phenology info to a file.
!
!debe changed dimensions of dummy 2 arrays for stressed and non-stressed
! values.
!debe added bhfwsf to the call to each crop's phenol subroutine to
! implement daily water stress effect on time of reaching a growth stage
!debe added initialized gddwsf array.
!
!debe added the variable endphenol to stop the call to phenol
!debe added cliname to write the climate location name to phenol.out
!
!     + + + argument definitions + + +
!     adjgdd - the adjusted gdd required to enter a growth stage.
!     aepa - the parameter for duration of anthesis (i.e., gdd from start
!            to end of anthesis.
!     antss - the start of anthesis growth stage. one open flower per
!             plant =100% bloom. this array includes daynum, year, month
!             and day of when this stage was reached.
!     bhfwsf - water stress factor ratio (0-1).  this is read in daily.
!     cliname - the name of the location for the climate data.
!     cname - crop name.
!     cots - cotyledonary and unifoliolate leaves are visible in dry
!            beans. this array includes daynum, year, month and day
!            of when this stage was reached.
!     daa - days after anthesis.
!     dae - days after emergence.
!     dap - days after planting.
!     daynum - the current day numbered from jan 1.
!     ddae - an array holding the dae for each growth stage.
!     ddap - an array holding the dap for each growth stage.
!     dgdde - an array holding the gdde for each growth stage.
!     dgdds - an array holding the gdds for each growth stage.
!     dummy2 - an array to hold the gdd values, both under stressed
!              and non- stressed conditions,required to reach each growth
!              stage of the current crop.
!     emrgflg - a flag to determine if the new emerge subroutine should be
!               called (emrgflg=1) or to proceed with the weps/upgm method
!               of achieving emergence (emrgflg=0).
!     ems - day when emergence occurred. this array includes daynum, year,
!           month and day of when this event occurred.
!     endphenol - a flag to indicate if this subroutine should be called
!                 again on the next day.
!     epods - one pod has reached the maximum length in dry beans (early
!             pod set). this array includes daynum,year, month and day of
!             when this stage was reached.
!     eseeds - there is one pod with fully developed seeds in dry
!              beans (early seed fill). this array includes daynum, year,
!              month and day of when this stage was reached.
!     first7 - used to set the value of aepa the first time phenolbn is called.
!     gdda - growing degree days from anthesis.
!     gdde - growing degree days from emergence.
!     gdds - growing degree days from seeding.
!     gddwsf - an array to hold the gn and gs gdd values plus the high and
!              low water stress factor values.  these are used in calculating
!              the slope of the line for each growth stage and this is then
!              used to calculate the adjusted gdd value for the current
!              growth stage.
!              column one contains the gn values and is y2.
!              column two contains the gs value and is y1.
!              column three contains wsfhi (high water stress) and is x1.
!              column four contains wsflo (low water stress) and is x2.
!              column five contains the adjgdd value for the stage.
!     gmethod - selects the method whereby gdd will be calculated.  a value
!               of 1 corresponds to method 1 in phenologymms and is used
!               for crops such as winter wheat, winter barley and proso
!               millet. a value of 2 corresponds to method 2 in
!               phenologymms and is used for crops such as corn, dry beans,
!               sorghum and sunflower.  a value of 3 is the way that weps/upgm
!               calculated ggd for the day.
!     hrs - 80% of pods are at the mature color in dry beans. time to
!           harvest ripe growth stage. this array includes daynum, year,
!           month and day of when this stage was reached.
!     lf1s - stage when the first trifoliolate leaf is unfolded in dry
!            beans. this array includes daynum, year, month and day of when
!            this stage was reached.
!     lf2s - stage when the second trifoliolate leaf is unfolded in dry
!            beans. this array includes daynum, year, month and day of
!            when this stage was reached.
!     lf3s - stage when the third trifoliolate leaf is unfolded in dry
!            beans. this array includes daynum, year, month and day of
!            when this stage was reached.
!     lf4s - the stage when the fourth trifoliolate leaf is unfolded in dry
!            beans.  this array includes daynum, year, month and day of
!            when this stage was reached.
!     lnpout - an array used in writing out daynum and the number of leaves
!              on that day.  the values are written each time a new leaf has
!              appeared.
!     mats - one pod has changed color/striped. physiological maturity growth
!            stage. this array includes daynum, year, month and day of
!            when this stage was reached.
!     mffls - the stage of mid to full flower in dry beans. this array
!             includes daynum, year, month and day of when this stage was
!             reached.
!     mpods - the stage when 50% of the pods are at the maximum length
!             (mid pod set). this array includes daynum, year, month and
!             day of when this stage was reached.
!     mseeds - the stage when 50% of the pods have fully developed seeds
!              in dry beans (mid seed fill). this array includes daynum,
!              year, month and day of when this stage was reached.
!     pchron - phyllochron value which is the number of gdd per leaf.
!     pdate - planting date.
!     pdepth - depth of growing point at time of planting (m).
!              bc0growdepth is assed into pdepth.
!     seedbed - contains the soil moisture condition of the seedbed.
!     year - year.

!     + + + local variable definitions + + +
!     i - this tells which row is to be read in from the dummy2 array.
!     j - a counter variable for outputting the leaf number array.
!     pdatearr - the planting date array. it contains the daynum,
!                year, month and day that planting occurred.
!     row - this holds the row to be filled in the gddwsf array in the
!           water_stress subroutine.

! note: check what aepa should be set to for dry beans.
!****   it is currently not used - is it needed? ****
!  aepa = anthesis end parameter
if (first7==0) then
  aepa = 120.        ! this is the value for crops which use method 1
                     ! for gdd calculation.
                ! note: need to change this value because dry beans uses method 2.
  first7 = 1
end if

 !debe initialize planting date array
do i = 1,4
  pdatearr(i) = 0
end do
pdatearr(2) = year

      j = 1

! emergence has occurred so fill the first row in the gddwsf array (only
! print for the first period from e to cotylendoary leaf stage):
if ((ems(1)/=999).and.(cots(1)==999)) then
  row = 1
  i = 1
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
end if

!
! *******   fill growth stage arrays   *******

!debe added code to change the adjusted value in gddwsf only when
! the growth stage has been reached.

!debe adjusted the code for stages that needed to be accumulating
! gdd's simultaneously. that is they are not dependent on the previous
! stage's completion before the stage can begin.
!note: use 'elseif' only when the stage is dependent upon the completion
! of the previous stage before it can begin. otherwise use 'endif' and
! end the 'if' block for that stage.

!  cotyledonary leaf stage - vc:
if (cots(1)==999) then
  row = 2
  i = 2
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=gddwsf(2,5)) then
     cots(1) = daynum
     cots(2) = year
     call date1(cots)
     ddap(2) = dap
     ddae(2) = dae
     dgdds(2) = gdds
     dgdde(2) = gdde
     print *,'cots = ',cots
  end if

!  1st trifoliolate leaf stage - v1:
else if (lf1s(1)==999) then
  row = 3
  i = 3
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(3,5))) then
     lf1s(1) = daynum
     lf1s(2) = year
     call date1(lf1s)
     ddap(3) = dap
     ddae(3) = dae
     dgdds(3) = gdds
     dgdde(3) = gdde
     print *,'lf1s = ',lf1s
  end if
        !endif

!  2nd trifoliolate leaf stage - v2:
else if (lf2s(1)==999) then
  row = 4
  i = 4
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(3,5)+gddwsf(4,5))) then
     lf2s(1) = daynum
     lf2s(2) = year
     call date1(lf2s)
     ddap(4) = dap
     ddae(4) = dae
     dgdds(4) = gdds
     dgdde(4) = gdde
     print *,'lf2s = ',lf2s
  end if
       ! endif

!  3rd trifoliolate leaf stage - v3:
else if (lf3s(1)==999) then
  row = 5
  i = 5
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if ((gdde>=gddwsf(2,5)+gddwsf(3,5)+gddwsf(4,5)+gddwsf(5,5))) then
     lf3s(1) = daynum
     lf3s(2) = year
     call date1(lf3s)
     ddap(5) = dap
     ddae(5) = dae
     dgdds(5) = gdds
     dgdde(5) = gdde
     print *,'lf3s = ',lf3s
  end if
      !  endif

!  4th trifoliolate leaf stage - v4:
else if (lf4s(1)==999) then
  row = 6
  i = 6
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(3,5)+gddwsf(4,5)+gddwsf(5,5)+gddwsf(6,5))) then
     lf4s(1) = daynum
     lf4s(2) = year
     call date1(lf4s)
     ddap(6) = dap
     ddae(6) = dae
     dgdds(6) = gdds
     dgdde(6) = gdde
     print *,'lf4s = ',lf4s
  end if
end if

! one open flower per plant=100% bloom - r1
if (antss(1)==999) then
  row = 7
  i = 7
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(3,5)+gddwsf(4,5)+gddwsf(5,5)+gddwsf(6,5)        &
    & +gddwsf(7,5))) then
     antss(1) = daynum
     antss(2) = year
     call date1(antss)
     ddap(7) = dap
     ddae(7) = dae
     dgdds(7) = gdds
     dgdde(7) = gdde
     print *,'antss = ',antss
  end if
end if

!  mid to full flower growth stage - r2.
if (mffls(1)==999) then
  row = 8
  i = 8
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(3,5)+gddwsf(4,5)+gddwsf(5,5)+gddwsf(6,5)        &
    & +gddwsf(7,5)+gddwsf(8,5))) then
     mffls(1) = daynum
     mffls(2) = year
     call date1(mffls)
     ddap(8) = dap
     ddae(8) = dae
     dgdds(8) = gdds
     dgdde(8) = gdde
     print *,'mffls = ',mffls
  end if
end if

!  one pod is at maximum length (early pod set) - r3
if (epods(1)==999) then
  row = 9
  i = 9
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(3,5)+gddwsf(4,5)+gddwsf(5,5)+gddwsf(6,5)        &
    & +gddwsf(7,5)+gddwsf(8,5)+gddwsf(9,5))) then
     epods(1) = daynum
     epods(2) = year
     call date1(epods)
     ddap(9) = dap
     ddae(9) = dae
     dgdds(9) = gdds
     dgdde(9) = gdde
     print *,'epods = ',epods
  end if
end if

!  50% of the pods are at maximum length (mid pod set) - r4
if (mpods(1)==999) then
  row = 10
  i = 10
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(3,5)+gddwsf(4,5)+gddwsf(5,5)+gddwsf(6,5)        &
    & +gddwsf(7,5)+gddwsf(8,5)+gddwsf(9,5)+gddwsf(10,5))) then
     mpods(1) = daynum
     mpods(2) = year
     call date1(mpods)
     ddap(10) = dap
     ddae(10) = dae
     dgdds(10) = gdds
     dgdde(10) = gdde
     print *,'mpods = ',mpods
  end if
end if

!  one pod has fully developed seeds (early seed fill) - r5
if (eseeds(1)==999) then
  row = 11
  i = 11
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(3,5)+gddwsf(4,5)+gddwsf(5,5)+gddwsf(6,5)        &
    & +gddwsf(7,5)+gddwsf(8,5)+gddwsf(9,5)+gddwsf(10,5)+gddwsf(11,5))) then
     eseeds(1) = daynum
     eseeds(2) = year
     call date1(eseeds)
     ddap(11) = dap
     ddae(11) = dae
     dgdds(11) = gdds
     dgdde(11) = gdde
     print *,'eseeds = ',eseeds
  end if
end if

!  50% of pods have fully developed seeds (mid seed fill) - r6
if (mseeds(1)==999) then
  row = 12
  i = 12
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(3,5)+gddwsf(4,5)+gddwsf(5,5)+gddwsf(6,5)        &
    & +gddwsf(7,5)+gddwsf(8,5)+gddwsf(9,5)+gddwsf(10,5)+gddwsf(11,5)            &
    & +gddwsf(12,5))) then
     mseeds(1) = daynum
     mseeds(2) = year
     call date1(mseeds)
     ddap(12) = dap
     ddae(12) = dae
     dgdds(12) = gdds
     dgdde(12) = gdde
     print *,'mseeds = ',mseeds
  end if
end if

! one pod has changed color/striped physiological maturity growth stage - r7
if (mats(1)==999) then
  row = 13
  i = 13
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(3,5)+gddwsf(4,5)+gddwsf(5,5)+gddwsf(6,5)        &
    & +gddwsf(7,5)+gddwsf(8,5)+gddwsf(9,5)+gddwsf(10,5)+gddwsf(11,5)            &
    & +gddwsf(12,5)+gddwsf(13,5))) then
     mats(1) = daynum
     mats(2) = year
     call date1(mats)
     ddap(13) = dap
     ddae(13) = dae
     dgdds(13) = gdds
     dgdde(13) = gdde
     print *,'mats = ',mats
  end if
end if

! 80% of the pods are at mature harvest color. harvest ready - r8
if (hrs(1)==999) then
  row = 14
  i = 14
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(3,5)+gddwsf(4,5)+gddwsf(5,5)+gddwsf(6,5)        &
    & +gddwsf(7,5)+gddwsf(8,5)+gddwsf(9,5)+gddwsf(10,5)+gddwsf(11,5)            &
    & +gddwsf(12,5)+gddwsf(13,5)+gddwsf(14,5))) then
     hrs(1) = daynum
     hrs(2) = year
     call date1(hrs)
     ddap(14) = dap
     ddae(14) = dae
     dgdds(14) = gdds
     dgdde(14) = gdde
     print *,'hrs = ',hrs
  end if
end if

! *******   output data   *******
! output information from each crop's phenol subroutine.
! print to the screen:
if (hrs(1)/=999) then
  print *,'crop is: ',cname
  print *,'gdds = ',gdds
  print *,'dap = ',dap
  print *,'gdde = ',gdde
  print *,'dae = ',dae
  print *,'gdda = ',gdda
  print *,'daa = ',daa
  print *,'year = ',year
!
! fill pdatearr
  pdatearr(1) = pdate
  call date1(pdatearr)

!  heading for leaf number table
  write (luophenol,1000) cname

! The following is the old way of writing out the leaf numbers which allowed &
! the discrepancy in the maximum leaf number in the leaf number table versus &
! that in the phenol table.

!  write out a table with leaf numbers by doy
!  do j = 1,60
!!  write only the integer values that are greater than 0
!     if ((lnpout(j,2)<dgdde(9)/pchron).and.(lnpout(j,2)>0.0))                 &
!       & write (luophenol,1100) lnpout(j,1),lnpout(j,2)
!  end do

      do while (lnpout(j,2) .le. dgdde(9)/pchron)
        write (luophenol,1100) lnpout(j,1),lnpout(j,2)
        j = j + 1
      end do

!! convert integer epods(1) to a real number
      write(luophenol,1100) real (epods(1)), dgdde(9)/pchron

      write (luophenol,1200)
                   ! leaf number table
!
!debe add items to print to the output file phenol.out
  write (luophenol,1300) cname,cliname,pdepth,pdatearr(1),pdatearr(3),          &
                       & pdatearr(4),gmethod,emrgflg,seedbed,bhfwsf

  write (luophenol,1400) pdatearr(1),pdatearr(3),pdatearr(4),ems(1),ems(3),     &
                       & ems(4),ddap(1),dgdds(1),cots(1),cots(3),cots(4),ddap(2)&
                       & ,ddae(2),dgdds(2),dgdde(2),dgdde(2)/pchron,lf1s(1),    &
                       & lf1s(3),lf1s(4),ddap(3),ddae(3),dgdds(3),dgdde(3),     &
                       & dgdde(3)/pchron,lf2s(1),lf2s(3),lf2s(4),ddap(4),ddae(4)&
                       & ,dgdds(4),dgdde(4),dgdde(4)/pchron,lf3s(1),lf3s(3),    &
                       & lf3s(4),ddap(5),ddae(5),dgdds(5),dgdde(5),dgdde(5)     &
                       & /pchron,lf4s(1),lf4s(3),lf4s(4),ddap(6),ddae(6),       &
                       & dgdds(6),dgdde(6),dgdde(6)/pchron,antss(1),antss(3),   &
                       & antss(4),ddap(7),ddae(7),dgdds(7),dgdde(7),dgdde(7)    &
                       & /pchron,mffls(1),mffls(3),mffls(4),ddap(8),ddae(8),    &
                       & dgdds(8),dgdde(8),dgdde(8)/pchron,epods(1),epods(3),   &
                       & epods(4),ddap(9),ddae(9),dgdds(9),dgdde(9),dgdde(9)    &
                       & /pchron,mpods(1),mpods(3),mpods(4),ddap(10),ddae(10),  &
                       & dgdds(10),dgdde(10),dgdde(9)/pchron,eseeds(1),eseeds(3)&
                       & ,eseeds(4),ddap(11),ddae(11),dgdds(11),dgdde(11),      &
                       & dgdde(9)/pchron,mseeds(1),mseeds(3),mseeds(4),ddap(12),&
                       & ddae(12),dgdds(12),dgdde(12),dgdde(9)/pchron,mats(1),  &
                       & mats(3),mats(4),ddap(13),ddae(13),dgdds(13),dgdde(13), &
                       & dgdde(9)/pchron,hrs(1),hrs(3),hrs(4),ddap(14),ddae(14),&
                       & dgdds(14),dgdde(14),dgdde(9)/pchron

! debe added writing out and formatting of the gddwsf array
  write (luophenol,1500) gddwsf(1,1),gddwsf(1,2),gddwsf(1,3),gddwsf(1,4),       &
                       & gddwsf(1,5),gddwsf(2,1),gddwsf(2,2),gddwsf(2,3),       &
                       & gddwsf(2,4),gddwsf(2,5),gddwsf(3,1),gddwsf(3,2),       &
                       & gddwsf(3,3),gddwsf(3,4),gddwsf(3,5),gddwsf(4,1),       &
                       & gddwsf(4,2),gddwsf(4,3),gddwsf(4,4),gddwsf(4,5),       &
                       & gddwsf(5,1),gddwsf(5,2),gddwsf(5,3),gddwsf(5,4),       &
                       & gddwsf(5,5),gddwsf(6,1),gddwsf(6,2),gddwsf(6,3),       &
                       & gddwsf(6,4),gddwsf(6,5),gddwsf(7,1),gddwsf(7,2),       &
                       & gddwsf(7,3),gddwsf(7,4),gddwsf(7,5),gddwsf(8,1),       &
                       & gddwsf(8,2),gddwsf(8,3),gddwsf(8,4),gddwsf(8,5),       &
                       & gddwsf(9,1),gddwsf(9,2),gddwsf(9,3),gddwsf(9,4),       &
                       & gddwsf(9,5),gddwsf(10,1),gddwsf(10,2),gddwsf(10,3),    &
                       & gddwsf(10,4),gddwsf(10,5),gddwsf(11,1),gddwsf(11,2),   &
                       & gddwsf(11,3),gddwsf(11,4),gddwsf(11,5),gddwsf(12,1),   &
                       & gddwsf(12,2),gddwsf(12,3),gddwsf(12,4),gddwsf(12,5),   &
                       & gddwsf(13,1),gddwsf(13,2),gddwsf(13,3),gddwsf(13,4),   &
                       & gddwsf(13,5),gddwsf(14,1),gddwsf(14,2),gddwsf(14,3),   &
                       & gddwsf(14,4),gddwsf(14,5),gddwsf(15,1),gddwsf(15,2),   &
                       & gddwsf(15,3),gddwsf(15,4),gddwsf(15,5)

  endphenol = .true.

end if
 1000 format (46x,a14)
!
 1100 format (40x,f5.1,6x,f4.1)
 1200 format (/1x) ! write a blank line after outputting the

 1300 format ('crop name =',2x,a15,/x,'climate location =',2x,a128,/x,          &
             &'planting depth =',2x,f5.3,'(m)',/x,'planting date =',2x,i3,':',  &
            & i2,'/',i2,/x,'gdd method =',2x,i1,/x,'emergence method used =',2x,&
            & i1,/x,'seedbed soil moisture =',2x,a17,/x,'water stress factor =',&
            & 2x,f3.1,/x)

 1400 format (' phenological event',7x,'day of year',2x,'date',2x,'dap',5x,     &
            & 'dae',5x,'gdd ap',5x,'gdd ae',5x,'nolvs',/1x,'planting date',18x, &
            & i4,2x,i2,'/',i2,/1x,'emergence',22x,i4,2x,i2,'/',i2,1x,i4,13x,    &
            & f6.1,/1x,'coyyledonary leaves (vc)',7x,i4,2x,i2,'/',i2,1x,i4,4x,  &
            & i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,'first trifoliolate leaf (v1)',3x, &
            & i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,          &
             &'second trifoliolate leaf (v2)',2x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,&
            & f6.1,5x,f6.1,4x,f6.1,/1x,'third trifoliolate leaf (v3)',3x,i4,2x, &
            & i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,                &
             &'fourth trifoliolate leaf (v4)',2x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,&
            & f6.1,5x,f6.1,4x,f6.1,/1x,'bloom (r1)',21x,i4,2x,i2,'/',i2,1x,i4,  &
            & 4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,'mid-full flower (r2)',11x,i4,  &
            & 2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,             &
             &'early pod set (r3)',13x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,  &
            & f6.1,4x,f6.1,/1x,'mid pod set (r4)',15x,i4,2x,i2,'/',i2,1x,i4,4x, &
            & i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,'early seed fill (r5)',11x,i4,2x,  &
            & i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,                &
             &'mid seed fill (r6)',13x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,  &
            & f6.1,4x,f6.1,/1x,'maturity (r7)',18x,i4,2x,i2,'/',i2,1x,i4,4x,i4, &
            & 5x,f6.1,5x,f6.1,4x,f6.1,/1x,'harvest ready',18x,i4,2x,i2,'/',i2,  &
            & 1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1)

!  heading for gddwsf array
 1500 format (/2x,39x,'gddwsf array',/1x,'phenological event',12x,'gn gdd',2x,  &
             &'gs gdd',2x,'wsfhi',2x,'wsflo',2x,'adjgdd',/1x,'emergence',22x,   &
            & f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'coyyledonary leaves',   &
            & 12x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,                     &
             &'first trifoliolate leaf',8x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,&
            & /1x,'second trifoliolate leaf',7x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,&
            & f5.1,/1x,'third trifoliolate leaf',8x,f5.1,3x,f5.1,3x,f3.1,4x,    &
            & f3.1,4x,f5.1,/1x,'fourth trifoliolate leaf',7x,f5.1,3x,f5.1,3x,   &
            & f3.1,4x,f3.1,4x,f5.1,/1x,'bloom',26x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,&
            & 4x,f5.1,/1x,'mid-full flower',16x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,&
            & f5.1,/1x,'early pod set',18x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,&
            & /1x,'mid pod set',20x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,   &
             &'early seed fill',16x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,   &
             &'mid seed fill',18x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,     &
             &'physiological maturity',9x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1, &
            & /1x,'harvest ready',18x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x, &
             &'row 15',25x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,6x,f3.1,/1x)
!
end subroutine phenolbn


! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

#include "error.inc"

program mc
  use libatoms_module
  use potential_module
  implicit none

  type(Potential) :: pot
  type(MPI_context) :: mpi_glob
  type(Cinoutput) :: atoms_out_file, atoms_in_file
  type(Atoms) :: at
  type(Dictionary) :: params
  type(extendable_str) :: params_es
  character(len=FIELD_LENGTH) :: atoms_in_filename, atoms_out_filename, params_in_filename
  character(len=FIELD_LENGTH) :: pot_init_args, pot_calc_args, first_pot_calc_args
  character(len=FIELD_LENGTH), allocatable :: atoms_print_property_list(:)
  character(len=FIELD_LENGTH) :: atoms_print_property_list_str
  integer :: N_steps, summary_interval, atoms_print_interval, rng_seed, atoms_print_property_list_n, i, rejections
  integer :: error = ERROR_NONE
  real(dp) :: E, Enew, T, proposal_amplitude
  logical :: do_timing, quiet_calc, fix_Roo
  real(dp), allocatable :: oldpos(:,:)

  call system_initialise()
  call initialise(mpi_glob)

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !
  ! get program parameters
  !
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  call initialise(params)
  call param_register(params, 'atoms_in_file', 'stdin', atoms_in_filename, help_string="Initial atomic data filename")
  call param_register(params, 'atoms_out_file', 'mc.xyz', atoms_out_filename, help_string="Output filename for MC samples")
  call param_register(params, 'params_in_file', 'quip_params.xml', params_in_filename, help_string="QUIP XML parameter filename")
  call param_register(params, 'rng_seed', '-1', rng_seed, help_string="Random seed")
  call param_register(params, 'N_steps', '1', N_steps,  help_string="Number of MC steps to perform")
  call param_register(params, 'T', '-1.0', T, "Simulation temperature (Kelvin)")
  call param_register(params, 'pot_init_args', PARAM_MANDATORY, pot_init_args, help_string="string to initialise potential")
  call param_register(params, 'summary_interval', '1', summary_interval, help_string="how often to print summary line")
  call param_register(params, 'atoms_print_interval', '100', atoms_print_interval, help_string="how often to print atomic config to log file")
  call param_register(params, 'print_property_list', '', atoms_print_property_list_str, help_string="list of properties to print for atoms")
  call param_register(params, 'pot_calc_args', '', pot_calc_args, help_string="args string for potential calc")
  call param_register(params, 'first_pot_calc_args', '', first_pot_calc_args, help_string="args string for first potential calc")
  call param_register(params, 'quiet_calc', 'T', quiet_calc, help_string="do calc() quietly")
  call param_register(params, 'do_timing', 'F', do_timing, help_string="if true, do timing")
  call param_register(params, 'use_fortran_random', 'F', system_use_fortran_random, help_string="if true, use fortran builtin random_number() routine")
  call param_register(params, 'proposal_amplitude', '1.0', proposal_amplitude, help_string="multiplies the proposal step size")
  call param_register(params, 'fix_Roo', 'F', fix_Roo, help_string="if true, does not change the initial Roo distance. defaults to false")

  ! parse params
  if (.not. param_read_args(params)) then
    call param_print_help(params)
    call system_abort("Error reading params from command line")
  endif

  if (len(trim(pot_init_args)) == 0) then
     call param_print_help(params)
     call system_abort("get_params() got empty pot_init_args")
  end if
  call finalise(params)

  if (len_trim(first_pot_calc_args) == 0) first_pot_calc_args = pot_calc_args

  if (len_trim(atoms_print_property_list_str) > 0) then
    allocate(atoms_print_property_list(500))
    call split_string_simple(trim(atoms_print_property_list_str), atoms_print_property_list, atoms_print_property_list_n, ':')
    deallocate(atoms_print_property_list)
    allocate(atoms_print_property_list(atoms_print_property_list_n))
    call split_string_simple(trim(atoms_print_property_list_str), atoms_print_property_list, atoms_print_property_list_n, ':')
  else
    if (allocated(atoms_print_property_list)) deallocate(atoms_print_property_list)
  endif

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !
  ! Initialise simulation
  !
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  ! Check temperature
  if (T <= 0.0_dp) then
     call system_abort("Cannot run at negative temperature: "//T)
  end if

  ! Turn on timing
  if (do_timing) call enable_timing()

  ! set random seed if asked for
  if (rng_seed >= 0) call system_reseed_rng(rng_seed)

  ! Read in atoms
  call initialise(atoms_in_file, atoms_in_filename, INPUT, mpi=mpi_glob)
  call read(at, atoms_in_file, error=error)
  HANDLE_ERROR(error)

  ! Read in QUIP parameters and initialise potential
  if (len_trim(params_in_filename) > 0) then
     call read(params_es, params_in_filename, convert_to_string=.true., mpi_comm=mpi_glob%communicator, mpi_id=mpi_glob%my_proc)
  else
     call initialise(params_es)
  endif
  call initialise(pot, args_str=pot_init_args, param_str=string(params_es), mpi_obj=mpi_glob)
  call print(pot)

  call finalise(params_es)

  call initialise(atoms_out_file, atoms_out_filename, OUTPUT, mpi=mpi_glob)

  call set_cutoff(at, cutoff(pot))

  ! first calc
  call calc_connect(at)
  if (quiet_calc) call verbosity_push_decrement()
  call calc(pot, at, args_str=trim(first_pot_calc_args)//" energy")
  call get_param_value(at, "energy", E)
  if (quiet_calc) call verbosity_pop()

  ! print header
  if(summary_interval > 0) then
     call print("   Iteration      Energy      Acceptance ratio")
  end if

  i = 0
  rejections = 0
  allocate(oldpos(3,at%N))
  call system_timer("mc_loop")
  do while(i < N_steps)
     ! propose new move
     oldpos = at%pos
     call propose_move(at)
     ! calculate new energy
     call calc_connect(at)

     if(mod(i, atoms_print_interval) == 0) then
!        if(fix_Roo) then
           call calc(pot, at, args_str=trim(pot_calc_args)//" energy force")
!        end if
        if (allocated(atoms_print_property_list)) then
           call write(atoms_out_file, at, properties_array=atoms_print_property_list, real_format='%18.10f')
        else
           call write(atoms_out_file, at, real_format='%18.10f')
        endif

     end if

     if (quiet_calc) call verbosity_push_decrement()
     call calc(pot, at, args_str=trim(pot_calc_args)//" energy")
     call get_param_value(at, "energy", Enew)
     if (quiet_calc) call verbosity_pop()

     ! Metropolis test
     if( Enew > E ) then
        if ( ran_uniform() > exp(-(Enew-E)/(BOLTZMANN_K*T)) ) then
           !reject the move
           at%pos = oldpos
           rejections = rejections+1
        else
           E = Enew ! accept
        end if
     else
        E = Enew ! accept
     end if

     ! print summary
     if(summary_interval > 0) then
        if(mod(i, summary_interval) == 0) then
           call print("MC "//i//" "//E//" "//(1.0_dp - real(rejections,dp)/real(summary_interval,dp)))
           rejections = 0
        end if
     end if

     i = i+1
  end do
  call system_timer("mc_loop")

  deallocate(oldpos)

  call system_finalise()

contains

  subroutine propose_move(at)
    type(Atoms), intent(inout) :: at
    type(Quaternion) :: quat
    real(dp) :: dr(3), u1, u2, u3, axis(3)
    real(dp), parameter :: drOHamp = 0.05_dp, drOOamp = 0.5_dp, dHOHamp = 1.0_dp

    ! Atoms are in the order OHHOHH

    ! first choose between monomer rotations vs. internal changes coupled with OO distance changes

    if(ran_uniform() < 0.5) then

       ! change OO distance
       if(.not. fix_Roo) then
          dr = (at%pos(:,4)-at%pos(:,1))/norm(at%pos(:,4)-at%pos(:,1))*(ran_uniform()-0.5_dp)*drOOamp*proposal_amplitude
          at%pos(:,4) = at%pos(:,4)+dr
          at%pos(:,5) = at%pos(:,5)+dr
          at%pos(:,6) = at%pos(:,6)+dr
       end if

       ! change OH distances
       at%pos(:,2) = at%pos(:,2) + (at%pos(:,2)-at%pos(:,1))/norm(at%pos(:,2)-at%pos(:,1))*(ran_uniform()-0.5_dp)*drOHamp*proposal_amplitude
       at%pos(:,3) = at%pos(:,3) + (at%pos(:,3)-at%pos(:,1))/norm(at%pos(:,3)-at%pos(:,1))*(ran_uniform()-0.5_dp)*drOHamp*proposal_amplitude
       at%pos(:,5) = at%pos(:,5) + (at%pos(:,5)-at%pos(:,4))/norm(at%pos(:,5)-at%pos(:,4))*(ran_uniform()-0.5_dp)*drOHamp*proposal_amplitude
       at%pos(:,6) = at%pos(:,6) + (at%pos(:,6)-at%pos(:,4))/norm(at%pos(:,6)-at%pos(:,4))*(ran_uniform()-0.5_dp)*drOHamp*proposal_amplitude

       ! change OH angles
       axis = (at%pos(:,2)-at%pos(:,1)) .cross. (at%pos(:,3)-at%pos(:,1))
       quat = rotation(axis, dHOHamp*proposal_amplitude/180.0_dp*PI*(ran_uniform()-0.5_dp))
       at%pos(:,2) = at%pos(:,1)+ rotate(at%pos(:,2)-at%pos(:,1), quat)

       axis = (at%pos(:,5)-at%pos(:,4)) .cross. (at%pos(:,6)-at%pos(:,4))
       quat = rotation(axis, dHOHamp*proposal_amplitude/180.0_dp*PI*(ran_uniform()-0.5_dp))
       at%pos(:,5) = at%pos(:,4)+ rotate(at%pos(:,5)-at%pos(:,4), quat)

    else
       ! uniform random rotation. formula from:
       ! K. Shoemake. Uniform random rotations. In D. Kirk, editor, Graphics Gems III, pages 124-132. Academic, New York, 1992.
       ! via  http://planning.cs.uiuc.edu/node198.html

       ! rotate first water monomer around its oxygen
       u1 = ran_uniform()
       u2 = ran_uniform()
       u3 = ran_uniform()
       call initialise(quat, sqrt(1.0_dp-u1)*sin(2.0_dp*PI*u2), sqrt(1.0_dp-u1)*cos(2.0_dp*PI*u2), sqrt(u1)*sin(2.0_dp*PI*u3), sqrt(u1)*cos(2.0_dp*PI*u3)) ! quaternion representing random rotation
       at%pos(:,2) = at%pos(:,1)+rotate(at%pos(:,2)-at%pos(:,1),quat)
       at%pos(:,3) = at%pos(:,1)+rotate(at%pos(:,3)-at%pos(:,1),quat)

       ! rotate second water monomer around its oxygen
       u1 = ran_uniform()
       u2 = ran_uniform()
       u3 = ran_uniform()
       call initialise(quat, sqrt(1.0_dp-u1)*sin(2.0_dp*PI*u2), sqrt(1.0_dp-u1)*cos(2.0_dp*PI*u2), sqrt(u1)*sin(2.0_dp*PI*u3), sqrt(u1)*cos(2.0_dp*PI*u3)) ! quaternion representing random rotation
       at%pos(:,5) = at%pos(:,4)+rotate(at%pos(:,5)-at%pos(:,4),quat)
       at%pos(:,6) = at%pos(:,4)+rotate(at%pos(:,6)-at%pos(:,4),quat)
    end if
  end subroutine propose_move

end program mc