!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     The subroutine interp_spline needs a certain value of the parameter
!     s to obtain the internal coordinates and the coupling strength
!     for that respective point on the 1D reaction path.
!
!     part of EVB
!
subroutine interp_spline(dim,s_act,path_s,klo,khi)
use evb_mod
implicit none
integer::intdim,dim   ! number of internal coordinates and total dimension
integer::n  ! number of points om the path
integer::i,j,k  ! loop indices
integer::j1,klo,khi  ! for interpolation routine
real(kind=8)::h,a,b    ! for interpolation routine
real(kind=8)::path_s(dim)   ! the resulting array with the internal coordinates
                                 ! and coupling strength for the s_act value
real(kind=8)::s_act  ! the actual s value that shall be interpolated

!
!     Determine, in which interval between two reference points the
!     current s-value is located. Perform the local cubic spline from
!     this two points
!
n=rp_irc_points
do k=1,n-1
   if (s_act .ge. rp_spl_s(k) .and. s_act .le. rp_spl_s(k+1)) then
      j1=k
      exit
   end if
end do
klo=j1
khi=j1+1
h=rp_spl_s(khi)-rp_spl_s(klo)
!
!     The x values need to have distinct values!
!
if (h .eq. 0) then
   write(*,*)  "Error in interp_spline.f90: two points are equal!"
   write(*,*)  "Control your inpur for the IRC!"
   call fatal
end if
a=(rp_spl_s(khi)-s_act)/h
b=(s_act-rp_spl_s(klo))/h
!
!     Now determine the coordinate values for all of the dimensions!
!
do j=1,dim
   path_s(j)=a*rp_spl_ref(j,klo)+b*rp_spl_ref(j,khi)+((a*a*a-a)*&
           & rp_spl_d2(klo,j)+(b*b*b-b)*rp_spl_d2(khi,j))*(h*h)/6.d0
end do
return
end subroutine interp_spline


C    %W% %G%
      subroutine solgovn (igr, mgvecs, iecs, idm, igovc)
      character*1 idm
c
c     This subroutine solves the governor differential equations.
c     It serves as the control module for the solution
c
      include 'tspinc/params.inc'
      include 'tspinc/blkcom1.inc'
      include 'tspinc/cntrl2.inc'
      include 'tspinc/prt.inc'
      include 'tspinc/toler.inc'
      include 'tspinc/param.inc'
      include 'tspinc/contrl.inc'
      include 'tspinc/search.inc'
      include 'tspinc/lnk12.inc'
      include 'tspinc/lnk1a.inc'
      include 'tspinc/vrgov.inc'
      include 'tspinc/ecsind.inc'
      include 'tspinc/bname.inc'
      include 'tspinc/buskv.inc'
      include 'tspinc/brake1.inc'
      include 'tspinc/ecstbb.inc'
      include 'tspinc/ecstbc.inc'
      include 'tspinc/ecstbd.inc'
      include 'tspinc/ecstbh.inc'
      include 'tspinc/ecstbj.inc'
      include 'tspinc/machd1.inc'
      include 'tspinc/machd2.inc'
      include 'tspinc/outaux.inc'
      include 'tspinc/igentn.inc'
      include 'tspinc/gentbla.inc'
      include 'tspinc/gentblb.inc'
      include 'tspinc/gentblc.inc'
      include 'tspinc/dateq.inc'
      include 'tspinc/lshed1.inc'
      include 'tspinc/busdta.inc'
      include 'tspinc/pointr.inc'
      include 'tspinc/relays.inc'
      include 'tspinc/amorts.inc'
      include 'tspinc/prate.inc'
      include 'tspinc/vtchkc.inc'
      include 'tspinc/busvolt.inc'

      common /vregl/ em,vmqt,vmdt

      include 'tspinc/comvar.inc'
      include 'tspinc/znox.inc'
      include 'tspinc/spare1.inc'

      common /ckpnt/ dnxmin,d13
      equivalence (creg(9), dr), (creg(21), rcex), (creg(23),
     1    xcex), (creg(3), vref), (creg(27), vco), (creg(7), cckp,
     2    ckpr), (creg(28), theta, ckpi), (creg(20), xl), (creg(10),
     3    ckc), (creg(11), v1max), (creg(13), va), (creg(30), vi),
     4    (creg(15), hcb), (creg(16), ckj), (creg(17), db),
     5    (creg(18), dc), (creg(19), vgmax), (creg(1), vrmax),
     6    (creg(2), vrmin), (creg(22), vr), (creg(8), cka), (creg(24),
     7    ckg), (creg(25), da), (creg(26), hba), (creg(4), efdmax),
     8    (creg(5), cki), (creg(29), efd), (creg(6), hbr),
     9    (creg(12), v1min), (creg(14),vfldo)

      include 'tspinc/deltfq.inc'

      common /govminmax/ govmn(MAXGEN), govmx(MAXGEN)

      equivalence (aeps,ar), (aes,brs,af1), (bes,bf1), (ba1s,br),
     1            (baps,a1), (bfs,a2), (ae, vfdo), (aep, bfx),
     2            (be, ba1x), (bf1, bapx)
      dimension istem(40)

      equivalence (istem,isorti)
      equivalence(csupp(26),x5o)

      dimension ktemp1(9), temp1(9)
      equivalence (ktemp1,temp1), (pgo,pgor), (sat,rt), (sater,dtc),
     1            (isg2,istp), (csupp(27),ivcsw)

      save

      call redecs (cgov,mgvecs,igv)

      if (mgov.eq.1) then
c -------------------------- Process GG Governor --------------------
        if (lppwr.eq.0) then

c --      update states using converged input and output
          st1 =(b1 - sgkp1*wnow*a2p)/a1p
          st3 = pgo + st1
          if (st3.gt.pmax) st3=pmax
          if (st3.lt.0.) st3=0.0
          st4 = (b3 + st3)/a3
          st5 = (b4 + st4)/a4
          st6 = (b5 + st5*a6)/a5

c --      update time constant variables if time step changed
          if (al .ne. 0.0) then
            a3    = a3*tfac - tfac + 1.
            a4    = a4*tfac - tfac + 1.
            a1p   = a1p*tfac - tfac + 1.
            a2p   = a2p*tfac - tfac + 1.
            a6    = a6 *tfac - tfac + 1.
            a5    = a5 *tfac - tfac + 1.
          endif

c --      update past state values
          b1 = sgkp1*wnow*(a2p - 2.) + st1*(a1p - 2.)
          b3 = st4*(a3-2.) + st3
          b4 = st5*(a4-2.) + st4
          b5 = st6*(a5-2.) - st5*(a6 - 2.)

          c1 = a6/(a3*a4*a5)
          c2 = b3*c1 + b4*c1*a3 + b5/a5

          govmx(ispf) = pmax*c1 + c2
          govmn(ispf) = c2

          a1gov = (-sgkp1*a2p*c1)/a1p
          a2gov = c2 + pgo*c1 + (b1*c1)/a1p
        endif

        govpow = a1gov*wnew + a2gov
        if (govpow.gt.govmx(ispf)) govpow = govmx(ispf)
        if (govpow.lt.govmn(ispf)) govpow = govmn(ispf)

      else if (mgov.eq.2) then
c -------------------------- Process GH Governor --------------------

        if (lppwr.eq.0) then

c --      update states using converged input and output
          st5 = govpwr(ispf)
          st3 = (b5 - a4*st5)/(2.0*a4 - 3.)
          if (st3.gt.pmax) st3 = pmax
          if (st3.lt.0.0) st3 = 0.0
          st4 = (b4 + a5*st3)/a3
          errsig = pgor - r*st3 - st4 - sgkp1*wnow
          st1 = a1p*(errsig + b1)/a2p
          if (st1 .gt. velmax) st1 = velmax
          if (st1 .lt. velmin) st1 = velmin

c --      update time constant variables if time step changed
          if (al .ne. 0.0) then
            a2p = a2p*tfac - tfac + 1.
            a3  = a3 *tfac - tfac + 1.
            a4  = a4 *tfac - tfac + 1.
            a5  = a5 *tfac
            a1gov  = -sgkp1/(120.0/edt*a2p/a1p + r + a5/a3)
            a1turb = -(2*a4 - 3.0)/a4
          endif

c --      update past state values
          if (st1.lt.velmax.and.st1.gt.velmin) then
             b1 = st1*(a2p-2.0)/a1p + errsig
          else
             b1 = st1*(a2p-1.0)/a1p
          endif
          if (st3.lt.pmax.and.st3.gt.0.0) then
            b3 = st1 + st3*120.0/edt
          else
            b3 = st3*120.0/edt
          endif
          b4 = st4*(a3-2.) - st3*a5
          b5 = st3*(2.0*a4-1.) + st5*(a4-2.)

          a2gov = (pgor - b4/a3 + b1 + b3*a2p/a1p) /
     &            (120.0/edt*a2p/a1p + r + a5/a3)
          a2turb = b5/a4

          govmx(ispf) = pmax
          govmn(ispf) = 0.0
          st3h = (b3 + velmax)*edt/120.0
          st3l = (b3 + velmin)*edt/120.0
          if (govmx(ispf).gt.st3h) govmx(ispf) = st3h
          if (govmn(ispf).lt.st3l) govmn(ispf) = st3l

        endif

        govpow = a1gov*wnew + a2gov
        if (govpow.gt.govmx(ispf)) govpow = govmx(ispf)
        if (govpow.lt.govmn(ispf)) govpow = govmn(ispf)
        govpow = a1turb*govpow + a2turb

      else if (mgov.eq.3) then
c -------------------------- Process GC Governor --------------------

        if (lvref .ne. 0) then
          vhd = eyri(ispf)
          vhq = eyii(ispf)
          if (xt .gt. 0.0 .and. rt .gt. 0.0) then
            curd = oid
            curq = oiq
            vld  = vhd + rt*curd - xt*curq
            vlq  = vhq + rt*curq + xt*curd
          endif
          vmt = sqrt(vld*vld + vlq*vlq)
          vmt = sqrt(vhd*vhd + vhq*vhq)
        else
          vmt = vmagt(ispf)
        endif

        wnow  = angp1(ispfh)
        wnew  = angp2(ispfh)
        wnewp = wnew - angp2(ispfl)

        if (lppwr.eq.0) then

c --      update states using converged input and output
          st1 = (b1 - sgk*wnow)/a1p
          st3 = pgo + st1
          if (st3.gt.pmax) st3 = pmax
          if (st3.lt.0.)   st3 = 0.0
          st4 = (b3 + st3)/a3
          st5 = (b4 + st4)/a4
          st6 = (b5 + st5*a6)/a5

c --      update time constant variables if time step changed
          if (al .ne. 0.0) then
            a3    = a3 *tfac - tfac + 1.
            a4    = a4 *tfac - tfac + 1.
            a1p   = a1p*tfac - tfac + 1.
            a6    = a6 *tfac - tfac + 1.
            a5    = a5 *tfac - tfac + 1.
          endif

c --      update past state values
          b1 = -sgk*wnow + st1*(a1p - 2.)
          b3 =  st4*(a3 - 2.) + st3
          b4 =  st5*(a4 - 2.) + st4
          b5 =  st6*(a5 - 2.) - st5*(a6 - 2.)

          c1 = a6/(a3*a4*a5)
          c2 = b3*c1 + b4*c1*a3 + b5/a5

          govmx(ispf) = pmax*c1 + c2
          govmn(ispf) = c2

          a1gov = (-sgk*c1)/a1p
          a2gov = c2 + pgo*c1 + (b1*c1)/a1p

        endif

        govpow = a1gov*wnew + a2gov
        if (govpow.gt.govmx(ispf)) govpow = govmx(ispf)
        if (govpow.lt.govmn(ispf)) govpow = govmn(ispf)
        govpow = govpow - a2p*vmt*vmt*wnewp

      else if (mgov.eq.4) then
c -------------------------- Process GW Governor --------------------
        if (lppwr.eq.0) then

c --      update states using converged input and output
          st1 = (b1 - sgkp1*wnow*a2p)/a1p
          st2 = (st1 + b3)/a3
          st3 =  st2 + pgo
          if (st3.gt.pmax) st3 = pmax
          if (st3.lt.pmin) st3 = pmin
          st4 = (st3 + b4)/a4
          st5 = (st4 + b5)/a5

c --      update time constant variables if time step changed
          if (al.ne.0.0) then
            a1p    = a1p*tfac - tfac + 1.
            a2p    = a2p*tfac - tfac + 1.
            a3     = a3 *tfac - tfac + 1.
            a4     = a4 *tfac - tfac + 1.
            a5     = a5 *tfac - tfac + 1.
            a1gov  = -sgkp1*a2p/(a1p*a3)
            a1turb = (3./a5-2.)/a4
          endif

c --      update past state values
          b1 = sgkp1*wnow*(a2p - 2.) + st1*(a1p - 2.)
          b3 = st1 + (a3 - 2.)*st2
          b4 = st3 + st4*(a4 - 2.)
          b5 = st4 + st5*(a5 - 2.)

          a2gov  = pgo + b3/a3 + b1/(a1p*a3)
          a2turb = 3.*b5/a5 + (b4/a4)*(3./a5 - 2.)

        endif

        govpow = a1gov*wnew + a2gov
        if (govpow.gt.pmax) govpow=pmax
        if (govpow.lt.pmin) govpow=pmin
        govpow = a1turb*govpow + a2turb

      else if (mgov.ge.5) then
c -------------------------- Process GS Governor --------------------
        if (lppwr.eq.0) then

c --      update states using converged input and output
          st1 = (b1 - sgkp1*wnow*a2p)/a1p

          st3 = a1gov*wnow + a2gov
          if (st3.gt.govmx(ispf)) st3 = govmx(ispf)
          if (st3.lt.govmn(ispf)) st3 = govmn(ispf)

          st2 = (pgo + st1 - st3)/((a3 - 1.0)*(ddt2/2.0))
          if (st2.gt.velmax) st2=velmax
          if (st2.lt.velmin) st2=velmin

          st3 = (st2 + b3)*ddt2/2.
          if (st3.gt.pmax) st3=pmax
          if (st3.lt.pmin) st3=pmin

          st4=(st3+b4)/a4

          if (mgov.ge.6) then
            st5 = (st4 + b5 )/a5
            st6 = (st5 + b6p)/a6p
            st7 = (st6 + b7 )/a7
          endif

c --      update time constant variables if time step changed
          if (al.ne.0.0) then
            a1p = a1p*tfac - tfac + 1.
            a2p = a2p*tfac - tfac + 1.
            a3  = a3 *tfac - tfac + 1.
            a4  = a4 *tfac - tfac + 1.
            a5  = a5 *tfac - tfac + 1.

            if (mgov.ge.6) then
              a6p = a6p*tfac - tfac + 1.
              a7  = a7 *tfac - tfac + 1.
            endif

            a1gov  = -sgkp1*a2p/(a1p*a3)

            if (mgov.eq.5) then
              a1turb = 1./a4
            else if (mgov.eq.6) then
              a1turb = (sgk1 + (sgk3 + sgk5/a6p)/a5)/a4
            else if (mgov.eq.7) then
              a1turb = (sgk1 + (sgk3 + (sgk5+sgk7/a7)/a6p)/a5)/a4
            else if (mgov.eq.8) then
              a1turb = (sgk1 + sgk5/a6p/a5)/a4
              a1turl = (sgk4 + sgk6/a6p)/a5/a4
            else if (mgov.eq.9) then
              a1turb = (sgk1 + sgk3/a5)/a4
              a1turl = sgk6/a6p/a5/a4
            else if (mgov.eq.10) then
              a1turb = (sgk1 + (sgk5+sgk7/a7)/a6p/a5)/a4
              a1turl = (sgk4 + (sgk6+sgk8/a7)/a6p)/a5/a4
            endif
          endif

c --      update past state values
          b1 = sgkp1*wnow*(a2p-2.) + st1*(a1p-2.)
          if (st3.lt.pmax.and.st3.gt.pmin) then
            b3 = st2 + (2./edt)*st3
          else
            b3 = (2./edt)*st3
          end if
          b4 = st3 + st4*(a4 - 2.)
          if (mgov.ge.6) then
            b5  = st4 + st5*(a5  - 2.)
            b6p = st5 + st6*(a6p - 2.)
            b7  = st6 + st7*(a7  - 2.)
          endif

          govmx(ispf) = pmax
          govmn(ispf) = pmin
          st3h = (b3 + velmax)*edt/2.
          st3l = (b3 + velmin)*edt/2.
          if (st3h.lt.govmx(ispf)) govmx(ispf) = st3h
          if (st3l.gt.govmn(ispf)) govmn(ispf) = st3l

          a2gov  = (pgo + b1/a1p + b3*(a3 - 1.)*(edt/2.))/a3

          if (mgov.eq.5) then
            a2turb = b4/a4
          else if (mgov.eq.6) then
            sgk6p  = sgk5/a6p
            sgk5p  = (sgk3+sgk6p)/a5
            a2turb = b4*a1turb + b5*sgk5p + b6p*sgk6p
          else if (mgov.eq.7) then
            sgk7p  = sgk7/a7
            sgk6p  = (sgk5 + sgk7p)/a6p
            sgk5p  = (sgk3 + sgk6p)/a5
            a2turb = b4*a1turb + b5*sgk5p + b6p*sgk6p + b7*sgk7p
          else if (mgov.eq.8) then
            sgk6p  = sgk5/a6p
            sgk5p  = sgk6p/a5
            a2turb = b6p*sgk6p + b5*sgk5p + b4*a1turb
            sgk6p  = sgk6/a6p
            sgk5p  = (sgk4 + sgk6p)/a5
            a2turl = b6p*sgk6p + b5*sgk5p + b4*a1turl
          else if (mgov.eq.9) then
            a2turb = (sgk3/a5)*b5 + b4*a1turb
            a2turl = sgk6*(b6p + (b5 + b4/a4)/a5)/a6p
          else if (mgov.eq.10) then
            sgk7p  = sgk7/a7
            sgk6p  = (sgk5 + sgk7p)/a6p
            sgk5p  = sgk6p/a5
            a2turb = b7*sgk7p + b6p*sgk6p + b5*sgk5p + b4*a1turb
            sgk7p  = sgk8/a7
            sgk6p  = (sgk6 + sgk7p)/a6p
            sgk5p  = (sgk4 + sgk6p)/a5
            a2turl = b7*sgk7p + b6p*sgk6p + b5*sgk5p + b4*a1turl
          endif

        endif

        govpow = a1gov*wnew + a2gov
        if (govpow.gt.govmx(ispf)) govpow = govmx(ispf)
        if (govpow.lt.govmn(ispf)) govpow = govmn(ispf)
        govpow = a1turb*govpow + a2turb

      endif

      govpwr(ispf) = govpow

      if (mgov .ge. 8) then
        ispl = idatat(4)
        govpwr(ispl) = a1turl*govpow + a2turl
      endif

      return
      end


	SUBROUTINE IS_TURB ( report, lenr, ibegin, iptrin, mxp, stidnt,
     +			     icorr, lunf, phen, origin, iret )
C************************************************************************
C* IS_TURB 								*
C*									*
C* This subroutine decodes the fields which may follow a TB		*
C* (turbulence), IC (icing), SQ (squall), or MW (mountain wave) report. *
C*                                                                      *
C* IS_TURB ( REPORT, LENR, IBEGIN, IPTRIN, MXP, STIDNT, ICORR, LUNF,    *
C*	     PHEN, ORIGIN, IRET )                                       *
C*									*
C* Input parameters:							*
C*	REPORT		CHAR*		International sigmet report     *
C*	LENR		INTEGER		Length of bulletin              *
C*	IBEGIN		INTEGER		Pointer to location before phen.*
C*	IPTRIN		INTEGER		Offset to pointer               *
C*	MXP   		INTEGER		Maximum number of points        *
C*	STIDNT		CHAR*		Time and message id string      *
C*	ICORR		INTEGER		Correction flag                 *
C*	PHEN		CHAR*		Phenomenon			*
C*	LUNF		INTEGER		ASCII output file number        *
C*	ORIGIN		CHAR*		Originating station id		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -4 = bad area definition       *
C*									*
C**									*
C* Log:									*
C* D. Kidwell/NCEP	10/99	                                        *
C* D. Kidwell/NCEP	11/99	Reset pointer following flight level    *
C* F. J. Yen/NCEP	 4/00	Updated for new paramter in IS_MOV	*
C* A. Hardy/NCEP	 9/02	Added origin parameter			*
C* F. J. Yen/NCEP	 9/03	Added check for FL earlier in report.	*
C*				Updated calling sequence to IS_AREA.	*
C* F. J. Yen/NCEP	 2/04	Added parameter PHEN to handle IC, SQ,	*
C*				and MW.	 (CSC)				*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	report, stidnt, phen, origin
C*
	INTEGER		iflvl (2)
	REAL   		rlat (20), rlon (20)
C------------------------------------------------------------------------
	iret  = 0
C
C*	Get the observed / forecast indicator.
C
	ibeg = ibegin + iptrin - 1
	lens = lenr - ibeg + 1
	istart = ibeg
	CALL IS_OBFC ( report ( ibeg:lenr ), lens, iobfc, iptr, iret )
	IF ( iret .lt. 0 ) THEN
	    iptr = 1
	END IF
C
C*	Get the flight level.
C
	ibeg = ibeg + iptr - 1
	lens = lenr - ibeg + 1
	CALL IS_FLVL ( report ( ibeg:lenr ), lens, iflflg, iflvl, iptr,
     +		       iret )
C
C*	Can't find flight level, look earlier in the report.
C
	IF ( iret .lt. 0 ) THEN
	    ibeg = istart
	    lens = lenr - ibeg + 1
	    CALL IS_FLVL ( report ( ibeg:lenr ), lens, iflflg, iflvl,
     +                     iptr, iret )
	    IF ( iret .lt. 0 ) iptr = 1
	END IF
C
C*	Set the pointer back to one in case area precedes flight level.
C
	iptr = 1
C
C*	Get the area covered by the phenomenon.
C
	ibeg = ibeg + iptr - 1
	lens = lenr - ibeg + 1
	CALL IS_AREA ( report ( ibeg:lenr ), lens, mxp, origin, npt,
     +		       rlat, rlon, irad, iptr, iret )
	IF ( iret .lt. 0 ) RETURN
C
C*	Get the direction and speed of movement.
C
	ibeg = ibeg + iptr - 1
	lens = lenr - ibeg + 1
	CALL IS_MOV ( report ( ibeg:lenr ), lens, 40, idir, ispd, iptr,
     +		      iret )
	IF ( iret .lt. 0 ) THEN
	    iptr = 1
	END IF
C
C*	Get the change in intensity.
C
	ibeg = ibeg + iptr - 1
	lens = lenr - ibeg + 1
	CALL IS_CHNG ( report ( ibeg:lenr ), lens, ichng, iptr, iret )
C
C*	Write out the phenomenon data.
C
	CALL IS_OUT ( lunf, phen, stidnt, origin, icorr,
     +		      iflflg, iflvl, idir, ispd, ' ', irad, rlat,
     +		      rlon, npt, iret )
C*
	RETURN
	END


      subroutine plots_stop_cfmt(p,wt,wt2)
c--- routine to provide a plotting interface that produces the plots
c--- for both single top processes (2->2 and 2->3)
c--- of Campbell, Frederix, Maltoni and Tramontano
      implicit none
      include 'constants.f'
      include 'jetlabel.f'
      include 'nplot.f'
      include 'process.f'
      include 'first.f'
      integer i,n,nplotmax,jet(2),jetswap,ibbar,inotb,ilight1,ilight2
      double precision p(mxpart,4),wt,wt2,getet,
     . pttop,etatop,ytop,bwgt,
     . pt,etarap,yrap,ptthree,etarapthree,yrapthree,
     . wtbbar,wtnotb,wtlight1,wtlight2,
     . wtbbar2,wtnotb2,wtlight12,wtlight22,
     . ptmin,ptmax,ptbin,rapmin,rapmax,rapbin
      character*4 tag
      logical jetmerge
      common/jetmerge/jetmerge
      common/btagging/bwgt
      common/nplotmax/nplotmax
!$omp threadprivate(/jetmerge/)
ccccc!$omp threadprivate(/nplotmax/)

c--- on the first call, initialize histograms
      if (first) then
        tag='book'
      pttop=-1d0
      etatop=1d3
      ytop=1d3
      ibbar=6
      inotb=7
      ilight1=6
      ilight2=7
      goto 99
      else
        tag='plot'
      endif

c--- check that this routine is being used for one of the envisaged
c--- processes and, if so, initialize variables accordingly
      if     (case .eq. 'bq_tpq') then
        if (jets .gt. 0) then
        do i=1,jets
          jet(i)=5+i ! jets start with parton 6 when removebr=.true.
        enddo
        pttop=ptthree(3,4,5,p)
        etatop=etarapthree(3,4,5,p)
        ytop=yrapthree(3,4,5,p)
      endif

      elseif (case .eq. 'qg_tbq') then
        if (jets .gt. 0) then
        do i=1,jets
          jet(i)=4+i ! jets start with parton 5
        enddo
        pttop=pt(3,p)
        etatop=etarap(3,p)
        ytop=yrap(3,p)
      endif
      else
        write(6,*) 'This plotting routine is not suitable for'
      write(6,*) 'the process that you are calculating.'
      stop
      endif

c--- there are at most two jets; reorder them according to pt if two
      if (jets .eq. 2) then
        if (pt(jet(2),p) .gt. pt(jet(1),p)) then
        jetswap=jet(1)
        jet(1)=jet(2)
        jet(2)=jetswap
      endif
      endif

c--- initialize all variabels to zero
      ibbar=0
      inotb=0
      ilight1=0
      ilight2=0

c--- Extract index to b~ (b for t~) in the 2->2 process
c--- Events should be plotted with weight = wt*bwgt instead of just wt
c--- (adapted from original code in nplotter.f by Z. Sullivan)
      if (case .eq. 'bq_tpq') then
c--- 1) Ascertain the identity of the jets
        if (jets .gt. 0) then
c---     There are 2 cases:
c---     If no merging, then only if jetlabel(i)=='pp' is it the b~.
          do i=1,jets
            if     (jetlabel(jet(i)-5).eq.'pp') then
            ibbar=jet(i)
            elseif (jetlabel(jet(i)-5).eq.'qj') then
            inotb=jet(i)
            endif
          enddo
c---      If merging occurred, then it matters whether the merged
c---      jet was already a bq or not.
          if (jetmerge) then
            ibbar=jet(1)   ! b~ was merged into jet(1)
          endif
      endif
c--- 2) Assign weights for histogramming
c---     there are three cases
        if     (jets .eq. 1) then
          if     (jetlabel(1) .eq. 'qj') then
c---     1) only one jet, that is definitely not a b
c---             jetlabel = (qj)
          ibbar=0
c           inotb already set above
          wtnotb=wt
          wtnotb2=wt2
        elseif (jetlabel(1) .eq. 'pp') then
c---     2) only one jet, that could be a b
c---             jetlabel = (pp)
c           ibbar already set above
          inotb=ibbar
          wtbbar=wt*bwgt
          wtnotb=wt*(1d0-bwgt)
          wtbbar2=wt2*bwgt**2
          wtnotb2=wt2*(1d0-bwgt)**2
          endif
c---     3) two jets, one of which could be a b
c---             jetlabel = (qj,pp) OR (pp,qj)
        elseif (jets .eq. 2) then
c         ibbar already set above
c         inotb already set above
          wtbbar=wt*bwgt
        wtnotb=wt*bwgt
        wtbbar2=wt2*bwgt**2
        wtnotb2=wt2*bwgt**2
          ilight1=jet(1) ! they are ordered according to pt
          ilight2=jet(2) ! they are ordered according to pt
        wtlight1=wt*(1d0-bwgt)
        wtlight2=wtlight1
        wtlight12=wt2*(1d0-bwgt)**2
        wtlight22=wtlight12
        elseif (jets .eq. 0) then
c---   nothing to set: all variables=0, only occurs when notag=1
          continue
        else
          write(6,*) 'Error: there should be 1 or 2 jets, instead ',jets
        stop
        endif
      endif

c--- Simpler manipulations for the 2->3 process
      if (case .eq. 'qg_tbq') then
        ibbar=4
      wtbbar=wt
      wtbbar2=wt2
      if (jets .gt. 0) then
        ilight1=jet(1)
        wtlight1=wt
        wtlight12=wt2
      endif
      if (jets .gt. 1) then
        ilight2=jet(2)
        wtlight2=wt
        wtlight22=wt2
      endif
c--- inotb should remain equal to zero
      endif

   99 continue
      n=1

c--- fill plots
c--- available veriables are
c---   pttop,eta,ytop: pt, pseudo-rapidity and rapidity of the top quark

      call bookplot(n,tag,'pt(top) ',pttop,wt,wt2,0d0,200d0,5d0,'log')
      n=n+1
      call bookplot(n,tag,'eta(top)',etatop,wt,wt2,-8d0,8d0,0.5d0,'lin')
      n=n+1
      call bookplot(n,tag,'y(top)  ',ytop,wt,wt2,-8d0,8d0,0.5d0,'lin')
      n=n+1

c--- more complicated procedure for these plots, due to 2->2 process
c---  pt and rapidity of the b-quark and other jets
c---  Note that the order is important (due to histogram finalizing):
c---     all plots for jet 1, all for bottom quark, all for jet 2

c--- set the ranges and bin sizes here
      ptmin=0d0
      ptmax=200d0
      ptbin=2d0
      rapmin=-5d0
      rapmax=+5d0
      rapbin=0.2d0

c--- 1) leading jet that isn't a b
c---    first account for events with only one non b jet (always occurs)
c---    (always occurs, except if notag=1)
c--- [pt]
      if (inotb .ne. 0) then
      call bookplot(n,tag,'pt(jet 1)',
     . pt(inotb,p),wtnotb,wtnotb2,ptmin,ptmax,ptbin,'log')
      endif
c---    then account for events with two non b jets (only if ilight1>0)
      if (ilight1 .ne. 0) then
      call bookplot(n,tag,'pt(jet 1)',
     . pt(ilight1,p),wtlight1,wtlight12,ptmin,ptmax,ptbin,'log')
      endif
      n=n+1
c--- [rapidity]
      if (inotb .ne. 0) then
      call bookplot(n,tag,'eta(jet 1)',
     . etarap(inotb,p),wtnotb,wtnotb2,rapmin,rapmax,rapbin,'lin')
      endif
c---    then account for events with two non b jets (only if ilight1>0)
      if (ilight1 .ne. 0) then
      call bookplot(n,tag,'eta(jet 1)',
     . etarap(ilight1,p),wtlight1,wtlight12,rapmin,rapmax,rapbin,'lin')
      endif
      n=n+1

c--- 2) b jet (only if ibbar>0)
c--- [pt]
      if (ibbar .ne. 0) then
      call bookplot(n,tag,'pt(bottom)',
     . pt(ibbar,p),wtbbar,wtbbar2,ptmin,ptmax,ptbin,'log')
      endif
      n=n+1
c--- [pt] with |rapidity| < 2.8  (plot for CDF)
      if (ibbar .ne. 0) then
        if ((abs(etarap(ibbar,p)) .lt. 2.8d0).or.(tag .eq. 'book')) then
        call bookplot(n,tag,'pt(bottom) with |eta(bottom)| < 2.8',
     .   pt(ibbar,p),wtbbar,wtbbar2,ptmin,ptmax,ptbin,'log')
        endif
      endif
      n=n+1
c--- [rapidity]
      if (ibbar .ne. 0) then
      call bookplot(n,tag,'eta(bottom)',
     . etarap(ibbar,p),wtbbar,wtbbar2,rapmin,rapmax,rapbin,'lin')
      endif
      n=n+1
c--- [rapidity] < 2.8 and pt > 20 GeV (plot for acceptance in CDF)
      if (ibbar .ne. 0) then
        if ((pt(ibbar,p) .gt. 20d0).or.(tag .eq. 'book')) then
        call bookplot(n,tag,'eta(bottom) with pt(bottom)>20 GeV',
     .   etarap(ibbar,p),wtbbar,wtbbar2,-2.8d0,2.801d0,rapbin,'lin')
        endif
      endif
      n=n+1
c--- [rapidity] < 2.8 and pt > 20 GeV (plot for acceptance in CDF)
      if (ibbar .ne. 0) then
        if ((getet(p(ibbar,4),p(ibbar,1),p(ibbar,2),p(ibbar,3)).gt.20d0)
     .      .or.(tag .eq. 'book')) then
        call bookplot(n,tag,'eta(bottom) with Et(bottom)>20 GeV',
     .   etarap(ibbar,p),wtbbar,wtbbar2,-2.8d0,2.801d0,rapbin,'lin')
        endif
      endif
      n=n+1

c--- 3) subleading jet that isn't a b (only if ilight2>0)
c--- [pt]
      if (ilight2 .ne. 0) then
      call bookplot(n,tag,'pt(jet 2)',
     . pt(ilight2,p),wtlight2,wtlight22,ptmin,ptmax,ptbin,'log')
      endif
      n=n+1
c--- [rapidity]
      if (ilight2 .ne. 0) then
      call bookplot(n,tag,'eta(jet 2)',
     . etarap(ilight2,p),wtlight2,wtlight22,rapmin,rapmax,rapbin,'lin')
      endif
      n=n+1

c--- copied from nplotter.f
      n=n-1

      if (n .gt. maxhisto) then
        write(6,*) 'WARNING - TOO MANY HISTOGRAMS!'
        write(6,*) n,' > ',maxhisto,', which is the built-in maximum.'
      write(6,*) 'To use more histograms, change the value of the'
      write(6,*) 'constant MAXHISTO in src/Inc/nplot.f then do:'
      write(6,*)
      write(6,*) ' make clean; make        to recompile from scratch.'
        write(6,*)
      stop
      endif

c--- set the maximum number of plots, on the first call
      if (first) then
        first=.false.
        nplotmax=n
      endif

      return
      end