      subroutine plasticctr(iflg)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!
! Driver routine for plastic computations using FEHM algorithm
!
! Author : Sai Rapaka
!

      use comai
      use comsi

      implicit none

      integer iflg
      integer i,j,k,iterm,jterm
      logical null1
      character*10 macro1
      double precision, dimension(1:3, 1:3) :: tmp

      if(iflg.eq.initPlastic) then

         if(icnl.eq.0) then
           allocate(row(1:3,1:3,1:9))
           allocate(col(1:3,1:3,1:9))
           tmp(1,1) = 1; tmp(1,2) = 4; tmp(1,3) = 6;
           tmp(2,1) = 4; tmp(2,2) = 2; tmp(2,3) = 5;
           tmp(3,1) = 6; tmp(3,2) = 5; tmp(3,3) = 3;
           do i=1,3
             do j=1,3
               do k=1,9
                 iterm = floor((k-0.5)/3) + 1
                 jterm = k - (iterm-1)*3
                 row(i,j,k) = tmp(i,jterm)
                 col(i,j,k) = tmp(iterm,j)
!                 write(iout,*) i,j,k,row(i,j,k), col(i,j,k)
               enddo
             enddo
           enddo
         else
             allocate(row(1:2,1:2,1:4))
             allocate(col(1:2,1:2,1:4))
         endif

      elseif (iflg.eq.assemblePlastic) then
!        if(icnl.eq.0) then
!          call geneq_plastic_3D()
!        endif
      endif

      end subroutine plasticctr


      module Coupling_transform_JJJK
!
      use Coupling_constants
      use Coupling_structures
      use Coupling_data
      use Coupling_transform_cfg_JJJK
!
      public  :: main_JJJK
      private :: cfg_count
!
      private :: form_cfg_structure
      private :: delete_cfg_structure
!
      type(cfg_structure), private::cfg_structure_JJ
!
      integer, private :: nr_of_JJ_coupling
!
      contains
!
      subroutine main_JJJK (icoupling_nr_in_expansions,                &
                                        iinr_of_JJ_coupling,print_level)
!--------------------------------------------------------------------
! This is managerial subroutine
!--------------------------------------------------------------------
      implicit none
      integer, intent (in):: icoupling_nr_in_expansions
      integer, intent (in):: iinr_of_JJ_coupling, print_level
      integer::istate
      integer::icfg, icsf_JK
      integer::nr_of_csfs_JK, cfg_nr_of_csfs_JK
      real(kind=dp)::sum_of_state
!      write(*,*) '  subroutine main_JJJK'
      write(iwrite_log,*) ''
      write(iwrite_log,*) 'JK coupling:'
      nr_of_JJ_coupling = iinr_of_JJ_coupling
      if(nr_of_JJ_coupling.lt.1) then
         write(*,*)'ERROR in subroutine main_JJJK: ',                  &
            'nr_of_JJ_coupling.lt.1'
         write(*,*)'(not specified a serial number of expansions in ', &
            'JJ coupling); nr_of_JJ_coupling=', nr_of_JJ_coupling
         write(*,*)'program will be terminated'
         write(iwrite_log,*)'ERROR in subroutine main_JJJK: ',         &
            'nr_of_JJ_coupling.lt.1'
         write(iwrite_log,*)'(not specified a serial number of ',      &
            'expansions in JJ coupling); nr_of_JJ_coupling=',          &
            nr_of_JJ_coupling
         write(iwrite_log,*)'program will be terminated'
         stop
      end if
      if(coupling_descriptions(all_expansions%coupling_expansions(     &
                 nr_of_JJ_coupling)%icoupling)%short_name.ne.'JJ') then
         write(*,*) 'ERROR AT subroutine main_JJJK: ',                 &
           'coupling_descriptions(all_expansions%coupling_expansions(',&
           'inr_of_JJ_coupling)%icoupling)%short_name.ne.JJ'
         write(*,*) '(possibly - using JJ-JK transformation without ', &
           'JJ coupling, or coupling_descriptions(...) not correctly ',&
           'filled...)'
         write(*,*) 'program will be terminated'
         write(iwrite_log,*) 'ERROR AT subroutine main_JJJK: ',        &
            'coupling_descriptions(all_expansions%',                   &
            'coupling_expansions()%icoupling)%short_name.ne.JJ'
         write(iwrite_log,*) '(possibly - using JJ-JK transformation ',&
            'without JJ coupling, or coupling_descriptions(...) ',     &
            'not correctly filled...)'
         write(iwrite_log,*) 'program will be terminated'
         stop
      end if
      all_expansions%coupling_expansions(icoupling_nr_in_expansions)%  &
         nr_of_expansions = all_expansions%coupling_expansions(        &
         nr_of_JJ_coupling)%nr_of_expansions
      allocate(all_expansions%coupling_expansions(                     &
         icoupling_nr_in_expansions)%expansions(all_expansions%        &
         coupling_expansions(icoupling_nr_in_expansions)%              &
         nr_of_expansions))
      do istate=1, all_expansions%coupling_expansions(                 &
         icoupling_nr_in_expansions)%nr_of_expansions, 1
         all_expansions%coupling_expansions(                           &
            icoupling_nr_in_expansions)%expansions(istate)%nr_of_state &
            = all_expansions%coupling_expansions(nr_of_JJ_coupling)%   &
            expansions(istate)%nr_of_state
         call form_cfg_structure(istate)
         nr_of_csfs_JK=0
         do icfg=1, cfg_structure_JJ%nr_of_cfgs
            call form_expansion_cfg_JJ(istate, icfg)
            call count_nr_of_csfs_JK(cfg_nr_of_csfs_JK)
            nr_of_csfs_JK = nr_of_csfs_JK + cfg_nr_of_csfs_JK
            call delete_expansion_cfg_JJ
         end do
         all_expansions%coupling_expansions(                           &
            icoupling_nr_in_expansions)%expansions(istate)%size =      &
            nr_of_csfs_JK
         all_expansions%coupling_expansions(                           &
            icoupling_nr_in_expansions)%expansions(istate)%            &
            nr_of_state = istate
         allocate(all_expansions%coupling_expansions(                  &
            icoupling_nr_in_expansions)%expansions(istate)%coeffs(     &
            all_expansions%coupling_expansions(                        &
            icoupling_nr_in_expansions)%expansions(istate)%size))
         allocate(                                                     &
        all_expansions%coupling_expansions(icoupling_nr_in_expansions)%&
         expansions(istate)%csfs(all_expansions%coupling_expansions(   &
         icoupling_nr_in_expansions)%expansions(istate)%size))
         nr_of_csfs_JK=0
         sum_of_state = ZERO_dp
         do icfg=1, cfg_structure_JJ%nr_of_cfgs
            call form_expansion_cfg_JJ(istate, icfg)
            call main_cfg_JJJK(print_level)
            do icsf_JK=1, expansion_cfg_JK%size, 1
               nr_of_csfs_JK = nr_of_csfs_JK + 1
               if(nr_of_csfs_JK.gt.all_expansions%coupling_expansions( &
                   icoupling_nr_in_expansions)%expansions(istate)%size)&
                                                             then
                   write(*,*) 'STOP at subroutine main_JJjj  : ',      &
                    'nr_of_csfs_JK.gt.',                               &
               'all_expansions%coupling_expansions()%expansions()%size'
                   stop
               end if
               all_expansions%coupling_expansions(                     &
                  icoupling_nr_in_expansions)%expansions(istate)%      &
                  csfs(nr_of_csfs_JK)=expansion_cfg_JK%csfs(icsf_JK)
               all_expansions%coupling_expansions(                     &
                  icoupling_nr_in_expansions)%expansions(istate)%      &
                  coeffs(nr_of_csfs_JK)=expansion_cfg_JK%coeffs(icsf_JK)
               sum_of_state = sum_of_state +                           &
                  all_expansions%coupling_expansions(                  &
                  icoupling_nr_in_expansions)%expansions(istate)%      &
                  coeffs(nr_of_csfs_JK) *                              &
                  all_expansions%coupling_expansions(                  &
                  icoupling_nr_in_expansions)%expansions(istate)%      &
                  coeffs(nr_of_csfs_JK)
            end do
            call delete_cfg_expansions
         end do
         if((sum_of_state-TWO_dp*dp_coeff_precision).gt.ONE_dp) then
            write(*,*) 'POSSIBLE ERROR at subroutine main_JJJK: ',     &
               'sum_of_state.gt.1: sum_of_state = ', sum_of_state
            write(iwrite_log,*)                                        &
               'POSSIBLE ERROR at subroutine main_JJJK: ',             &
               'sum_of_state.gt.1: sum_of_state = ', sum_of_state
         end if
         if(istate == 1) write(iwrite_log,*)                           &
         'State number   Expansion size   Summation rules'
         write(iwrite_log,*) istate,nr_of_csfs_JK,'   ',sum_of_state
         call delete_cfg_structure
      end do
!      write(*,*) '  end subroutine main_JJJK'
!
      contains
!
         subroutine form_expansion_cfg_JJ(istate, icfg)
!--------------------------------------------------------------------
! This subroutine forms oneconfigurational
! expansion "expansion_cfg_JJ"
! of the state with serial number "istate"
! of configuration with serial number "icfg"
!--------------------------------------------------------------------
         integer, intent(in) :: istate, icfg
         integer::icsf
         expansion_cfg_JJ%size =                                       &
                           cfg_structure_JJ%csfs_lists(icfg)%list_size
         expansion_cfg_JJ%nr_of_state =                                &
            all_expansions%coupling_expansions(nr_of_JJ_coupling)%     &
            expansions(istate)%nr_of_state
         allocate(expansion_cfg_JJ%csfs(expansion_cfg_JJ%size))
         allocate(expansion_cfg_JJ%coeffs(expansion_cfg_JJ%size))
         do icsf=1, expansion_cfg_JJ%size
            expansion_cfg_JJ%coeffs(icsf) =                            &
               all_expansions%coupling_expansions(nr_of_JJ_coupling)%  &
               expansions(istate)%coeffs(cfg_structure_JJ%csfs_lists(  &
               icfg)%items(icsf))
            expansion_cfg_JJ%csfs(icsf) =                              &
               all_expansions%coupling_expansions(nr_of_JJ_coupling)%  &
               expansions(istate)%csfs(cfg_structure_JJ%csfs_lists(    &
               icfg)%items(icsf))
         end do
         end subroutine form_expansion_cfg_JJ
!
         subroutine delete_expansion_cfg_JJ
!--------------------------------------------------------------------
! This subroutine deallocates the arrays of "expansion_cfg_JJ"
!--------------------------------------------------------------------
         integer::error
         integer::icsf
         if(associated(expansion_cfg_JJ%csfs)) then
            do icsf=1, expansion_cfg_JJ%size
               if(associated(expansion_cfg_JJ%csfs(icsf)%subc_cfg))    &
             deallocate(expansion_cfg_JJ%csfs(icsf)%subc_cfg,STAT=error)
               if(associated(expansion_cfg_JJ%csfs(icsf)%subc))        &
                 deallocate(expansion_cfg_JJ%csfs(icsf)%subc,STAT=error)
               if(associated(expansion_cfg_JJ%csfs(icsf)%iM1))         &
                 deallocate(expansion_cfg_JJ%csfs(icsf)%iM1, STAT=error)
               if(associated(expansion_cfg_JJ%csfs(icsf)%iM2))         &
                 deallocate(expansion_cfg_JJ%csfs(icsf)%iM2, STAT=error)
               if(associated(expansion_cfg_JJ%csfs(icsf)%iJ))          &
                 deallocate(expansion_cfg_JJ%csfs(icsf)%iJ, STAT=error)
            end do
            deallocate(expansion_cfg_JJ%csfs, STAT=error)
         end if
         deallocate(expansion_cfg_JJ%coeffs, STAT=error)
         end subroutine delete_expansion_cfg_JJ
!
!subroutine print_cfg_structure
!--------------------------------------------------------------------
! This subroutine prints the "cfg_structure_JJ" to the unit "iwrite_log2"
!--------------------------------------------------------------------
!	integer::icfg, icsf
!	write(iwrite_log2,*)'********************************************'
!	write(iwrite_log2,*)'cfg structure: '
!	write(iwrite_log2,*)'istate,  nr_of_cfgs', istate, cfg_structure_JJ%nr_of_cfgs
!	!
!	do icfg=1,cfg_structure_JJ%nr_of_cfgs
!		write(iwrite_log2,*)'  list_size:', cfg_structure_JJ%csfs_lists(icfg)%list_size
!		!write csfs in cfg_structure
!		do icsf=1, cfg_structure_JJ%csfs_lists(icfg)%list_size
!			write(iwrite_log2,*)'          csf:', cfg_structure_JJ%csfs_lists(icfg)%items(icsf)
!		end do
!	end do
!end subroutine print_cfg_structure
!
      end subroutine main_JJJK

!---------  subroutine form_cfg_structure  ------
!
      subroutine form_cfg_structure(istate)
!--------------------------------------------------------------------
! This subroutine forms the structure "cfg_structure_JJ"
!--------------------------------------------------------------------
      implicit none
      integer, intent(in)::istate
      integer::icsf, icfg, inr_of_csfs_of_cfg
      cfg_structure_JJ%nr_of_cfgs=cfg_count(istate)
      allocate(cfg_structure_JJ%csfs_lists(cfg_structure_JJ%           &
                                                           nr_of_cfgs))
      icfg=1
      inr_of_csfs_of_cfg=1
      do icsf=2,all_expansions%coupling_expansions(nr_of_JJ_coupling)% &
                                                expansions(istate)%size
         if(the_same_cfg(all_expansions%coupling_expansions(           &
            nr_of_JJ_coupling)%expansions(istate)%csfs(icsf-1),        &
            all_expansions%coupling_expansions(nr_of_JJ_coupling)%     &
            expansions(istate)%csfs(icsf))) then
            inr_of_csfs_of_cfg = inr_of_csfs_of_cfg + 1
         else
            cfg_structure_JJ%csfs_lists(icfg)%list_size =              &
               inr_of_csfs_of_cfg
            allocate(cfg_structure_JJ%csfs_lists(icfg)%items(          &
              cfg_structure_JJ%csfs_lists(icfg)%list_size))
            inr_of_csfs_of_cfg = 1
            icfg=icfg+1
         end if
      end do
      cfg_structure_JJ%csfs_lists(icfg)%list_size=inr_of_csfs_of_cfg
      allocate(cfg_structure_JJ%csfs_lists(icfg)%items(                &
        cfg_structure_JJ%csfs_lists(icfg)%list_size))
      inr_of_csfs_of_cfg = 1
      do icfg=1, cfg_structure_JJ%nr_of_cfgs, 1
         do icsf=1, cfg_structure_JJ%csfs_lists(icfg)%list_size, 1
            cfg_structure_JJ%csfs_lists(icfg)%items(icsf) =            &
               inr_of_csfs_of_cfg
            inr_of_csfs_of_cfg = inr_of_csfs_of_cfg + 1
         end do
      end do
!
      end subroutine form_cfg_structure
!
!---------  subroutine delete_cfg_structure  ------
!
      subroutine delete_cfg_structure
!--------------------------------------------------------------------
! This subroutine deallocates the arrays of the structure "cfg_structure_JJ"
!--------------------------------------------------------------------
      implicit none
      integer::error
      integer::icfg
      if(associated(cfg_structure_JJ%csfs_lists)) then
         do icfg=1,cfg_structure_JJ%nr_of_cfgs
            if(associated(cfg_structure_JJ%csfs_lists(icfg)%items))    &
               deallocate(cfg_structure_JJ%csfs_lists(icfg)%items,     &
                                                            STAT=error)
         end do
         deallocate(cfg_structure_JJ%csfs_lists, STAT=error)
      end if
      end subroutine delete_cfg_structure
!
!--------  function cfg_count    ----------------
!
      function cfg_count(istate)   result(irez)
!--------------------------------------------------------------------
! This function counts number of diffferent
! configurations in the expansion of the state "istate"
!--------------------------------------------------------------------
      implicit none
      integer::istate, icsf
      integer::irez
      if(istate.eq.0) then
         irez=0
      else
         if(istate.ne.all_expansions%coupling_expansions(              &
            nr_of_JJ_coupling)%expansions(istate)%nr_of_state) then
            write(*,*)                                                 &
        'STOP at subroutine cfg_count module Coupling_transform_JJJK:',&
           ' istate.ne.expansion(nr_of_JJ_coupling)(istate)%nr_of_state'
            stop
         end if
         irez=1
         do icsf=2,all_expansions%coupling_expansions(                 &
                             nr_of_JJ_coupling)%expansions(istate)%size
!there assumed that csfs in expansion is ordered so that
!they are in groups of csfs of teh same cfg
            if(.not. the_same_cfg(all_expansions%coupling_expansions(  &
               nr_of_JJ_coupling)%expansions(istate)%csfs(icsf-1),     &
               all_expansions%coupling_expansions(nr_of_JJ_coupling)%  &
               expansions(istate)%csfs(icsf))) then
               irez=irez+1
            end if
         end do
      end if
      end function
!
      end module


C$Procedure      ZZCKE06 ( C-Kernel, evaluate, type 6 )

      SUBROUTINE ZZCKE06 ( RECORD, QSTATE, CLKOUT )

C$ Abstract
C
C     SPICE Private routine intended solely for the support of SPICE
C     routines.  Users should not call this routine directly due
C     to the volatile nature of this routine.
C
C     Evaluate a single data record from a type 6 CK segment. The
C     output is expressed as an interpolated unit quaternion and
C     quaternion derivative rather than as a C-matrix and angular
C     velocity vector.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     CK
C
C$ Keywords
C
C     POINTING
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE 'ck06.inc'
      INCLUDE 'ckparam.inc'

      DOUBLE PRECISION      RECORD   ( * )
      DOUBLE PRECISION      QSTATE   ( * )
      DOUBLE PRECISION      CLKOUT

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     RECORD    I-O  Data type 6 record.
C     QSTATE     O   Interpolated output record.
C     CLKOUT     O   SCLK associated with input record.
C
C$ Detailed_Input
C
C     RECORD      is a record from a type 6 CK segment which, when
C                 evaluated at the epoch contained in its first
C                 element, will give the attitude and angular velocity
C                 of a spacecraft structure or instrument relative to a
C                 base reference frame.
C
C                 The structure of the record is as follows:
C
C                    +----------------------+
C                    | evaluation epoch     |
C                    +----------------------+
C                    | subtype code         |
C                    +----------------------+
C                    | number of packets (n)|
C                    +----------------------+
C                    | nominal SCLK rate    |
C                    +----------------------+
C                    | packet 1             |
C                    +----------------------+
C                    | packet 2             |
C                    +----------------------+
C                             .
C                             .
C                             .
C                    +----------------------+
C                    | packet n             |
C                    +----------------------+
C                    | epochs 1--n          |
C                    +----------------------+
C
C                See the CK Required Reading or the include file
C                ck06.inc for details on CK type 6 packet contents.
C
C
C$ Detailed_Output
C
C     RECORD     has been modified due to its use as a workspace array.
C                The contents are undefined.
C
C     QSTATE     is an interpolated output record, represented as a unit
C                quaternion and its derivative with respect to time.
C
C     CLKOUT     is the encoded SCLK associated with the returned
C                C-matrix and angular velocity vector.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the input record contains an unrecognized subtype code,
C         the error SPICE(NOTSUPPORTED) is signaled.
C
C     2)  If the record subtype is one for which quaternion derivatives
C         are stored (subtypes 0 and 2), and if the Ith quaternion in
C         the input record is farther than its negative from the (I-1)st
C         quaternion in the record, the error SPICE(BADQUATSIGN)
C         is signaled.
C
C         For subtypes 1 and 3, this condition is not considered an
C         error: the closer to the preceding quaternion of the two
C         quaternion representations is used for interpolation.
C
C     3)  If a zero-magnitude quaternion is produced as a result
C         of interpolating quaternions, the error SPICE(DIVIDEBYZERO)
C         is signaled.
C
C     4)  If the input record contains a non-positive SCLK rate value,
C         the error SPICE(INVALIDSCLKRATE) is signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine returns quaternion states that, presuming validity
C     of the input record, are suitable for interpolation, unlike
C     quaternion states obtained by calling CKE06 and then M2Q. The
C     latter method of obtaining quaternions is subject to branch
C     singularities.
C
C     The exact format and structure of CK type 6 (MEX/Rosetta Attitude
C     file interpolation) CK segments is described in the CK Required
C     Reading.
C
C$ Examples
C
C     None.
C
C$ Restrictions
C
C     1)  This routine performs minimal error checking. The input data
C         are assumed to have been checked when the source CK file was
C         created.
C
C     2)  With the exception of the check described in item 2 of
C         the Exceptions section above, the input data are assumed to
C         be suitable for the interpolation method specified by the
C         input record's subtype and packet count (which implies an
C         interpolating polynomial degree).
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C     B.V. Semenov   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 10-AUG-2015 (NJB) (BVS)
C
C-&

C$ Index_Entries
C
C     evaluate type_6 ck_segment
C
C-&

C$ Revisions
C
C     None.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      LGRINT
      DOUBLE PRECISION      VDISTG
      DOUBLE PRECISION      VDOTG
      DOUBLE PRECISION      VNORMG

      LOGICAL               RETURN

C
C     Local parameters
C

C
C     Index of evaluation epoch in record:
C
      INTEGER               EPCIDX
      PARAMETER           ( EPCIDX = 1 )

C
C     Index of subtype code in record:
C
      INTEGER               SBTIDX
      PARAMETER           ( SBTIDX = 2 )

C
C     Index of packet count in record:
C
      INTEGER               CNTIDX
      PARAMETER           ( CNTIDX = 3 )

C
C     Index at which packets start; packet base:
C
      INTEGER               PKTIDX
      PARAMETER           ( PKTIDX = 5 )

      INTEGER               PKTBAS
      PARAMETER           ( PKTBAS = PKTIDX - 1 )

C
C     Local variables
C
      DOUBLE PRECISION      AV     ( 3 )
      DOUBLE PRECISION      DQ     ( 0 : 3 )
      DOUBLE PRECISION      DS     ( 0 : 3 )
      DOUBLE PRECISION      LOCREC ( CKMRSZ )
      DOUBLE PRECISION      MAGS
      DOUBLE PRECISION      Q      ( 0 : 3 )
      DOUBLE PRECISION      QAV    ( 0 : 3 )
      DOUBLE PRECISION      QNEG   ( 0 : 3 )
      DOUBLE PRECISION      RADTRM ( 0 : 3 )
      DOUBLE PRECISION      RATE
      DOUBLE PRECISION      SCLDDQ ( 0 : 3 )
      DOUBLE PRECISION      SCLKDP
      DOUBLE PRECISION      STATE  ( 8 )
      DOUBLE PRECISION      VBUFF  ( 6 )
      DOUBLE PRECISION      WORK   ( CKMRSZ * 2,  2 )

      INTEGER               FROM
      INTEGER               I
      INTEGER               J
      INTEGER               N
      INTEGER               NEWPTR
      INTEGER               PACKSZ
      INTEGER               PKTSZS ( 0 : C06NST-1 )
      INTEGER               PRVPTR
      INTEGER               SUBTYP
      INTEGER               TO
      INTEGER               XSTART
      INTEGER               YSTART

C
C     Saved variables
C
      SAVE                  PKTSZS

C
C     Initial values
C
      DATA                  PKTSZS / C06PS0, C06PS1, C06PS2, C06PS3 /

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'ZZCKE06' )

C
C     Transfer the input record's epoch to the output epoch.
C
      CLKOUT = RECORD(1)

C
C     Capture the subtype from the record and set the packet size
C     accordingly.
C
      SUBTYP =  NINT( RECORD(SBTIDX) )

      IF (  ( SUBTYP .LT. 0 ) .OR. ( SUBTYP .GE. C06NST)  )  THEN

         CALL SETMSG ( 'Unexpected CK type 6 subtype # found in '
     .   //            'type 6 segment.'                          )
         CALL ERRINT ( '#',  SUBTYP                               )
         CALL SIGERR ( 'SPICE(NOTSUPPORTED)'                      )
         CALL CHKOUT ( 'ZZCKE06'                                  )
         RETURN

      ELSE

         PACKSZ = PKTSZS( SUBTYP )

      END IF

C
C     Get the packet count and epoch.
C
      N       =  NINT( RECORD(CNTIDX) )
      SCLKDP  =        RECORD(EPCIDX)

C
C     Get the nominal clock rate.
C
      RATE = RECORD(4)

      IF ( RATE .LE. 0.D0 ) THEN

         CALL SETMSG ( 'SCLK rate is #; rate must be positive.' )
         CALL ERRDP  ( '#', RATE                                )
         CALL SIGERR ( 'SPICE(INVALIDSCLKRATE)'                 )
         CALL CHKOUT ( 'ZZCKE06'                                )
         RETURN

      END IF

C
C     Adjust quaternion "signs" as necessary to minimize distance
C     between successive quaternions. This adjustment is performed
C     only for subtypes that don't store quaternion derivatives
C     (these are the Lagrange subtypes).
C
      IF (  ( SUBTYP .EQ. C06TP1 ) .OR. ( SUBTYP .EQ. C06TP3 )  ) THEN
C
C        For these subtypes, only the quaternions themselves need be
C        adjusted.
C
C        PRVPTR is the index of the "previous" quaternion---the one to
C        which the successor and its negative will be compared.
C
         PRVPTR = PKTIDX

         DO I = 2, N
C
C           NEWPTR points to the quaternion ahead of the one
C           pointed to by PRVPTR.
C
            NEWPTR = PKTIDX + PACKSZ*(I-1)

            CALL VMINUG ( RECORD(NEWPTR), 4,  QNEG )

C
C           Replace the Ith quaternion with QNEG if QNEG is closer
C           than the current quaternion to the previous quaternion.
C
            IF (     VDISTG( RECORD(PRVPTR), QNEG,           4 )
     .          .LT. VDISTG( RECORD(PRVPTR), RECORD(NEWPTR), 4 ) ) THEN

               CALL MOVED ( QNEG, 4, RECORD( NEWPTR ) )

            END IF

            PRVPTR = NEWPTR

         END DO

      ELSE
C
C        For the Hermite types, if the quaternions need to be adjusted,
C        we have an error condition.
C
C        PRVPTR is the index of the "previous" quaternion---the one to
C        which the successor and its negative will be compared.
C
         PRVPTR = PKTIDX

         DO I = 2, N
C
C           NEWPTR points to the quaternion ahead of the one
C           pointed to by PRVPTR.
C
            NEWPTR = PKTIDX + PACKSZ*(I-1)

            CALL VMINUG ( RECORD(NEWPTR), 4,  QNEG )
C
C           For the Hermite subtypes, it's an error for the current
C           quaternion to be closer to QNEG than to the previous
C           quaternion.
C
            IF (     VDISTG( RECORD(PRVPTR), QNEG,           4 )
     .          .LT. VDISTG( RECORD(PRVPTR), RECORD(NEWPTR), 4 ) ) THEN

               CALL SETMSG ( 'Quaternion sign error: quaternion at '
     .         //            'index # in the input record is farther '
     .         //            'than its negative from the preceding '
     .         //            'quaternion in the record. Quaternion '
     .         //            'is (#, #, #, #); predecessor is '
     .         //            '(#, #, #, #). This makes the quaternion '
     .         //            'sequence unsuitable for Hermite '
     .         //            'interpolation. The quaternions, and '
     .         //            'if applicable, their derivatives, '
     .         //            'must be adjusted before they are '
     .         //            'passed to this routine.'                 )
               CALL ERRINT ( '#', I                                    )
               CALL ERRDP  ( '#', RECORD(NEWPTR  )                     )
               CALL ERRDP  ( '#', RECORD(NEWPTR+1)                     )
               CALL ERRDP  ( '#', RECORD(NEWPTR+2)                     )
               CALL ERRDP  ( '#', RECORD(NEWPTR+3)                     )
               CALL ERRDP  ( '#', RECORD(PRVPTR  )                     )
               CALL ERRDP  ( '#', RECORD(PRVPTR+1)                     )
               CALL ERRDP  ( '#', RECORD(PRVPTR+2)                     )
               CALL ERRDP  ( '#', RECORD(PRVPTR+3)                     )
               CALL SIGERR ( 'SPICE(BADQUATSIGN)'                      )
               CALL CHKOUT ( 'ZZCKE06'                                 )
               RETURN

            END IF

            PRVPTR = NEWPTR

         END DO

      END IF

      IF ( SUBTYP .EQ. C06TP1 ) THEN
C
C        We perform Lagrange interpolation on each quaternion
C        component, and obtain quaternion derivatives from the
C        interpolating polynomials.
C
C        We'll transpose the pointing information in the input record so
C        that contiguous pieces of it can be shoved directly into the
C        interpolation routine LGRIND.
C
         N   =  NINT( RECORD(CNTIDX) )

         CALL XPSGIP ( PACKSZ, N, RECORD(PKTIDX) )

C
C        We interpolate each state component in turn.
C
         XSTART   =   PKTIDX   +  N * PACKSZ

         DO I = 1, PACKSZ

            YSTART    =   PKTIDX  +  N * (I-1)

            CALL LGRIND ( N,
     .                    RECORD(XSTART),
     .                    RECORD(YSTART),
     .                    WORK,
     .                    SCLKDP,
     .                    STATE(I),
     .                    STATE(I+4)  )

         END DO

C
C        The output quaternion is a unitized version of the
C        interpolated state.
C
         MAGS = VNORMG( STATE, 4 )

         IF ( MAGS .EQ. 0.D0 ) THEN

            CALL SETMSG ( 'Quaternion magnitude at SCLK # was zero.' )
            CALL ERRDP  ( '#',  SCLKDP                               )
            CALL SIGERR ( 'SPICE(DIVIDEBYZERO)'                      )
            CALL CHKOUT ( 'ZZCKE06'                                  )
            RETURN

         END IF

         CALL VSCLG ( 1.D0/MAGS, STATE, 4, Q )

C
C        Find the time derivative of the unit quaternion:
C        Letting S represent the quaternion portion of STATE, we
C        have
C
C           Q = S/||S||
C
C
C        Then letting < , > denote the 4-dimensional inner product
C        operator, we have
C
C
C                      d(S)/dt      < Q, d(S)/dt >
C           d(Q)/dt =  -------  -   -------------- * Q
C                       ||S||            ||S||
C
C
         CALL MOVED ( STATE(5), 4, DS )

         CALL VSCLG ( 1.D0          / MAGS,  DS, 4,  SCLDDQ )
         CALL VSCLG ( VDOTG(Q,DS,4) / MAGS,  Q,  4,  RADTRM )

         CALL VSUBG ( SCLDDQ, RADTRM, 4, DQ )

C
C        Scale the derivative from 1/tick to 1/second.
C
         CALL VSCLG ( 1.D0/RATE,  DQ,  4,  SCLDDQ )

         CALL MOVED ( Q,      4, QSTATE(1) )
         CALL MOVED ( SCLDDQ, 4, QSTATE(5) )

      ELSE IF ( SUBTYP .EQ. C06TP3 ) THEN
C
C        This is the easiest case:  we perform Lagrange interpolation
C        on each quaternion or angular velocity component.
C
C        We'll transpose the pointing information in the input record so
C        that contiguous pieces of it can be shoved directly into the
C        interpolation routine LGRINT.  We allow LGRINT to overwrite
C        the state values in the input record, since this saves local
C        storage and does no harm.  (See the header of LGRINT for a
C        description of its work space usage.)
C
         N   =  NINT( RECORD(CNTIDX) )

         CALL XPSGIP ( PACKSZ, N, RECORD(PKTIDX) )

C
C        We interpolate each state component in turn.
C
         XSTART  =  PKTIDX   +  N * PACKSZ

         DO I = 1, PACKSZ

            YSTART    =   PKTIDX  +  N * (I-1)

            STATE(I)  =   LGRINT ( N,
     .                             RECORD(XSTART),
     .                             RECORD(YSTART),
     .                             LOCREC,
     .                             SCLKDP          )
         END DO

         MAGS = VNORMG( STATE, 4 )

         IF ( MAGS .EQ. 0.D0 ) THEN

            CALL SETMSG ( 'Quaternion magnitude at SCLK # was zero.' )
            CALL ERRDP  ( '#',  SCLKDP                               )
            CALL SIGERR ( 'SPICE(DIVIDEBYZERO)'                      )
            CALL CHKOUT ( 'ZZCKE06'                                  )
            RETURN

         END IF

         CALL VSCLG ( 1.D0/MAGS, STATE, 4, Q )

C
C        The angular velocity already is in units of radians/second.
C
         CALL VEQU ( STATE(5), AV )

C
C        Convert AV to a quaternion derivative. We have from
C        the header of QDQ2AV
C
C                       *
C           AV =  -2 * Q  * DQ
C
C        so
C
C           DQ =  -1/2 * Q * AV
C
C
         CALL VSCLIP ( -0.5D0, AV )

         QAV(0) = 0.D0
         CALL VEQU ( AV, QAV(1) )

         CALL QXQ ( Q, QAV, DQ )

         CALL MOVED ( Q,  4, QSTATE    )
         CALL MOVED ( DQ, 4, QSTATE(5) )

      ELSE
C
C        We have a Hermite-style subtype.  Whether it's subtype 0
C        or 2, we perform Hermite interpolation on the quaternions.
C
C        We interpolate each quaternion component in turn.  Attitude and
C        angular velocity are interpolated separately.
C
         XSTART   =   PKTIDX  +  PACKSZ * N

         DO I = 1, 4

            DO J = 1, N
C
C              For the Jth input packet, copy the Ith position and
C              velocity components into the local record buffer RECORD.
C
C              In order to perform Hermite interpolation, the
C              quaternions and quaternion derivatives must have a
C              common time scale. So prior to interpolation, we scale
C              the units of the quaternion derivatives from radians/sec
C              to radians/tick.
C
               FROM         = PKTBAS + PACKSZ*(J-1) + I
               TO           =              2 * J    - 1

               LOCREC(TO  ) = RECORD ( FROM     )
               LOCREC(TO+1) = RECORD ( FROM + 4 ) * RATE

            END DO

C
C           Interpolate the Ith quaternion and quaternion derivative
C           components.
C
            CALL HRMINT ( N,
     .                    RECORD(XSTART),
     .                    LOCREC,
     .                    SCLKDP,
     .                    WORK,
     .                    STATE(I  ),
     .                    STATE(I+4)      )

         END DO

C
C        The output quaternion is a unitized version of the
C        interpolated state.
C
         MAGS = VNORMG( STATE, 4 )

         IF ( MAGS .EQ. 0.D0 ) THEN

            CALL SETMSG ( 'Quaternion magnitude at SCLK # was zero.' )
            CALL ERRDP  ( '#',  SCLKDP                               )
            CALL SIGERR ( 'SPICE(DIVIDEBYZERO)'                      )
            CALL CHKOUT ( 'ZZCKE06'                                  )
            RETURN

         END IF

         CALL VSCLG ( 1.D0/MAGS, STATE, 4, Q )

         IF ( SUBTYP .EQ. C06TP0 ) THEN
C
C           Find the time derivative of the unit quaternion:
C           Letting S represent the quaternion portion of STATE, we
C           have
C
C              Q = S/||S||
C
C
C           Then letting < , > denote the 4-dimensional inner product
C           operator, we have
C
C
C                         d(S)/dt      < Q, d(S)/dt >
C              d(Q)/dt =  -------  -   -------------- * Q
C                          ||S||            ||S||
C
C
            CALL MOVED ( STATE(5), 4, DS )

            CALL VSCLG ( 1.D0          / MAGS,  DS, 4,  SCLDDQ )
            CALL VSCLG ( VDOTG(Q,DS,4) / MAGS,  Q,  4,  RADTRM )

            CALL VSUBG ( SCLDDQ, RADTRM, 4, DQ )
C
C           Scale the derivative from radians/tick to
C           radians/second.
C
            CALL VSCLG ( 1.D0/RATE, DQ, 4, SCLDDQ )

C
C           Store Q and DQ in QSTATE. In the process,
C
            CALL MOVED ( Q,      4, QSTATE    )
            CALL MOVED ( SCLDDQ, 4, QSTATE(5) )

         ELSE
C
C           This is subtype 2; we perform Hermite interpolation on
C           the angular velocity and its derivative.
C
C           Now interpolate angular velocity, using separate angular
C           velocity data and angular acceleration.
C
            DO I = 1, 3

               DO J = 1, N
C
C                 For the Jth input packet, copy the Ith angular
C                 velocity and angular acceleration components into the
C                 local record buffer LOCREC.  Note that, as with
C                 quaternion derivatives, we must scale angular
C                 acceleration from radians/sec**2 to
C                 radians/(sec*tick) before interpolating. We would
C                 need to scale the angular acceleration to
C                 radians/sec**2 for output, if we were returning this
C                 quantity. However, we're returning only angular
C                 velocity, which is already in the correct units of
C                 radians/second.
C
                  FROM         = PKTBAS + PACKSZ*(J-1) +  8  +  I
                  TO           =              2 * J    -  1

                  LOCREC(TO  ) = RECORD ( FROM     )
                  LOCREC(TO+1) = RECORD ( FROM + 3 ) * RATE

               END DO

C
C              Interpolate the Ith angular velocity and angular
C              acceleration components of the attitude. We'll
C              capture the result in a temporary buffer, then
C              transfer the velocity to the output argument AV.
C
               CALL HRMINT ( N,
     .                       RECORD(XSTART),
     .                       LOCREC,
     .                       SCLKDP,
     .                       WORK,
     .                       VBUFF(I  ),
     .                       VBUFF(I+3)     )

            END DO
C
C           Fill in the angular velocity in the output angular
C           velocity vector using the results of interpolating
C           velocity and acceleration.
C
C           The angular velocity is already in units of
C           radians/second.
C
            CALL VEQU ( VBUFF, AV )
C
C           Convert AV to a quaternion derivative. We have from
C           the header of QDQ2AV
C
C                          *
C              AV =  -2 * Q  * DQ
C
C           so
C
C              DQ =  -1/2 * Q * AV
C
C
            CALL VSCLIP ( -0.5D0, AV )

            QAV(0) = 0.D0
            CALL VEQU ( AV, QAV(1) )

            CALL QXQ ( Q, QAV, DQ )

            CALL MOVED ( Q,  4, QSTATE    )
            CALL MOVED ( DQ, 4, QSTATE(5) )

         END IF
C
C        We've handled the type 0 and type 2 cases.
C
C
C        We've computed the angular velocity AV for the Hermite
C        subtypes, if a.v. was requested.
C
      END IF
C
C     We've handled all four subtypes.
C

      CALL CHKOUT ( 'ZZCKE06' )
      RETURN
      END


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYINPR
C...Selects partonic subprocesses to be included in the simulation.

      SUBROUTINE PYINPR

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYCOMP

C...User process initialization commonblock.
      include 'inc/heprup'

C...Commonblocks and character variables.
      include 'inc/pydat1'
      include 'inc/pydat2'
      include 'inc/pydat3'
      include 'inc/pysubs'
      include 'inc/pypars'
      include 'inc/pyint1'
      include 'inc/pyint2'
      include 'inc/pyint6'
      CHARACTER CHIPR*10

C...Reset processes to be included.
      IF(MSEL.NE.0) THEN
        DO 100 I=1,500
          MSUB(I)=0
  100   CONTINUE
      ENDIF

C...Set running pTmin scale.
      IF(MSTP(82).LE.1) THEN
        PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
      ELSE
        PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
      ENDIF

C...Begin by assuming incoming photon to enter subprocess.
      IF(MINT(11).EQ.22) MINT(15)=22
      IF(MINT(12).EQ.22) MINT(16)=22

C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
      IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
        MSUB(10)=1
        MINT(123)=MINT(122)+1

C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
C...allow mixture.
C...Here also set a few parameters otherwise normally not touched.
      ELSEIF(MINT(121).GT.1) THEN

C...Parton distributions dampened at small Q2; go to low energies,
C...alpha_s <1; no minimum pT cut-off a priori.
        IF(MSTP(18).EQ.2) THEN
          MSTP(57)=3
          PARP(2)=2D0
          PARU(115)=1D0
          CKIN(5)=0.2D0
          CKIN(6)=0.2D0
        ENDIF

C...Define pT cut-off parameters and whether run involves low-pT.
        PTMVMD=PTMRUN
        VINT(154)=PTMVMD
        PTMDIR=PTMVMD
        IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
        PTMANO=PTMVMD
        IF(MSTP(15).EQ.5) PTMANO=0.60D0+
     &  0.125D0*LOG(1D0+0.10D0*VINT(1))**2
        IPTL=1
        IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
        IF(MSEL.EQ.2) IPTL=1

C...Set up for p/gamma * gamma; real or virtual photons.
        IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
     &  MSTP(14).EQ.30)) THEN

C...Set up for p/VMD * VMD.
        IF(MINT(122).EQ.1) THEN
          MINT(123)=2
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0

C...Set up for p/VMD * direct gamma.
        ELSEIF(MINT(122).EQ.2) THEN
          MINT(123)=0
          IF(MINT(121).EQ.6) MINT(123)=5
          MSUB(131)=1
          MSUB(132)=1
          MSUB(135)=1
          MSUB(136)=1
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR

C...Set up for p/VMD * anomalous gamma.
        ELSEIF(MINT(122).EQ.3) THEN
          MINT(123)=3
          IF(MINT(121).EQ.6) MINT(123)=7
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0

C...Set up for DIS * p.
        ELSEIF(MINT(122).EQ.4.AND.(ABS(MINT(11)).GT.100.OR.
     &  ABS(MINT(12)).GT.100)) THEN
          MINT(123)=8
          IF(IPTL.EQ.1) MSUB(99)=1

C...Set up for direct * direct gamma (switch off leptons).
        ELSEIF(MINT(122).EQ.4) THEN
          MINT(123)=0
          MSUB(137)=1
          MSUB(138)=1
          MSUB(139)=1
          MSUB(140)=1
          DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
            IF(ABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
  110     CONTINUE
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR

C...Set up for direct * anomalous gamma.
        ELSEIF(MINT(122).EQ.5) THEN
          MINT(123)=6
          MSUB(131)=1
          MSUB(132)=1
          MSUB(135)=1
          MSUB(136)=1
          IF(IPTL.EQ.1) CKIN(3)=PTMANO

C...Set up for anomalous * anomalous gamma.
        ELSEIF(MINT(122).EQ.6) THEN
          MINT(123)=3
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0
        ENDIF

C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
        ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN

C...Set up for direct * direct gamma (switch off leptons).
        IF(MINT(122).EQ.1) THEN
          MINT(123)=0
          MSUB(137)=1
          MSUB(138)=1
          MSUB(139)=1
          MSUB(140)=1
          DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
            IF(ABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
  120     CONTINUE
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR

C...Set up for direct * VMD and VMD * direct gamma.
        ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
          MINT(123)=5
          MSUB(131)=1
          MSUB(132)=1
          MSUB(135)=1
          MSUB(136)=1
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR

C...Set up for direct * anomalous and anomalous * direct gamma.
        ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
          MINT(123)=6
          MSUB(131)=1
          MSUB(132)=1
          MSUB(135)=1
          MSUB(136)=1
          IF(IPTL.EQ.1) CKIN(3)=PTMANO

C...Set up for VMD*VMD.
        ELSEIF(MINT(122).EQ.5) THEN
          MINT(123)=2
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0

C...Set up for VMD * anomalous and anomalous * VMD gamma.
        ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
          MINT(123)=7
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0

C...Set up for anomalous * anomalous gamma.
        ELSEIF(MINT(122).EQ.9) THEN
          MINT(123)=3
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0

C...Set up for DIS * VMD and VMD * DIS gamma.
        ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
          MINT(123)=8
          IF(IPTL.EQ.1) MSUB(99)=1

C...Set up for DIS * anomalous and anomalous * DIS gamma.
        ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
          MINT(123)=9
          IF(IPTL.EQ.1) MSUB(99)=1
        ENDIF

C...Set up for gamma* * p; virtual photons = dir, res.
        ELSEIF(MINT(121).EQ.2) THEN

C...Set up for direct * p.
        IF(MINT(122).EQ.1) THEN
          MINT(123)=0
          MSUB(131)=1
          MSUB(132)=1
          MSUB(135)=1
          MSUB(136)=1
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR

C...Set up for resolved * p.
        ELSEIF(MINT(122).EQ.2) THEN
          MINT(123)=1
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0
        ENDIF

C...Set up for gamma* * gamma*; virtual photons = dir, res.
        ELSEIF(MINT(121).EQ.4) THEN

C...Set up for direct * direct gamma (switch off leptons).
        IF(MINT(122).EQ.1) THEN
          MINT(123)=0
          MSUB(137)=1
          MSUB(138)=1
          MSUB(139)=1
          MSUB(140)=1
          DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
            IF(ABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
  130     CONTINUE
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR

C...Set up for direct * resolved and resolved * direct gamma.
        ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
          MINT(123)=5
          MSUB(131)=1
          MSUB(132)=1
          MSUB(135)=1
          MSUB(136)=1
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR

C...Set up for resolved * resolved gamma.
        ELSEIF(MINT(122).EQ.4) THEN
          MINT(123)=2
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0
        ENDIF

C...End of special set up for gamma-p and gamma-gamma.
        ENDIF
        CKIN(1)=2D0*CKIN(3)
      ENDIF

C...Flavour information for individual beams.
      DO 140 I=1,2
        MINT(40+I)=1
        IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
        IF(ABS(MINT(10+I)).GT.100) MINT(40+I)=2
        MINT(44+I)=MINT(40+I)
        IF(MSTP(11).GE.1.AND.(ABS(MINT(10+I)).EQ.11.OR.
     &  ABS(MINT(10+I)).EQ.13.OR.ABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
  140 CONTINUE

C...If two real gammas, whereof one direct, pick the first.
C...For two virtual photons, keep requested order.
      IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
        IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
          MINT(41)=1
          MINT(45)=1
        ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
     &  MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
          MINT(41)=1
          MINT(45)=1
        ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
     &  MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
          MINT(42)=1
          MINT(46)=1
        ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
     &  .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
          MINT(41)=1
          MINT(45)=1
        ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
     &  .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
          MINT(42)=1
          MINT(46)=1
        ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
          MINT(41)=1
          MINT(45)=1
        ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
          MINT(42)=1
          MINT(46)=1
        ENDIF
      ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
        IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
          IF(MINT(11).EQ.22) THEN
            MINT(41)=1
            MINT(45)=1
          ELSE
            MINT(42)=1
            MINT(46)=1
          ENDIF
        ENDIF
        IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
     &  '(PYINPR:) unallowed MSTP(14) code for single photon')
      ENDIF

C...Flavour information on combination of incoming particles.
      MINT(43)=2*MINT(41)+MINT(42)-2
      MINT(44)=MINT(43)
      IF(MINT(123).LE.0) THEN
        IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
        IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
      ELSEIF(MINT(123).LE.3) THEN
        IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
        IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
      ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
        MINT(43)=4
        MINT(44)=1
      ENDIF
      MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
      IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
      IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
      IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
      MINT(50)=0
      IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
      MINT(107)=0
      MINT(108)=0
      IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
        IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
     &  MINT(107)=2
        IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
     &  MINT(107)=3
        IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
        IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
     &  MINT(122).EQ.10) MINT(108)=2
        IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
     &  MINT(122).EQ.11) MINT(108)=3
        IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
      ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
        IF(MINT(122).GE.3) MINT(107)=1
        IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
      ELSEIF(MINT(121).EQ.2) THEN
        IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
        IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
      ELSE
        IF(MINT(11).EQ.22) THEN
          MINT(107)=MINT(123)
          IF(MINT(123).GE.4) MINT(107)=0
          IF(MINT(123).EQ.7) MINT(107)=2
          IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
          IF(MSTP(14).EQ.28) MINT(107)=2
          IF(MSTP(14).EQ.29) MINT(107)=3
          IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
     &    MINT(107)=4
        ENDIF
        IF(MINT(12).EQ.22) THEN
          MINT(108)=MINT(123)
          IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
          IF(MINT(123).EQ.7) MINT(108)=3
          IF(MSTP(14).EQ.26) MINT(108)=2
          IF(MSTP(14).EQ.27) MINT(108)=3
          IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
          IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
     &    MINT(108)=4
        ENDIF
        IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
     &  MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
          MINTTP=MINT(107)
          MINT(107)=MINT(108)
          MINT(108)=MINTTP
        ENDIF
      ENDIF
      IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
      IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0

C...Select default processes according to incoming beams
C...(already done for gamma-p and gamma-gamma with
C...MSTP(14) = 10, 20, 25 or 30).
      IF(MINT(121).GT.1) THEN
      ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN

        IF(MINT(43).EQ.1) THEN
C...Lepton + lepton -> gamma/Z0 or W.
          IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
          IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1

        ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
     &    (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
C...Unresolved photon + lepton: Compton scattering.
          MSUB(133)=1
          MSUB(134)=1

        ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
     &  .OR.MINT(12).EQ.22)) THEN
C...DIS as pure gamma* + f -> f process.
          MSUB(99)=1

        ELSEIF(MINT(43).LE.3) THEN
C...Lepton + hadron: deep inelastic scattering.
          MSUB(10)=1

        ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
     &    MINT(12).EQ.22) THEN
C...Two unresolved photons: fermion pair production,
C...exclude lepton pairs.
          DO 150 ISUB=137,140
            MSUB(ISUB)=1
  150     CONTINUE
          DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
            IF(ABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
  160     CONTINUE
          PTMDIR=PTMRUN
          IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
          IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
          CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))

        ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
     &    .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
     &    MINT(12).EQ.22)) THEN
C...Unresolved photon + hadron: photon-parton scattering.
          DO 170 ISUB=131,136
            MSUB(ISUB)=1
  170     CONTINUE

        ELSEIF(MSEL.EQ.1) THEN
C...High-pT QCD processes:
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          PTMN=PTMRUN
          VINT(154)=PTMN
          IF(CKIN(3).LT.PTMN) MSUB(95)=1
          IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0

        ELSE
C...All QCD processes:
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          MSUB(91)=1
          MSUB(92)=1
          MSUB(93)=1
          MSUB(94)=1
          MSUB(95)=1
        ENDIF

      ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
C...Heavy quark production.
        MSUB(81)=1
        MSUB(82)=1
        MSUB(84)=1
        DO 180 J=1,MIN(8,MDCY(21,3))
          MDME(MDCY(21,2)+J-1,1)=0
  180   CONTINUE
        MDME(MDCY(21,2)+MSEL-1,1)=1
        MSUB(85)=1
        DO 190 J=1,MIN(12,MDCY(22,3))
          MDME(MDCY(22,2)+J-1,1)=0
  190   CONTINUE
        MDME(MDCY(22,2)+MSEL-1,1)=1

      ELSEIF(MSEL.EQ.10) THEN
C...Prompt photon production:
        MSUB(14)=1
        MSUB(18)=1
        MSUB(29)=1

      ELSEIF(MSEL.EQ.11) THEN
C...Z0/gamma* production:
        MSUB(1)=1

      ELSEIF(MSEL.EQ.12) THEN
C...W+/- production:
        MSUB(2)=1

      ELSEIF(MSEL.EQ.13) THEN
C...Z0 + jet:
        MSUB(15)=1
        MSUB(30)=1

      ELSEIF(MSEL.EQ.14) THEN
C...W+/- + jet:
        MSUB(16)=1
        MSUB(31)=1

      ELSEIF(MSEL.EQ.15) THEN
C...Z0 & W+/- pair production:
        MSUB(19)=1
        MSUB(20)=1
        MSUB(22)=1
        MSUB(23)=1
        MSUB(25)=1

      ELSEIF(MSEL.EQ.16) THEN
C...h0 production:
        MSUB(3)=1
        MSUB(102)=1
        MSUB(103)=1
        MSUB(123)=1
        MSUB(124)=1

      ELSEIF(MSEL.EQ.17) THEN
C...h0 & Z0 or W+/- pair production:
        MSUB(24)=1
        MSUB(26)=1

      ELSEIF(MSEL.EQ.18) THEN
C...h0 production; interesting processes in e+e-.
        MSUB(24)=1
        MSUB(103)=1
        MSUB(123)=1
        MSUB(124)=1

      ELSEIF(MSEL.EQ.19) THEN
C...h0, H0 and A0 production; interesting processes in e+e-.
        MSUB(24)=1
        MSUB(103)=1
        MSUB(123)=1
        MSUB(124)=1
        MSUB(153)=1
        MSUB(171)=1
        MSUB(173)=1
        MSUB(174)=1
        MSUB(158)=1
        MSUB(176)=1
        MSUB(178)=1
        MSUB(179)=1

      ELSEIF(MSEL.EQ.21) THEN
C...Z'0 production:
        MSUB(141)=1

      ELSEIF(MSEL.EQ.22) THEN
C...W'+/- production:
        MSUB(142)=1

      ELSEIF(MSEL.EQ.23) THEN
C...H+/- production:
        MSUB(143)=1

      ELSEIF(MSEL.EQ.24) THEN
C...R production:
        MSUB(144)=1

      ELSEIF(MSEL.EQ.25) THEN
C...LQ (leptoquark) production.
        MSUB(145)=1
        MSUB(162)=1
        MSUB(163)=1
        MSUB(164)=1

      ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
C...Production of one heavy quark (W exchange):
        MSUB(83)=1
        DO 200 J=1,MIN(8,MDCY(21,3))
          MDME(MDCY(21,2)+J-1,1)=0
  200   CONTINUE
        MDME(MDCY(21,2)+MSEL-31,1)=1

CMRENNA++Define SUSY alternatives.
      ELSEIF(MSEL.EQ.39) THEN
C...Turn on all SUSY processes.
        IF(MINT(43).EQ.4) THEN
C...Hadron-hadron processes.
          DO 210 I=201,296
            IF(ISET(I).GE.0) MSUB(I)=1
  210     CONTINUE
        ELSEIF(MINT(43).EQ.1) THEN
C...Lepton-lepton processes: QED production of squarks.
          DO 220 I=201,214
            MSUB(I)=1
  220     CONTINUE
          MSUB(210)=0
          MSUB(211)=0
          MSUB(212)=0
          DO 230 I=216,228
            MSUB(I)=1
  230     CONTINUE
          DO 240 I=261,263
            MSUB(I)=1
  240     CONTINUE
          MSUB(277)=1
          MSUB(278)=1
        ENDIF

      ELSEIF(MSEL.EQ.40) THEN
C...Gluinos and squarks.
        IF(MINT(43).EQ.4) THEN
          MSUB(243)=1
          MSUB(244)=1
          MSUB(258)=1
          MSUB(259)=1
          MSUB(261)=1
          MSUB(262)=1
          MSUB(264)=1
          MSUB(265)=1
          DO 250 I=271,296
            MSUB(I)=1
  250     CONTINUE
        ELSEIF(MINT(43).EQ.1) THEN
          MSUB(277)=1
          MSUB(278)=1
        ENDIF

      ELSEIF(MSEL.EQ.41) THEN
C...Stop production.
        MSUB(261)=1
        MSUB(262)=1
        MSUB(263)=1
        IF(MINT(43).EQ.4) THEN
          MSUB(264)=1
          MSUB(265)=1
        ENDIF

      ELSEIF(MSEL.EQ.42) THEN
C...Slepton production.
        DO 260 I=201,214
          MSUB(I)=1
  260   CONTINUE
        IF(MINT(43).NE.4) THEN
          MSUB(210)=0
          MSUB(211)=0
          MSUB(212)=0
        ENDIF

      ELSEIF(MSEL.EQ.43) THEN
C...Neutralino/Chargino + Gluino/Squark.
        IF(MINT(43).EQ.4) THEN
          DO 270 I=237,242
            MSUB(I)=1
  270     CONTINUE
          DO 280 I=246,254
            MSUB(I)=1
  280     CONTINUE
          MSUB(256)=1
        ENDIF

      ELSEIF(MSEL.EQ.44) THEN
C...Neutralino/Chargino pair production.
        IF(MINT(43).EQ.4) THEN
          DO 290 I=216,236
            MSUB(I)=1
  290     CONTINUE
        ELSEIF(MINT(43).EQ.1) THEN
          DO 300 I=216,228
            MSUB(I)=1
  300     CONTINUE
        ENDIF

      ELSEIF(MSEL.EQ.45) THEN
C...Sbottom production.
        MSUB(287)=1
        MSUB(288)=1
        IF(MINT(43).EQ.4) THEN
          DO 310 I=281,296
            MSUB(I)=1
  310     CONTINUE
        ENDIF

      ELSEIF(MSEL.EQ.50) THEN
C...Pair production of technipions and gauge bosons.
        DO 320 I=361,368
          MSUB(I)=1
  320   CONTINUE
        IF(MINT(43).EQ.4) THEN
          DO 330 I=370,377
            MSUB(I)=1
  330     CONTINUE
        ENDIF

      ELSEIF(MSEL.EQ.51) THEN
C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
        DO 340 I=381,386
          MSUB(I)=1
  340   CONTINUE

      ELSEIF(MSEL.EQ.61) THEN
C...Charmonium production in colour octet model, with recoiling parton.
        DO 342 I=421,439
          MSUB(I)=1
 342   CONTINUE

      ELSEIF(MSEL.EQ.62) THEN
C...Bottomonium production in colour octet model, with recoiling parton.
        DO 344 I=461,479
          MSUB(I)=1
 344   CONTINUE

      ELSEIF(MSEL.EQ.63) THEN
C...Charmonium and bottomonium production in colour octet model.
        DO 346 I=421,439
          MSUB(I)=1
          MSUB(I+40)=1
 346   CONTINUE
      ENDIF

C...Find heaviest new quark flavour allowed in processes 81-84.
      KFLQM=1
      DO 350 I=1,MIN(8,MDCY(21,3))
        IDC=I+MDCY(21,2)-1
        IF(MDME(IDC,1).LE.0) GOTO 350
        KFLQM=I
  350 CONTINUE
      IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
     &KFLQM=MSTP(7)
      MINT(55)=KFLQM
      KFPR(81,1)=KFLQM
      KFPR(81,2)=KFLQM
      KFPR(82,1)=KFLQM
      KFPR(82,2)=KFLQM
      KFPR(83,1)=KFLQM
      KFPR(84,1)=KFLQM
      KFPR(84,2)=KFLQM

C...Find heaviest new fermion flavour allowed in process 85.
      KFLFM=1
      DO 360 I=1,MIN(12,MDCY(22,3))
        IDC=I+MDCY(22,2)-1
        IF(MDME(IDC,1).LE.0) GOTO 360
        KFLFM=KFDP(IDC,1)
  360 CONTINUE
      IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
     &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
      MINT(56)=KFLFM
      KFPR(85,1)=KFLFM
      KFPR(85,2)=KFLFM

C...Initialize Generic Processes
      KFGEN=9900001
      KCGEN=PYCOMP(KFGEN)
      IF(KCGEN.GT.0) THEN
        IDCY=MDCY(KCGEN,2)
        IF(IDCY.GT.0) THEN
          KFF1=KFDP(IDCY+1,1)
          KFF2=KFDP(IDCY+1,2)
          KCF1=PYCOMP(KFF1)
C unvar           KCF2=PYCOMP(KFF2)
          JCOL1=ABS(KCHG(KCF1,2))
          IF(JCOL1.EQ.1) THEN
            KF1=KFF1
            KF2=KFF2
          ELSE
            KF1=KFF2
            KF2=KFF1
          ENDIF
          KFPR(481,1)=KF1
          KFPR(481,2)=KF2
          KFPR(482,1)=KF1
          KFPR(482,2)=KF2
        ENDIF
        IF(KFDP(IDCY,1).EQ.21.OR.KFDP(IDCY,2).EQ.21) THEN
          KFIN(1,0)=1
          KFIN(2,0)=1
        ENDIF
      ENDIF

C...Import relevant information on external user processes.
      IF(MINT(111).GE.11) THEN
        IPYPR=0
        DO 390 IUP=1,NPRUP
C...Find next empty PYTHIA process number slot and enable it.
  370     IPYPR=IPYPR+1
          IF(IPYPR.GT.500) CALL PYERRM(26,
     &    '(PYINPR.) no more empty slots for user processes')
          IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
          IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
          ISET(IPYPR)=11
C...Overwrite KFPR with references back to process number and ID.
          KFPR(IPYPR,1)=IUP
          KFPR(IPYPR,2)=LPRUP(IUP)
C...Process title.
          WRITE(CHIPR,'(I10)') LPRUP(IUP)
          ICHIN=1
          DO 380 ICH=1,9
            IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
  380     CONTINUE
          PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
C...Switch on process.
          MSUB(IPYPR)=1
  390   CONTINUE
      ENDIF

      RETURN
      END


C$ Procedure TIMECN (Convert and round times)

      SUBROUTINE TIMECN ( TCONV, IDS, TOUT, LINET )

C$ Abstract
C
C     This is internal subroutine for CKBRIEF program. It converts
C     time between encoded SCLK, SCLK string, ET, UTC or UTC/DOY.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Keywords
C
C     SUMMARY
C     C KERNEL
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE           'ckbrief.inc'

      DOUBLE PRECISION  TCONV
      INTEGER           IDS
      CHARACTER*(*)     TOUT
      CHARACTER*(*)     LINET

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     TCONV      I   Encoded SCLK time
C     IDS        I   NAIF ID code of object
C     TOUT       I   Form of time representation on output
C     LINET      O   Text presentation of time
C
C$ Detailed Input
C
C     TCONV          Encoded SCLK time to be converted, rounded
C                    and decoded to character string
C
C     IDS            Integer NAIF ID code found in summary from which
C                    TCONV was obtained.
C
C     TOUT           Key specifying time presentation on output:
C                    SCLK string, encoded SCLK, ET, UTC or DOY UTC.
C
C$ Detailed Output
C
C     LINET          Character string which contains time converted
C                    to requested representation or NOTIME flag if
C                    conversion was not possible.
C
C$ Parameters
C
C     None.
C
C$ Files
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Particulars
C
C     None.
C
C$ Examples
C
C     None.
C
C$ Restrictions
C
C     None.
C
C$ Author_and_Institution
C
C     Y.K. Zaiko      (BERC)
C     B.V. Semenov    (NAIF)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    CKBRIEF Beta Version 1.0.0, 17-FEB-1999 (YKZ)(BVS)
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               FAILED

C
C     Local variables
C
      DOUBLE PRECISION      ETTIME

      INTEGER               SC
      LOGICAL               OK

C
C     Reset output time string.
C
      LINET  = ' '

C
C     It is necessary to use real spacecraft ID in SCLK<->ET
C     conversion routines. CKMETA is providing it.
C
      CALL CKMETA ( IDS, 'SCLK', SC )

C
C     TIMECN is the special routine to be used in CKBRIEF
C     utility to convert times in accordance to user request. If user
C     haven't provided ancillary files to perform this conversion, the
C     program shouldn't stop. To achieve this we'll forbid TIMECN to
C     be aborted by SPICELIB standard error processing if it can't
C     convert times. On the exit from TIMECN, SPICE error handling
C     is restored to its original state.
C
      CALL ERRACT ( 'SET', 'RETURN' )
      CALL ERRPRT ( 'SET', 'NONE' )

C
C     We do appropriate conversion depending on the requested output
C     time representation. If SCLK for the s/c of interest and(!)
C     LSK file weren't loaded, conversions to string SCLK, ET, UTC
C     and UTC/DOY are not possible. The output time set to NOTIME
C     flag.
C
      IF ( TOUT .EQ. DPSCLK ) THEN

C
C        DP SLCKs should be simply converted to string.
C
         CALL DPFMT ( TCONV, PICTDP, LINET )

      ELSE IF ( TOUT .EQ. SCLK ) THEN

C
C        SCLK string is computed from DP SCLK if it's possible.
C
         CALL SCDECD ( SC, TCONV, LINET )
         IF ( FAILED () ) THEN
            LINET = NOTIME
         END IF

      ELSE IF ( TOUT .EQ. ET ) THEN

C
C        Calendar ET is computed by converting DP SCLK to ET seconds
C        and converting them further to ET calendar string
C
         CALL SCT2E ( SC, TCONV, ETTIME )
         IF ( .NOT. FAILED() ) THEN
            CALL TIMOUT ( ETTIME, PICTET, LINET )
            IF ( FAILED() ) THEN
               LINET = NOTIME
            END IF
         ELSE
            LINET = NOTIME
         END IF

      ELSE IF ( TOUT .EQ. UTC ) THEN

C
C        UTC time is computed by converting DP SCLK to ET seconds,
C        which after that converted to UTC string.
C
         CALL SCT2E ( SC, TCONV, ETTIME )
         IF ( .NOT. FAILED() ) THEN
            CALL TIMOUT ( ETTIME, PICTUT, LINET )
            IF ( FAILED() ) THEN
               LINET = NOTIME
            END IF
         ELSE
            LINET = NOTIME
         END IF

      ELSE IF ( TOUT .EQ. DOY ) THEN

C
C        UTCDOY time is computed by converting DP SCLK to ET seconds,
C        which after that converted to UTC string.
C
         CALL SCT2E ( SC, TCONV, ETTIME )
         IF ( .NOT. FAILED() ) THEN
            CALL TIMOUT ( ETTIME, PICTDY, LINET )
            IF ( FAILED() ) THEN
               LINET = NOTIME
            END IF
         ELSE
            LINET = NOTIME
         END IF

      END IF

      OK = .NOT. FAILED()

C
C     Now we can reset SPICE error handling mechanism back to its
C     original state.
C
      CALL RESET
      CALL ERRACT ( 'SET', 'ABORT' )
      CALL ERRPRT ( 'SET', 'DEFAULT' )

C
C     There is a bug in UNITIM (trace: SCT2E --> SCTE01 --> UNITIM)
C     that has to be temporarily fixed before UNITIM officially fixed
C     in N0049 delivery. Call to a specially written routine FIXUNI
C     does that.
C
      IF ( .NOT. OK ) THEN
         CALL FIXUNI
      END IF

      RETURN
      END


*DECK DSTOKA
      SUBROUTINE DSTOKA (NEQ, Y, YH, NYH, YH1, EWT, SAVF, SAVX, ACOR,
     1   WM, IWM, F, JAC, PSOL)
      EXTERNAL F, JAC, PSOL
      INTEGER NEQ, NYH, IWM
      DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, SAVX, ACOR, WM
      DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*),
     1   SAVX(*), ACOR(*), WM(*), IWM(*)
      INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP,
     1   ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L,
     2   LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER,
     3   MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
      INTEGER NEWT, NSFI, NSLJ, NJEV
      INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT,
     1   NNI, NLI, NPS, NCFN, NCFL
      DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO,
     2   CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND
      DOUBLE PRECISION STIFR
      DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN
      COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12),
     1   HOLD, RMAX, TESCO(3,12),
     2   CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND,
     3   IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP,
     3   ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L,
     4   LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER,
     5   MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
      COMMON /DLS002/ STIFR, NEWT, NSFI, NSLJ, NJEV
      COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN,
     1   JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT,
     2   NNI, NLI, NPS, NCFN, NCFL
C-----------------------------------------------------------------------
C DSTOKA performs one step of the integration of an initial value
C problem for a system of Ordinary Differential Equations.
C
C This routine was derived from Subroutine DSTODPK in the DLSODPK
C package by the addition of automatic functional/Newton iteration
C switching and logic for re-use of Jacobian data.
C-----------------------------------------------------------------------
C Note: DSTOKA is independent of the value of the iteration method
C indicator MITER, when this is .ne. 0, and hence is independent
C of the type of chord method used, or the Jacobian structure.
C Communication with DSTOKA is done with the following variables:
C
C NEQ    = integer array containing problem size in NEQ(1), and
C          passed as the NEQ argument in all calls to F and JAC.
C Y      = an array of length .ge. N used as the Y argument in
C          all calls to F and JAC.
C YH     = an NYH by LMAX array containing the dependent variables
C          and their approximate scaled derivatives, where
C          LMAX = MAXORD + 1.  YH(i,j+1) contains the approximate
C          j-th derivative of y(i), scaled by H**j/factorial(j)
C          (j = 0,1,...,NQ).  On entry for the first step, the first
C          two columns of YH must be set from the initial values.
C NYH    = a constant integer .ge. N, the first dimension of YH.
C YH1    = a one-dimensional array occupying the same space as YH.
C EWT    = an array of length N containing multiplicative weights
C          for local error measurements.  Local errors in y(i) are
C          compared to 1.0/EWT(i) in various error tests.
C SAVF   = an array of working storage, of length N.
C          Also used for input of YH(*,MAXORD+2) when JSTART = -1
C          and MAXORD .lt. the current order NQ.
C SAVX   = an array of working storage, of length N.
C ACOR   = a work array of length N, used for the accumulated
C          corrections.  On a successful return, ACOR(i) contains
C          the estimated one-step local error in y(i).
C WM,IWM = real and integer work arrays associated with matrix
C          operations in chord iteration (MITER .ne. 0).
C CCMAX  = maximum relative change in H*EL0 before DSETPK is called.
C H      = the step size to be attempted on the next step.
C          H is altered by the error control algorithm during the
C          problem.  H can be either positive or negative, but its
C          sign must remain constant throughout the problem.
C HMIN   = the minimum absolute value of the step size H to be used.
C HMXI   = inverse of the maximum absolute value of H to be used.
C          HMXI = 0.0 is allowed and corresponds to an infinite HMAX.
C          HMIN and HMXI may be changed at any time, but will not
C          take effect until the next change of H is considered.
C TN     = the independent variable. TN is updated on each step taken.
C JSTART = an integer used for input only, with the following
C          values and meanings:
C               0  perform the first step.
C           .gt.0  take a new step continuing from the last.
C              -1  take the next step with a new value of H, MAXORD,
C                    N, METH, MITER, and/or matrix parameters.
C              -2  take the next step with a new value of H,
C                    but with other inputs unchanged.
C          On return, JSTART is set to 1 to facilitate continuation.
C KFLAG  = a completion code with the following meanings:
C               0  the step was succesful.
C              -1  the requested error could not be achieved.
C              -2  corrector convergence could not be achieved.
C              -3  fatal error in DSETPK or DSOLPK.
C          A return with KFLAG = -1 or -2 means either
C          ABS(H) = HMIN or 10 consecutive failures occurred.
C          On a return with KFLAG negative, the values of TN and
C          the YH array are as of the beginning of the last
C          step, and H is the last step size attempted.
C MAXORD = the maximum order of integration method to be allowed.
C MAXCOR = the maximum number of corrector iterations allowed.
C MSBP   = maximum number of steps between DSETPK calls (MITER .gt. 0).
C MXNCF  = maximum number of convergence failures allowed.
C METH/MITER = the method flags.  See description in driver.
C N      = the number of first-order differential equations.
C-----------------------------------------------------------------------
      INTEGER I, I1, IREDO, IRET, J, JB, JOK, M, NCF, NEWQ, NSLOW
      DOUBLE PRECISION DCON, DDN, DEL, DELP, DRC, DSM, DUP, EXDN, EXSM,
     1   EXUP, DFNORM, R, RH, RHDN, RHSM, RHUP, ROC, STIFF, TOLD, DVNORM
C
      KFLAG = 0
      TOLD = TN
      NCF = 0
      IERPJ = 0
      IERSL = 0
      JCUR = 0
      ICF = 0
      DELP = 0.0D0
      IF (JSTART .GT. 0) GO TO 200
      IF (JSTART .EQ. -1) GO TO 100
      IF (JSTART .EQ. -2) GO TO 160
C-----------------------------------------------------------------------
C On the first call, the order is set to 1, and other variables are
C initialized.  RMAX is the maximum ratio by which H can be increased
C in a single step.  It is initially 1.E4 to compensate for the small
C initial H, but then is normally equal to 10.  If a failure
C occurs (in corrector convergence or error test), RMAX is set at 2
C for the next increase.
C-----------------------------------------------------------------------
      LMAX = MAXORD + 1
      NQ = 1
      L = 2
      IALTH = 2
      RMAX = 10000.0D0
      RC = 0.0D0
      EL0 = 1.0D0
      CRATE = 0.7D0
      HOLD = H
      MEO = METH
      NSLP = 0
      NSLJ = 0
      IPUP = 0
      IRET = 3
      NEWT = 0
      STIFR = 0.0D0
      GO TO 140
C-----------------------------------------------------------------------
C The following block handles preliminaries needed when JSTART = -1.
C IPUP is set to MITER to force a matrix update.
C If an order increase is about to be considered (IALTH = 1),
C IALTH is reset to 2 to postpone consideration one more step.
C If the caller has changed METH, DCFODE is called to reset
C the coefficients of the method.
C If the caller has changed MAXORD to a value less than the current
C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly.
C If H is to be changed, YH must be rescaled.
C If H or METH is being changed, IALTH is reset to L = NQ + 1
C to prevent further changes in H for that many steps.
C-----------------------------------------------------------------------
 100  IPUP = MITER
      LMAX = MAXORD + 1
      IF (IALTH .EQ. 1) IALTH = 2
      IF (METH .EQ. MEO) GO TO 110
      CALL DCFODE (METH, ELCO, TESCO)
      MEO = METH
      IF (NQ .GT. MAXORD) GO TO 120
      IALTH = L
      IRET = 1
      GO TO 150
 110  IF (NQ .LE. MAXORD) GO TO 160
 120  NQ = MAXORD
      L = LMAX
      DO 125 I = 1,L
 125    EL(I) = ELCO(I,NQ)
      NQNYH = NQ*NYH
      RC = RC*EL(1)/EL0
      EL0 = EL(1)
      CONIT = 0.5D0/(NQ+2)
      EPCON = CONIT*TESCO(2,NQ)
      DDN = DVNORM (N, SAVF, EWT)/TESCO(1,L)
      EXDN = 1.0D0/L
      RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0)
      RH = MIN(RHDN,1.0D0)
      IREDO = 3
      IF (H .EQ. HOLD) GO TO 170
      RH = MIN(RH,ABS(H/HOLD))
      H = HOLD
      GO TO 175
C-----------------------------------------------------------------------
C DCFODE is called to get all the integration coefficients for the
C current METH.  Then the EL vector and related constants are reset
C whenever the order NQ is changed, or at the start of the problem.
C-----------------------------------------------------------------------
 140  CALL DCFODE (METH, ELCO, TESCO)
 150  DO 155 I = 1,L
 155    EL(I) = ELCO(I,NQ)
      NQNYH = NQ*NYH
      RC = RC*EL(1)/EL0
      EL0 = EL(1)
      CONIT = 0.5D0/(NQ+2)
      EPCON = CONIT*TESCO(2,NQ)
      GO TO (160, 170, 200), IRET
C-----------------------------------------------------------------------
C If H is being changed, the H ratio RH is checked against
C RMAX, HMIN, and HMXI, and the YH array rescaled.  IALTH is set to
C L = NQ + 1 to prevent a change of H for that many steps, unless
C forced by a convergence or error test failure.
C-----------------------------------------------------------------------
 160  IF (H .EQ. HOLD) GO TO 200
      RH = H/HOLD
      H = HOLD
      IREDO = 3
      GO TO 175
 170  RH = MAX(RH,HMIN/ABS(H))
 175  RH = MIN(RH,RMAX)
      RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH)
      R = 1.0D0
      DO 180 J = 2,L
        R = R*RH
        DO 180 I = 1,N
 180      YH(I,J) = YH(I,J)*R
      H = H*RH
      RC = RC*RH
      IALTH = L
      IF (IREDO .EQ. 0) GO TO 690
C-----------------------------------------------------------------------
C This section computes the predicted values by effectively
C multiplying the YH array by the Pascal triangle matrix.
C The flag IPUP is set according to whether matrix data is involved
C (NEWT .gt. 0 .and. JACFLG .ne. 0) or not, to trigger a call to DSETPK.
C IPUP is set to MITER when RC differs from 1 by more than CCMAX,
C and at least every MSBP steps, when JACFLG = 1.
C RC is the ratio of new to old values of the coefficient  H*EL(1).
C-----------------------------------------------------------------------
 200  IF (NEWT .EQ. 0 .OR. JACFLG .EQ. 0) THEN
        DRC = 0.0D0
        IPUP = 0
        CRATE = 0.7D0
      ELSE
        DRC = ABS(RC - 1.0D0)
        IF (DRC .GT. CCMAX) IPUP = MITER
        IF (NST .GE. NSLP+MSBP) IPUP = MITER
        ENDIF
      TN = TN + H
      I1 = NQNYH + 1
      DO 215 JB = 1,NQ
        I1 = I1 - NYH
CDIR$ IVDEP
        DO 210 I = I1,NQNYH
 210      YH1(I) = YH1(I) + YH1(I+NYH)
 215    CONTINUE
C-----------------------------------------------------------------------
C Up to MAXCOR corrector iterations are taken.  A convergence test is
C made on the RMS-norm of each correction, weighted by the error
C weight vector EWT.  The sum of the corrections is accumulated in the
C vector ACOR(i).  The YH array is not altered in the corrector loop.
C Within the corrector loop, an estimated rate of convergence (ROC)
C and a stiffness ratio estimate (STIFF) are kept.  Corresponding
C global estimates are kept as CRATE and stifr.
C-----------------------------------------------------------------------
 220  M = 0
      MNEWT = 0
      STIFF = 0.0D0
      ROC = 0.05D0
      NSLOW = 0
      DO 230 I = 1,N
 230    Y(I) = YH(I,1)
      CALL F (NEQ, TN, Y, SAVF)
      NFE = NFE + 1
      IF (NEWT .EQ. 0 .OR. IPUP .LE. 0) GO TO 250
C-----------------------------------------------------------------------
C If indicated, DSETPK is called to update any matrix data needed,
C before starting the corrector iteration.
C JOK is set to indicate if the matrix data need not be recomputed.
C IPUP is set to 0 as an indicator that the matrix data is up to date.
C-----------------------------------------------------------------------
      JOK = 1
      IF (NST .EQ. 0 .OR. NST .GT. NSLJ+50) JOK = -1
      IF (ICF .EQ. 1 .AND. DRC .LT. 0.2D0) JOK = -1
      IF (ICF .EQ. 2) JOK = -1
      IF (JOK .EQ. -1) THEN
        NSLJ = NST
        NJEV = NJEV + 1
        ENDIF
      CALL DSETPK (NEQ, Y, YH1, EWT, ACOR, SAVF, JOK, WM, IWM, F, JAC)
      IPUP = 0
      RC = 1.0D0
      DRC = 0.0D0
      NSLP = NST
      CRATE = 0.7D0
      IF (IERPJ .NE. 0) GO TO 430
 250  DO 260 I = 1,N
 260    ACOR(I) = 0.0D0
 270  IF (NEWT .NE. 0) GO TO 350
C-----------------------------------------------------------------------
C In the case of functional iteration, update Y directly from
C the result of the last function evaluation, and STIFF is set to 1.0.
C-----------------------------------------------------------------------
      DO 290 I = 1,N
        SAVF(I) = H*SAVF(I) - YH(I,2)
 290    Y(I) = SAVF(I) - ACOR(I)
      DEL = DVNORM (N, Y, EWT)
      DO 300 I = 1,N
        Y(I) = YH(I,1) + EL(1)*SAVF(I)
 300    ACOR(I) = SAVF(I)
      STIFF = 1.0D0
      GO TO 400
C-----------------------------------------------------------------------
C In the case of the chord method, compute the corrector error,
C and solve the linear system with that as right-hand side and
C P as coefficient matrix.  STIFF is set to the ratio of the norms
C of the residual and the correction vector.
C-----------------------------------------------------------------------
 350  DO 360 I = 1,N
 360    SAVX(I) = H*SAVF(I) - (YH(I,2) + ACOR(I))
      DFNORM = DVNORM (N, SAVX, EWT)
      CALL DSOLPK (NEQ, Y, SAVF, SAVX, EWT, WM, IWM, F, PSOL)
      IF (IERSL .LT. 0) GO TO 430
      IF (IERSL .GT. 0) GO TO 410
      DEL = DVNORM (N, SAVX, EWT)
      IF (DEL .GT. 1.0D-8) STIFF = MAX(STIFF, DFNORM/DEL)
      DO 380 I = 1,N
        ACOR(I) = ACOR(I) + SAVX(I)
 380    Y(I) = YH(I,1) + EL(1)*ACOR(I)
C-----------------------------------------------------------------------
C Test for convergence.  If M .gt. 0, an estimate of the convergence
C rate constant is made for the iteration switch, and is also used
C in the convergence test.   If the iteration seems to be diverging or
C converging at a slow rate (.gt. 0.8 more than once), it is stopped.
C-----------------------------------------------------------------------
 400  IF (M .NE. 0) THEN
        ROC = MAX(0.05D0, DEL/DELP)
        CRATE = MAX(0.2D0*CRATE,ROC)
        ENDIF
      DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/EPCON
      IF (DCON .LE. 1.0D0) GO TO 450
      M = M + 1
      IF (M .EQ. MAXCOR) GO TO 410
      IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410
      IF (ROC .GT. 10.0D0) GO TO 410
      IF (ROC .GT. 0.8D0) NSLOW = NSLOW + 1
      IF (NSLOW .GE. 2) GO TO 410
      MNEWT = M
      DELP = DEL
      CALL F (NEQ, TN, Y, SAVF)
      NFE = NFE + 1
      GO TO 270
C-----------------------------------------------------------------------
C The corrector iteration failed to converge.
C If functional iteration is being done (NEWT = 0) and MITER .gt. 0
C (and this is not the first step), then switch to Newton
C (NEWT = MITER), and retry the step.  (Setting STIFR = 1023 insures
C that a switch back will not occur for 10 step attempts.)
C If Newton iteration is being done, but using a preconditioner that
C is out of date (JACFLG .ne. 0 .and. JCUR = 0), then signal for a
C re-evalutation of the preconditioner, and retry the step.
C In all other cases, the YH array is retracted to its values
C before prediction, and H is reduced, if possible.  If H cannot be
C reduced or MXNCF failures have occurred, exit with KFLAG = -2.
C-----------------------------------------------------------------------
 410  ICF = 1
      IF (NEWT .EQ. 0) THEN
        IF (NST .EQ. 0) GO TO 430
        IF (MITER .EQ. 0) GO TO 430
        NEWT = MITER
        STIFR = 1023.0D0
        IPUP = MITER
        GO TO 220
        ENDIF
      IF (JCUR.EQ.1 .OR. JACFLG.EQ.0) GO TO 430
      IPUP = MITER
      GO TO 220
 430  ICF = 2
      NCF = NCF + 1
      NCFN = NCFN + 1
      RMAX = 2.0D0
      TN = TOLD
      I1 = NQNYH + 1
      DO 445 JB = 1,NQ
        I1 = I1 - NYH
CDIR$ IVDEP
        DO 440 I = I1,NQNYH
 440      YH1(I) = YH1(I) - YH1(I+NYH)
 445    CONTINUE
      IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680
      IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670
      IF (NCF .EQ. MXNCF) GO TO 670
      RH = 0.5D0
      IPUP = MITER
      IREDO = 1
      GO TO 170
C-----------------------------------------------------------------------
C The corrector has converged.  JCUR is set to 0 to signal that the
C preconditioner involved may need updating later.
C The stiffness ratio STIFR is updated using the latest STIFF value.
C The local error test is made and control passes to statement 500
C if it fails.
C-----------------------------------------------------------------------
 450  JCUR = 0
      IF (NEWT .GT. 0) STIFR = 0.5D0*(STIFR + STIFF)
      IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ)
      IF (M .GT. 0) DSM = DVNORM (N, ACOR, EWT)/TESCO(2,NQ)
      IF (DSM .GT. 1.0D0) GO TO 500
C-----------------------------------------------------------------------
C After a successful step, update the YH array.
C If Newton iteration is being done and STIFR is less than 1.5,
C then switch to functional iteration.
C Consider changing H if IALTH = 1.  Otherwise decrease IALTH by 1.
C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for
C use in a possible order increase on the next step.
C If a change in H is considered, an increase or decrease in order
C by one is considered also.  A change in H is made only if it is by a
C factor of at least 1.1.  If not, IALTH is set to 3 to prevent
C testing for that many steps.
C-----------------------------------------------------------------------
      KFLAG = 0
      IREDO = 0
      NST = NST + 1
      IF (NEWT .EQ. 0) NSFI = NSFI + 1
      IF (NEWT .GT. 0 .AND. STIFR .LT. 1.5D0) NEWT = 0
      HU = H
      NQU = NQ
      DO 470 J = 1,L
        DO 470 I = 1,N
 470      YH(I,J) = YH(I,J) + EL(J)*ACOR(I)
      IALTH = IALTH - 1
      IF (IALTH .EQ. 0) GO TO 520
      IF (IALTH .GT. 1) GO TO 700
      IF (L .EQ. LMAX) GO TO 700
      DO 490 I = 1,N
 490    YH(I,LMAX) = ACOR(I)
      GO TO 700
C-----------------------------------------------------------------------
C The error test failed.  KFLAG keeps track of multiple failures.
C Restore TN and the YH array to their previous values, and prepare
C to try the step again.  Compute the optimum step size for this or
C one lower order.  After 2 or more failures, H is forced to decrease
C by a factor of 0.2 or less.
C-----------------------------------------------------------------------
 500  KFLAG = KFLAG - 1
      TN = TOLD
      I1 = NQNYH + 1
      DO 515 JB = 1,NQ
        I1 = I1 - NYH
CDIR$ IVDEP
        DO 510 I = I1,NQNYH
 510      YH1(I) = YH1(I) - YH1(I+NYH)
 515    CONTINUE
      RMAX = 2.0D0
      IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660
      IF (KFLAG .LE. -3) GO TO 640
      IREDO = 2
      RHUP = 0.0D0
      GO TO 540
C-----------------------------------------------------------------------
C Regardless of the success or failure of the step, factors
C RHDN, RHSM, and RHUP are computed, by which H could be multiplied
C at order NQ - 1, order NQ, or order NQ + 1, respectively.
C in the case of failure, RHUP = 0.0 to avoid an order increase.
C the largest of these is determined and the new order chosen
C accordingly.  If the order is to be increased, we compute one
C additional scaled derivative.
C-----------------------------------------------------------------------
 520  RHUP = 0.0D0
      IF (L .EQ. LMAX) GO TO 540
      DO 530 I = 1,N
 530    SAVF(I) = ACOR(I) - YH(I,LMAX)
      DUP = DVNORM (N, SAVF, EWT)/TESCO(3,NQ)
      EXUP = 1.0D0/(L+1)
      RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0)
 540  EXSM = 1.0D0/L
      RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0)
      RHDN = 0.0D0
      IF (NQ .EQ. 1) GO TO 560
      DDN = DVNORM (N, YH(1,L), EWT)/TESCO(1,NQ)
      EXDN = 1.0D0/NQ
      RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0)
 560  IF (RHSM .GE. RHUP) GO TO 570
      IF (RHUP .GT. RHDN) GO TO 590
      GO TO 580
 570  IF (RHSM .LT. RHDN) GO TO 580
      NEWQ = NQ
      RH = RHSM
      GO TO 620
 580  NEWQ = NQ - 1
      RH = RHDN
      IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0
      GO TO 620
 590  NEWQ = L
      RH = RHUP
      IF (RH .LT. 1.1D0) GO TO 610
      R = EL(L)/L
      DO 600 I = 1,N
 600    YH(I,NEWQ+1) = ACOR(I)*R
      GO TO 630
 610  IALTH = 3
      GO TO 700
 620  IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610
      IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0)
C-----------------------------------------------------------------------
C If there is a change of order, reset NQ, L, and the coefficients.
C In any case H is reset according to RH and the YH array is rescaled.
C Then exit from 690 if the step was OK, or redo the step otherwise.
C-----------------------------------------------------------------------
      IF (NEWQ .EQ. NQ) GO TO 170
 630  NQ = NEWQ
      L = NQ + 1
      IRET = 2
      GO TO 150
C-----------------------------------------------------------------------
C Control reaches this section if 3 or more failures have occured.
C If 10 failures have occurred, exit with KFLAG = -1.
C It is assumed that the derivatives that have accumulated in the
C YH array have errors of the wrong order.  Hence the first
C derivative is recomputed, and the order is set to 1.  Then
C H is reduced by a factor of 10, and the step is retried,
C until it succeeds or H reaches HMIN.
C-----------------------------------------------------------------------
 640  IF (KFLAG .EQ. -10) GO TO 660
      RH = 0.1D0
      RH = MAX(HMIN/ABS(H),RH)
      H = H*RH
      DO 645 I = 1,N
 645    Y(I) = YH(I,1)
      CALL F (NEQ, TN, Y, SAVF)
      NFE = NFE + 1
      DO 650 I = 1,N
 650    YH(I,2) = H*SAVF(I)
      IPUP = MITER
      IALTH = 5
      IF (NQ .EQ. 1) GO TO 200
      NQ = 1
      L = 2
      IRET = 3
      GO TO 150
C-----------------------------------------------------------------------
C All returns are made through this section.  H is saved in HOLD
C to allow the caller to change H on the next step.
C-----------------------------------------------------------------------
 660  KFLAG = -1
      GO TO 720
 670  KFLAG = -2
      GO TO 720
 680  KFLAG = -3
      GO TO 720
 690  RMAX = 10.0D0
 700  R = 1.0D0/TESCO(2,NQU)
      DO 710 I = 1,N
 710    ACOR(I) = ACOR(I)*R
 720  HOLD = H
      JSTART = 1
      RETURN
C----------------------- End of Subroutine DSTOKA ----------------------
      END