!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!BOP
! !ROUTINE: ods_drad
!
! !INTERFACE:
!
      subroutine ods_drad ( obstype, isat, iuse, iinfo, pinfo, pdata,
     .                      varchn, nuchan,
     .                      ndiag, iint, ireal, ipchan, npred, nchanl,
     .  		    ods, mobs, kobs, iks, ioff, rc )
      use m_odsmeta
      use m_ods
      use m_ods_obsdiags, only : ods_obsdiags
      use m_ods_obsdiags, only : ods_obsdiags_getparam

      implicit NONE

! !INPUT PARAMETERS:

      character(len=*), intent(in)    :: obstype
      integer,          intent(in)    :: isat
      integer,          intent(in)    :: ireal, ipchan, npred, nchanl, iint
      integer,          intent(in)    :: mobs, iks
      integer,          intent(in)    :: ndiag
      integer,          intent(in)    :: ioff
      integer,          intent(in)    :: iuse(nchanl)
      integer,          intent(in)    :: iinfo(iint)
      real(4),          intent(in)    :: pinfo(ireal)
      real(4),          intent(in)    :: pdata(ndiag,nchanl)
      integer,          intent(in)    :: nuchan(nchanl)
      real(4),          intent(in)    :: varchn(nchanl)

! !INPUT/OUTPUT PARAMETERS:

      integer,          intent(inout) :: kobs      ! current obs counter
      type(ods_vect),   intent(inout) :: ods

! !OUTPUT PARAMETERS:

      integer,          intent(out)   :: rc

! !DESCRIPTION: Converts radiance data from GSI diag_ files to ODS.
!
! !REVISION HISTORY:
!	20Dec2004 - D. Dee - Initial code.
!       02Mar2005 - Dee - Updated for latest GSI
!       20May2005 - Dee - Handle passive radiance data
!       03Nov2005 - Sienkiewicz - addition for SSM/I radiance
!                                  (has some QC marks -> history marks)
!       24Jan2006 - Todling - Bug fix; defining xvec w/ undef's
!       31Jan2006 - Todling - Filling in time attribute
!        9Mar2006 - Sienkiewicz - restore xvec ( = sigO) and modify
!                                 sigO screening criteria
!       24Jul2006 - Sienkiewicz - Corrected bug with time attribute
!       17Oct2006 - Sienkiewicz - add SSU
!       14Dec2006 - Todling     - update to gsi-2006_09
!       22Dec2006 - Sienkiewicz - update SSM/I history mark assignment
!       18Jan2008 - Todling     - Add ability to read in observation impacts
!       17Feb2012 - Todling     - Update to Sep2011 GSI
!       08Mar2012 - Todling     - Use pdata(5,i)<0 to identify passive data
!       29Mar2012 - Bloom/RT    - bug; sigo's were getting sqrt'd twice!
!       02Apr2014 - Todling     - when desired, write out table sigo to file
!       16Dec2016 - Todling     - add lreduced to indicate reduced diag
!                                 (use real chan number)
!EOP
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      character(len=*), parameter :: myname = 'ods_drad'

      integer, parameter   :: r_single = selected_real_kind(6)
      real(r_single)  zero_single,tiny_single
      real small_num,nlomx,tlomx

      logical satknown,lobsdiagsave,passed,ladjsigo,lreduced
      integer i, n, kidsat, kobs0, miter

      real, parameter :: undef = 1.e15

!     Pointers to ods attributes:
!     --------------------------
      integer, pointer :: kt(:)       ! data type index
      integer, pointer :: kx(:)       ! data source index
      integer, pointer :: ks(:)       ! sounding index
      real   , pointer :: lon(:)      ! longitude of obs (degrees)
      real   , pointer :: lat(:)      ! latitude of obs (degrees)
      real   , pointer :: lev(:)      ! pressure level of obs (hPa)
      integer, pointer :: time(:)     ! time
      real   , pointer :: obs(:)      ! observation
      real   , pointer :: OmF(:)      ! obs-minus-fcst (O-F)
      real   , pointer :: OmA(:)      ! obs-minus-ana  (O-A)
      real   , pointer :: sigo(:)     ! obs error std dev
      real   , pointer :: xm(:)       ! metadata
      integer, pointer :: qcx(:)      ! exclusion mark
      integer, pointer :: qch(:)      ! history mark

!     Assign pointers to ODS attributes
!     ---------------------------------
      kt   => ods%data%kt
      kx   => ods%data%kx
      ks   => ods%data%ks
      lon  => ods%data%lon
      lat  => ods%data%lat
      lev  => ods%data%lev
      time => ods%data%time
      obs  => ods%data%obs
      OmF  => ods%data%OmF
      OmA  => ods%data%OmA
      sigo => ods%data%Xvec
      xm   => ods%data%xm
      qcx  => ods%data%qcexcl
      qch  => ods%data%qchist

      tiny_single = tiny(zero_single)
      small_num = 10. * tiny_single

      rc = 0  ! all is well to start with

      call ods_obsdiags_getparam ( 'ladjsigo', ladjsigo )
      call ods_obsdiags_getparam ( 'lobsdiagsave', lobsdiagsave )
      if ( lobsdiagsave ) then
           call ods_obsdiags_getparam ( 'miter', miter )
           if (ndiag/=ipchan+npred+2+4*miter+1) then
              rc = 99
              print *, myname, ': dim violation(obs sens), obstype = ', obstype
              return
           endif
           if(ioff.ne.ipchan+npred+2) then
              rc = 99
              print *, myname, ': sensitivity index appears to be incorrect = ', ioff,ipchan+npred+2
              return
           endif
      endif
      call ods_obsdiags_getparam ( 'reduce_diag', lreduced )

      satknown = .false.
      kidsat   = isat
      do n = 1, nsats
         if(trim(sats(n))==trim(obstype)) then
            satknown = .true.
            kidsat   = kidsat+idsats(n)
            exit
         else
           cycle
         endif
      end do

      if (.not.satknown .or. kidsat==0) then
        rc = 98
        print *, myname, ': Cannot identify satellite type = ', obstype, ' kidsat = ', kidsat
        return
      endif

      kobs0 = kobs
      do i = 1, nchanl

	kobs	   = kobs + 1
        if (kobs>mobs) then
           rc = 98
           print *, myname, ': dim violation, obstype = ', obstype
           exit
        endif
        kt(kobs)   = ktTb		  ! brightness temperature
        kx(kobs)   = kidsat
        ks(kobs)   = iks

        lat(kobs)  = pinfo(1)
        lon(kobs)  = pinfo(2)
        if (lreduced) then
           lev(kobs)  = nuchan(i) ! in case of reduced diag output, need to use
                                  ! true channel number
        else
           lev(kobs)  = i ! nuchan(i) ---> back to index for now (RTodling)
        endif
        time(kobs) = pinfo(4) * 60	  ! time
        obs(kobs)  = pdata(1,i)           ! observed brightness temperature
        omf(kobs)  = pdata(2,i)   	  ! bias-corrected omf
        oma(kobs)  = undef		  ! no info available
        xm(kobs)   = pdata(3,i)-pdata(2,i)! bias correction

        qch(kobs)  = 0  		  ! no info available
        qcx(kobs)  = 0
	if (iuse(i)==-1.or.pdata(5,i)<0) qcx(kobs) = 1    ! passive data
	if (pdata(4,i)>small_num) then
           if (ladjsigo) then
              sigo(kobs) = 1.0/pdata(4,i)                 ! adjusted   sigo
           else
              sigo(kobs) = sqrt(varchn(i))                ! prescribed sigo
           endif
	else                                      ! rejected by GSI
	   sigo(kobs) = undef
	   if (qcx(kobs)==0) qcx(kobs) = 2
	endif

!       Place obs impacts in sigo slot
!       ------------------------------
        if ( lobsdiagsave ) then
             sigo(kobs) = 0.0
             call ods_obsdiags ( nlomx, tlomx, sigo(kobs), pdata, ioff, i, ndiag, nchanl, undef, passed )
             if(passed) qcx(kobs) = 0
        endif

      end do

!     Nullify pointers
!     -----------------
      if(associated(lat) ) nullify(lat)
      if(associated(lon) ) nullify(lon)
      if(associated(lev) ) nullify(lev)
      if(associated(time)) nullify(time)
      if(associated(kt)  ) nullify(kt)
      if(associated(kx)  ) nullify(kx)
      if(associated(ks)  ) nullify(ks)
      if(associated(xm)  ) nullify(xm)
      if(associated(qch) ) nullify(qch)
      if(associated(qcx) ) nullify(qcx)
      if(associated(obs) ) nullify(obs)
      if(associated(omf) ) nullify(omf)
      if(associated(oma) ) nullify(oma)
      if(associated(sigo)) nullify(sigo)

      end subroutine ods_drad


      SUBROUTINE xcorex( buf, lbuf, ibuf, scr, lscr, iscr )
!
!  Written by Paul Henkart, Scripps Institution of Oceanography, October 1998
!  Copyright (C) 1998 The Regents of the University of California
!  ALL RIGHTS RESERVED.
!
!  mod 6 Apr 99 - Add parameter CATS - Use previous trace as the pilot
!
      COMMON /sioap/ iasgnd, irelse, in, iout, nextad, lapsiz, ifree,
     *     iuseap
      COMMON /apmem/ a(32766)
      COMMON /readt/ ilun, numhdr, nsamps, ihunit, ireeln, jntrcs,
     *               ifmt, nskip, secs, lrenum, isrcf, idtype,
     *               nfskip, jform, itxsi, itxdel, nfktrc, norigtr,
     *               nrskip, nfiles
      COMMON /segyptr/ llsegptr, lrseqptr, lshotptr, lshtrptr, lrpnptr,
     *                 lrptrptr, itridptr, ldisptr,  lwbdptr,  lsxcoptr,
     *                 lrxcoptr, idelmptr, istmptr,  iendmptr, isampptr,
     *                 isiptr,   iyrptr,   idayptr,  ihrptr,   iminptr,
     *                 isecptr,  igmtptr,  ldelsptr, lsmusptr, lemusptr,
     *                 lsisptr,  lwbtsptr, lgatptr,  lssmsptr, lesmsptr,
     *                 lsbptr,   ifoldptr, icvleptr, lespnptr
      COMMON /corr/ ipunit, nlists, npwrds
      DIMENSION buf(111), lbuf(111), ibuf(111),
     &          scr(111), lscr(111), iscr(111)
      DIMENSION setp(2), setd(2)
      INTEGER*2 ibuf, iscr
      INTEGER lprint, pilot, psno, ptr
      DATA lastpi/0/
      SAVE

!****
!****  If a dead trace, exit now!
!****
      IF( ibuf(15) .EQ. 2 ) RETURN
C****
!****
      IF( mlists .EQ. 0 ) THEN
          CALL podisc( ipunit, 1, 0 )
          CALL rddisc( ipunit, scr, npwrds, istat  )
          IF( istat .NE. npwrds ) THEN
              PRINT *,' ***  ERROR  ***  Program error in seg2ex.',
     *           npwrds, istat
             STOP
         ENDIF
         mlists = mlists + 1
         lprint = lscr(1)
         pilot = lscr(2)
         nlags = lscr(3)
         setp(1) = scr(4)
         setp(2) = scr(5)
         setd(1) = scr(6)
         setd(2) = scr(7)
         lunpilot = lscr(8)
         psno = lscr(9)
         ptr = lscr(10)
         idouble = lscr(11)
         icats = lscr(12)
!****    get a file for the pilot trace - the pilot will always be there
!****    Edit saved the pilot in lunpilot if PPATH was given.
         IF( lunpilot .EQ. 0 )
     &       CALL getfil( 1, lunpilot, lscr, istat )
         IF( iuseap .EQ. 1 ) THEN
             PRINT *,' ***  ERROR  ***  CORR not set up for AP.'
             STOP
         ENDIF
         nsamps_pilot = ibuf(58)                                        ! If xcored wrote it.
      ENDIF
      IF( lbuf(7) .EQ. 0 ) THEN
          no = lbuf(3)
          itrno = lbuf(4)
      ELSE
          no = lbuf(6)
          itrno = lbuf(7)
      ENDIF
      si = buf(lsisptr)
!      nsamps_data = ibuf(isampptr)
      nsamps_data = nsamps
      delay = buf(ldelsptr)
!****
!****  Get the data into the "ap"
!****
      CALL inap( buf(numhdr+1), nsamps_data )
!**** pilot was preset to 1 by the edit
      IF( itrno .EQ. pilot ) THEN                                       ! save the pilot on disk
          CALL podisc( lunpilot, 0, 0 )
          CALL wrdisc( lunpilot, buf(numhdr+1), nsamps_data )
          nsamps_pilot = nsamps_data
      ENDIF
      CALL podisc( lunpilot, 0, 0 )
      CALL rddisc( lunpilot, a(nextad), nsamps_pilot, istat )
!****
!****   If CATS, save this trace to use as the pilot on the next trace
!**** The number of the pilot trace that's used in the correlation is
!**** in segy header word 5.
!****
      IF( icats .NE. 0 ) THEN
          CALL podisc( lunpilot, 0, 0 )
          CALL wrdisc( lunpilot, buf(numhdr+1), nsamps_data )
          nsamps_pilot = nsamps_data
          IF( lastpi .NE. lbuf(3) ) THEN
              CALL podisc( lunpilot, 0, 0 )
              CALL rddisc( lunpilot, a(nextad), nsamps_pilot, istat )
          ENDIF
          lastpi = lbuf(3)
      ENDIF
!****
!****  Set the indices (p for pilot, d for data)
!****
      istartp = NINT((setp(1)-delay)/si)
      IF( setp(2) .NE. 0. ) THEN
          iendp = NINT((setp(2)-delay)/si)
      ELSE
          iendp = nsamps_pilot
      ENDIF
      nsampsp = iendp - istartp + 1
      istartd = NINT((setd(1)-delay)/si)
      IF( setd(2) .NE. 0. ) THEN
          iendd = NINT((setd(2)-delay)/si)
      ELSE
          iendd = nsamps_data
      ENDIF
      nsampsd = iendd - istartd + 1
      IF( nlags .EQ. 0 ) nlags = (MIN0(nsampsd,nsampsp)/2)
!****
!****  Do the correlation and bring it out of the ap
!****
      IF( IAND(lprint,4) .NE. 0 ) THEN
        PRINT *,' istartp= ',istartp,' iendp=',iendp,' nsampsp=',nsampsp
        PRINT *,' istartd= ',istartd,' iendd=',iendd,' nsampsd=',nsampsd
        PRINT *,' nlags=',nlags, ' nsamps_pilot=',nsamps_pilot,
     &    ' nextad=',nextad
      ENDIF
      IF( lunpilot .EQ. 0 ) THEN
          PRINT *,' ***  ERROR  ***  No pilot given.'
          STOP
      ENDIF
      IF( idouble .EQ. 0 ) THEN
          CALL convo( 2, a(in+istartd), nsampsd, a(nextad+istartp),
     &       nsampsp, a(nextad+nsamps_pilot), nlags )
      ELSE
          CALL dconvo( 2, a(in+istartd), nsampsd, a(nextad+istartp),
     &       nsampsp, a(nextad+nsamps_pilot), nlags )
      ENDIF
      itemp = nextad+nsamps_pilot-1
      DO i = 1, nlags
         buf(numhdr+i) = a(itemp+i)
      ENDDO
      ibuf(idelmptr) = 0
      ibuf(isampptr) = nlags
      CALL long2ushort( nlags, ibuf(isampptr) )
      numdat = nlags
      buf(ldelsptr) = 0.
      in = 0

      RETURN
      END


      SUBROUTINE ARISET
C
C     Sets up parameters for ARIA assignment, calibration and
C     violation analysis.
C     Nilges, M., Macias, M., O'Donoghue, S., & Oschkinat, M. (1997).
C     Automated NOESY Interpretation with Ambiguous Distance Restraints
C     The Refined Solution Structure of the Pleckstrin Homology Domain
C     from beta-Spectrin.
C     J. Mol. Biol. 269, 408-422.
C
C     **********************************************
C     * Author and copyright: Michael Nilges, EMBL *
C     * No warranty implied or expressed           *
C     * All rights reserved                        *
C     **********************************************
C
      IMPLICIT NONE
C
      INCLUDE 'cns.inc'
      INCLUDE 'aria.inc'
      INCLUDE 'heap.inc'
      INCLUDE 'mtf.inc'
      INCLUDE 'funct.inc'
      INCLUDE 'noe.inc'
      INCLUDE 'numbers.inc'
C     local
      INTEGER ISLCT, JSLCT, NISLCT
C     begin
C
      IF (ARINIT) THEN
         CALL ARIHP(0,0,NATOM)
         NMRATM=NATOM
         CALL FILL4(HEAP(HPNHGL),NMRATM,1)
         CALL FILL4(HEAP(HPNPSE),NMRATM,1)
         CALL MAKIND(HEAP(HPNPSE),NMRATM,NISLCT)
         WRITE (6,'(A)') ' ARIA arrays initialized'
         ARINIT = .FALSE.
C         CALL MAKIND(NOEHGL,NMRATM,ISLCT)
      END IF
C
      ISLCT=ALLHP(INTEG4(NATOM))
      JSLCT=ALLHP(INTEG4(NATOM))
      CALL ARISE2(HEAP(ISLCT),HEAP(JSLCT),HEAP(HPNHGL),HEAP(HPNPSE))
      CALL FREHP(JSLCT,INTEG4(NATOM))
      CALL FREHP(ISLCT,INTEG4(NATOM))
C
      RETURN
      END
C====================================================================
      SUBROUTINE ARISE2(ISLCT,JSLCT,NOEHGL,NOEPSE)
C
C     **********************************************
C     * Author and copyright: Michael Nilges, EMBL *
C     * No warranty implied or expressed           *
C     * All rights reserved                        *
C     **********************************************
C
      IMPLICIT NONE
C
C     I/O
      INCLUDE 'cns.inc'
      INCLUDE 'mtf.inc'
      INCLUDE 'noe.inc'
      INCLUDE 'aria.inc'
      INCLUDE 'comand.inc'
      INCLUDE 'coord.inc'
      INCLUDE 'consta.inc'
      INCLUDE 'deriv.inc'
      INCLUDE 'heap.inc'
      INCLUDE 'funct.inc'
      INTEGER ISLCT(*), JSLCT(*), NOEHGL(*), NOEPSE(*)
C     local
      INTEGER I, J, NISLCT, NJSLCT, NMISS, IPEAK, MATDIM2, NHG2
      INTEGER IAT, JAT, II, JJ, NIAT, NJAT
      CHARACTER*4 CLASS, ACTION
      DOUBLE PRECISION VIOUPL, VIOLOL, TEMPX, TEMPY, TEMPZ
      DOUBLE PRECISION OLDNOE, NEWNOE, FSWAP, RNUM
      LOGICAL MATCH, QNEXT
C     parameter
      DOUBLE PRECISION ZERO, ONE, SIX
      PARAMETER (ZERO=0.0D0, ONE=1.0D0, SIX=6.0D0)
C     function
      INTEGER BONDED
      LOGICAL FRSTEL
      EXTERNAL FRSTEL, BONDED
C
C     begin
C
C     all defaults are set in NOERES!
      CALL PUSEND('ARIA>')
      DO WHILE (.NOT.DONE)
         CALL NEXTWD('ARIA>')
         CALL MISCOM('ARIA>',USED)
         IF (.NOT.USED) THEN
C
            IF (WD(1:4).EQ.'HELP') THEN
               CALL CNSHELP('cns-aria')
C
C====================================================================
            ELSE IF (WD(1:2).EQ.'DO') THEN
               CALL ARIMAN(HEAP(HPNDIS),HEAP(HPNLOW),HEAP(HPNHIG),
     &              HEAP(HPNWGH),HEAP(HPNVOL),HEAP(HPNCV))
C====================================================================
            ELSE IF (WD(1:4).EQ.'FLOA') THEN
               CALL PUSEND('FLOAting-assignment>')
               DO WHILE (.NOT.DONE)
                  CALL NEXTWD('FLOAting-assignment>')
C
                  IF (WD(1:4).EQ.'HELP') THEN
                     CALL CNSHELP('cns-aria-floatingassignment')
C
                  ELSE IF (WD(1:4).EQ.'DEFI') THEN
                     CALL SELCTA(ISLCT,NISLCT,X,Y,Z,.TRUE.)
                     IF (NISLCT.GT.0) THEN
                        NMISS=0
                        DO I=1,NATOM
                           IF ((ISLCT(I).GT.0).AND.
     $                          (.NOT.FRSTEL(I,NOEHGL)))
     $                          THEN
                              ISLCT(I)=0
                              NISLCT=NISLCT-1
                           END IF
                        END DO
                     END IF
                     IF (NISLCT.EQ.2) THEN
                        CALL MAKIND(ISLCT,NATOM,NISLCT)
                        IAT=ISLCT(1)
                        JAT=ISLCT(2)
                        NOEPSE(IAT)=JAT
                     ELSE
                        WRITE(6,'(A,A)') ' ARIA-FLOAT-ERR: exactly',
     $                       ' two atom groups have to be selected '
                     END IF
C
                  ELSE IF (WD(1:4).EQ.'SWAP') THEN
                     CALL NEXTF('SWAP_limit',FSWAP)
                     DO I=1,NATOM
                        CALL GGUBFS(RNUM)
                        IF ((NOEPSE(I).NE.I).AND.(RNUM.LT.FSWAP)) THEN
                           JJ=ABS(NOEPSE(I))
                           CALL ENOE(OLDNOE,'NOAN',0)
                           CALL ARIFLI(IAT,JAT,ISLCT,JSLCT,
     $                          HEAP(HPNILS), HEAP(HPNJLS), NOEHGL)
                           CALL ENOE(NEWNOE,'NOAN',0)
                           WRITE(6,'(A,2F15.5)')
     $                          ' ARIFLI energies: ', OLDNOE, NEWNOE
C     we store the information on the flipping in NOEPSE
                           IF (NEWNOE.GT.OLDNOE) THEN
                              CALL ARIFLI(IAT,JAT,ISLCT,JSLCT,
     $                             HEAP(HPNILS), HEAP(HPNJLS),NOEHGL)
                           ELSE
                              IF (NOEPSE(IAT).EQ.IAT) THEN
                                 NOEPSE(IAT)=-JAT
                              ELSE
                                 NOEPSE(IAT)=-NOEPSE(IAT)
                              END IF
                           END IF
                        END IF
                     END DO
C
                  ELSE IF (WD(1:4).EQ.'STOR') THEN
C
C     this writes the state of the assignments to a print file.
                     DO I=1,NATOM
                        IF (NOEPSE(I).LT.0) THEN
                           II=I
                           NOEPSE(I)=-NOEPSE(I)
                           JJ=NOEPSE(I)
                           NOEPSE(JJ)=I
C
                           WRITE(PUNIT,'(14A)')
     $                          ' REVE ((segid "',SEGID(II),
     &                          '" and resid ',RESID(II),
     &                          ' and name ',TYPE(II),')',
     $                          ' OR   ( segid "',SEGID(JJ),
     &                          '" and resid ',RESID(JJ),
     &                          ' and name ',TYPE(JJ),'))'
                        END IF
                     END DO
                  ELSE
                     CALL CHKEND('FLOAting-assignment>',DONE)
                  END IF
               END DO
               DONE=.FALSE.
C====================================================================
            ELSE IF (WD(1:4).EQ.'CFLI') THEN
               CALL SELCTA(ISLCT,NISLCT,X,Y,Z,.TRUE.)
               IF (NISLCT.GT.0) THEN
                  NMISS=0
                  DO I=1,NATOM
                     IF ((ISLCT(I).GT.0).AND.
     $                    (.NOT.FRSTEL(I,NOEHGL))
     $                    .OR..NOT.INITIA(I,X,Y,Z)) THEN
                        ISLCT(I)=0
                        NMISS=NMISS+1
                        NISLCT=NISLCT-1
                     END IF
                  END DO
               END IF
               IF (NISLCT.EQ.2) THEN
                  CALL MAKIND(ISLCT,NATOM,NISLCT)
                  II=ISLCT(1)
                  JJ=ISLCT(2)
                  NIAT=0
                  QNEXT=.TRUE.
                  DO WHILE (QNEXT)
                     NIAT=NIAT+1
                     ISLCT(NIAT)=II
                     CALL NEXTHY(II, NOEHGL,QNEXT)
                  END DO
                  NJAT=0
                  QNEXT=.TRUE.
                  DO WHILE (QNEXT)
                     NJAT=NJAT+1
                     JSLCT(NJAT)=JJ
                     CALL NEXTHY(JJ, NOEHGL,QNEXT)
                  END DO
C
                  IF (NIAT.EQ.NJAT) THEN
                     DO II=1,NIAT
                        IAT=ISLCT(II)
                        JAT=JSLCT(II)
                        TEMPX=X(IAT)
                        TEMPY=Y(IAT)
                        TEMPZ=Z(IAT)
                        X(IAT)=X(JAT)
                        Y(IAT)=Y(JAT)
                        Z(IAT)=Z(JAT)
                        X(JAT)=TEMPX
                        Y(JAT)=TEMPY
                        Z(JAT)=TEMPZ
                     END DO
C     this is maybe a little risky
C     the heavy atom attached to the first
C     of the hydrogens is swapped, too
                     IF (NIAT.GT.1) THEN
                        IAT=BONDED(ISLCT(1))
                        JAT=BONDED(JSLCT(1))
                        TEMPX=X(IAT)
                        TEMPY=Y(IAT)
                        TEMPZ=Z(IAT)
                        X(IAT)=X(JAT)
                        Y(IAT)=Y(JAT)
                        Z(IAT)=Z(JAT)
                        X(JAT)=TEMPX
                        Y(JAT)=TEMPY
                        Z(JAT)=TEMPZ
                     END IF
                  END IF
               END IF
C
            ELSE IF (WD(1:4).EQ.'VFLI') THEN
C
               IF (NISLCT.GT.0) THEN
                  NMISS=0
                  DO I=1,NATOM
                     IF (ISLCT(I).NE.1) THEN
                     ELSE IF (.NOT.INITIA(I,X,Y,Z)) THEN
                        ISLCT(I)=0
                        NMISS=NMISS+1
                        NISLCT=NISLCT-1
                     END IF
                  END DO
               END IF
               IF (NISLCT.EQ.2) THEN
                  CALL MAKIND(ISLCT,NATOM,NISLCT)
                  TEMPX=XV(ISLCT(1))
                  TEMPY=YV(ISLCT(1))
                  TEMPZ=ZV(ISLCT(1))
                  XV(ISLCT(1))=XV(ISLCT(2))
                  YV(ISLCT(1))=YV(ISLCT(2))
                  ZV(ISLCT(1))=ZV(ISLCT(2))
                  XV(ISLCT(2))=TEMPX
                  YV(ISLCT(2))=TEMPY
                  ZV(ISLCT(2))=TEMPZ
               END IF
C
C====================================================================
            ELSE IF (WD(1:4).EQ.'FLIP') THEN
C
               CALL SELCTA(ISLCT,NISLCT,X,Y,Z,.TRUE.)
               IF (NISLCT.GT.0) THEN
                  NMISS=0
                  DO I=1,NATOM
                     IF ((ISLCT(I).GT.0).AND.
     $                    (.NOT.FRSTEL(I,NOEHGL)))
     $                    THEN
                        ISLCT(I)=0
                        NISLCT=NISLCT-1
                     END IF
                  END DO
               END IF
C
               WRITE (6, '(A,I6,A)') ' ARIFLI: ', NISLCT,
     $              ' groups selected'
               IF (NISLCT.EQ.2) THEN
                  CALL MAKIND(ISLCT,NATOM,NISLCT)
                  IAT=ISLCT(1)
                  JAT=ISLCT(2)
                  CALL ENOE(OLDNOE,'NOAN',0)
                  CALL ARIFLI(IAT,JAT,ISLCT,JSLCT,HEAP(HPNILS),
     $                 HEAP(HPNJLS), NOEHGL)
                  CALL ENOE(NEWNOE,'NOAN',0)
                  WRITE(6,'(A,2F15.5)')
     $                 ' ARIFLI energies: ', OLDNOE, NEWNOE
C     we store the information on the flipping in NOEPSE
                  IF (NEWNOE.GT.OLDNOE) THEN
                     CALL ARIFLI(IAT,JAT,ISLCT,JSLCT,
     $                    HEAP(HPNILS), HEAP(HPNJLS),NOEHGL)
                  ELSE
                     IF (NOEPSE(IAT).EQ.IAT) THEN
                        NOEPSE(IAT)=-JAT
                     ELSE
                        NOEPSE(IAT)=-NOEPSE(IAT)
                     END IF
                  END IF
               END IF
C
C
C====================================================================
            ELSE IF (WD(1:4).EQ.'KEEP') THEN
C     do nothing - leave group as it is - just parse
               CALL SELCTA(ISLCT,NISLCT,X,Y,Z,.TRUE.)
C
C====================================================================
            ELSE IF (WD(1:4).EQ.'REVE') THEN
C
               CALL SELCTA(ISLCT,NISLCT,X,Y,Z,.TRUE.)
               IF (NISLCT.GT.0) THEN
                  NMISS=0
                  DO I=1,NATOM
                     IF ((ISLCT(I).GT.0).
     $                    AND.(.NOT.FRSTEL(I,NOEHGL))) THEN
                        ISLCT(I)=0
                        NISLCT=NISLCT-1
                     END IF
                  END DO
               END IF
C
ccc   WRITE (6, '(A,I6,A)') ' ARIFLI: ', NISLCT, ' groups selected'
               IF (NISLCT.EQ.2) THEN
                  CALL MAKIND(ISLCT,NATOM,NISLCT)
                  IAT=ISLCT(1)
                  JAT=ISLCT(2)
                  CALL ARIFLI(IAT,JAT,ISLCT,JSLCT,HEAP(HPNILS),
     $                 HEAP(HPNJLS),NOEHGL)
                  IF (NOEPSE(IAT).EQ.IAT) THEN
                     NOEPSE(IAT)=-JAT
                  ELSE
                     NOEPSE(IAT)=-NOEPSE(IAT)
                  END IF
               END IF
C
C====================================================================
            ELSE IF (WD(1:4).EQ.'MODI') THEN
C     get peakid, then use truncated form of noeass
C     e.g. modify 333 test=0 end
               CALL ARIMOD(HEAP(HPNORR),
     &              HEAP(HPNIPR),
     &              HEAP(HPNILS),HEAP(HPNJPR),HEAP(HPNJLS),
     $              HEAP(HPNCND),
     &              HEAP(HPNRAV),HEAP(HPNRRV),HEAP(HPNNSP),
     $              HEAP(HPNDIS),
     &              HEAP(HPNLOW),HEAP(HPNHIG),HEAP(HPNWGH),
     $              HEAP(HPNCV),
     &              HEAP(HPNVIO),
     &              HEAP(HPNPID),
     &              HEAP(HPNPP1),HEAP(HPNPP2),HEAP(HPNHP1),
     $              HEAP(HPNHP2),
     &              HEAP(HPNVOL),NATOM,ISLCT,NISLCT,
     &              JSLCT,NJSLCT,X,Y,Z)
C===================================================================
            ELSE IF (WD(1:4).EQ.'?   ') THEN
               WRITE(6,'(A,I6,A,I6,A,/,A,F8.3,A,I6)')
     &              ' NOE: total number of restraints:',NOENUM,
     &              ' partitioned into ',NOECCN,' classes',
     &              ' NOE: ceiling=',NOECEI
     $              ,' current allocation=',NOEMAX
               IF (NOEICV.GT.0) THEN
                  WRITE(6,'(2A,/,A,I6)')
     &                 ' NOE: data are partitioned into working set',
     $                 ' and test set.',
     &                 ' NOE: test set number=',NOEICV
               END IF
C===================================================================
            ELSE IF (WD(1:4).EQ.'COUN') THEN
C
C     get the class name:
               CALL PUSEND('COUNtviolations>')
               DO WHILE (.NOT.DONE)
                  CALL NEXTWD('COUNtviolations>')
C
                  IF (WD(1:4).EQ.'HELP') THEN
                     CALL CNSHELP('cns-aria-countviolations')
C
                  ELSE IF (WD(1:4).EQ.'RESE') THEN
                     VIOSTR = 0
                     VIOEXC = ZERO
                     VIOTHR = ZERO
                     CALL NOEEXC(0,NOENUM,VIOEXC,VIOSTR,'INIT',
     $                    ZERO,ZERO,
     1                    HEAP(HPNORR),HEAP(HPNIPR),HEAP(HPNILS
     $                    ),HEAP(HPNJPR),HEAP(HPNJLS)
     $                    ,HEAP(HPNCND),HEAP(HPNRAV)
     $                    ,HEAP(HPNRRV),HEAP(HPNDIS)
     $                    ,HEAP(HPNLOW),HEAP(HPNHIG)
     $                    ,HEAP(HPNVOL),HEAP(HPNPP1)
     $                    ,HEAP(HPNPP2),HEAP(HPNHP1)
     $                    ,HEAP(HPNHP2),HEAP(HPNWGH)
     $                    ,HEAP(HPNVIO),HEAP(HPNNUM)
     $                    ,HEAP(HPNNSP),HEAP(HPNCV),HEAP(HPNEXC
     $                    ),HEAP(HPNPID),HEAP(HPCDIS))
C
                  ELSE IF (WD(1:4).EQ.'THRE') THEN
                     CALL NEXTF('THREshold=',VIOTHR)
                     VIOSTR=VIOSTR+1
                     CALL ARIVIO(HEAP(HPNORR),HEAP(HPNIPR),
     $                    HEAP(HPNILS),HEAP(HPNJPR),
     $                    HEAP(HPNJLS),HEAP(HPNCND),HEAP(HPNRAV
     $                    ), HEAP(HPNRRV),HEAP(HPNDIS)
     $                    ,HEAP(HPNLOW),HEAP(HPNHIG)
     $                    ,HEAP(HPNVOL), HEAP(HPNPP1)
     $                    ,HEAP(HPNPP2),HEAP(HPNHP1),
     $                    HEAP(HPNHP2), HEAP(HPNWGH)
     $                    ,HEAP(HPNVIO), HEAP(HPNNUM),
     $                    HEAP(HPNNSP),HEAP(HPNCV),HEAP(HPNEXC)
     $                    , HEAP(HPNPID))
C
                  ELSE IF (WD(1:4).EQ.'EXCL') THEN
                     CALL NEXTA4('class-name=',CLASS)
                     CALL NEXTF('EXCLude=',VIOEXC)
                     DO I=1,NOECCN
                        CALL EQSTWC(NOECNM(I),4,CLASS,4,1,1
     $                       ,MATCH)
                        IF (MATCH) THEN
                           CALL NOEEXC(I,NOENUM,VIOEXC,VIOSTR
     $                          ,'EXCL',ZERO,ZERO,HEAP(HPNORR)
     $                          ,HEAP(HPNIPR),HEAP(HPNILS)
     $                          ,HEAP(HPNJPR),HEAP(HPNJLS)
     $                          ,HEAP(HPNCND),HEAP(HPNRAV)
     $                          ,HEAP(HPNRRV),HEAP(HPNDIS)
     $                          ,HEAP(HPNLOW),HEAP(HPNHIG)
     $                          ,HEAP(HPNVOL),HEAP(HPNPP1)
     $                          ,HEAP(HPNPP2),HEAP(HPNHP1)
     $                          ,HEAP(HPNHP2),HEAP(HPNWGH)
     $                          ,HEAP(HPNVIO),HEAP(HPNNUM)
     $                          ,HEAP(HPNNSP),HEAP(HPNCV)
     $                          ,HEAP(HPNEXC),HEAP(HPNPID)
     $                          ,HEAP(HPCDIS))
                        END IF
                     END DO
C
                  ELSE IF (WD(1:3).EQ.'SET') THEN
                     CALL NEXTA4('class-name=',CLASS)
                     CALL NEXTF('ratio=',VIOEXC)
C     get lower limit. check for TOKEN.
                     CALL NEXTA4('lower_limit=',ACTION)
                     IF (ACTION.EQ.'TOKE') THEN
                        VIOLOL = -ONE
                     ELSE
                        CALL SAVEWD
                        CALL NEXTF('lower_limit=',VIOLOL)
                     END IF
C     get upper limit. check for TOKEN.
                     CALL NEXTA4('upper_limit=',ACTION)
                     IF (ACTION.EQ.'TOKE') THEN
                        VIOUPL = -ONE
                     ELSE
                        CALL SAVEWD
                        CALL NEXTF('upper_limit=',VIOUPL)
                     END IF
C
                     DO I=1,NOECCN
                        CALL EQSTWC(NOECNM(I),4,CLASS,4,1,1
     $                       ,MATCH)
                        IF (MATCH) THEN
                           CALL NOEEXC(I,NOENUM,VIOEXC,VIOSTR
     $                          ,'SET ',VIOLOL,VIOUPL
     $                          ,HEAP(HPNORR),HEAP(HPNIPR)
     $                          ,HEAP(HPNILS),HEAP(HPNJPR)
     $                          ,HEAP(HPNJLS),HEAP(HPNCND)
     $                          ,HEAP(HPNRAV),HEAP(HPNRRV)
     $                          ,HEAP(HPNDIS),HEAP(HPNLOW)
     $                          ,HEAP(HPNHIG),HEAP(HPNVOL)
     $                          ,HEAP(HPNPP1),HEAP(HPNPP2)
     $                          ,HEAP(HPNHP1),HEAP(HPNHP2)
     $                          ,HEAP(HPNWGH),HEAP(HPNVIO)
     $                          ,HEAP(HPNNUM),HEAP(HPNNSP)
     $                          ,HEAP(HPNCV),HEAP(HPNEXC)
     $                          ,HEAP(HPNPID),HEAP(HPCDIS))
                        END IF
                     END DO
C
                  ELSE IF (WD(1:4).EQ.'MULT') THEN
                     CALL NEXTA4('class-name=',CLASS)
                     CALL NEXTF('ratio=',VIOEXC)
C     get lower limit. check for TOKEN.
                     CALL NEXTA4('lower_limit=',ACTION)
                     IF (ACTION.EQ.'TOKE') THEN
                        VIOLOL = -ONE
                     ELSE
                        CALL SAVEWD
                        CALL NEXTF('lower_limit=',VIOLOL)
                     END IF
C     get upper limit. check for TOKEN.
                     CALL NEXTA4('upper_limit=',ACTION)
                     IF (ACTION.EQ.'TOKE') THEN
                        VIOUPL = -ONE
                     ELSE
                        CALL SAVEWD
                        CALL NEXTF('upper_limit=',VIOUPL)
                     END IF
C
                     DO I=1,NOECCN
                        CALL EQSTWC(NOECNM(I),4,CLASS,4,1,1
     $                       ,MATCH)
                        IF (MATCH) THEN
                           CALL NOEEXC(I,NOENUM,VIOEXC,VIOSTR
     $                          ,'MULT',VIOLOL,VIOUPL
     $                          ,HEAP(HPNORR),HEAP(HPNIPR)
     $                          ,HEAP(HPNILS),HEAP(HPNJPR)
     $                          ,HEAP(HPNJLS),HEAP(HPNCND)
     $                          ,HEAP(HPNRAV),HEAP(HPNRRV)
     $                          ,HEAP(HPNDIS),HEAP(HPNLOW)
     $                          ,HEAP(HPNHIG),HEAP(HPNVOL)
     $                          ,HEAP(HPNPP1),HEAP(HPNPP2)
     $                          ,HEAP(HPNHP1),HEAP(HPNHP2)
     $                          ,HEAP(HPNWGH),HEAP(HPNVIO)
     $                          ,HEAP(HPNNUM),HEAP(HPNNSP)
     $                          ,HEAP(HPNCV),HEAP(HPNEXC)
     $                          ,HEAP(HPNPID),HEAP(HPCDIS))
                        END IF
                     END DO
C
                  ELSE IF (WD(1:4).EQ.'WEIG') THEN
                     CALL NEXTA4('class-name=',CLASS)
                     DO I=1,NOECCN
                        CALL EQSTWC(NOECNM(I),4,CLASS,4,1,1
     $                       ,MATCH)
                        IF (MATCH) THEN
                           CALL NOEEXC(I,NOENUM,VIOEXC,VIOSTR
     $                          ,'WEIG',VIOLOL,VIOUPL
     $                          ,HEAP(HPNORR),HEAP(HPNIPR)
     $                          ,HEAP(HPNILS),HEAP(HPNJPR)
     $                          ,HEAP(HPNJLS),HEAP(HPNCND)
     $                          ,HEAP(HPNRAV),HEAP(HPNRRV)
     $                          ,HEAP(HPNDIS),HEAP(HPNLOW)
     $                          ,HEAP(HPNHIG),HEAP(HPNVOL)
     $                          ,HEAP(HPNPP1),HEAP(HPNPP2)
     $                          ,HEAP(HPNHP1),HEAP(HPNHP2)
     $                          ,HEAP(HPNWGH),HEAP(HPNVIO)
     $                          ,HEAP(HPNNUM),HEAP(HPNNSP)
     $                          ,HEAP(HPNCV),HEAP(HPNEXC)
     $                          ,HEAP(HPNPID))
                        END IF
                     END DO
C
                  ELSE IF (WD(1:4).EQ.'LIST') THEN
                     CALL NEXTA4('class-name=',CLASS)
                     CALL NEXTF('EXCLude=',VIOEXC)
                     DO I=1,NOECCN
                        CALL EQSTWC(NOECNM(I),4,CLASS,4,1,1
     $                       ,MATCH)
                        IF (MATCH) THEN
                           CALL NVIOLS(NOENUM,VIOEXC,VIOSTR,
     1                          HEAP(HPNORR),HEAP(HPNIPR),
     $                          HEAP(HPNILS),HEAP(HPNJPR),
     1                          HEAP(HPNJLS),HEAP(HPNCND),
     $                          HEAP(HPNRAV),HEAP(HPNRRV),
     1                          HEAP(HPNDIS),HEAP(HPNLOW),
     $                          HEAP(HPNHIG),HEAP(HPNVOL),
     1                          HEAP(HPNPP1),HEAP(HPNPP2),
     $                          HEAP(HPNHP1),HEAP(HPNHP2),
     1                          HEAP(HPNWGH),HEAP(HPNVIO),
     $                          HEAP(HPNNUM),
     1                          HEAP(HPNNSP),HEAP(HPNCV)
     $                          ,HEAP(HPNEXC),HEAP(HPNPID))
                        END IF
                     END DO
C
                  ELSE
                     CALL CHKEND('COUNtviolations>',DONE)
                  END IF
               END DO
               DONE=.FALSE.
C====================================================================
            ELSE IF (WD(1:4).EQ.'CALI') THEN
               HPNDIA=ALLHP(IREAL8(NATOM))
               CALL FILLR8(HEAP(HPNDIA),NATOM,1.0D0)
               HPNCAL=ALLHP(INTEG4(NATOM))
               CALL FILL4(HEAP(HPNCAL),NATOM,0)
               CALL CALIBR(ISLCT,HEAP(HPNCAL),HEAP(HPNDIA))
               CALL FREHP(HPNCAL,INTEG4(NATOM))
               CALL FREHP(HPNDIA,IREAL8(NATOM))
C====================================================================
            ELSE IF (WD(1:4).EQ.'ANAL') THEN
               CALL ANALRS(NOEHGL,ISLCT,JSLCT)
C====================================================================
c            ELSE IF (WD(1:4).EQ.'RESE') THEN
c               ARINIT=.TRUE.
c               CALL ARIINI
C====================================================================
            ELSE
               CALL CHKEND('ARIA>',DONE)
            END IF
         END IF
      END DO
      DONE=.FALSE.
      RETURN
      END
C
C====================================================================
C
      SUBROUTINE ARIFLI(I,J,ISLCT,JSLCT,NOEILS,NOEJLS,NOEHGL)
C
C     flips the assignments of two atoms in the restraint list
C
C     **********************************************
C     * Author and copyright: Michael Nilges, EMBL *
C     * No warranty implied or expressed           *
C     * All rights reserved                        *
C     **********************************************
C
      IMPLICIT NONE
C
C     -I/O
      INCLUDE 'cns.inc'
      INCLUDE 'cnst.inc'
      INCLUDE 'comand.inc'
      INCLUDE 'consta.inc'
      INCLUDE 'coord.inc'
      INCLUDE 'funct.inc'
      INCLUDE 'mtf.inc'
      INCLUDE 'noe.inc'
      INTEGER NOEILS(*),NOEJLS(*)
      INTEGER NOEHGL(*),ISLCT(*),JSLCT(*),I,J
C     -local
      INTEGER II,JJ,NIAT,NJAT,IINOE
      LOGICAL QNEXT
C
C     -begin
C
      NIAT=0
      II=I
      QNEXT=.TRUE.
      DO WHILE (QNEXT)
         NIAT=NIAT+1
         ISLCT(NIAT)=II
         CALL NEXTHY(II, NOEHGL,QNEXT)
      END DO
      NJAT=0
      JJ=J
      QNEXT=.TRUE.
      DO WHILE (QNEXT)
         NJAT=NJAT+1
         JSLCT(NJAT)=JJ
         CALL NEXTHY(JJ, NOEHGL,QNEXT)
      END DO
C      WRITE(6,'(A,2I5)') ' ARIFLI: atoms in group: ', NIAT, NJAT
      IF (NIAT.EQ.NJAT) THEN
         DO IINOE=1,NOEMAX
            DO II=1,NIAT
               IF (NOEILS(IINOE).EQ.ISLCT(II)) THEN
                  NOEILS(IINOE)=JSLCT(II)
               ELSEIF (NOEILS(IINOE).EQ.JSLCT(II)) THEN
                  NOEILS(IINOE)=ISLCT(II)
               END IF
               IF (NOEJLS(IINOE).EQ.ISLCT(II)) THEN
                  NOEJLS(IINOE)=JSLCT(II)
               ELSEIF (NOEJLS(IINOE).EQ.JSLCT(II)) THEN
                  NOEJLS(IINOE)=ISLCT(II)
               END IF
            END DO
         END DO
      END IF
C
      RETURN
      END
C
C====================================================================
C
      SUBROUTINE ARIMOD(NOEORR,
     &     NOEIPR,NOEILS,NOEJPR,NOEJLS,NOECND,NOERAV,NOERRV,
     &     NOESTP,NOEDIS,NOELOW,NOEHIG,NOEWGH,NOECV,NOEVIO,
     &     NOEPID,NOEPP1,NOEPP2,NOEHP1,NOEHP2,NOEVOL,
     &     NATOM,ISLCT,NISLCT,
     &     JSLCT,NJSLCT,X,Y,Z)
C
C     Subroutine modifies any of the values of the specified restraint.
C     e.g., MODIFY H200 1111 TEST=0 END
C
C     **********************************************
C     * Author and copyright: Michael Nilges, EMBL *
C     * No warranty implied or expressed           *
C     * All rights reserved                        *
C     **********************************************
C
      IMPLICIT NONE
C
      INCLUDE 'cns.inc'
      INCLUDE 'noe.inc'
      INCLUDE 'comand.inc'
      INCLUDE 'numbers.inc'
C     I/O
      INTEGER NOEORR(*)
      INTEGER NOEIPR(*), NOEILS(*), NOEJPR(*), NOEJLS(*), NOECND(*)
      DOUBLE PRECISION NOERAV(*), NOERRV(*), NOEDIS(*)
      DOUBLE PRECISION NOELOW(*), NOEHIG(*), NOEWGH(*)
      INTEGER NOECV(*), NOEVIO(*), NOESTP(*), NOEPID(*)
      DOUBLE PRECISION NOEPP1(*),NOEPP2(*),NOEHP1(*),NOEHP2(*)
     $     ,NOEVOL(*)
      INTEGER NATOM, ISLCT(*), NISLCT, JSLCT(*), NJSLCT
      DOUBLE PRECISION X(*), Y(*), Z(*)
C     local
      INTEGER I, II, JJ, J, TISLCT, TJSLCT, IINOE, PEAKID
      LOGICAL SUCCES,OK,FOUND
      CHARACTER*4 CLASS
C
C     begin
C
      CALL NEXTA4('class-name=',CLASS)
      CALL NEXTI('PEAKid=',PEAKID)
      IINOE=0
      FOUND=.FALSE.
      DO WHILE (.NOT.FOUND.AND.IINOE.LT.NOENUM)
         IINOE=IINOE+1
         FOUND = (NOEPID(IINOE).EQ.PEAKID)
     $        .AND.(CLASS.EQ.NOECNM(NOECND(IINOE)))
      END DO
      IF (.NOT.FOUND) THEN
         WRITE(6,'(A)')
     &        ' %ARIMOD-ERR: peak not found'
         IINOE=NOEMAX
      END IF

C
         CALL PUSEND('ARIMOD>')
         DO WHILE (.NOT. DONE)
            CALL NEXTWD('ARIMOD>')
            CALL MISCOM('ARIMOD>',USED)
            IF (.NOT.USED) THEN
C
               IF (WD(1:4).EQ.'HELP') THEN
                  CALL CNSHELP('cns-noe')
               ELSEIF (WD(1:4).EQ.'DIST') THEN
                  CALL NEXTF('Distance=',NOEDIS(IINOE))
               ELSEIF (WD(1:4).EQ.'LOW ') THEN
                  CALL NEXTF('lower-error=',NOELOW(IINOE))
               ELSEIF (WD(1:4).EQ.'HIGH') THEN
                  CALL NEXTF('higher-error=',NOEHIG(IINOE))
               ELSE IF (WD(1:4).EQ.'PPM1') THEN
                  CALL NEXTF('PPM(F1)=',NOEPP1(IINOE))
               ELSE IF (WD(1:4).EQ.'PPM2') THEN
                  CALL NEXTF('PPM(F2)=',NOEPP2(IINOE))
               ELSE IF (WD(1:4).EQ.'HPM1') THEN
                  CALL NEXTF('PPM(F1)=',NOEHP1(IINOE))
               ELSE IF (WD(1:4).EQ.'HPM2') THEN
                  CALL NEXTF('PPM(F2)=',NOEHP2(IINOE))
               ELSE IF (WD(1:4).EQ.'VOLU') THEN
                  CALL NEXTF('VOLUME=',NOEVOL(IINOE))
               ELSE IF (WD(1:4).EQ.'WEIG') THEN
                  CALL NEXTF('WEIGHT=',NOEWGH(IINOE))
               ELSE IF (WD(1:4).EQ.'CV  ') THEN
                  CALL NEXTI('CV=',NOECV(IINOE))
               ELSE
                  CALL CHKEND('ARIMOD>',DONE)
               END IF
            END IF
         END DO
         DONE=.FALSE.
      RETURN
      END
C
C=======================================================================
      SUBROUTINE ATGR(NATOM,HGLNK,IATGR)
C
C     sets up pointer array  iat --> igra
C     (<=> HGLNK(IAT) >= I; then enter all atoms in group)
C
C     **********************************************
C     * Author and copyright: Michael Nilges, EMBL *
C     * No warranty implied or expressed           *
C     * All rights reserved                        *
C     **********************************************
C
      IMPLICIT NONE
C
C     input/ output
      INTEGER NATOM, HGLNK(*), IATGR(*)
      LOGICAL FRSTEL
      EXTERNAL FRSTEL
C
C     local
      INTEGER I,I1,NGRP
      LOGICAL QNEXT
C
C     begin
C
      DO I=1,NATOM
         IATGR(I)=0
      END DO
C
      NGRP=0
      DO I=1,NATOM
         IF (FRSTEL(I,HGLNK)) THEN
            NGRP=NGRP+1
            I1=I
            QNEXT=.TRUE.
            DO WHILE (QNEXT)
               CALL NEXTHY(I1,HGLNK,QNEXT)
               IATGR(I1)=NGRP
            END DO
         END IF
      END DO
C
      RETURN
      END
C====================================================================
C
      SUBROUTINE NEXTHY(IAT, HGLNK, QNEXT)
C
C     -returns next element in a group in IAT (cyclically).
C     -QNEXT true if there are elements left in group
C
      IMPLICIT NONE
C
C     -global
C
C     -input/ output
      INTEGER IAT, HGLNK(*)
      LOGICAL QNEXT
C
C     -local
      INTEGER JAT
C
C     -begin
C
      JAT=HGLNK(IAT)
      QNEXT=(HGLNK(JAT).LT.JAT)
      IAT=JAT
C
      END
C
C======================================================================
C
      SUBROUTINE EQVGRP(NATOM,HGLNK)
C
C     group hydrogen atoms into groups of unresolved hydrogens.
C
C     Author and copyright: Michael Nilges, EMBL
C     No warranty implied or expressed
C     All rights reserved
C
      IMPLICIT NONE
C     global
      INCLUDE 'cns.inc'
      INCLUDE 'funct.inc'
      INCLUDE 'comand.inc'
      INCLUDE 'heap.inc'
      INCLUDE 'coord.inc'
C     input/output
      INTEGER NATOM,HGLNK(*)
C     local
      INTEGER IISLCT,INHYBO,IPATBO,NSLCT,NHYBMX,IHGR
C
C     begin
C
      NHYBMX=4
C
C     initialise group link array
C
C     allocate space for the bond lists
      IISLCT=ALLHP(INTEG4(NATOM))
      INHYBO=ALLHP(INTEG4(NATOM))
      IPATBO=ALLHP(INTEG4(NHYBMX*NATOM))
      IHGR=ALLHP(INTEG4(NATOM))
C
C     -parsing
      CALL PUSEND('EQUIvalent>')
      DO WHILE (.NOT. DONE)
         CALL NEXTWD('EQUIvalent>')
         CALL MISCOM('EQUIvalent>',USED)
         IF (.NOT.USED) THEN
C
            IF (WD(1:4).EQ.'HELP') THEN
               CALL CNSHELP('cns-aria-equivalent')
C=====================================================================
            ELSE IF (WD(1:4).EQ.'METH') THEN
               CALL ALLGRP(3,.FALSE.,HGLNK,HEAP(INHYBO),4,
     @              HEAP(IPATBO),HEAP(IISLCT),HEAP(IHGR))
C=====================================================================
            ELSE IF (WD(1:4).EQ.'1-2 ') THEN
               CALL ALLGRP(2,.FALSE.,HGLNK,HEAP(INHYBO),4,
     @              HEAP(IPATBO),HEAP(IISLCT),HEAP(IHGR))
C=====================================================================
            ELSE IF ((WD(1:4).EQ.'NONE').OR.(WD(1:4).EQ.'INIT')) THEN
               CALL HGRINI(NATOM,HGLNK)
C=====================================================================
            ELSE IF (WD(1:4).EQ.'SELE') THEN
               CALL SELCTA(HEAP(IISLCT),NSLCT,X,Y,Z,.TRUE.)
               CALL NEWGRP(HEAP(IISLCT),NSLCT,.TRUE.,HGLNK,HEAP(IHGR))
C=====================================================================
            ELSE
               CALL CHKEND('EQUIvalent>',DONE)
C
            END IF
         END IF
      END DO
      DONE=.FALSE.
C
      CALL FREHP(IHGR,INTEG4(NATOM))
      CALL FREHP(IPATBO,INTEG4(NHYBMX*NATOM))
      CALL FREHP(INHYBO,INTEG4(NATOM))
      CALL FREHP(IISLCT,INTEG4(NATOM))
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE HGRINI(NATOM,HGLNK)
C
C     -initialises the hydrogen group array.
C     -Checks if atoms are known and interact.
C     -All subsequent hydrogen tests are based on the hydrogen group array.
C
C     -Author: Michael Nilges, HHMI and Yale University
C
      IMPLICIT NONE
C     -global
      INCLUDE 'cns.inc'
      INCLUDE 'cnst.inc'
      INCLUDE 'coord.inc'
      INCLUDE 'funct.inc'
C     -input/output
      INTEGER NATOM,HGLNK(*)
C     -local
      INTEGER I,NH
C
C     -begin
C
      NH=0
      DO I=1,NATOM
         HGLNK(I)=0
      END DO
      DO I=1,NATOM
         IF (HYDROG(I)) THEN
            HGLNK(I)=I
            NH=NH+1
         END IF
      END DO
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ALLGRP(HMIN,OVRWRT,HGLNK,NHYBON,NHYBMX,
     &     PATBON,ISLCT,LHGR)
C
C     defines hydrogen groups by connectivity and number.
C     if OVRWRT any existing overlapping groups are overwritten.
C
C     Author: Michael Nilges, HHMI and Yale University
C
      IMPLICIT NONE
C     global
      INCLUDE 'cns.inc'
      INCLUDE 'mtf.inc'
C     input/output
      INTEGER HMIN,HGLNK(*),NHYBON(*)
      INTEGER NHYBMX,PATBON(NHYBMX,*),ISLCT(*),LHGR(*)
      LOGICAL OVRWRT
C     local
      INTEGER NHYDRO,I,J,IBT,JBT,I1,J1
C     function
      LOGICAL FRSTEL
      EXTERNAL FRSTEL
C
C     begin
C
C     set up list of bonds to hydrogens
      DO I=1,NATOM
         NHYBON(I)=0
      END DO
C
      DO I=1,NBOND
         IBT=IB(I)
         JBT=JB(I)
         IF (IBT.GT.0 .AND. JBT.GT.0) THEN
            IF (HGLNK(JBT).GT.0) THEN
               NHYBON(IBT)=NHYBON(IBT)+1
               PATBON(NHYBON(IBT),IBT)=JBT
            END IF
            IF (HGLNK(IBT).GT.0) THEN
               NHYBON(JBT)=NHYBON(JBT)+1
               PATBON(NHYBON(JBT),JBT)=IBT
            END IF
         END IF
      END DO
C
C     insert groups
      DO I=1,NATOM
C
         IF (HGLNK(I).EQ.0) THEN
            NHYDRO=NHYBON(I)
            DO I1=1,NATOM
               ISLCT(I1)=0
            END DO
C
            IF (NHYDRO.GE.HMIN) THEN
C     found a group
               DO J=1,NHYDRO
                  J1=PATBON(J,I)
                  ISLCT(J1)=1
               END DO
               CALL NEWGRP(ISLCT,NHYDRO,OVRWRT,HGLNK,LHGR)
C
            ELSEIF (NHYDRO.GT.0) THEN
C     one group for each h-atom
               DO J=1,NHYDRO
                  J1=PATBON(J,I)
                  ISLCT(J1)=1
                  CALL NEWGRP(ISLCT,1,OVRWRT,HGLNK,LHGR)
                  ISLCT(J1)=0
               END DO
C
            END IF
         END IF
      END DO
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE NEWGRP(ISLCT,NSLCT,OVRWRT,HGLNK,LGRP)
C
C     groups are defined by array ISELCT.
C     non-hydrogen atoms are removed.
C     the groups are connected by cyclic pointers:
C     HGLNK(I1ST) = ILAST; => HGLNK(I1ST) > I1ST
C     HGLNK(I2ND) = I1ST;  => HGLNK(I2ND) < I2ND
C     HGLNK(I3RD) = I2ND;  ...
C     ...
C     HGLNK(I) = I  <=>  I is the only atom in group
C     HGLNK(I) = 0  <=>  I is not a hydrogen
C     if OVRWRT any existing overlapping groups are overwritten.
C
C     Author and copyright: Michael Nilges, EMBL
C     No warranty implied or expressed
C     All rights reserved
C
C
      IMPLICIT NONE
C

C     global variables
      INCLUDE 'cns.inc'
      INCLUDE 'mtf.inc'
C     input/output
      INTEGER ISLCT(*),NSLCT,HGLNK(*),LGRP(*)
      LOGICAL OVRWRT
C     local variables
      INTEGER NHYDRO,I,J,J1,JTEMP
      LOGICAL CLEAR
C     function
      LOGICAL FRSTEL
      EXTERNAL FRSTEL
C
C     begin
C
C     remove non-hydrogen and unknown or non-interacting atoms in selection
      DO I=1,NATOM
         IF (HGLNK(I).GT.0) THEN
            ISLCT(I)=ISLCT(I)
         ELSE
            ISLCT(I)=0
         END IF
      END DO
C     gather selected group indices
      NHYDRO=0
      DO I=1,NATOM
         IF ((ISLCT(I)).GT.0) THEN
            NHYDRO=NHYDRO+1
            LGRP(NHYDRO)=I
         END IF
      END DO
C
      CLEAR=.TRUE.
C
C     check if any groups exist and delete if OVRWRT
      DO J=1,NHYDRO
         J1=HGLNK(LGRP(J))
         IF (HGLNK(J1).NE.J1) THEN
            IF (OVRWRT) THEN
C     remove group
               DO WHILE ((HGLNK(J1).NE.J1))
                  JTEMP=J1
                  HGLNK(J1)=J1
                  J1=HGLNK(JTEMP)
               END DO
            ELSE
               CLEAR=.FALSE.
            END IF
         END IF
      END DO
C
      IF (CLEAR) THEN
C
C     add a new group
         IF (NHYDRO.GT.0) THEN
            DO J=1,NHYDRO
               IF (J.GT.1) THEN
                  J1=J-1
               ELSE
                  J1=NHYDRO
               END IF
               HGLNK(LGRP(J))=LGRP(J1)
            END DO
         END IF
      END IF
C
      RETURN
      END
C
C====================================================================
C
      LOGICAL FUNCTION FRSTEL(IAT, HGLNK)
C
C     true if IAT is first element on input.
C
      IMPLICIT NONE
C
C     input/ output
      INTEGER IAT, HGLNK(*)
C
C     begin
C
      FRSTEL=((HGLNK(IAT).GE.IAT).AND.(HGLNK(IAT).GT.0))
C
      END
C
C====================================================================
      SUBROUTINE ARIINI
C
C     subroutine initializes the ARIA list
C
C     Author and copyright: Michael Nilges, EMBL
C     No warranty implied or expressed
C     All rights reserved
C
      IMPLICIT NONE
C
C     I/O
      INCLUDE 'cns.inc'
      INCLUDE 'aria.inc'
C     begin
C
C     set heap pointers of dynamic data structure to zero
      HPNHGL=0
      HPNMAT=0
      HPNMA2=0
      HPDMAT=0
      HPIMAT=0
      HPNCAL=0
      HPNPSE=0
      HPNDIA=0
      HPHHPR=0
      HPNPR =0
      HPRATE=0
C
C     initialize array sizes
      MATDIM=0
      DIMMAT=0
      NHG=0
      DIMNHG=0
      NMRATM=0
      DIMATM=0
C
C     reset other variables
      CALL ARIRES
      RETURN
      END

C====================================================================
      SUBROUTINE ARIRES
C
C     subroutine resets all ARIA variables
C
C     Author and copyright: Michael Nilges, EMBL
C     No warranty implied or expressed
C     All rights reserved
C
C
      IMPLICIT NONE
C
C     I/O
      INCLUDE 'cns.inc'
      INCLUDE 'aria.inc'
      INCLUDE 'consta.inc'
C begin
      CALL ARIHP(0,0,0)
C
      ARINIT = .TRUE.
      VIOSTR = 0
      VIOEXC = 0.0D0
      VIOTHR = 0.0D0
      AMBLEV = 1.0D0
      AMBMAX = 1
      AMBMIN = 1
      AMBSTR = 0
      AMBCUT = R4BIG
      AVEMOD = 'AVER'
      AMBMOD = 'ALL '
      AMBFRM = 'OR-R'
      CALCNT=0
      CALDIS=6.0D0
C
      RETURN
      END
C
C====================================================================
      SUBROUTINE ARIHP(NMATDIM,NNHG,NNATOM)
C
C     **********************************************
C     * Author and copyright: Michael Nilges, EMBL *
C     * No warranty implied or expressed           *
C     * All rights reserved                        *
C     **********************************************
C
      IMPLICIT NONE
C
      INCLUDE 'cns.inc'
      INCLUDE 'heap.inc'
      INCLUDE 'funct.inc'
      INCLUDE 'aria.inc'
      INTEGER NMATDIM,NNHG,NNATOM
C
C     free old space if things have changed
C     assign new space or initialize variables
      IF (NMATDIM.NE.DIMMAT) THEN
         IF (HPNMA2.NE.0)   CALL FREHP(HPNMA2,INTEG4(DIMMAT))
         IF (HPNMAT.NE.0)   CALL FREHP(HPNMAT,IREAL8(DIMMAT))
         IF (NMATDIM .GT. 0) THEN
            HPNMAT=ALLHP(IREAL8(NMATDIM))
            HPNMA2=ALLHP(INTEG4(NMATDIM))
         ELSE
            HPNMA2=0
            HPNMAT=0
         END IF
      END IF
      IF (NNHG.NE.DIMNHG) THEN
         IF (HPIMAT.NE.0)   CALL FREHP(HPIMAT,IREAL8(DIMNHG*DIMNHG))
         IF (HPDMAT.NE.0)   CALL FREHP(HPDMAT,IREAL8(DIMNHG*DIMNHG))
         IF (HPHHPR.NE.0)   CALL FREHP(HPHHPR,INTEG4(DIMNHG*DIMNHG))
         IF (HPRATE.NE.0)   CALL FREHP(HPRATE,IREAL8(DIMNHG*DIMNHG))
         IF (NNHG .GT. 0) THEN
            HPRATE = ALLHP(IREAL8(NNHG*NNHG))
            HPHHPR = ALLHP(INTEG4(NNHG*NNHG))
            HPDMAT = ALLHP(IREAL8(NNHG*NNHG))
            HPIMAT = ALLHP(IREAL8(NNHG*NNHG))
         ELSE
            HPDMAT=0
            HPHHPR=0
            HPIMAT=0
            HPRATE=0
         END IF
      END IF
      IF (NNATOM.NE.DIMATM) THEN
         IF (HPPOPU.NE.0)   CALL FREHP(HPPOPU,IREAL8(DIMATM))
         IF (HPNPR.NE.0)    CALL FREHP(HPNPR,INTEG4(DIMATM))
         IF (HPIGR.NE.0)    CALL FREHP(HPIGR,INTEG4(DIMATM))
         IF (HPNCAL.NE.0)   CALL FREHP(HPNCAL,INTEG4(DIMATM))
         IF (HPNDIA.NE.0)   CALL FREHP(HPNDIA,IREAL8(DIMATM))
         IF (HPNPSE.NE.0)   CALL FREHP(HPNPSE,INTEG4(DIMATM))
         IF (HPNHGL.NE.0)   CALL FREHP(HPNHGL,INTEG4(DIMATM))
         IF (NNATOM .GT. 0) THEN
            HPNHGL = ALLHP(INTEG4(NNATOM))
            HPNPSE = ALLHP(INTEG4(NNATOM))
            HPNDIA = ALLHP(IREAL8(NNATOM))
            HPNCAL = ALLHP(INTEG4(NNATOM))
            HPIGR = ALLHP(INTEG4(NNATOM))
            HPNPR = ALLHP(INTEG4(NNATOM))
            HPPOPU = ALLHP(IREAL8(NNATOM))
         ELSE
            HPNHGL=0
            HPNPSE=0
            HPNDIA=0
            HPNCAL=0
            HPPOPU=0
            HPNPR=0
            HPIGR=0
         END IF
      END IF
C
C     store the dimensions values in common block
      DIMATM=NNATOM
      DIMNHG=NNHG
      DIMMAT=NMATDIM
C
      RETURN
      END


*------------------------------------------------------------------------------
*
* Filename             : TEST_HYDJET.F
*
*==============================================================================
*
* Description : Example program to simulate hadron spectra in AA collisions
*               at LHC with HYDJET-code (should be compiled with object files
*               obtained with hydjet1_1.f, pyquen1_1.f, pythia6401.f (or later
*               pythia versions) and jetset_73.f with extended array size of
*               common block LUJETS)
*
*==============================================================================

      double precision ckin,parp,pari
      real A,bmin,bmax,bfix
      external ludata,pydata
      common /lujets/ n,k(150000,5),p(150000,5),v(150000,5)
      common /hyfpar/ bgen,nbcol,npart,npyt,nhyd
      common /hyflow/ ytfl,ylfl,fpart
      common /hyjpar/ nhsel,ptmin,njet
      common /pydat1/ mstu(200),paru(200),mstj(200),parj(200)
      common /pysubs/ msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
      common /pypars/ mstp(200),parp(200),msti(200),pari(200)
c      common /pawc/ hmemor(20000)
      save /lujets/,/hyflow/,/hyjpar/,/hyfpar/
      save /pysubs/,/pypars/,/pydat1/

* prepare hbook memory
c      call hlimit(20000)
* open hrout file to write histograms
c      call HROPEN(1,'HISTO','hydjet.hrout','N',1024,ISTAT)
* prepare hbook histograms
c      call hbook1(1,'dN/dy $',100,-10.,10.,0.)     ! rapidity
c      call hbook1(2,'dN/deta $',100,-10.,10.,0.)   ! pseudorapidity
c      call hbook1(3,'dN/dpt $',100,0.,10.,0.)      ! transverse momentum
c      call hbook1(4,'dN/dphi $',100,-3.15,3.15,0.) ! azimuthal angle
c      call hbarx(0)

* set initial beam parameters
      A=207.                        ! atomic weigth
      nh=20000                      ! mean soft multiplicity for central Pb-Pb
      ifb=0                         ! fixed impact parameter
      bfix=0.                       ! in nucleus radius units
c      ifb=1                         ! distribution over impact parameter
c      bmin=0.                       ! from 'bmin'
c      bmax=1.                      ! to 'bmax'

* set hydro parameters
* nhsel=0 - hydro (no jets), nhsel=1 - hydro + pythia jets, nhsel=2 - hydro +
* pyquen jets, nhsel=3 - pythia jets (no hydro), nhsel=4 - pyquen jets (no hydro)
      nhsel=2                        ! flag to include hard scatterings
      ylfl=5.                        ! maximum longitudinal flow rapidity
      ytfl=1.                        ! maximum transverse flow rapidity
      fpart=1.                       ! fraction of soft multiplicity proportional
                                      ! # of nucleons-participants
* set input PYTHIA parameters
      msel=1                        ! QCD-dijet production
      ptmin=10.
      ckin(3)=dble(ptmin)           ! minimum pt in initial hard sub-process
      mstp(51)=7                    ! CTEQ5M pdf
      mstp(81)=0                    ! pp multiple scattering off
      mstu(21)=1                    ! avoid stopping run
      paru(14)=1.d0                 ! tolerance parameter to adjust fragmentation

* set original (rounded) test values and its rms for current model parameters
      pta0=0.56
      eta0=0.
      dna0=29850.
* set initial test values and its rms
      ptam=0.
      ptrms=0.
      etam=0.
      etrms=0.
      dnam=0.
      dnrms=0.

* initialize PYTHIA for hard parton-parton scattering
      if(nhsel.ne.0) call pyinit('CMS','p','p',5500.D0)

* set number of generated events
      ntot=10

      do ne=1,ntot                        ! cycle on events
       call hydro(A,ifb,bmin,bmax,bfix,nh)! single event generation

       call luedit(2)                     ! remove unstable particles and partons

       do ip=1,n                          ! cycle on particles
        pt=plu(ip,10)                     ! transverse momentum...
        ycm=plu(ip,17)                    ! rapidity...
        eta=plu(ip,19)                    ! pseudorapidity...
        phi=plu(ip,15)                    ! azimuthal angle...
        charge=plu(ip,6)                  ! electric charge...

* add current test values of eta, pt and its rms
        etam=etam+eta
	etrms=etrms+(eta-eta0)**2
	ptam=ptam+pt
	ptrms=ptrms+(pt-pta0)**2

* fill histograms for charged particles
c        if(abs(charge).gt.0.) then
c         call hfill(1,ycm,0.,1.)          ! rapidity
c         call hfill(2,eta,0.,1.)          ! pseudorapidity
c         call hfill(3,pt,0.,1.)           ! transverse momentum
c         call hfill(4,phi,0.,1.)          ! azimuthal angle
c        end if
       end do
       write(6,*) 'Event #',ne
       write(6,*) 'Impact parameter',bgen,'*RA',' Total multiplicity',n
       write(6,*) 'Pt hard min',ptmin,' GeV','   Ndijets',njet
       write(6,*) '***************************************************'

* add current test value of event multiplicity and its rms
       dnam=dnam+n
       dnrms=dnrms+(n-dna0)**2
      end do

* test calculating and printing of original "true" (rounded) numbers
* and generated one's (with statistical errors)
      etam=etam/dnam
      etrms=sqrt(etrms)/dnam
      ptam=ptam/dnam
      ptrms=sqrt(ptrms)/dnam
      dnam=dnam/float(ntot)
      dnrms=sqrt(dnrms)/float(ntot)
      write(6,1) dna0
1     format(2x,'True (rounded) mean multiplicity =',f7.0)
      write(6,2) dnam, dnrms
2     format(2x,'Generated mean multiplicity      =',f7.0,3x,
     > '+-  ',f6.0)
      write(6,3) eta0
3     format(2x,'True (rounded) mean pseudorapidity =',f5.2)
       write(6,4) etam, etrms
4     format(2x,'Generated mean pseudorapidity      =',f5.2,3x,
     > '+-  ',f5.2)
      write(6,5) pta0
5     format(2x,'True (rounded) mean transverse momentum =',f5.2)
      write(6,6) ptam, ptrms
6     format(2x,'Generated mean transverse momentum      =',f5.2,3x,
     > '+-  ',f5.2)

* finish histograms writing procedure
c      call hidopt(0,'ERRO')
c      call histdo
c      CALL HROUT(0,ICYCLE,' ')
c      CALL HREND('HISTO')

      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...PY4JTS
C...Auxiliary to PY4JET, to set up chosen configuration.

      SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)

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

C...Commonblocks.
      include 'inc/pyjets'

C...Reset info.
      DO 110 I=N+1,N+6
        DO 100 J=1,5
          K(I,J)=0
          V(I,J)=V(IA2,J)
  100   CONTINUE
        K(I,1)=16
  110 CONTINUE

C...First case: when both original partons radiate.
C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
      IF(IA1.NE.0) THEN

C...Set up flavour and history pointers for new partons.
        K(N+1,2)=K(IA1,2)
        K(N+2,2)=K(IA3,2)
        K(N+3,2)=K(IA1,2)
        K(N+4,2)=K(IA2,2)
        K(N+5,2)=K(IA3,2)
        K(N+6,2)=K(IA4,2)
        K(N+1,3)=IA1
        K(N+1,4)=N+3
        K(N+1,5)=N+4
        K(N+2,3)=IA3
        K(N+2,4)=N+5
        K(N+2,5)=N+6
        K(N+3,3)=N+1
        K(N+4,3)=N+1
        K(N+5,3)=N+2
        K(N+6,3)=N+2

C...Set up momenta for new partons.
        DO 120 J=1,5
          P(N+1,J)=P(IA1,J)+P(IA2,J)
          P(N+2,J)=P(IA3,J)+P(IA4,J)
          P(N+3,J)=P(IA1,J)
          P(N+4,J)=P(IA2,J)
          P(N+5,J)=P(IA3,J)
          P(N+6,J)=P(IA4,J)
  120   CONTINUE
        P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
     &  P(N+1,3)**2))
        P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
     &  P(N+2,3)**2))
        QMAX=MIN(P(N+1,5),P(N+2,5))

C...Second case: q radiates twice.
C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
C...IA5=N+2 does not radiate.
      ELSEIF(K(IA2,2).EQ.21) THEN

C...Set up flavour and history pointers for new partons.
        K(N+1,2)=K(IA3,2)
        K(N+2,2)=K(IA5,2)
        K(N+3,2)=K(IA3,2)
        K(N+4,2)=K(IA2,2)
        K(N+5,2)=K(IA3,2)
        K(N+6,2)=K(IA4,2)
        K(N+1,3)=IA3
        K(N+1,4)=N+3
        K(N+1,5)=N+4
        K(N+2,3)=IA5
        K(N+3,3)=N+1
        K(N+3,4)=N+5
        K(N+3,5)=N+6
        K(N+4,3)=N+1
        K(N+5,3)=N+3
        K(N+6,3)=N+3

C...Set up momenta for new partons.
        DO 130 J=1,5
          P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
          P(N+2,J)=P(IA5,J)
          P(N+3,J)=P(IA3,J)+P(IA4,J)
          P(N+4,J)=P(IA2,J)
          P(N+5,J)=P(IA3,J)
          P(N+6,J)=P(IA4,J)
  130   CONTINUE
        P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
     &  P(N+1,3)**2))
        P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
     &  P(N+3,3)**2))
        QMAX=P(N+3,5)

C...Third case: q radiates g, g branches.
C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
C...IA5=N+2 does not radiate.
      ELSE

C...Set up flavour and history pointers for new partons.
        K(N+1,2)=K(IA2,2)
        K(N+2,2)=K(IA5,2)
        K(N+3,2)=K(IA2,2)
        K(N+4,2)=21
        K(N+5,2)=K(IA3,2)
        K(N+6,2)=K(IA4,2)
        K(N+1,3)=IA2
        K(N+1,4)=N+3
        K(N+1,5)=N+4
        K(N+2,3)=IA5
        K(N+3,3)=N+1
        K(N+4,3)=N+1
        K(N+4,4)=N+5
        K(N+4,5)=N+6
        K(N+5,3)=N+4
        K(N+6,3)=N+4

C...Set up momenta for new partons.
        DO 140 J=1,5
          P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
          P(N+2,J)=P(IA5,J)
          P(N+3,J)=P(IA2,J)
          P(N+4,J)=P(IA3,J)+P(IA4,J)
          P(N+5,J)=P(IA3,J)
          P(N+6,J)=P(IA4,J)
  140   CONTINUE
        P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
     &  P(N+1,3)**2))
        P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
     &  P(N+4,3)**2))
        QMAX=P(N+4,5)

      ENDIF
      N=N+6

      RETURN
      END


      subroutine tringl(x,y,n0,ibound,idom,nodes,net,nt1)
C...01/09/78
      dimension x(1),y(1),net(1),ibound(2,1),n(5),nodes(1)
    4 format(28hboundary is very complicated)
      if(idom.ne.1) goto 90
      loc=0
  124 do 120 i=1,n0
      do 120 j=1,2
      k=ibound(j,i)
      if(k.gt.0) goto 121
  120 continue
      do 127 i=1,n0
      do 127 j=1,2
  127 ibound(j,i)=iabs(ibound(j,i))
   90 nt1=0
      iend=n0
      l=1
      ir=1
      do 51 i=1,n0
   51 nodes(i)=i
   10 if(ibound(1,l).eq.ir) goto 7
      if(ibound(2,l).eq.ir) goto 7
      do 9 i=1,iend
      l=nodes(i)
      ir=ibound(1,l)
      if(ir.ne.0) go to 10
      ir=ibound(2,l)
      if(ir.ne.0) go to 7
    9 continue
    7 ind=-1
      r0=((x(ir)-x(l))**2+(y(ir)-y(l))**2)/4
      do 14 i=1,iend
      if(nodes(i).ne.l) goto 15
      l1=i
      go to 14
   15 if(nodes(i).ne.ir) goto 17
      ir1=i
      go to 14
   17 j=nodes(i)
      s=cosin2(y(l)-y(ir),x(ir)-x(l),x(j)-x(l),y(j)-y(l))
      if(s.le.0) goto 14
      s1=cosin2(y(ir)-y(j),x(j)-x(ir),x(l)-x(ir),y(l)-y(ir))
      if(s1.gt.s) s=s1
      r1=(x(j)-(x(l)+x(ir))/2)**2+(y(j)-(y(l)+y(ir))/2)**2
      if(r1.lt.r0) nodes(i)=-nodes(i)
      if((ind+1).ne.0) goto 22
      r=r1
      k1=i
      ind=0
      if(s.ge.0.04) ind=1
      go to14
   22 if(ind.ne.0) goto 26
      if(s.le.0.04) goto 28
      ind=1
   31 k1=i
      r=r1
      go to14
   28 if(r-r1) 14,14,31
   26 if(s-0.04) 14,14,28
   14 continue
      k=iabs(nodes(k1))
      do 97 i=1,iend
      if(nodes(i).gt.0) goto 97
      k2=iabs(nodes(i))
      r1=cosin1(y(l)-y(k2),x(k2)-x(l),x(k)-x(l),y(k)-y(l))
      if(r1.lt.0) goto 97
      r1=cosin1(y(ir)-y(k),x(k)-x(ir),x(k2)-x(ir),y(k2)-y(ir))
      if(r1.lt.0) goto 97
      k1=i
      k=iabs(nodes(k1))
   97 nodes(i)=iabs(nodes(i))
      if(idom.ne.1) goto 102
      call tmf(x(l),y(l),xl,yl)
      call tmf(x(ir),y(ir),xir,yir)
      call tmf(x(k),y(k),xk,yk)
      if(ibound(1,ir).eq.k) goto 105
      if(ibound(2,ir).eq.k) goto 105
      if(loc.ne.ir) goto 107
      call move(xk,yk,1)
      call move(xl,yl,1)
      loc=l
      go to 102
  107 call move(xl,yl,0)
      call move(xk,yk,1)
      call move(xir,yir,1)
      loc=ir
      go to 102
  105 call move(xl,yl,0)
      call move(xk,yk,1)
      loc=k
  102 n(1)=l1
      n(2)=ir1
      n(3)=k1
      ish=1
      do 85 i=1,3
      do 87 j=1,3
      if(n(j)-i) 87,85,87
   87 continue
      do 88 j=ish,3
      j1=n(j)
      if(j1.le.3) goto 88
      nodes(j1)=nodes(i)
      ish=j+1
      go to 85
   88 continue
   85 continue
      nodes(1)=l
      l1=-1
      nodes(2)=ir
      ir1=2
      nodes(3)=k
      k1=3
      if(ibound(1,ir).eq.k) goto 74
      if(ibound(2,ir).ne.k) goto 75
   74 ir1=-ir1
   75 if(ibound(1,k).eq.l) goto 77
      if(ibound(2,k).ne.l) goto 78
   77 k1=-k1
   78 n(1)=k1
      n(2)=l1
      n(3)=ir1
      n(4)=k1
      n(5)=l1
      do 32 i=2,4
      k1=iabs(n(i))
      l1=nodes(k1)
      k1=iabs(n(i+1))
      ir1=nodes(k1)
      k1=iabs(n(i-1))
      k1=nodes(k1)
      if(ibound(1,l1).ne.ir1) goto 33
      ibound(1,l1)=0
      go to 35
   33 if(ibound(2,l1).eq.ir1) ibound(2,l1)=0
   35 if(n(i-1).le.0) goto 32
      if(ibound(1,l1).ne.0) goto 63
      ibound(1,l1)=k1
      go to 32
   63 if(ibound(2,l1).ne.0) goto 65
      ibound(2,l1)=k1
      go to 32
   65 write (*,4)
      stop
   32 continue
      i=3*nt1
      net(i+1)=l
      net(i+2)=ir
      net(i+3)=k
      nt1=nt1+1
      if(iend.le.3) goto 49
      do 80 i=1,3
      k1=nodes(i)
      if(ibound(1,k1).ne.0) goto 80
      if(ibound(2,k1).ne.0) goto 80
      nodes(i)=nodes(iend)
      iend=iend-1
   80 continue
      if(ibound(1,k).eq.ir) goto 46
      if(ibound(2,k).ne.ir) goto 47
   46 l=k
      go to 48
   47 ir=k
   48 if(iend.gt.0) goto 10
   49 return
  121 call tmf(x(i),y(i),r0,r1)
      call move(r0,r1,0)
  125 call tmf(x(k),y(k),r0,r1)
      ibound(j,i)=-k
      call move(r0,r1,1)
      i=k
      do 122 j=1,2
      if(ibound(j,i).gt.0) goto 123
  122 continue
      go to 124
  123 k=ibound(j,i)
      go to 125
      end


!Wapening
W_Diameter = 25 / 1000 !25 mm
W_Straal = W_Diameter / 2
W_Dekking_y = 14.5 / 1000
W_Dekking_x = 13 / 1000
W_Halve_Lengte = S_Lengte/2 - (75 / 1000) !wapening stopt iets voor het einde van de ligger.

!Call rest of the default parameters
/INPUT, parameters, f, '%GeometryFolder(1)%' , 0, 1


C    %W% %G%
      subroutine dcint
C * * *
C * * * THIS SUBROUTINE INITIALIZES THE TWO TERMINAL DC TABLES
C * * * IT IS CALLED BY INITL4. IT CALLS GAMINT AND MODINT TO
C * * * INITIALIZE DC MODULATION.
C * * *
      include 'tspinc/params.inc'
      include 'tspinc/blkcom1.inc'
      include 'tspinc/busvolt.inc'
      include 'tspinc/namec.inc'
      include 'tspinc/cntrl2.inc'
      include 'tspinc/toler.inc'
      include 'tspinc/param.inc'
      include 'tspinc/contrl.inc'
      include 'tspinc/ecsind.inc'
      include 'tspinc/ectba.inc'
      include 'tspinc/ecstbb.inc'
      include 'tspinc/pointr.inc'
      include 'tspinc/matrow.inc'
      include 'tspinc/newton.inc'
      include 'tspinc/prt.inc'
      include 'tspinc/gamma.inc'
      include 'tspinc/dcblk.inc'
        equivalence(erio,tab(164)),(eroo,tab(165)),(eron,tab(166)),
     1             (etio,tab(167)),(eioo,tab(168)),(eion,tab(169)),
     2             (ectim1,tab(148)),(ectim2,tab(149))
        dimension zoecs(512)
        character*8 ibus1,dcbus1,dcbus2,name,name1,name2
      pi=3.14159265
      f135=3.0*sqrt(2.0)/pi
      rpib3=3.0/pi
      rpib18=18.0/(pi*pi)
      sqr2=sqrt(2.0)
      zero=0.0
      ipwr=2
      k1=0
      do 100 itrr = 1,20
      idcblk(itrr) = 0
 100  continue
      do 3820 iidc=1,ldc
      locdc=kdc+k1*idcl
      call redecs (ptab,locdc,idcl)
C * * *
C * * * IF ITAB(129) = 0 THE DYNAMICS OF THIS LINE ARE BLOCKED
C * * *
      if(itab(129) .ne. 0)idcblk(iidc) = 1
C****
C* YISOLN, NEWTON OPTION
C****
C** REMOVE ADMITT. FROM DIAGONAL AND SAVE
      go to (3010, 3000) , inewts
 3000 i1 = itab(35)
      call  getmat (i1, ii)
      atrow(ii-1) = atrow(ii-1) - tab(38)
      atrow(ii  ) = atrow(ii  ) - tab(39)
      gadmit(i1) =  tab(38)
      badmit(i1) =  tab(39)
      call putmat (i1, ii)
      i1 = itab (37)
      call getmat(i1, ii)
      atrow(ii-1) = atrow(ii-1) - tab(40)
      atrow(ii  ) = atrow(ii  ) - tab(41)
      gadmit(i1) =  tab(40)
      badmit(i1) =  tab(41)
      call putmat (i1, ii)
      go to  3010
 3010 dcbus1 = exnamc(itab(35))
      dcbus2 = exnamc(itab(37))
      if (keybrd(22).eq.0) go to 3100
      write (outbuf,3060) iptab(1),iptab(3),iptab(7),iptab(33),iptab(34)
      call prtout (1)
      do 3062 jjj = 1,45,6
         kkk = min0 (jjj+5,45)
         write (outbuf,3061) (i,ptab(i),i=jjj,kkk)
         call prtout (1)
 3062 continue
 3060 format('0IPTAB(1,3,7,33,34),PTAB(1,...,45)=',5i5)
 3061 format(6(i5,e16.5))
      write (outbuf,3080) itab(7),itab(22),itab(33),itab(34),itab(35),
     1  itab(36),itab(37)
      call prtout (1)
      do 3082 jjj = 1,120,6
         kkk = min0 (jjj+5,120)
         write (outbuf,3081) (i,tab(i),i=jjj,kkk)
         call prtout (1)
 3082 continue
 3080 format('0ITAB(7,22,34,35,36,37),TAB(1,...,120)=',7i5)
 3081 format(6(i5,e16.5))
      if(itab(114) .le. 0) go to 3100
      itabl = 177
      if(itab(114) .eq. 6) itabl= 205
      do 3091 jjj = 121,itabl,6
         kkk = min0 (jjj+5,itabl)
         write (outbuf,3090) (i,tab(i),i=jjj,kkk)
         call prtout (1)
 3091 continue
 3090 format(6(i5,e16.5))
 3790 format(8(i4,e13.4))
 3100 continue
      ovbse1=ptab(2)
      ovbse2=ptab(4)
C * * *
C     SWAP TIME CONS T2,T3 IN TAB TABLE
C * * *
      tt2=tab(4)
      tab(4)=tab(5)
      tab(5)=tt2
      tt2=tab(19)
      tab(19)=tab(20)
      tab(20)=tt2
C * * *
C     CONVERT MH TO HENRY AND UF TO FARAD..
C     SCALE HENRY*FRQBSE FOR SECONDS TO CYCLE
C * * *
      ptab(9)=ptab(9)*0.001*frqbse
      ptab(10)=ptab(10)*0.000001*frqbse
      ptab(27)=ptab(27)*0.001*frqbse
      ptab(28)=ptab(28)*0.001*frqbse
C * * *
C     CONVERT AMPS TO KILOAMPS
C * * *
      ptab(11)=ptab(11)*.001
      ptab(14)=ptab(14)*.001
      ptab(17)=ptab(17)*.001
      ptab(39)=ptab(39)*.001
      tab(99)=ptab(35)*ovbse1*ptab(12)
      tab(100)=ptab(36)*ovbse2*ptab(15)
      tab(11)=ptab(30)*ptab(12)
      tab(12)=ptab(29)*ptab(12)
      tab(26)=ptab(32)*ptab(15)
      tab(27)=ptab(31)*ptab(15)
      conv1=ptab(2)*ptab(12)*rpib3*sqr2/ptab(14)
      conv2=ptab(4)*ptab(15)*rpib3*sqr2/ptab(17)
      tab( 6)= -tab( 6)*conv1
      tab(21)= -tab(21)*conv2
C * * *
C     CONVERT MARGIN SW UNIT CONSTANT C=72 AMP TO KILOAMPS
C * * *
      tab(50) = 72.0*0.001
      tab(70) = 72.0*0.001
C * * *
C     SET PROPER PMAX
C * * *
      if(itab(114) .gt. 0) go to 40090
      if (tab(117).eq.0.0) tab(117)=ptab(5)
40090 continue
C * * *
C     DETERMINE IMAX USED IN POWER FLOW
C * * *
      crate=amin1(ptab(11),amin1(ptab(14),ptab(17)))
C * * *
C     CONVERT IMARGIN TO KILOAMP
C * * *
      tab(9)=tab(9)*crate
      tab(24)=tab(24)*crate
      if(tab( 9).eq.0.0)tab( 9)= tab(24)
      if(tab(24).eq.0.0)tab(24)= tab( 9)
      ptab(11)=crate
C * * *
C     RECTIFIER INIT COND
C * * *
      i1=iptab(33)
      e1 = eyr(i1)
      f1 = eyi(i1)
      eo1=sqrt(e1*e1+f1*f1)*tab(99)
C * * *
C     INITIAL  DELAY COMMUTATION VOLTAGES
C * * *
      erio= eo1
      eroo= eo1
      eron= eo1
      cosa1=cos(ptab(22))
      tab(95)=cosa1
      dc1=f135*eo1*cosa1-ptab(39)*(rpib3*tab(11)+tab(12)*rpib18)-ptab(13
     1)
      tab(65)=dc1
      tab(53)=dc1
      tab(110)=dc1
      tab(68)=eo1
      tab(92)=eo1
      tab(54)=ptab(39)
      dcb1=dc1-tab(32)*tab(55)
      dv1=dcb1
C * * *
C     SETUP CMAX,CMARGIN
C * * *
      if (tab(8).eq.tab(23)) go to 3140
      write (errbuf(1),3120) dcbus1,dcbus2
      call prterr ('E',1)
 3120 format (1x,'MISMATCH IN IMAX',2a8)
      tab(8)=amin1(tab(8),tab(23))
 3140 tab(8)=tab(8)*crate
      if (tab(8).eq.0.0) tab(8)=tab(23)*crate
      if (tab(8).eq.0.0) tab(8)=crate
      tab(23)=tab(8)
      fid1=ptab(39)
      tab(102)=fid1
      if(ptab(39) .gt. tab(8))then
         write(errbuf,3125) dcbus1,dcbus2
         call prterr('E',1)
 3125    format (1h0,5x,' INITIAL CURRENT EXCEEDS MAXIMUM CURRENT FOR ',
     1   a8, ' TO ',a8)
         iabort = 1
      endif
      if (itab(7).eq.1) fid1=ptab(5)/dv1
      fipm1=amin1(amax1(0.1*ptab(11),dv1*tab(8)/(0.25*ptab(6))),tab(8))
      tab(88)=fipm1
      tab(51)=0.0
      cosgo=cos(ptab(25))
C * * *
C     INITIALIZE D.E. STORAGE
C * * *
      cx1=2.0*tab(11)*tab(54)*rpib3
      eop1=eo1*sqr2*rpib3
      vpa1=eop1*(cos(ptab(22))+cosgo)-cx1
      zero=0.0
      zmax1=eop1*(cosgo+cos(ptab(18)))-cx1
C * * *
C     TEST IF WITHIN LIMITS
C * * *
          if(vpa1 .le. zmax1+1.0e-4 .and. vpa1+1.0e-4 .ge. 0.0)
     1      go to 3180
      write (errbuf(1),3160) vpa1,zero,zmax1
      call prterr ('E',1)
 3160 format (46h0valve 1 cntrl limit violation...vpa1,min,max=,3e15.6)
      iabort=1
 3180 continue
C * * *
C * * * REGULATOR STATE VARIABLES FOR FULL DC MODEL
C * * *
      if(itab(119).eq.1) then
        tab(58)=vpa1
        tab(57)=vpa1
        tab(56)=vpa1
        tab(55)=vpa1/tab(6)
        tab(103)=vpa1/tab(6)
        tab(115) = cx1+vpa1
      endif
C * * *
C     INVERTER INIT COND
C * * *
      i1=iptab(34)
      e2 = eyr(i1)
      f2 = eyi(i1)
      eo2=sqrt(e2*e2+f2*f2)*tab(100)
C * * *
C     INITIALIZE DELAY COMMUTATION VOLTAGES
C * * *
      eioo= eo2
      eion= eo2
      ectim1=ectim1*frqbse
      ectim2=ectim2*frqbse
C * * *
C     GET INITIAL ALPHA FOR INVERTER
C * * *
      tab(60)=ptab(39)
      cx2=2.0*tab(26)*tab(60)*rpib3
      eop2=eo2*sqr2*rpib3
      cosa2=cx2/eop2-cos(ptab(26))
      tab(96)=cosa2
      dc2=-f135*eo2*cosa2+ptab(39)*(rpib3*tab(26)+tab(27)*rpib18)+ptab(1
     16)
      tab(66)=dc2
      tab(59)=dc2
      tab(111)=dc2
      tab(69)=eo2
      tab(94)=eo2
      dcb2=dc2-(tab(32)-ptab(8))*tab(60)
      dv2=dcb2
      fid2=ptab(39)
      if (itab(22).eq.1) fid2=ptab(5)/dv2
      fipm2=amin1(amax1(0.1*ptab(11),dv2*tab(23)/(0.25*ptab(6))),tab(23)
     1)
      tab(89)=fipm2
      tab(52)=0.0
      cosgam=cos(ptab(26))
      vpa2=eop2*(cosa2+cosgam)-cx2
      zmax2=eop2*(cosgam+cos(ptab(24)))-cx2
C * * *
C     TEST IF WITHIN LIMITS
C * * *
          if(vpa2 .le. zmax2+1.0e-4 .and. vpa2+1.0e-4 .ge. 0.0)
     1      go to 3220
      write (errbuf(1),3200) vpa2,zero,zmax2
      call prterr ('E',1)
 3200 format (47h0valve 2 cntrl limit violation... vpa2,min,max=,3e15.6)
      iabort=1
 3220 continue
C * * *
C * * * REGULATOR STATE VARIABLES FOR FULL DC MODEL
C * * *
      if(itab(119).eq.1) then
        tab(64)=vpa2
        tab(63)=vpa2
        tab(62)=vpa2
        tab(61)=vpa2/tab(21)
        tab(104)=vpa2/tab(21)
        tab(116) = cx2
      end if
      itab(33)=1
      tab(67)=ptab(39)
      tab(157)=tab(67)
      tab(156)=tab(157)
C * * *
C * * * INITIALIZE EXTINCTION ANGLES
C * * *
      tab(121) = acos(tab(95) -(sqr2*tab(11)*ptab(39))/tab(68))
      tab(122) = acos(tab(96) -(sqr2*tab(26)*ptab(39))/tab(69))
C * * *
C     CONVERT TIME CONS.TO PROPER UNITS
C * * *
      do 3240 i=1,5
 3240 tab(i)=tab(i)*frqbse
      do 3260 i=16,20
 3260 tab(i)=tab(i)*frqbse
C     TEST IF WITHIN LIMITS
C  *********** ************** ************** ***************
C ****  ERROR CHECK FOR T3 REMOVED 12/15/83 TRR
C      IF (TAB(4).NE.0.0.AND.TAB(19).NE.0.0) GO TO 3300
C      WRITE (ERRBUF(1),3280)
C      CALL PRTERR ('E',1)
C 3280 FORMAT (34H0DC CNTRL CKT TIME CONS T2 IS ZERO)
C      IABORT=1
C *****  ******************** ************ *********** **************
 3300 idcap=1
C * * *
C     SET UP DC LINE DATA + CODES
C     READ SWITCHING TABLES FOR USE IN DC REP
C * * *
      intmd=1
      pleft=0.5
      pright=0.5
C * * *
C     CK IF THERE IS ANY INTERMEDIATE FLT
C * * *
      do 3320 i=1,ifcd
      if (mflt(i).ne.5) go to 3320
      idflt = iabs(ipcdtn(i))
C * * *
C * * * CHECK TO SEE IF MANUAL RAMPING AGREES WITH CONTROL MODE
C * * *
      if(idflt .ne. 7 .and. idflt .ne. 8) go to 3309
      if(iftabn(i).ne.itab(35) .and. iftabn(i).ne.tab(37))go to 3320
      if(itab(7) .eq. 1 .and. idflt .eq. 7)go to 3320
      if(itab(7) .eq. 2 .and. idflt .eq. 8)go to 3320
      write (errbuf(1),3308) dcbus1,dcbus2
      call prterr ('E',1)
 3308 format (1h0,2x,'CONTROL MODE DOES NOT AGREE WITH MANUAL RAMPING',
     1' TYPE ON LINE SWITCHING CARD ',5x,a8,5x,a8)
      iabort=1
      go to 3320
C * * *
C     CK IF DC LINE MATCHES DC ITERMED FLT
C * * *
 3309 if(iftabn(i).eq.itab(35).and.jftabn(i).eq.itab(37))go to 3310
      if(jftabn(i).ne.itab(35).or. iftabn(i).ne.itab(37))go to 3320
 3310 if (idflt.ne.3) go to 3320
      if (perct(i).le.0.0.or.perct(i).ge.100.0) go to 3340
      pleft=perct(i)/100.0
      pright=1.0-pleft
      intmd=2
      fltx(i)=-1.0
      go to 3380
 3320 continue
      go to 3380
 3340 write (errbuf(1),3360)
      call prterr ('E',1)
 3360 format ('0ILLEGAL PERCENT ON DC INTERMED FLT CD')
      iabort=1
 3380 sri=ptab(27)*ptab(28)
      ptab(10)=0.0
      if (ptab(10).eq.0.0.and.ptab(9).eq.0.0.and.sri.eq.0.) go to 3420
      if (ptab(10).eq.0.0.and.sri.ne.0.0) go to 3440
      if (ptab(10).ne.0.0.and.sri.ne.0.0) go to 3460
      write (errbuf(1),3400) dcbus1,dcbus2
      call prterr ('E',1)
 3400 format (24h0illegal dc line data...,a8,1h-,a8)
      iabort=1
C * * *
C     DC LINE RESISTANCE ONLY
C * * *
 3420 tab(14)=ptab(8)
      idcap=3
      go to 3520
C * * *
C     NO CAP
C * * *
 3440 tab(14)=ptab(8)*pleft
      tab(29)=ptab(8)*pright
      tab(13)=ptab(9)*pleft
      tab(28)=ptab(9)*pright
      idcap=2
      go to 3520
 3460 continue
 3480 tab(13)=ptab(9)*pleft*0.5
      tab(28)=ptab(9)*pright*0.5
      tab(14)=ptab(8)*pleft*0.5
      tab(29)=ptab(8)*pright*0.5
      tab(15)=ptab(10)*pleft
      tab(30)=ptab(10)*pright
C * * *
C     GET INITIAL CHARGE ACROSS CAP
C * * *
 3500 dd1=dc1-tab(14)*tab(62)
      tab(63)=dd1*tab(15)
      dd2=dd1-(tab(14)+tab(29))*tab(62)
      tab(66)=dd2*tab(30)
      tab(97)=0.0
      tab(98)=0.0
C * * *
C     STORE INITIAL VALUES
C * * *
 3520 do 3540 i=1,17
 3540 tab(i+70)=tab(i+50)
C * * *
C     STORE IDCAP,IDCF CODES
C * * *
      itab(105)=1
      iblck=1
      itab(106)=idcap
      tab(101)=1.0/bmva
      do 3560 i=31,43
 3560 ptab(i)=0.0
      ptab(34)=ptab(6)*tab(102)
      if(itab(7).eq.2) ptab(34)=tab(102)
      do 3580 i=129,138
 3580 tab(i)=0.0
      do 3581 i=1,8
 3581 dcadd(i)=0.0
C * * *
C * * * INITALIZE MARGIN SWITCHING TIMERS IF PTAB(36) = -1. THERE IS
C * * * NO MARGIN SWITCHING
C * * *
         ptab(36) = 0.0
         if(ptab(20) .eq. -1.0)ptab(36)= -1.
         ptab(20) = 0.0
         ptab(37) = 0.25*frqbse
         ptab(38) = 0.5*frqbse
C * * *
C * * * INITIALIZE MODULATION TABLES IF THEY EXIST
C * * *
      if (itab(114) .eq. 0) go to 3720
      if(itab(114) .eq. 5) then
C * * *
C * * * INITIALIZE TABLES FOR GAMMA MODULATION
C * * *
         igam = itab(118)
C * * * INITALIIZE INVERTER BUS NUMBER

         igamno(igam) = itab(36)
         vdcgam = tab(111)
C * * * INITALIZE GAMMA EXTINCTION ANGLE FROM POWER FLOW
         gama(igam) = ptab(26)
         call gamint(igam,vdcgam)
      else
C * * *
C * * * INITIALIZE TABLES FOR OTHER MODULATION TYPES
C * * *
         imod = itab(118)
         call modint(imod)
      endif

C * * *
C     STORE INITIAL DESIRED CURRENT
C * * *
 3720 tab(107)=ptab(5)/(tab(73)-tab(32)*tab(74))
      if (itab(7).ne.1) tab(107)=ptab(39)
      tab(108)=ptab(5)/(tab(79)-(tab(32)-ptab(8))*tab(80))
      if (itab(22).ne.1) tab(108)=ptab(39)
C * * *
C     SETUP PROPER VOLTAGE FOR DC LINE WITH OR WITHOUT CAP.
C * * *
      dc11=f135*eo1*cosa1-ptab(13)
      dc22=-f135*eo2*cosa2+ptab(16)
      if(itab(106).eq.2) go to 3725
      tab(65)=dc11
      tab(85)=dc11
      tab(53)=dc11
      tab(110)=dc11
      tab(66)=dc22
      tab(86)=dc22
      tab(59)=dc22
      tab(111)=dc22
 3725 continue
      if (keybrd(22).eq.0) go to 3800
      write (outbuf,3740) iptab(1),iptab(3),iptab(7),iptab(33),iptab(34)
      call prtout (1)
      do 3742 jjj = 1,45,6
         kkk = min0 (jjj+5,45)
         write (outbuf,3741) (i,ptab(i),i=jjj,kkk)
         call prtout (1)
 3742 continue
 3740 format('0IPTAB(1,3,7,33,34),PTAB(1,...,45)=',5i5)
 3741 format(6(i5,e16.5))
      write (outbuf,3760) itab(119),itab(120)
      call prtout (1)
 3760 format (' DC CNTRL BR',2i5)
      write (outbuf,3780) itab(7),itab(22),itab(33),itab(34),itab(35),
     1   itab(36),itab(37)
      call prtout (1)
      do 3782 jjj = 1,177,6
         kkk = min0 (jjj+5,177)
         write (outbuf,3781) (i,tab(i),i=jjj,kkk)
         call prtout (1)
 3782 continue
 3780 format('0ITAB(7,22,34,35,36,37),TAB(1,...,120)=',7i5)
 3781 format(6(i5,e16.5))
      if(itab(114) .ne. 6) go to 3800
      do 3791 jjj = 178,205,6
         kkk = min0 (jjj+5,205)
         write (outbuf,3790) ( i,tab(i),i=jjj,kkk)
         call prtout (1)
 3791 continue
 3800 call ritecs (ptab,locdc,idcl)
      k1=k1+1
 3820 continue
      return
      end