      SUBROUTINE DIEGRD (COORD,DXYZ)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      COMMON / SOLV / FEPSI,RDS,DISEX2,NSPA,NPS,NPS2,NDEN,
     1                COSURF(3,LENABC), SRAD(NUMATM),ABCMAT(LENAB2),
     2                TM(3,3,NUMATM),QDEN(MAXDEN),DIRTM(3,NPPA),
     3                QS(LENABC)
     4       /SOLVI/  IATSP(LENABC+1),NAR(LENABC)
      COMMON /DIRVEC/ DIRVEC(3,NPPA), NN(3,NUMATM)
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
     3       /MULTIP/ DD(107),QQ(107),AM(107),AD(107),AQ(107)
      DIMENSION DXYZ(3,*),DB(0:3,10),XK(3),XL(3),XX(3),COORD(3,NUMATM)
      DO 10 I=1,NPS
         J=IATSP(I)
         RI=SRAD(J)-RDS
         DO 10 IX=1,3
   10 COSURF(IX,I)=COSURF(IX,I)*RI+COORD(IX,J)
      DO 20 I=1,10
         DO 20 IX=1,3
   20 DB(IX,I)=0.D0
      DB(0,1)=1.D0
      CALL CQDEN()
      FACT=-2*13.6058*.5292*FEPSI*23.061
      DO 30 I=1,NPS
   30 QS(I)=0.D0
      I0=NPS2-NDEN
      DO 70 I=1,NPS
         I2=(I*(I-1))/2
         I1=I0+I*NDEN
         POSI=0.D0
         DO 40 J=1,NDEN
   40    POSI=POSI+QDEN(J)*ABCMAT(J+I1)
         DO 50 K=1,I
   50    QS(K)=QS(K)+POSI*ABCMAT(K+I2)
         DO 60 K=I+1,NPS
   60    QS(K)=QS(K)+POSI*ABCMAT(I+(K*(K-1))/2)
   70 CONTINUE
      DO 120 K=1,NPS
         IAK=IATSP(K)
         DO 80 IX=1,3
   80    XK(IX)=COSURF(IX,K)
         QSK=QS(K)
         DO 110 L=1,K-1
            IAL=IATSP(L)
            IF(IAL .EQ. IAK) GO TO 110
            DIST2=0.D0
            DO 90 IX=1,3
               XXX=COSURF(IX,L)-XK(IX)
               XL(IX)=XXX
               DIST2=DIST2+XXX*XXX
   90       CONTINUE
            FF=QSK*QS(L)*FACT*DIST2**-1.5D0
            DO 100 IX=1,3
               DXYZ(IX,IAK)=DXYZ(IX,IAK)-XL(IX)*FF
               DXYZ(IX,IAL)=DXYZ(IX,IAL)+XL(IX)*FF
  100       CONTINUE
  110    CONTINUE
  120 CONTINUE
      DO 190 K=1,NPS
         IAK=IATSP(K)
         DO 130 IX=1,3
  130    XK(IX)=COSURF(IX,K)
         QSK=QS(K)
         IDEN=0
         DO 180 I=1,NUMAT
            IDEL=NLAST(I)-NFIRST(I)
            IF(I .EQ. IAK) GO TO 180
            NATI=NAT(I)
            DIST2=0.D0
            DO 140 IX=1,3
               XXX=XK(IX)-COORD(IX,I)
               XX(IX)=XXX
               DIST2=DIST2+XXX*XXX
  140       CONTINUE
            DDI=DD(NATI)*2*.529177
            QQI2=(.529177*QQ(NATI))**2
            FF0=-QSK*FACT*DIST2**-1.5D0
            IF(IDEL .EQ. 0) GO TO 150
            RM2=1.D0/DIST2
            RM4=RM2**2
            DB(0,2)=DDI*3*XX(1)*RM2
            DB(0,4)=DDI*3*XX(2)*RM2
            DB(0,7)=DDI*3*XX(3)*RM2
            DB(0,3)=1.D0+QQI2*(15*XX(1)**2*RM2-3.D0)*RM2
            DB(0,6)=1.D0+QQI2*(15*XX(2)**2*RM2-3.D0)*RM2
            DB(0,10)=1.D0+QQI2*(15*XX(3)**2*RM2-3.D0)*RM2
            DB(0,5)=QQI2*30*XX(1)*XX(2)*RM4
            DB(0,8)=QQI2*30*XX(1)*XX(3)*RM4
            DB(0,9)=QQI2*30*XX(3)*XX(2)*RM4
            DB(1,2)=DDI
            DB(2,4)=DB(1,2)
            DB(3,7)=DB(1,2)
            DB(1,3)=6*QQI2*XX(1)*RM2
            DB(2,6)=6*QQI2*XX(2)*RM2
            DB(3,10)=6*QQI2*XX(3)*RM2
            DB(1,5)=DB(2,6)
            DB(2,5)=DB(1,3)
            DB(1,8)=DB(3,10)
            DB(3,8)=DB(1,3)
            DB(2,9)=DB(3,10)
            DB(3,9)=DB(2,6)
  150       DO 170 J=1,1+IDEL*IDEL
               FF=FF0*QDEN(IDEN+J)
               DO 160 IX=1,3
                  DX=(XX(IX)*DB(0,J)-DB(IX,J))*FF
                  DXYZ(IX,IAK)=DXYZ(IX,IAK)+DX
                  DXYZ(IX,I)=DXYZ(IX,I)-DX
  160          CONTINUE
  170       CONTINUE
  180    IDEN=IDEN+1+IDEL**2
  190 CONTINUE
      DO 200 I=1,NPS
         J=IATSP(I)
         RM=SRAD(J)-RDS
         DO 200 IX=1,3
  200 COSURF(IX,I)=(COSURF(IX,I)-COORD(IX,J))/RM
      RETURN
      END


!***********************************************************************
!                                                                      *
      SUBROUTINE DAMPCK(IPR, J, ED1, ED2)
!                                                                      *
!   This subroutine determines the damping factor appropriate to the   *
!   present  orbital. The algorithm is taken from C Froese Fischer's   *
!   program MCHF.                                                      *
!                                                                      *
!   Written by Farid A Parpia, at Oxford    Last update: 08 Dec 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:58   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE damp_C
      USE orb_C
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(INOUT) :: IPR
      INTEGER, INTENT(IN) :: J
      REAL(DOUBLE), INTENT(INOUT) :: ED1
      REAL(DOUBLE), INTENT(INOUT) :: ED2
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      LOGICAL :: ADAPTV
!-----------------------------------------------
!
!   The damping is adaptive (i.e., can be modified by this SUBROUTINE)
!   if and only if ODAMP(J) .GE. 0.0
!
      ADAPTV = ODAMP(J) >= 0.0D00
!
      ED2 = (ED2-E(J))/ED2
      IF (ADAPTV) THEN
         IF (ED1*ED2 < -1.0d-4) THEN
!           We have a significant oscillation, damp
            ODAMP(J) = 0.10D00 + 0.90D00*ODAMP(J)
!           Print *, 'Increasing ODAMP', odamp(j)
         ELSE
            ODAMP(J) = 0.50D00*ODAMP(J)
         ENDIF
      ENDIF
!
!     Save the relative difference for the next update of this orbital
      PED(J) = ED2
!
      RETURN
      END SUBROUTINE DAMPCK


c     ****************************************************************
c     *                                                              *
c     *                      subroutine ouddpa                       *
c     *                                                              *
c     *                       written by : bh                        *
c     *                                                              *
c     *                   last modified : 1/31/2019 rhd              *
c     *                                                              *
c     *     write nodal displacements, velocities, accelerations,    *
c     *     reactions, temperatures to (1) patran file in            *
c     *     either binary or formatted forms, or (2) a flat text     *
c     *     on stream (binary) file                                  *
c     *                                                              *
c     ****************************************************************
c
      subroutine ouddpa( dva, oubin, ouasc, nodmax, defmax, nwidth,
     &                 flat_file, stream_file, text_file, compressed )
      use global_data ! old common.main
c
      use main_data, only : trn, trnmat, mdiag, pbar, rload,
     &                      inverse_incidences, temper_nodes,
     &                      temper_nodes_ref
      implicit none
c
      integer :: dva, nodmax, nwidth
      logical :: oubin, ouasc, flat_file, stream_file, text_file,
     &           compressed
      double precision :: defmax
c
c                       local declarations
c
      integer :: step_num, bnfile, fmfile, flat_file_number, nod, elem,
     &           dof, ndof, sdof, i
      integer :: titl(80), titl1(80)
      double precision, allocatable :: edva(:,:), trnmte(:,:,:)
      double precision :: nfac
      double precision, parameter :: one = 1.0d0
      real :: sgl_defmax, sgl_vals(10)
      logical :: patran_file
      logical, allocatable :: trne(:,:)

      character(len=4) :: title(80), title1(80)
      character(len=80) :: string, strng1, stepstring*7
      equivalence (title,titl), (title1,titl1)
c
c                       make file name and open file
c                       patran:  binary or formatted files or
c                       both for output.
c
c                       flat file: text or stream. no header lines
c                       in file and no node numbers written
c
c                       for mpi, all nodal results have been collected
c                       to rank 0 -- only 1 patran or flat file
c                       is needed.
c
      allocate( trne(mxvl,mxndel), edva(mxvl,mxndof), ! keep off stack
     &          trnmte(mxvl,mxedof,mxndof) )
c
      step_num = ltmstp
      call ouocdd( dva, step_num, oubin, ouasc, bnfile, fmfile, 1,
     &             .false., myid, flat_file, stream_file, text_file,
     &             compressed, flat_file_number )
c
c                        writing of patran file(s) and flat files
c                        mingled together since same logic is followed
c                        for both.
c
      patran_file = oubin .or. ouasc
c
c                        write info at head of file
c
      if( patran_file ) call ouddpa_patran_header
      if( flat_file .and. text_file )
     &   call ouddpa_flat_header( 1, dva, flat_file_number, 3,
     &                            '(3e15.6)' )
c
c                       loop over the all nodes & write records
c
      do nod = 1, nonode
c
        elem = inverse_incidences(nod)%element_list(1)
        ndof = iprops(4,elem)
c
c                       set the vector of dis/vel/acc/reactions to be
c                       printed. for reactions, it is a bit complicated
c                       since we have to remove internal forces and
c                       inertia effects. nfac is from newmark beta
c                       integration scheme. transform to global from
c                       node local if needed
c
        if( dva .le. 4 ) then
          nfac = one / (nbeta*dt*dt)
          do dof = 1, ndof
            sdof = dstmap(nod)+dof-1
            if( dva .eq. 1 ) then
               edva(1,dof) = u(sdof)
            else if( dva .eq. 2 ) then
               edva(1,dof) = v(sdof)
            else if( dva .eq. 3 ) then
               edva(1,dof) = a(sdof)
            else if( dva .eq. 4 ) then
               edva(1,dof) = pbar(sdof) - ifv(sdof) -
     &                       mdiag(sdof)*du(sdof)*nfac
               if( cstmap(sdof) .ne. 0 ) edva(1,dof) =
     &                       -rload(sdof)+ifv(sdof)+
     &                        mdiag(sdof)*a(sdof)
            end if
          end do
          trne(1,1) = trn(nod)
          if ( trne(1,1) ) then
            trnmte(1,1:3,1:3) = trnmat(nod)%mat(1:3,1:3)
            call trnvec( edva, trnmte, trne, ndof, 1, 1, 2 )
          end if
        end if     !  on dva <= 4
c
        if( dva .eq. 5 ) then   ! temperature only
         edva(1,1) = temper_nodes(nod)
         edva(1,2) = temper_nodes(nod) - temper_nodes_ref(nod)
        end if
c
c                       write the results records for this node.
c                       patran binary results must be real*4. use
c                       real*4 for ASCII to keep compiler from
c                       using a "d" format.
c
c                       flat files: just use double precision
c                       values
c
        sgl_vals(1:nwidth) = sngl( edva(1,1:nwidth) )
        if( patran_file .and. oubin ) write(bnfile) nod,
     &                                sgl_vals(1:nwidth)
        if( patran_file .and. ouasc ) write(fmfile,920) nod,
     &                                sgl_vals(1:nwidth)
c
        if( flat_file .and. stream_file )
     &    write(flat_file_number) edva(1,1:nwidth)
        if( flat_file .and. text_file )
     &    write(flat_file_number,930) edva(1,1:nwidth)
c
      end do  ! on all nodes
c
c                       close patran or flat file. done.
c
      call ouocdd( dva, ltmstp, oubin, ouasc, bnfile, fmfile, 2,
     &             .false., myid, flat_file, stream_file, text_file,
     &             compressed, flat_file_number )
c
      return
c
 920  format(i8,5(e13.6))
 930  format(3e15.6)
c
      contains
c     ========
c
c     ****************************************************************
c     *                                                              *
c     *             subroutine ouddpa_patran_header                  *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 4/16/2014 (rhd)            *
c     *                                                              *
c     *     Write Patran file header info                            *
c     *                                                              *
c     ****************************************************************

      subroutine ouddpa_patran_header
      implicit none
c
      string = ' '
      strng1 = ' '
c
      if( dva.eq.1 ) then
         string = 'nodal displacement results for structure '
      else if( dva.eq.2) then
         string = 'nodal velocity results for structure     '
      else if(dva.eq.3) then
         string = 'nodal acceleration results for structure '
      else if( dva.eq.4 ) then
         string = 'nodal reactions for structure            '
      else if( dva.eq.5 ) then
         string = 'nodal temperatures for structure         '
      end if
      strng1 = 'loading '
c
c                     step number is ltmstp
c
      string(42:49) = stname
      strng1(9:16)  = lsldnm
      write(stepstring,'(i7)') step_num
      string(50:) = ', step '//stepstring
c
      do i = 1, 80
       title(i)  = string(i:i)
       title1(i) = strng1(i:i)
      end do
c
c                       write initial records to either binary or
c                       formatted file
c
      sgl_defmax = sngl( defmax )
c
      if( patran_file .and. oubin ) then
        write(bnfile) titl, nonode, nonode, sgl_defmax, nodmax, nwidth
        write(bnfile) titl1
        write(bnfile) titl1
      end if
c
c                       write to a formatted file, if necessary.
c
      if( patran_file .and. ouasc ) then
        write(fmfile,900) titl
        write(fmfile,910) nonode, nonode, sgl_defmax, nodmax, nwidth
        write(fmfile,900) titl1
        write(fmfile,900) titl1
      end if
c
      return
c
 900  format(80a1)
 910  format(2i9,e15.6,2i9)
c
c
      end subroutine ouddpa_patran_header
      end subroutine ouddpa

c     ****************************************************************
c     *                                                              *
c     *             subroutine ouddpa_flat_header                    *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 1/31/2019 rhd              *
c     *                                                              *
c     *     Write header lines for flat text files                   *
c     *                                                              *
c     ****************************************************************

      subroutine ouddpa_flat_header( type, quantity,
     &                               flat_file_number, num_values,
     &                               format_string )
      use global_data ! old common.main
      implicit none

      integer :: type, quantity, flat_file_number, num_values
      character(len=*) :: format_string
c
c                       local declarations
c
      integer :: step_num
      character(len=15) :: vector_types(5), tensor_types(2),
     &                     scalar_types(1)
      character(len=24) :: sdate_time_tmp
c
      data vector_types / 'displacements', 'velocities',
     &                    'accelerations', 'reactions',
     &                    'temperatures' /
      data tensor_types / 'strains', 'stresses' /
      data scalar_types / 'states' /
c
c                       type:
c                         = 1 a nodal quantity of vector type
c                         = 2 a nodal tensor type
c                         = 3 an element tensor type
c                         = 4 scalar type
c                       quantity for type = 1, see entries in
c                         vector_types above
c                       quantity for type = 2,3 see entries in
c                         tensor_types
c                       quantity for type = see scalar_types
c
      step_num = ltmstp  ! from common.main
c
      write(flat_file_number,9000)
      if( type .eq. 1 ) then
        write(flat_file_number,9010) vector_types(quantity)
      end if
      if( type .eq. 2 ) then
        write(flat_file_number,9011) tensor_types(quantity),
     &                               num_values, format_string
      end if
      if( type .eq. 3 ) then
        write(flat_file_number,9012) tensor_types(quantity),
     &                               num_values, format_string
      end if
      if( type .eq. 4 ) then
        write(flat_file_number,9014) scalar_types(quantity)
      end if
      write(flat_file_number,9020) stname
      write(flat_file_number,9030) nonode, noelem
      call fdate( sdate_time_tmp )
      write(flat_file_number,9040) sdate_time_tmp
      write(flat_file_number,9050) step_num
      write(flat_file_number,9000)
c
      return
c
 9000 format('#')
 9010 format('#  WARP3D nodal results: ',a15 )
 9011 format('#  WARP3D nodal results: ',a15, ' no. data cols: ', i3,
     &        ' format: ',a)
 9012 format('#  WARP3D element results: ',a15, ' no. data cols: ', i3,
     &        ' format: ',a)
 9014 format('#  WARP3D element results: ',a15)
 9020 format('#  Structure name: ',a8 )
 9030 format('#  Model nodes, elements: ',2i8)
 9040 format('#  ',a24)
 9050 format('#  Load(time) step: ',i8 )
c
      end


module snake
    use ncurses
    use constants
    implicit none

    !TYPES
    type :: Point
        integer :: x, y
    end type Point

    type :: Snake_t
        integer :: direction
        type(Point) :: head
        type(Point), dimension(MAX_BODY_LEN) :: body
        integer :: bodyLen
        integer :: idleTicks
        logical :: resetOnIdleEnd
        logical :: is_player
    end type Snake_t

    !VARIABLES
    !max x and y of the main window
    integer :: mwMaxX, mwMaxY
    !max x and y of the subwindow used as playfield
    integer :: fieldMaxX, fieldMaxY
    integer :: boostTicks
    type(C_PTR) :: field
    !player's snake
    type(Snake_t) :: player
    !ki's snakes
    type(Snake_t), dimension(MAX_AI_COUNT) :: snakes
    integer :: aiCount

contains

    subroutine init_game(mode)
        integer, intent(in) :: mode
        integer :: i
        select case(mode)
            case(MODE_SNAKE)
                aiCount = 0
            case(MODE_SNAKE_AI)
                aiCount = MAX_AI_COUNT
        end select
        boostTicks = 0
        call getmaxyx(field, fieldMaxY, fieldMaxX)
        !align field
        fieldMaxX = fieldMaxX - modulo(fieldMaxX, 2)
        do i = 1, FOOD_AMOUNT
            call generate_food()
        end do
    end subroutine init_game

    subroutine init_snake(this, is_player)
        type(Snake_t), intent(inout) :: this
        logical, intent(in) :: is_player
        integer :: i
        this%bodyLen = 1
        this%direction = DIRECTION_UP
        this%idleTicks = -1
        this%resetOnIdleEnd = .FALSE.
        this%is_player = is_player
        do i = 1, MAX_BODY_LEN
            this%body(i) = Point(-1,-1)
        end do
    end subroutine init_snake

    !@return a collision type
    function move_snake(this) result(collision)
        type(Snake_t), intent(inout) :: this
        integer :: collision
        integer :: i
        integer :: new_x, new_y
        integer(chtype) :: cell
        new_x = this%head%x
        new_y = this%head%y

        select case(this%direction)
            case(DIRECTION_UP)
                new_y = modulo(this%head%y - 1, fieldMaxY)
            case(DIRECTION_RIGHT)
                new_x = modulo(this%head%x + 2, fieldMaxX)
            case(DIRECTION_DOWN)
                new_y = modulo(this%head%y + 1, fieldMaxY)
            case(DIRECTION_LEFT)
                new_x = modulo(this%head%x - 2, fieldMaxX)
        end select

        !move body
        do i = this%bodyLen + 1, 2, -1
            this%body(i) = this%body(i - 1)
        end do

        this%body(1) = this%head

        !move head
        this%head%x = new_x
        this%head%y = new_y

        !check collision
        cell = mvwinch(field, new_y, new_x)
        if (iand(cell, A_CHARTEXT) == ichar("*")) then
            !on eat
            call eat_food(this)
            call generate_food()
            collision = COLLISION_NONE
            return
        else if (iand(cell, A_CHARTEXT) /= ichar(" ")) then
            if(iand(cell, A_COLOR) == COLOR_PAIR(7) &
                .or. iand(cell, A_COLOR) == COLOR_PAIR(8)) then
                collision = COLLISION_AI_PLAYER
            else
                collision = COLLISION_AI_AI
            end if
            return
        else
            collision = COLLISION_NONE
            return
        end if
    end function move_snake

    subroutine display_snake(this)
        type(Snake_t), intent(in) :: this
        integer :: i
        integer(C_LONG) :: ierr
        integer :: headColor, bodyColor

        if(this%is_player) then
            headColor = CP_PLAYER_HEAD
        else
            headColor = CP_AI_HEAD
        end if
        if(this%idleTicks>-1) then
            bodyColor = CP_AI_HEAD
        else if(this%is_player) then
            bodyColor = CP_PLAYER_BODY
        else
            bodyColor = CP_AI_BODY
        end if
        !render
        ierr = wattron(field, COLOR_PAIR(headColor))
        ierr = mvwaddch(field, this%head%y, this%head%x, ichar("X", 8))
        ierr = wattroff(field, COLOR_PAIR(headColor))

        ierr = wattron(field, COLOR_PAIR(bodyColor))
        do i = 1, this%bodyLen
            if(this%body(i)%x == -1 .or. this%body(i)%y == -1) exit
            ierr = mvwaddch(field, this%body(i)%y, this%body(i)%x, ichar("0", 8))
        end do
        ierr = wattroff(field, COLOR_PAIR(bodyColor))
        ierr = mvwaddch(field, this%body(this%bodyLen + 1)%y, &
            this%body(this%bodyLen + 1)%x, ichar(" ", 8))
    end subroutine display_snake

    subroutine advance_AI(this)
        type(Snake_t), intent(inout) :: this
        integer :: res
        if(this%idleTicks>0) then
            this%idleTicks = this%idleTicks - 1
            return
        else if(this%idleTicks==0) then
            this%idleTicks = -1
            if(this%resetOnIdleEnd .eqv. .TRUE.) then
                call clear_snake(this)
                call respawn_AI_snake(this)
            end if
        end if
        select case(modulo(irand(), 10))
            case(0)
                call turn_left(this)
            case(1)
                call turn_right(this)
        end select
        res = move_snake(this)
        if(res /= COLLISION_NONE) then
            this%idleTicks = 5
            this%resetOnIdleEnd = .TRUE.
            if(res == COLLISION_AI_PLAYER) then
                call eat_food(player)
            end if
        end if
    end subroutine advance_AI

    subroutine clear_snake(this)
        type(Snake_t), intent(inout) :: this
        integer :: i
        integer(C_LONG) :: ierr
        ierr = mvwaddch(field, this%head%y, this%head%x, ichar(" ", 8))
        this%head = Point(-1,-1)
        do i=1, this%bodyLen
            ierr = mvwaddch(field, this%body(i)%y, this%body(i)%x, ichar(" ", 8))
            this%body(i) = Point(-1,-1)
        end do
    end subroutine clear_snake

    subroutine respawn_AI_snake(this)
        type(Snake_t), intent(inout) :: this
        integer :: side
        side = modulo(irand(),4)
        select case(side)
            case(0) !top side
                this%bodyLen = modulo(irand(), MAX_AI_BODY_LEN)+1
                this%head%x = alignX(modulo(irand(), fieldMaxX))
                this%head%y = 0
            case(1) !right side
                this%bodyLen = modulo(irand(), MAX_AI_BODY_LEN)+1
                this%head%x = fieldMaxX
                this%head%y = modulo(irand(), fieldMaxY+1)
            case(2) !bottom side
                this%bodyLen = modulo(irand(), MAX_AI_BODY_LEN)+1
                this%head%x = alignX(modulo(irand(), fieldMaxX))
                this%head%y = fieldMaxY
            case(3) !left side
                this%bodyLen = modulo(irand(), MAX_AI_BODY_LEN)+1
                this%head%x = 0
                this%head%y = modulo(irand(), fieldMaxY+1)
        end select
    end subroutine respawn_AI_snake

    function alignX(x)
        integer, intent(in) :: x
        integer :: alignX
        alignX = x
        if (modulo(x, 2) == 1) then
            alignX = modulo(x + 1, fieldMaxX)
        end if
        return
    end function alignX

    subroutine set_pos_center(this)
        type(Snake_t), intent(inout) :: this
        !setup and align the snake you start with
        this%head%x = alignX(fieldMaxX/2)
        this%head%y = fieldMaxY/2
        !add body
        this%body(1)%x = this%head%x - 1
        this%body(1)%y = this%head%y
    end subroutine set_pos_center

    subroutine turn_left(this)
        type(Snake_t), intent(inout) :: this
        this%direction = modulo(this%direction - 1, 4)
    end subroutine turn_left

    subroutine turn_right(this)
        type(Snake_t), intent(inout) :: this
        this%direction = modulo(this%direction + 1, 4)
    end subroutine turn_right

    !increases snake length by 1, adds boost
    subroutine eat_food(this)
        type(Snake_t), intent(inout) :: this
        this%bodyLen = this%bodyLen + 1
        if(this%is_player .eqv. .TRUE.) then
            boostTicks = int(boostTicks + BOOST_TIME_MS/ &
                (get_sleep_time_us(this%bodyLen, .FALSE.)/1000.0))
        end if
    end subroutine eat_food

    !spawns a new food entity
    subroutine generate_food()
        integer :: ierr, x, y
        integer(C_LONG) :: ch
        ch = ichar(" ")
        do
            x = modulo(irand(), fieldMaxX)
            y = modulo(irand(), fieldMaxY)
            !align food
            x = x + modulo(x, 2)
            if (iand(mvwinch(field, y, x), A_CHARTEXT) == ch) exit
        end do
        ierr = wattron(field, COLOR_PAIR(CP_FOOD))
        ierr = mvwaddch(field, y, x, ichar("*", 8))
        ierr = wattroff(field, COLOR_PAIR(CP_FOOD))
    end subroutine generate_food

    subroutine draw_info(this)
        type(Snake_t), intent(in) :: this
        integer(C_LONG) :: ierr
        character(len=3) :: str
        ierr = move(1, 0)
        ierr = clrtoeol()
        if (.NOT. can_change_color()) then
            !draw separator at the end of the header
            ierr = mvhline(HEADER_HEIGHT - 1, 0, 0_C_LONG, mwMaxX)
        end if
        ierr = mvprintw(0, 0, "Press q to exit"//C_NULL_CHAR)
        ierr = mvprintw(1, 0, "Length: "//C_NULL_CHAR)
        if (boostTicks > 0) then
            ierr = attron(COLOR_PAIR(CP_ALERT_TEXT))
            ierr = mvprintw(1, mwMaxX/2 - 4, "BOOSTING"//C_NULL_CHAR)
            ierr = attroff(COLOR_PAIR(CP_ALERT_TEXT))
        end if
        write(str, '(i3)') this%bodyLen
        ierr = mvprintw(1, 8, str)
    end subroutine draw_info

    integer function get_sleep_time_us(len, applyBoost)
        integer, intent(in) :: len
        logical, intent(in) :: applyBoost
        integer :: sleep_time
        real :: intensity
        sleep_time = 6000000
        if (boostTicks > 0 .AND. applyBoost) then
            intensity = BOOST_INTENSITY
        else
            intensity = 1.0
        end if
        get_sleep_time_us = int(sleep_time/(len+15) * intensity)
    end function get_sleep_time_us
end module snake


*****************
* LHAPDF version*
*****************
      subroutine pdfwrap
      implicit none
      include 'masses.f'
      include 'lhapdf.f'
      include 'nlooprun.f'
      include 'PDFerrors.f'
      include 'pdlabel.f'
      include 'couple.f'
      double precision alphasPDF
      logical validPDF
      character*50 oldPDFname
      character*72 checkpath
      character*5 :: LHAPDFversionnumber
      integer i,iorder

c      if (newinput .eqv. .false.) then
c        open(unit=21,file='lhapdf.DAT',status='old',err=999)
c        call checkversion(21,'lhapdf.DAT')
c        read(21,*) PDFname
c        read(21,*) PDFmember
c        close(21)
c      endif

      oldPDFname=PDFname
      validPDF=.false.
      i=0
   20 continue
      i=i+1
      if ((oldPDFname(i:i) .eq. '.') .or.
     .    (oldPDFname(i:i) .eq. ' ') .or.
     .    (oldPDFname(i:i) .eq. '[')) then
        validPDF=.true.
        if (oldPDFname(i:i+6) .eq. '.LHgrid') then
          PDFname=oldPDFname(1:i-1)//'.LHgrid'
        else
          PDFname=oldPDFname(1:i-1)//'.LHpdf'
        endif
      endif
      if ((i .lt. 40) .and. (validPDF .eqv. .false.)) goto 20

      if (validPDF .eqv. .false.) then
        write(6,*) 'Problem with PDFname'
        write(6,*)
        stop
      endif

      call LHAPDFversion(LHAPDFversionnumber)
      write(6,*)
      write(6,*) '*******************************************'
      write(6,*) '*     MCFM is calling LHAPDF              *'
      write(6,*) '*                                         *'
      write(6,*) '*   LHAPDF version ',LHAPDFversionnumber,
     . '                  *'
      write(6,*) '*                                         *'
      write(6,98) 'PDFname',PDFname(1:49)
      write(6,99) 'PDFmember',PDFmember
      write(6,*) '*******************************************'

      write(6,*)
      if (LHAPDFversionnumber .ge. "6.2.1") then
        call InitPDFSetByName(trim(PDFname))
      else
        call InitPDFSet(trim(PDFname))
      endif
c      call InitPDFset(checkpath('PDFsets/'//PDFname))
c      write(6,*) '+ PDF set succesfully initialized'

      if (PDFmember .lt. 0) then
        PDFerrors=.true.
        call numberPDF(maxPDFsets)
        if (maxPDFsets .gt. 1000) then
          write(6,*) 'ERROR: Max. number of error sets is 1000!'
          stop
        endif
        write(6,*)
        write(6,*) '****************************************'
        write(6,*) '*        Calculating errors using      *'
        write(6,97) maxPDFsets
        write(6,*) '****************************************'
        call InitPDF(0)
        amz=alphasPDF(zmass)
        currentPDF=0
      else
        call InitPDF(PDFmember)
        amz=alphasPDF(zmass)
      endif

c--- fill MCFM global variable "nlooprun" with the correct value
      call GetOrderAs(iorder)
      nlooprun=iorder+1

c--- rename pdlabel to get sensible output name
      pdlabel=PDFname(1:7)

      return

   97 format(' *        ',i4,' sets of error PDFs       *')
   98 format(' *   ',a7,' ',a29,' *')
   99 format(' *  ',a10,i3,'                          *')

  999 write(6,*) 'Error reading lhapdf.DAT'
      call flush(6)
      stop

      end


C    @(#)ldoldbse.f	20.5 2/13/96
        subroutine ldoldbse (case, bdate, loaded)
        character case *(*), bdate*(*)
c
c       To do:
C
C       1. 11 October: Update in LTRAN the y-matrix pointers
C       2. 11 October: Update in TIE the BRNCH pointers
c
c       Load old base and internally convert into new base
c
      include 'ipfinc/parametr.inc'

      include 'ipfinc/alpha.inc'
c	Global variables used:
c		gkku(r*8), bkku(r*8), qloadu(r*8), pnetu(r*8), qnetu(r*8),
c		ineti(r*8), inetr(r*8), bkmu(r*8), gkmu(r*8), ploadu(r*8),
c		vlimn(r*8), vlimx(r*8), km, kmlen, yptr, nspar
      include 'ipfinc/anlys.inc'
c	Global variables used:
c		None
      include 'ipfinc/arcntl.inc'
c	Global variables used:
c		arcnam, arcbus, arcbas, arcnet, arczns
c		arcnum, arcnam, ntotic, arcinp, arcint
      include 'ipfinc/area.inc'
c	Global variables used:
c		jarzn, tie(r*8), area(r*8)
      include 'ipfinc/basval.inc'
c	Global variables used:
c		basval
      include 'ipfinc/blank.inc'
c	Global variables used:
c		nztot, mtdcbs, mtdcln, kbrknt, kbsknt, kdchg, nslkxx,
c		ltot, kdtot, jtie, jphno, ntotb, ntotc, ntotcs, ntot,
c		ntot2, bmva
      include 'ipfinc/branch.inc'
c	Global variables used:
c		brnch_nxt, brid, brtype, kx, ky, brnch_ptr, brsect,
c		kbrnch, ltot2, brnch_nxt, rateln
      include 'ipfinc/bus.inc'
c	Global variables used:
c		vstart, kbsdta, bus, inp2opt, opt2inp, zone, owner, base
c		alf2inp, inp2alf, e(r*8), f(r*8), capcor(r*8), busdta
      include 'ipfinc/busanl.inc'
c	Global variables used:
c		zsum, jowner
      include 'ipfinc/bushasht.inc'
c	Global variables used:
c		htable_b, nextptr_b
      include 'ipfinc/cbus.inc'
c	Global variables used:
c		kbctbl, bctbl_nxt
      include 'ipfinc/com008.inc'
c	Global variables used:
c		None
      include 'ipfinc/coment.inc'
c	Global variables used:
c		None
      include 'ipfinc/dc2t.inc'
c	Global variables used:
c		dc2t(r*8)
      include 'ipfinc/dcmt.inc'
c	Global variables used:
c		dcmtbs(r*8), dcmtln(r*8)
      include 'ipfinc/delete.inc'
c	Global variables used:
c		None
      include 'ipfinc/dtaiop.inc'
c	Global variables used:
c		kount, clabl2, pversn, usrnam
      include 'ipfinc/epridc.inc'
c	Global variables used:
c		nepbus, nepctl, epbus, epctl
      include 'ipfinc/filnam.inc'
c	Global variables used:
c		None
      include 'ipfinc/lfiles.inc'
c	Global variables used:
c		datai, lprt
      include 'ipfinc/losanl.inc'
c	Global variables used:
c		ownnam, ownlos
      include 'ipfinc/oldbus.inc'
c	Global variables used:
c		oldbus, oldbas, olde
      include 'ipfinc/oldtbx.inc'
c	Global variables used:
c		oldtbx, numtbx
      include 'ipfinc/ordsta.inc'
c	Global variables used:
c		None
      include 'ipfinc/pfdata.inc'
c	Global variables used:
c		None
      include 'ipfinc/phase.inc'
c	Global variables used:
c		jphid
      include 'ipfinc/prt.inc'
c	Global variables used:
c		errbuf
      include 'ipfinc/tbx.inc'
c	Global variables used:
c		tbx(r*8)
      include 'ipfinc/tran.inc'
c	Global variables used:
c		tran(r*4), tap(r*8)
      include 'ipfinc/xdata.inc'
c	Global variables used:
c		xdata(r*8)
      include 'ipfinc/ycomp.inc'
c	Global variables used:
c		nycomp, kycomp

        common /scratch/ xcomments(MAXCMT), xdelete(MAXDEL),
     &                   oldarczns(MAXCAZR,MAXCAR)
        character xcomments * 120, xdelete * 129, oldarczns * 2
        real temp(MAXYE), x22_temp(22,MAXXDT), x2_temp(2,MAXBUS),
     &       x8_temp(8,MAXTBX), x10_temp(10,MAXTIE),
     &       x45_temp(45,MAX2DC), x36_temp(36,MAXMDC)
        integer kx22_temp(22,MAXXDT), kx8_temp(8,MAXTBX),
     &          kx10_temp(10,MAXTIE), kx45_temp(45,MAX2DC),
     &          kx36_temp(36,MAXMDC)
        equivalence (oldarczns, temp, x22_temp, kx22_temp, x2_temp,
     &               x8_temp, kx8_temp, x10_temp, kx10_temp,
     &               x45_temp, kx45_temp, x36_temp, kx36_temp)

        parameter (MAXECS = 13 * MAXBUS + 4 * MAXBRN)
        common /amtrx/ kk(2,MAXBUS), ecs(MAXECS), branch(18,2*MAXBRN)
        integer iecs(MAXECS), linxrf(2*MAXBRN), kbranch(18,2*MAXBRN),
     &          xbctbl(11,MAXCBS)
        real xrateln(3,2*MAXBRN)
        equivalence (ecs, iecs, xbctbl, linxrf),
     &              (ecs(2*MAXBRN+1), xrateln),
     &              (branch, kbranch)

        common /is_batch / is_batch

        logical stab, rcflag, ldflow, error, found
        integer histin, p, h, bus_hash, pold
        character brn_type(9)*2
        character name * 80, tname * 80, backslash * 1

        data brn_type /'E*','LM','L ','R ','T ','TP','LD','E ','RZ'/

        backslash = char(92)
        loaded = 1

c       Description of COUNT array
C
c       COUNT(*)   Description
C
C         1        Solution   -   0 = diverged
C                                 1 = converged
c
C         2        Program version when file was created
C                  Version  Date         Description
c
C                     0     -----------  Original Version
c
C                     1     13-JUL-1987  Sorted Area Interchange records
c
C                     2                  Skipped!
c
C                     3                  Extended branch ratings
C                                        0 = none
C                                        1 = winter ratings
C                                        2 = winter ratings
C
C                     4                  Revised for HASHING
c
C         3        Extended branch ratings - 0 = none
C                                            1 = winter ratings
C                                            2 = summer ratings
C       Description of KOUNT array
c
C       KOUNT(*)   Counter   Description
c
C         1        NZTOTX    Counter of ownerships in array ZSUM
c
C         2        JOWNER    Cnt of ownerships in arrays OWNNAM
C                            and OWNLOS
c
C         3        NTOT      Counter of buses in array VSTART
c
C         4        NTOTIC    Counter of area intertie "I" records
C                            in arrays ARCINT and ARCINP
c
C         5        NYCOMP    Cnt of type "RZ" line compensation
C                            branches in array YCOMP
c
C         6        (not used)
c
C         7        TIME      Base case time:
C                            10000 * hr + 100*min + sec
C
C         8        NEPBUS    Number of EPRI RP1964 d-c buses in case
C
C         9        NEPCTL    Number of EPRI RP1964 d-c control
C                            records in case
c
C        10        LTOT2     Number of double-entry branch records
c                            (Not used in old format)
C
C        11        NDEL      Number of data deletion records
c
C        12        NCOM      Number of case comment records
c
        read (datai) ntot, ntot2, ltot, ntota, ntotb, ntotc, kdtot,
     &               mtdcbs, mtdcln, kxtot, bmva, jtie, kecsy, kbsknt,
     &               kbrknt, jphno, nztot, nspare, ntotcs, nbslck,
     &               nslkxx, kount

        kdchg = 1
        ntotcs = 0
        ntot_alf = ntot

c       bus names, kv, zone code, ownership records

        call rddac (datai, bus, ntot)
        call rddat (datai, base, ntot)
        call rddac (datai, zone, ntot)
        call rddac (datai, owner, ntot)
c
c       Read segmented bus data records (new form is non-segmented)

        do i1 = 1, ntot, 100
           i2 = min0 (100, ntot-i1+1)
           call rddat (datai, busdta(1,i1), i2*16)
        enddo

c       Create bus hash arrays

        call bushinit ()       ! initialize the bus hash tables...

        do i = 1, ntot
           h = bus_hash (bus(i), base(i))
           p = htable_b(h)
           do while (p .gt. 0)         ! Position to end of linked list
              p = nextptr_b(p)
           enddo
           nextptr_b(i) = htable_b(h)
           htable_b(h) = i             ! Inserts new bus at top of stack
        enddo
c
c       Read segmented continuation bus data records (new form is
c       non-segmented and redimensioned (12,*). Relink using linked
c       lists.

        if (ntot2.gt.0) then
           do i1 = 1, ntot2, 100
              i2 = min0 (100, ntot2-i1+1)
              call rddat (datai, xbctbl(1,i1), i2*11)
           enddo
           iold = 0
           pold = 0
           do i = 1, ntot2
              do j = 1, 11
                 kbctbl(j,i) = xbctbl(j,i)
              enddo
              if (iold .ne. kbctbl(1,i)) pold = 0
              iold = kbctbl(1,i)
              kbctbl(12,i) = 0
              bctbl_nxt(i) = 0
              if (pold .gt. 0) bctbl_nxt(pold) = i
              pold = i
           enddo

        endif

c       Read interchange controls records

        if (ntotc.gt.0) then
           call rddac (datai, arcnam, ntotc)
           call rddac (datai, arcbus, ntotc)
           call rddat (datai, arcbas, ntotc)
           call rddat (datai, arcnet, ntotc)
           call rddac (datai, oldarczns, ntotc * MAXCAZR)
           do i = 1, ntotc
              do j = 1, MAXCAZR
                 arczns(j,i) = oldarczns(j,i)
              enddo
              do j = MAXCAZR+1, MAXCAZ
                 arczns(j,i) = ' '
              enddo
           enddo
           call rddat (datai, acznum, nztot)
           call rddac (datai, acznam, nztot)
           call rddat (datai, jarzn, ntot)
           call rddat (datai, area, ntotc * 8)
        endif

c       Read switched reactive data record

        if (kxtot.gt.0) then
           call rddat (datai, x22_temp, kxtot * 22)
           do i = 1, kxtot
              xdata(1,i) = kx22_temp(1,i)
              xdata(2,i) = kx22_temp(2,i)
              do j = 3, 22
                 xdata(j,i) = x22_temp(j,i)
              enddo
           enddo
        endif

c       Read segmented branch data records, defer conversion until
c       extended line ratings are loaded

        do i1 = 1, ltot, 100
           i2 = min0(100,ltot-i1+1)
           call rddat (datai, branch(1,i1), i2*18)
        enddo

c       internal, external bus numbers e + Jf voltage tables
c       capacitor correction tables
C
        call rddat (datai, opt2inp, ntot)
        call rddat (datai, inp2opt, ntot)
        do i = 1, ntot
           alf2inp(i) = i       ! Note that the old scheme is
           inp2alf(i) = i       ! input order == alpha order
        enddo

        call rddat (datai, temp, ntot)
        do i = 1, ntot
           e(i) = temp(i)
        enddo
        call rddat (datai, temp, ntot)
        do i = 1, ntot
           f(i) = temp(i)
        enddo
        call rddat (datai, x2_temp, ntot * 2)
        do i = 1, ntot
           capcor(1,i) = x2_temp(1,i)
           capcor(2,i) = x2_temp(2,i)
        enddo

C       Store old bus names, voltages in alpha order

        do 122 i = 1, ntot
           oldbus(i) = bus(i)
           oldbas(i) = base(i)
           olde(i) = e(inp2opt(i))
           oldf(i) = f(inp2opt(i))
  122   continue
        numobs = ntot
C
c       conditional] phase shifter data record

        if (jphno.gt.0) then
           call rddat (datai, jphid, jphno * 8)
        endif

C       Load in and convert Y-matrix and solution arrays
c
        call rddat (datai, kk, ntot*2)

        do i1 = 1, kecsy, 4000
           last = min0(4000,kecsy-i1+1)
           call rddat (datai, iecs(i1), last)
        enddo

        yptr = 0
        do i = 1, ntot
           is = kk(1,i)
           ie = kk(2,i)
           pnetu(i) = ecs(is)
           qnetu(i) = ecs(is+1)
           gkku(i) = ecs(is+2)
           bkku(i) = ecs(is+3)
           ntypu(i) = iecs(is+4)
           nspar(i) = iecs(is+5)
           vlimn(i) = ecs(is+6)
           vlimx(i) = ecs(is+7)
           ploadu(i) = ecs(is+8)
           qloadu(i) = ecs(is+9)
           inetr(i) = ecs(is+10)
           ineti(i) = ecs(is+11)

           km(i) = yptr + 1
           kmlen(i) = (ie - 12) / 3
           do j = is+12, is+ie-1, 3
              yptr = yptr + 1
              ikmu(yptr) = iecs(j)
              gkmu(yptr) = ecs(j+1)
              bkmu(yptr) = ecs(j+2)
           enddo
        enddo
C
c       Load segmented TBX array
C
        if (ntotb.gt.0) then
           do i1 = 1, ntotb, 50
              i2 = min0(50, ntotb-i1+1)
              call rddat (datai, x8_temp(1,i1), i2*8)
           enddo
           do i = 1, ntotb
              ltyp = kx8_temp(1,i)
              tbx(1,i) = ltyp
              tbx(2,i) = kx8_temp(2,i)
              tbx(3,i) = x8_temp(3,i)
              tbx(4,i) = x8_temp(4,i)
              if (ltyp .eq. 5) then
                 tbx(5,i) = kx8_temp(5,i)
              else
                 tbx(5,i) = x8_temp(5,i)
              endif
              tbx(6,i) = x8_temp(6,i)
              tbx(7,i) = kx8_temp(7,i)
              tbx(8,i) = kx8_temp(8,i)
           enddo
c
C          Convert any distantly remote controlled buses;
C          store original TBX array.
c
           do j = 1, ntotb
              ltyp = kx8_temp(1,i)
              if (ltyp .eq. 3 .or. ltyp .eq. 5) then
                 if (tbx(8,j) .lt. 0) then
                    m = tbx(8,j)
                    m = iabs(m)
                    tbx(8,j) = opt2inp(m)
                 endif
              endif
              do k = 1, 8
                 oldtbx(k,j) = tbx(k,j)
              enddo
           enddo
           numtbx = ntotb

        endif
C
c       Load segmented LTC (automatic transformer) arrays
C
        if (ntota.gt.0) then
           do i1 = 1, ntota,50
              i2 = min0(50, ntota-i1+1)
              call rddat (datai, tran(1,i1), i2*12)
              call rddat (datai, temp(i1), i2)
           enddo
           do i = 1, ntota
              tap(i) = temp(i)
           enddo
        endif
C
c       Load segmented tie line array
C
        if (jtie.gt.0) then
           do i1 = 1, jtie, 100
              i2 = min0(100,jtie-i1+1)
              call rddat (datai, x10_temp(1,i1), i2*10)
           enddo
           do i = 1, jtie
              tie(1,i) = kx10_temp(1,i)
              tie(2,i) = kx10_temp(2,i)
              do k = 3, 6
                 tie(k,i) = x10_temp(k,i)
              enddo
              do k = 7, 10
                 tie(k,i) = kx10_temp(k,i)
              enddo
           enddo
        endif
C
c       Load d-c system arrays
C
        if (kdtot .gt. 0) then
           call rddat (datai, x45_temp, kdtot * 45)
           do i = 1, kdtot
              dc2t(1,i) = kx45_temp(1,i)
              dc2t(2,i) = x45_temp(2,i)
              dc2t(3,i) = kx45_temp(3,i)
              do k = 4, 6
                 dc2t(k,i) = x45_temp(k,i)
              enddo
              dc2t(7,i) = kx45_temp(7,i)
              do k = 8, 19
                 dc2t(k,i) = x45_temp(k,i)
              enddo
              dc2t(20,i) = kx45_temp(20,i)
              do k = 21, 32
                 dc2t(k,i) = x45_temp(k,i)
              enddo
              dc2t(33,i) = kx45_temp(33,i)
              dc2t(34,i) = kx45_temp(34,i)
              do k = 35, 36
                 dc2t(k,i) = x45_temp(k,i)
              enddo
              dc2t(37,i) = kx45_temp(37,i)
              dc2t(38,i) = kx45_temp(38,i)
              do k = 39, 45
                 dc2t(k,i) = x45_temp(k,i)
              enddo
           enddo
        endif
        if (mtdcbs.gt.0) then
           call rddat (datai, x36_temp, mtdcbs * 36)
           do i = 1, mtdcbs
              dcmtbs(1,i) = kx36_temp(1,i)
              dcmtbs(2,i) = x36_temp(2,i)
              dcmtbs(3,i) = kx36_temp(3,i)
              dcmtbs(4,i) = kx36_temp(4,i)
              do k = 5, 14
                 dcmtbs(k,i) = x36_temp(k,i)
              enddo
              dcmtbs(15,i) = kx36_temp(15,i)
              do k = 16, 20
                 dcmtbs(k,i) = x36_temp(k,i)
              enddo
              dcmtbs(21,i) = kx36_temp(21,i)
              dcmtbs(22,i) = kx36_temp(22,i)
              do k = 23, 26
                 dcmtbs(k,i) = x36_temp(k,i)
              enddo
              dcmtbs(27,i) = kx36_temp(27,i)
              dcmtbs(28,i) = kx36_temp(28,i)
              do k = 29, 30
                 dcmtbs(k,i) = x36_temp(k,i)
              enddo
              do k = 31, 36
                 dcmtbs(k,i) = kx36_temp(k,i)
              enddo
           enddo
        endif
        if (mtdcln.gt.0) then
           call rddat (datai, x10_temp, mtdcln * 10)
           do i = 1, mtdcln
              do k = 1, 3
                 dcmtln(k,i) = kx10_temp(k,i)
              enddo
              do k = 4, 6
                 dcmtln(k,i) = x10_temp(k,i)
              enddo
              do k = 7, 10
                 dcmtln(k,i) = kx10_temp(k,i)
              enddo
           enddo
        endif

        nztotx = kount (1)
        jowner = kount (2)
        if (nztotx.gt.0)  then
           read (datai) (zsum(5,i),zsum(6,i) ,i=1, nztotx)
        endif
        if (jowner.gt.0) then
           call rddac (datai, ownnam, jowner)
           call rddat (datai, ownlos, jowner * 2)
        endif

        i = kount (3)
        if (i.gt.0) call rddat (datai, vstart, i)

        ntotic = kount(4)
        if (ntotic.gt.0) then
           call rddat (datai,arcinp,ntotic)
           call rddac (datai,arcint,2 * ntotic)
        endif

        nycomp = kount(5)
        if (nycomp .gt. 0) then
           call rddat(datai,kycomp,48 * nycomp)
        endif
c
c       Load extended line rating array with the following steps:
c
c       1. Load from old base into temporary array rateln(*,*)
c       2. Expand rateln(*,*) into xrateln(*,*) which is parallel
c          with branch(*,*)
c       3. Load xrateln(*,*) into rateln(*,*)
c
        numlrt = kount(6)
        if (numlrt .gt. 0) then
           do 180 i1 = 1, ltot, 2000
              i2 = min0(2000, ltot-i1+1)
              call rddatx (datai, linxrf(i1), i2, error)
              if (error) then
                 write (*,176) numlrt
  176            format (' Record fragment in extended line ratings.'
     1,i6,' data items are ignored.')
                 write (errbuf(1),176) numlrt
                 call prterx ('w',1)
                 numlrt = 0
                 go to 191
              endif
  180      continue
           do 190 i1 = 1, numlrt, 100
              i2 = min0(100, numlrt-i1+1)
              call rddatx (datai, rateln(1,i1), 3*i2, error)
              if (error) then
                 write (*,176) numlrt
                 write (errbuf(1),176) numlrt
                 call prterx ('w',1)
                 numlrt = 0
                 go to 191
              endif
  190      continue
  191      continue
        else
           do i = 1, ltot
              linxrf(i) = 0
           enddo
        endif
c
c       Build branch data records
c
        iold = 0
        ltot2 = ltot
        ltot = 0
c
c       Initialize xrateln
c
        do i = 1, ltot2
           do k = 1, 3
              xrateln(k,i) = 0.0
           enddo
        enddo
c
c       Transfer compact rateln into xrateln. It will now be parallel
c       with branch
c
        do i = 1, ltot2
           j = linxrf(i)
           if (j .gt. 0) then
              do k = 1, 3
                 xrateln(k,i) = rateln(k,j)
              enddo
           endif
        enddo

        do i = 1, ltot2
           brtype(i) = kbranch(1,i)
           kx(i) = kbranch(2,i)
           ky(i) = kbranch(12,i)
           if (brtype(i) .eq. 4) then
              brid(i) = ' '
              brsect(i) = 0
           else
              call getchr (1, brid(i), kbranch(13,i))
              brsect(i) = kbranch(14,i)
           endif
           if (kbranch(17,i) .eq. 0) then
              ltot = ltot + 1
              do j = 1,18
                 kbrnch(j,ltot) = kbranch(j,i)
              enddo
              do j = 1, 3
                 rateln(j,ltot) = xrateln(j,i)
              enddo
              brnch_ptr(i) = ltot
           else
              brnch_ptr(i) = 0
           endif
           brnch_nxt(i) = 0
           if (kx(i) .eq. iold) then
              brnch_nxt(jold) = i
           else
              iold = kx(i)
              kbsdta(16,iold) = i
           endif
           jold = i
        enddo
c
c       Now catch transposes which were skipped.
c
        do i = 1, ltot2
           if (brnch_ptr(i) .eq. 0) then
              found = .false.
              p = kbsdta(16,ky(i))
              do while (p .gt. 0 .and. .not. found)
                 if (ky(p) .eq. kx(i) .and.
     &               brid(p) .eq. brid(i) .and.
     &               brsect(p) .eq. brsect(i) .and.
     &               brtype(p) .eq. brtype(i)) then
                    brnch_ptr(i) = -brnch_ptr(p)
                    found = .true.
                 else
                    p = brnch_nxt(p)
                 endif
              enddo
              if (.not. found) call erexit(1)
           endif
        enddo
c
c       If all is well, ltot == ltot2 / 2
c
        error = .false.
        if (2 * ltot .eq. ltot2) then
        else if (2 * ltot .ne. ltot2) then
           error = .true.
           write (errbuf(1), 192) ltot, ltot2/2
  192      format (' Internal branch conversion error - ',
     1             'number of single-entry branches counted = ',i5,
     2             ', computed = ', i5)
           write (errbuf(2), 193)
  193      format (' Duplicately constructed branches are flagged')
           call prterx ('W', 2)
           do i = 1, ltot2
              if (brnch_ptr(i) .eq. 0) then
                 write (errbuf(1), 194) brn_type(brtype(i)), bus(kx(i)),
     &              base(kx(i)), bus(ky(i)), base(ky(i)), brid(i),
     &              brsect(i)
  194            format (' Omitted branch ', a, 1x, a8, f7.1, 1x, a7,
     &              f7.1, 1x, a1, i2)
              else
                 found = .false.
                 p = kbsdta(16,ky(i))
                 do while (p .gt. 0 .and. .not. found)
                    if (ky(p) .eq. kx(i) .and.
     &                  brid(p) .eq. brid(i) .and.
     &                  brsect(p) .eq. brsect(i) .and.
     &                  brtype(p) .eq. brtype(i)) then
                       found = .true.
                    else
                       p = brnch_nxt(p)
                    endif
                 enddo
                 if (found) then
                    if (brnch_ptr(i) .eq. 0) then
                    else if (isign(1,brnch_ptr(i)) .eq.
     &                       isign(1,brnch_ptr(p))) then
                       write (errbuf(1), 195) brn_type(brtype(i)),
     &                    bus(kx(i)), base(kx(i)), bus(ky(i)),
     &                    base(ky(i)), brid(i), brsect(i)
  195                  format (' Duplicately constructed branch ', a,
     &                    1x, a8, f7.1, 1x, a7, f7.1, 1x, a1, i2)
                       call prterx ('w', 1)
                    else
                    endif
                 endif
              endif
           enddo
           if (is_batch .eq. 0) then
              call prterx ('E',1)
           else
              call prterx ('F',1)
           endif
        endif
C
C       Retrieve any EPRI RP1964 d-c data.
C
        nepbus = kount(8)
        nepctl = kount(9)
C
C       EPBUS = character array containing BD, BZ, LD, MD records.
C       EPCTL = character array containing CC, CD, CN, CR records.

        if (nepbus .gt. 0) then
           call rddac (datai, epbus, nepbus)
           if (nepctl .gt. 0) call rddac (datai, epctl, nepctl)

           iver = 5
           histin = datai    ! RCFLAG -  recover saved case flag.
           jtape = lprt
           stab = .false.
           ldflow = .true.
           rcflag = .true.   ! RCFLAG -  recover saved case flag.
C
C          IVER = 5 corresponds with highest version in EPRI
C          powerflow.

           call loaddc (iver, histin, rcflag, jtape, ldflow, stab)
           call loadcc (histin)
        endif

        ndelx = kount(11)
        ncomx = kount(12)

        if (ncomx .gt. 0) then
           call rddac(datai, xcomments, ncomx)
        endif

        if (ndelx .gt. 0) then
           call rddac(datai, xdelete, ndelx)
        endif

        return
        end


      SUBROUTINE QUIKVIS5A2D1(ITIME1,ITIME2,
     *       ITARG,IDTARG,TARGNAMES,KTARGTYP,TARGPARM)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C THIS ROUTINE IS PART OF THE QUIKVIS PROGRAM.  IT IS THE OUTPUT ROUTINE
C GIVING PRINTED OUTPUT OF TARGET AVAILABILITY FOR INDIVIDUALLY
C SPECIFIED TARGETS.  OUTPUT IS IN THE SUMMARY TABLE FORMAT.
C
C
C VARIABLE      DIM       TYPE I/O DESCRIPTION
C --------      ---       ---- --- -----------
C
C ITIME1         1         I*4  I  INDEX OF THE FIRST TIME FOR WHICH
C                                  OUTPUT IS WANTED
C
C ITIME2         1         I*4  I  INDEX OF THE LAST TIME FOR WHICH
C                                  OUTPUT IS WANTED
C
C ITARG          1         I*4  I  INDEX OF THE TARGET FOR WHICH OUTPUT
C                                  IS TO BE GENERATED.
C
C IDTARG      MAXTARGS     I*4  I  DESCRIBED IN QUIKVIS(=MAIN) PROLOGUE.
C
C TARGNAMES   MAXTARGS    CH*16 I  DESCRIBED IN QUIKVIS(=MAIN) PROLOGUE.
C
C KTARGTYP    MAXTARGS     I*4  I  DESCRIBED IN QUIKVIS(=MAIN) PROLOGUE.
C
C TARGPARM NPARMS,MAXTARGS R*8  I  DESCRIBED IN QUIKVIS(=MAIN) PROLOGUE.
C
C***********************************************************************
C
C BY C PETRUZZO/GFSC/742.   2/86.
C       MODIFIED.... 9/86. CJP. ADDED NODETEXT ARRAY; CHANGED SUMMARY
C                               HEADER FORMAT;  DELETED TAREQMT ARRAY;
C
C***********************************************************************
C
      INCLUDE 'QUIKVIS.INC'
C
      CHARACTER*16 TARGNAMES(MAXTARGS)
      INTEGER*4 IDTARG(MAXTARGS)
      REAL*8 TARGPARM(NPARMS,MAXTARGS)
      INTEGER*4 KTARGTYP(MAXTARGS)
C
      REAL*8 VISTIMES(MAXNODES),TMIN(MAXTIMES),TMAX(MAXTIMES)
      CHARACTER*4 CHARLINE(MAXTIMES)
C
      INTEGER LU(2)
      CHARACTER*3 CHAR3,I4CHAR
      CHARACTER*60 SHADTEXT
      CHARACTER*20 CH20
      CHARACTER*18 DATETIME
      CHARACTER*16 CH16NAME
C
      CHARACTER*44 NODETEXT(2)/
     *  'ORBIT RIGHT ASCENSION OF THE ASCENDING NODE.',
     *  'MEAN SOLAR TIME OF THE ASCENDING NODE.'/
C
C
      IBUG = 0
      LUBUG = 19
C
C
C
C SET UNIT NUMBERS TO WHICH OUTPUT IS DIRECTED
C
      LU(1) = LUPRINT
      IF(.NOT.TOPRINT) LU(1) = 0
      LU(2) = LUPROMPT
      IF(.NOT.TOPROMPT) LU(2) = 0
      IF(LUPRINT.EQ.LUPROMPT) LU(2) = 0  ! ELIMINATES DUPLICATE WRITES
C
C
C INITIALIZE TMIN AND TMAX
C
      CALL MTXSETR8(TMIN, 1.D10,MAXTIMES,1)
      CALL MTXSETR8(TMAX,-1.D10,MAXTIMES,1)
C
C SET TEXT TELLING ABOUT ORBIT NIGHT REQMT
C
      IF(DOREQMT(2)) THEN
        SHADTEXT = 'TARGET AVAILABILITY REQUIRES ORBIT NIGHT'
      ELSE
        SHADTEXT = 'TARGET AVAILABILITY IGNORES ORBIT NIGHT.'
        END IF
C
C
C PAGE HEADER
C
      DO 1000 ILU=1,2
      IF(LU(ILU).EQ.0) GO TO 1000
C
      KTEMP = 1
      IF(NODEOPT.EQ.2) KTEMP = 2
      WRITE(LU(ILU),1009) DATETIME(0),IDTARG(ITARG),TARGNAMES(ITARG),
     *    SHADTEXT,EAVOID*DEGRAD,VAVOID*DEGRAD,ZMAXSEP*DEGRAD,
     *    NODETEXT(KTEMP)
      IF(VISMIN.EQ.0.D0) THEN
        WRITE(LU(ILU),1007)
      ELSE
        WRITE(LU(ILU),1008) VISMIN/60.D0
        END IF
      IF(NEEDTIME) THEN
        CALL PAKT50CH(TSTART,CH20)
        CH20(12:12) = ':'
        CH20(15:15) = ':'
        WRITE(LU(ILU),1010) CH20(1:17)
        END IF
      IF(NODEOPT.EQ.1) THEN
        NLINE1011 = 3
        WRITE(LU(ILU),1011)
     *    ' ORBIT',
     *    '  RAAN',
     *    ' (DEG)', (JIDNNT( (I-1)*DELTIME/86400.D0 ),I=ITIME1,ITIME2)
      ELSE
        NLINE1011 = 5
        WRITE(LU(ILU),1011)
     *    'RAAN''S',
     *    '  MEAN',
     *    ' SOLAR',
     *    '  TIME',
     *    '(HH:MM)', (JIDNNT( (I-1)*DELTIME/86400.D0 ),I=ITIME1,ITIME2)
        END IF
C
C
C GENERATE THE TABLE.  GATHER DATA ONE NODE AT A TIME BY READING EACH
C RECORD AND SELECTING THE DATA CORRESPONDING TO THAT NODE.
C
      IF(NODEOPT.EQ.1) THEN
        NUMNODES = NUMRAAN
      ELSE IF(NODEOPT.EQ.2) THEN
        NUMNODES = NUMSOLT
      ELSE  ! BAD NODEOPT VALUE.
        STOP ' QUIKVIS5A2D1. CODING ERROR. STOP 1. SEE CODE.'
        END IF
C
      DO INODE = 1,NUMNODES
C
        DO ITIME = 1,NUMTIMES
C
C        READ A DATA RECORD FROM LUSCR1
          CALL QV5READ(ITIME,T50,KTARG,ID,CH16NAME,DUM,DUM,DUM,DUM,KDUM,
     *          .FALSE.,DUM, .TRUE.,VISTIMES, .FALSE.,DUM)
C
C        ERROR CHECK.  BE SURE ID IS AS EXPECTED.
          IF(KTARG.NE.ITARG) THEN
            STOP ' QUIKVIS5A2D1. CODING ERROR. STOP 2.  SEE CODE.'
            END IF
C
C        SET UP OUTPUT INFO.
          IF(ITIME1.LE.ITIME .AND. ITIME.LE.ITIME2) THEN
            TMIN(ITIME) = DMIN1(TMIN(ITIME),VISTIMES(INODE))
            TMAX(ITIME) = DMAX1(TMAX(ITIME),VISTIMES(INODE))
            KTEMP = JIDINT(VISTIMES(INODE)/60.D0)
            CHAR3 = I4CHAR(KTEMP,3,KDUM)
            CHARLINE(ITIME)(1:1) = ' '
            CHARLINE(ITIME)(2:2) = CHAR3(1:1)
            CHARLINE(ITIME)(3:3) = CHAR3(2:2)
            CHARLINE(ITIME)(4:4) = CHAR3(3:3)
            IF(VISTIMES(INODE).LT.VISMIN) CHARLINE(ITIME) = ' ---'
            IF(VISTIMES(INODE).EQ.0.D0)   CHARLINE(ITIME) = ' ---'
            END IF
          END DO   ! END ITIME LOOP
C
        IF(NODEOPT.EQ.1) THEN
          RAAN = EQVANG( RAAN1 + (INODE-1)*DELRAAN )
          WRITE(LU(ILU),1012) RAAN*DEGRAD,
     *            (CHARLINE(ITIME),ITIME=ITIME1,ITIME2)
        ELSE
          SOLT = DMOD( SOLTIM1 + (INODE-1)*DELSOLT, 86400.D0)
          CALL PAKT50CH(SOLT,CH20)
          CH20(12:12) = ':'
          WRITE(LU(ILU),1014)
     *       CH20(10:14),(CHARLINE(ITIME),ITIME=ITIME1,ITIME2)
          END IF
        END DO  ! END INODE LOOP
C
      WRITE(LU(ILU),1015)
     *   ' T-MIN=',(JIDINT(TMIN(ITIME)/60.D0),ITIME=ITIME1,ITIME2)
      WRITE(LU(ILU),1016)
     *   ' T-MAX=',(JIDINT(TMAX(ITIME)/60.D0),ITIME=ITIME1,ITIME2)
C
 1000 CONTINUE
C
      RETURN
C
C***********************************************************************
C
C
C**** INITIALIZATION CALL. PUT GLOBAL PARAMETER VALUES INTO THIS
C     ROUTINE'S LOCAL VARIABLES.
C
      ENTRY QVINIT5A2D1
C
      CALL QUIKVIS999(-1,R8DATA,I4DATA,L4DATA)
      RETURN
C
C***********************************************************************
C
C
 1009 FORMAT(
     * '1SUMMARY TARGET AVAILABILITY INFO',T90,'GENERATED ',A/,
     * ' ********************************'//,
     * ' TARGET ID = ',I5,'  TARGET NAME= ',A//,
     * ' OBSERVATION REQUIREMENTS:'//,
     * T7,A/
     * T7,'EARTH LIMB AVOIDANCE ANGLE(DEG) =      ',F8.2/,
     * T7,'VELOCITY VECTOR AVOIDANCE ANGLE(DEG) = ',F8.2/,
     * T7,'MAX OK SEPARATION FROM ZENITH(DEG) =   ',F8.2//,
     * ' THIS TABLE GIVES TARGET AVAILABILITY DURATION AS A FUNCTION ',
     *   'OF DATE AND ',A//,
     * ' DURATIONS ARE IN MINUTES ROUNDED DOWN TO A WHOLE NUMBER.')
 1007 FORMAT(
     * '   --- MEANS BEFORE ROUNDING, DURATION WAS ZERO.'/)
 1008 FORMAT(
     * '   --- MEANS BEFORE ROUNDING, DURATION WAS LESS THAN ',
     *       F6.3,' MINUTES(= THE USER-SPECIFIED MINIMUM OF INTEREST)'/)
 1010 FORMAT(' COLUMN HEADERS ARE DAYS FROM (Y/M/D H:M:S) ',A/)
 1011 FORMAT( <NLINE1011>(/,1X,A), T9,<ITIME2-ITIME1+1>I4/)
 1012 FORMAT(1X,F6.1,T9,<ITIME2-ITIME1+1>A)
 1014 FORMAT(2X,   A,T9,<ITIME2-ITIME1+1>A)
 1015 FORMAT(/, 1X,A, T9,<ITIME2-ITIME1+1>I4)
 1016 FORMAT(   1X,A, T9,<ITIME2-ITIME1+1>I4)
      END


C$Procedure      SPKE19 ( SPK, evaluate record, type 19 )

      SUBROUTINE SPKE19 ( ET, RECORD, STATE )

C$ Abstract
C
C     Evaluate a single data record from a type 19 SPK segment.
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     SPK
C
C$ Keywords
C
C     EPHEMERIS
C     SPK
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE 'spk19.inc'
      INCLUDE 'spkrec.inc'

      DOUBLE PRECISION      ET
      DOUBLE PRECISION      RECORD   ( * )
      DOUBLE PRECISION      STATE    ( 6 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     MAXREC     P   Maximum size of SPK record.  See SPKPVN.
C     ET         I   Epoch for which a state is desired.
C     RECORD     I   Record from a type 19 SPK segment valid for ET.
C     STATE      O   State (position and velocity) at epoch ET.
C
C$ Detailed_Input
C
C     ET             is the epoch for which a state vector is desired,
C                    expressed as seconds past J2000 TDB.
C
C
C     RECORD         is a record from a type 19 SPK segment which, when
C                    evaluated at epoch ET, will give the state
C                    (position and velocity) of some body, relative to
C                    some center, in the reference frame associated
C                    with the data packets. Usually the body, center
C                    and frame are those of the SPK segment from which
C                    the packets were read.
C
C                    The structure of the record is as follows:
C
C                       +----------------------+
C                       | subtype code         |
C                       +----------------------+
C                       | number of packets (n)|
C                       +----------------------+
C                       | packet 1             |
C                       +----------------------+
C                                .
C                                .
C                                .
C                       +----------------------+
C                       | packet n             |
C                       +----------------------+
C                       | epoch 1              |
C                       +----------------------+
C                                .
C                                .
C                                .
C                       +----------------------+
C                       | epoch n              |
C                       +----------------------+
C
C$ Detailed_Output
C
C     STATE    is the state vector at epoch ET. Its contents are, in
C              order, X, Y, Z, X', Y', and Z'. Units are km and km/sec.
C
C$ Parameters
C
C     MAXREC   is the maximum size of SPK record. See the SPICELIB
C              routine SPKPVN for details.
C
C$ Exceptions
C
C     1)  Most types of errors in the input record cannot be diagnosed
C         by this routine. This routine assumes that the input record
C         is valid.
C
C     2)  If the subtype code in the input record is invalid, the error
C         will be diagnosed by a routine in the call tree of this
C         routine.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The exact format and structure of type 19 (ESOC/DDID piecewise
C     interpolation) SPK segments is described in the SPK Required
C     Reading.
C
C$ Examples
C
C     The SPKEnn routines are almost always used in conjunction with
C     the corresponding SPKRnn routines, which read the records from
C     SPK files.
C
C     The data returned by the SPKRnn routine is in a raw form, taken
C     directly from the segment. As such, it will be not be directly
C     useful to a user unless they have a complete understanding of the
C     structure of the data type.  Given that understanding, however,
C     the SPKRnn routines could be used to "dump" and check segment data
C     for a particular epoch before evaluating the record to obtain a
C     state vector, as in the example that follows.
C
C
C     C
C     C     Get a segment applicable to a specified body and epoch.
C     C
C           CALL SPKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND )
C
C     C
C     C     Look at parts of the descriptor.
C     C
C           CALL DAFUS ( DESCR, 2, 6, DCD, ICD )
C
C           CENTER = ICD( 2 )
C           REF    = ICD( 3 )
C           TYPE   = ICD( 4 )
C
C           IF ( TYPE .EQ. 19 ) THEN
C
C              CALL SPKR19 ( HANDLE, DESCR, ET, RECORD )
C                  .
C                  .  Look at the RECORD data.
C                  .
C              CALL SPKE19 ( ET, RECORD, STATE )
C                  .
C                  .  Check out the evaluated state.
C                  .
C           END IF
C
C$ Restrictions
C
C     1)  This routine assumes that the input record is valid.  Any
C         checking of the input data is assumed to have been performed
C         when the source SPK file was created.
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 2.0.0, 11-MAY-2015 (NJB)
C
C        Updated to support subtype 2. Now performs
C        computations in-line, rather than calling
C        SPKE18.
C
C-    SPICELIB Version 1.0.0, 14-MAR-2014 (NJB) (BVS)
C
C-&

C$ Index_Entries
C
C     evaluate type_19 spk_segment
C
C-&

C$ Revisions
C
C     None.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      LGRINT
      LOGICAL               RETURN

C
C     Local parameters
C

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

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

C
C     Index at which packets start:
C
      INTEGER               PKTIDX
      PARAMETER           ( PKTIDX = 3 )

C
C     Local variables
C
      DOUBLE PRECISION      LOCREC ( MAXREC )
      DOUBLE PRECISION      WORK   ( MAXREC * 2,  2 )
      DOUBLE PRECISION      VBUFF  ( 6 )

      INTEGER               FROM
      INTEGER               I
      INTEGER               J
      INTEGER               N
      INTEGER               PACKSZ
      INTEGER               SUBTYP
      INTEGER               TO
      INTEGER               XSTART
      INTEGER               YSTART

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

      CALL CHKIN ( 'SPKE19' )

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

      IF ( SUBTYP .EQ. S19TP0 ) THEN

         PACKSZ = S19PS0

      ELSE IF ( SUBTYP .EQ. S19TP1 ) THEN

         PACKSZ = S19PS1

      ELSE IF ( SUBTYP .EQ. S19TP2 ) THEN

         PACKSZ = S19PS2

      ELSE

         CALL SETMSG ( 'Unexpected SPK type 19 subtype found in '
     .   //            'type 19 record.'                          )
         CALL ERRINT ( '#',  SUBTYP                               )
         CALL SIGERR ( 'SPICE(INVALIDVALUE)'                      )
         CALL CHKOUT ( 'SPKE19'                                   )
         RETURN

      END IF

C
C     Get the packet count.
C
      N = NINT( RECORD(CNTIDX) )

      IF ( SUBTYP .EQ. S19TP0 ) THEN
C
C        We interpolate each state component in turn.  Position and
C        velocity are interpolated separately.
C
         XSTART = 3  +  PACKSZ * N

         DO I = 1, 3

            DO J = 1, N
C
C              For the Jth input packet, copy the Ith position and
C              velocity components into the local record buffer LOCREC.
C
               FROM         = 2 + PACKSZ*(J-1) + I
               TO           =     2 * J        - 1

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

            END DO

C
C           Interpolate the Ith position and velocity components of the
C           state.  We'll keep the position and overwrite the velocity.
C
            CALL HRMINT ( N,
     .                    RECORD(XSTART),
     .                    LOCREC,
     .                    ET,
     .                    WORK,
     .                    STATE(I  ),
     .                    STATE(I+3)      )

         END DO

C
C        Now interpolate velocity, using separate velocity data and
C        acceleration.
C
         DO I = 1, 3

            DO J = 1, N
C
C              For the Jth input packet, copy the Ith position and
C              velocity components into the local record buffer LOCREC.
C
               FROM         = 2  +  PACKSZ*(J-1)  +  PACKSZ/2  +  I
               TO           =       2 * J         -  1

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

            END DO

C
C           Interpolate the Ith velocity and acceleration components of
C           the state.  We'll capture the result in a temporary buffer,
C           then transfer the velocity to the output state array.
C
            CALL HRMINT ( N,
     .                    RECORD(XSTART),
     .                    LOCREC,
     .                    ET,
     .                    WORK,
     .                    VBUFF(I  ),
     .                    VBUFF(I+3)     )
         END DO

C
C        Fill in the velocity in the output state using the results of
C        interpolating velocity and acceleration.
C
         CALL VEQU ( VBUFF, STATE(4) )

      ELSE IF ( SUBTYP .EQ. S19TP1 ) THEN
C
C        We perform Lagrange interpolation on each state component.
C
C        We'll transpose the state information in the input record so
C        that contiguous pieces of it can be shoved directly into the
C        interpolation routine LGRINT.
C
         CALL XPSGIP ( PACKSZ, N, RECORD(PKTIDX) )

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

         DO I = 1, PACKSZ

            YSTART    =   3   +  N * (I-1)

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

      ELSE IF ( SUBTYP .EQ. S19TP2 ) THEN
C
C        We perform Hermite interpolation on each position component
C        and corresponding velocity component.
C
         XSTART   =   3   +  N * PACKSZ

         DO I = 1, 3

            DO J = 1, N
C
C              For the Jth input packet, copy the Ith position and
C              velocity components into the local record buffer LOCREC.
C
               FROM         = 2 + PACKSZ*(J-1) + I
               TO           =     2 * J        - 1

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

            END DO

C
C           Interpolate the Ith position and velocity components of the
C           state.
C
            CALL HRMINT ( N,
     .                    RECORD(XSTART),
     .                    LOCREC,
     .                    ET,
     .                    WORK,
     .                    STATE(I),
     .                    STATE(I+3)      )
         END DO

      ELSE
C
C         This is a backstop case.
C
         CALL SETMSG ( 'Unexpected SPK type 19 subtype found in '
     .   //            'type 19 record.'                          )
         CALL ERRINT ( '#',  SUBTYP                               )
         CALL SIGERR ( 'SPICE(INVALIDVALUE)'                      )
         CALL CHKOUT ( 'SPKE19'                                   )
         RETURN

      END IF

      CALL CHKOUT ( 'SPKE19' )
      RETURN
      END


      SUBROUTINE DEMAND(DYNAMIC, CONTROL,
     &  AGRLF, AGRRT, AGRSH2, AGRSTM, CROP, DRPP, DXR57,
     &  FILECC, FILEGC, FILEIO, FNINSH, FRACDN, LAGSD,
     &  LNGPEG, NDLEAF, NSTRES, PAR, PCNL, PCNRT, PCNST,
     &  PGAVL, PUNCSD, PUNCTR, PLTPOP, RPROAV, RTWT,
     &  SDDES, SDNO, SDVAR, SHELN, SHVAR, STMWT, SWFAC,
     &  TAVG, TDUMX, TDUMX2, TGRO, TURFAC, VSTAGE, WCRLF,
     &  WCRRT, WCRST, WNRLF, WNRRT, WNRSH, WNRST, WTLF,
     &  WTSD, WTSHE, XPOD, NVEG0, NR1, NR2, NR5, NR7,

     &  AGRSD1, AGRSD2, AGRVG, AGRVG2, CDMREP, F, FNINL,
     &  FNINR, FNINS, FNINSD, FRLF, FRRT, FRSTM, GDMSD,
     &  GRRAT1, NDMNEW,  NDMOLD, NDMREP, NDMSDR, NDMTOT,
     &  NDMVEG, NMINEP, NMOBR, PHTIM, PNTIM, POTCAR,
     &  POTLIP, SDGR, TURADD, XFRT, YREND)

      USE ModuleDefs
      USE ModuleData
      IMPLICIT NONE
      SAVE

      CHARACTER*2 CROP
      CHARACTER*3 TYPSDT
      CHARACTER*6   ERRKEY
      PARAMETER (ERRKEY = 'DEMAND')
      CHARACTER*30 FILEIO
      CHARACTER*78 MSG(2)
      CHARACTER*92 FILECC, FILEGC

      INTEGER DYNAMIC
      INTEGER NPP, I, NAGE, DAS
      INTEGER NDLEAF, NR1, NR2, NR5, NR7, NVEG0, YREND

      REAL FRLFM, FRSTMM, YY, XX, TMPFAC
      REAL REDPUN,TMPFCS,PAGE,REDSHL,SDMAX,CDMSH,GDMSH,ADDSHL
      REAL TEMXFR,CAVTOT,GDMSDO,CNOLD
      REAL NVSTL,NVSTS,NVSTR,FRNLFT
      REAL TABEX,CURV
      REAL POTLIP, POTCAR

      REAL TPHFAC,PARSLA,FFVEG
      REAL GROYES,GAINNW,GAINWT
      REAL SLAVAR, SLAREF, FINREF
      REAL SLAMAX, SLAMIN, THRESH
      REAL AGRSH2, AGRRT, AGRSTM, FRLFF, FRSTMF
      REAL CARMIN, LIPOPT, LIPTB, SLOSUM

      REAL AGRLF, AGRSD1, AGRSD2, AGRVG, AGRVG2,
     &  CDMREP, CDMSD, CDMSDR, CDMTOT,
     &  CDMVEG, DRPP, DUMFAC, DXR57, F,
     &  FNINL, FNINR, FNINS, FNINSD, FNINSH,
     &  FRACDN, FRLF, FRLFMX,
     &  FRRT, FRSTM, FVEG,
     &  GDMSD, GDMSDR,
     &  GROMAX, GRRAT1, LAGSD, LNGPEG, LNGSH,
     &  NDMNEW, NDMOLD, NDMREP,
     &  NDMSD, NDMSDR, NDMSH, NDMTOT, NDMVEG,
     &  NMINEP, NMOBMX, NMOBR, NRCVR, NSTRES,
     &  NVSMOB,
     &  PAR, PCNL, PCNRT, PCNST,
     &  PGAVL, PLIGSD, PLTPOP, PMINSD, POASD,
     &  PROLFF, PROLFI,
     &  PRORTF, PRORTI, PROSTF, PROSTI, RCH2O,
     &  RLIG, RLIP, RMIN, RNO3C,
     &  ROA, RPRO, RPROAV, RTWT, SDGR,
     &  SDLIP, SDPRO, SDVAR, SHLAG, SHVAR,
     &  SIZELF, SIZREF, SLAMN, SLAMX, SLAPAR,
     &  SRMAX, STMWT, SWFAC, TAVG, TDUMX,
     &  SIZRAT, TDUMX2,
     &  TURADD, TURFAC, TURSLA, TURXFR,
     &  VSSINK, VSTAGE, WCRLF, WCRRT, WCRST, WNRLF,
     &  WNRRT, WNRSH, WNRST, WTLF, XFRMAX,
     &  XFRT, XFRUIT, XPOD

      REAL FNSDT(4)
      REAL XVGROW(6), YVGROW(6), YVREF(6)
      REAL XSLATM(10), YSLATM(10), XTRFAC(10), YTRFAC(10),
     &         XXFTEM(10), YXFTEM(10)
      REAL XLEAF(25), YLEAF(25), YSTEM(25)
      REAL TGRO(TS)
      REAL SDDES(NCOHORTS), SDNO(NCOHORTS), SHELN(NCOHORTS)
      REAL WTSD(NCOHORTS), WTSHE(NCOHORTS)
      REAL PHTIM(NCOHORTS), PNTIM(NCOHORTS)

      REAL TURFSL

 - puncture variables, not functional
      REAL PUNCSD, PUNCTR, RPRPUN

      TYPE (ControlType) CONTROL

      IF (DYNAMIC .EQ. RUNINIT) THEN
      CALL IPDMND(
     &  FILECC, FILEGC, FILEIO,
     &  CARMIN, FINREF, FNSDT, FRLFF, FRLFMX,
     &  FRSTMF, LIPOPT, LIPTB, LNGSH, NMOBMX,
     &  NRCVR, NVSMOB, PLIGSD, PMINSD, POASD,
     &  PROLFF, PROLFI, PRORTF, PRORTI, PROSTF, PROSTI,
     &  RCH2O, RLIG, RLIP, RMIN, RNO3C, ROA,
     &  RPRO, SDLIP, SDPRO, SHLAG, SLAMAX, SLAMIN,
     &  SLAPAR, SLAREF, SLAVAR, SLOSUM, SIZELF, SIZREF,
     &  SRMAX, THRESH, TURSLA, TYPSDT, VSSINK, XFRMAX,
     &  XFRUIT, XLEAF, XSLATM, XTRFAC, XVGROW, XXFTEM,
     &  YLEAF, YSLATM, YSTEM, YTRFAC, YVREF, YXFTEM)

      ELSEIF (DYNAMIC .EQ. SEASINIT) THEN
      CDMSDR = 0.0
      GDMSDR = 0.0
      FNINSD = 0.0
      NDMNEW = 0.0
      NDMREP = 0.0
      NDMSD  = 0.0
      NDMSH  = 0.0
      NDMSDR = 0.0
      NDMVEG = 0.0
      NMOBR  = 0.0
      SDGR   = 0.0
      FNINL  = 0.0
      FNINS  = 0.0
      FNINR  = 0.0
      NMINEP = 0.0

      RPRPUN = 1.0
      TMPFAC = 1.0

      IF (CROP .NE. 'FA') THEN
        DUMFAC = SLAVAR / SLAREF
        F      = DUMFAC * FINREF
        FVEG   = DUMFAC * SLAMAX
        SLAMN  = DUMFAC * SLAMIN
        SLAMX  = DUMFAC * SLAMAX
        GROMAX = 0.0
        SIZRAT = SIZELF / SIZREF

        DO I = 1,6
          YVGROW(I) = SIZRAT * YVREF(I)
        ENDDO

        FRLF = TABEX(YLEAF,XLEAF,0.0,8)
        FRSTM = TABEX(YSTEM,XLEAF,0.0,8)
        FRRT = 1.0 - FRLF - FRSTM

      ENDIF

      ELSEIF (DYNAMIC .EQ. EMERG) THEN
        XFRT   = XFRUIT
        ADDSHL = 0.0
        TURXFR = 0.0
        GDMSD  = 0.0
        CDMSD  = 0.0
        NDMSD  = 0.0
        GDMSDR = 0.0
        CDMSDR = 0.0
        NDMSDR = 0.0
        CDMREP = 0.0
        NAGE   = 0
        DO NPP = 1,NCOHORTS
          PHTIM(NPP) = 0.
          PNTIM(NPP) = 0.
        END DO
        FNINSD = SDPRO * 0.16
        FNINL  = PROLFI * 0.16
        FNINS  = PROSTI * 0.16
        FNINR  = PRORTI * 0.16

      ELSEIF (DYNAMIC .EQ. INTEGR) THEN
      CALL GET(CONTROL)
      DAS = CONTROL % DAS
      NMOBR  = NVSMOB * NMOBMX * TDUMX
      IF (DAS .GT. NR5) THEN
        NMOBR = NMOBMX * TDUMX2 * (1.0 + 0.5*(1.0 - SWFAC))
     &      * (1.0 + 0.3*(1.0 - NSTRES)) * (NVSMOB + (1. - NVSMOB)
     &      * MAX(XPOD,DXR57**2.))
      ENDIF
      NMINEP = NMOBR * (WNRLF + WNRST + WNRRT + WNRSH)

      IF (DAS .GE. NR1) THEN
        IF (DAS - NR1 + 1 > NCOHORTS) THEN
          WRITE(MSG(1),'(A,I5)')
     &      'Number of flower cohorts exceeds maximum limit of',NCOHORTS
          CALL WARNING(1,ERRKEY,MSG)
          CALL ErrorCode(CONTROL, 100, ERRKEY, YREND)
          RETURN
        ENDIF

        IF (DAS .EQ. NR1) THEN
          PNTIM(1) = 0.0
        ELSE
          PNTIM(DAS - NR1 + 1) = PNTIM(DAS - NR1) + TDUMX
        ENDIF

        IF (DAS .LE. NR2) THEN
          PHTIM(1) = 0.0
        ELSE
          PHTIM(DAS - NR2 + 1) = PHTIM(DAS - NR2) + TDUMX
        ENDIF

        TMPFAC = 0.
        TMPFCS = 0.
        DO I = 1,TS
          TMPFAC =CURV(TYPSDT,FNSDT(1),FNSDT(2),FNSDT(3),FNSDT(4),
     &                  TGRO(I))
        TMPFCS = TMPFCS + TMPFAC
        ENDDO
        TMPFAC = TMPFCS /REAL(TS)
C 24 changed to TS on 3Jul17 by Bruce Kimball

        IF (PUNCSD .GT. 0.001) THEN
          REDPUN = 1.0 - (PUNCTR/PUNCSD) * RPRPUN
          REDPUN = MAX(0.0,REDPUN)
        ELSE
          REDPUN = 1.0
        ENDIF
        TURADD = TABEX (YTRFAC,XTRFAC,TURFAC,4)
        SDGR = SDVAR * TMPFAC * REDPUN * (1.-(1.-DRPP)*SRMAX) *
     &       (1. + TURADD)
        GDMSD  = 0.0
        CDMSD  = 0.0
        NDMSD  = 0.0
        GDMSDR = 0.0
        CDMSDR = 0.0
        NDMSDR = 0.0
        IF (DAS .GT. NR2) THEN
          DO NPP = 1, DAS - NR2
            PAGE = PHTIM(DAS - NR2 + 1) - PHTIM(NPP)
            IF (PAGE .GE. LAGSD) THEN
              REDSHL = 0
              IF (SDDES(NPP).GT.0) THEN
                REDSHL = WTSHE(NPP)*SDDES(NPP)/(SDDES(NPP)+SDNO(NPP))
              ENDIF
              SDMAX = (WTSHE(NPP)-REDSHL)*THRESH/(100.-THRESH)-WTSD(NPP)
              SDMAX = MAX(0.0,SDMAX)
              GDMSD  = GDMSD  + MIN(SDGR*SDNO(NPP)*REDPUN, SDMAX)
            ENDIF
          ENDDO
          CALL SDCOMP(
     &      CARMIN, LIPOPT, LIPTB, PLIGSD, PMINSD, POASD,
     &      RCH2O, RLIG, RLIP, RMIN, RNO3C, ROA, SDLIP,
     &      SDPRO, SLOSUM, TAVG,
     &      AGRSD1, AGRSD2, FNINSD, POTCAR, POTLIP)

          NDMSD  = FNINSD * GDMSD
          IF (NDMSD .GT. NMINEP) THEN
            NDMSDR = NMINEP
          ELSE
            NDMSDR = NDMSD
          ENDIF
          GDMSDR = NDMSDR/FNINSD
          CDMSDR = GDMSDR * (AGRSD1 + FNINSD*6.25 * RPRO)
          CDMSD = (MAX(0.0,(GDMSD - GDMSDR))) * AGRSD2 + CDMSDR
        ENDIF
      ENDIF
      GRRAT1 = SHVAR * TMPFAC * (1.- (1.-DRPP) * SRMAX)
     & * (1.0 + TURADD)
      GDMSH = 0.0
      NDMSH = 0.0
      CDMSH = 0.0
      IF (DAS .GT. NR2) THEN
        DO NPP = 1,DAS - NR2
          NAGE = DAS - NR2 + 1 - NPP   not used - chp
          PAGE = PHTIM(DAS - NR2 + 1) - PHTIM(NPP)
          IF (PAGE .LE. LNGSH .AND. SHELN(NPP) .GE. 0.001 .AND.
     &       GRRAT1 .GE. 0.001) THEN
            IF (PAGE .GE. LNGPEG) THEN
               between LNGPEG and LNGSH
              ADDSHL = GRRAT1 * SHELN(NPP)
            ELSE
               < LNGPEG
              ADDSHL = GRRAT1 * SHELN(NPP) * SHLAG
            ENDIF
          ENDIF
          GDMSH  = GDMSH + ADDSHL
        ENDDO
        CDMSH = GDMSH * AGRSH2
      ENDIF
      TEMXFR = 0.
      DO I = 1,TS
        TEMXFR = TEMXFR + TABEX(YXFTEM,XXFTEM,TGRO(I),6)
      ENDDO
      TEMXFR = TEMXFR/REAL(TS)
C 24 changed to TS by Bruce Kimball on 3Jul17

      TURXFR = XFRMAX * (1. - TURFAC)
      TURXFR = MIN(TURXFR,1.0)
      TURXFR = MAX(TURXFR,0.0)
      XFRT = XFRUIT * TEMXFR + XFRUIT * TURXFR
      XFRT = MIN(XFRT,1.0)
      XFRT = MAX(XFRT,0.0)
      CAVTOT = PGAVL * XFRT
      CDMREP = CDMSH + CDMSD
      GDMSDO = GDMSD
      IF (CDMREP .GT. CAVTOT) THEN
        IF (CDMSD .GT. CAVTOT) THEN
          CDMSH = 0.0
          GDMSH = 0.0
          CDMSD = CAVTOT
          IF (CDMSDR .GT. CAVTOT) THEN
            CDMSDR = CAVTOT
          ENDIF
          GDMSD = (MAX(0.0,(CDMSD-CDMSDR)))/AGRSD2 +
     &    CDMSDR/(AGRSD1+FNINSD*6.25*RPRO)
          NDMSDR = GDMSDR * FNINSD
        ELSE
          CDMSH = CAVTOT - CDMSD
          GDMSH = CDMSH/AGRSH2
        ENDIF
        CDMREP = CDMSD + CDMSH
      ENDIF
      NDMSD  = GDMSD * FNINSD
      NDMSH  = GDMSH * FNINSH
      NDMREP = NDMSD + NDMSH

      CDMVEG = MAX(0.0,(1.-XFRT)*PGAVL)
      NDMVEG = 0.0
      CDMVEG = (PGAVL * XFRT - CDMREP) + CDMVEG

      IF (DAS .EQ. NR1) THEN
        FRLFM  = TABEX (YLEAF, XLEAF, VSTAGE, 8)
        FRSTMM = TABEX (YSTEM, XLEAF, VSTAGE, 8)
        YY = FRLFM - FRLFF
        XX = FRSTMM - FRSTMF
      ENDIF
      IF (DAS .LT. NR1) THEN
        FRLF  = TABEX(YLEAF,XLEAF,VSTAGE,8)
        FRSTM = TABEX(YSTEM,XLEAF,VSTAGE,8)
      ELSE
        FRLF = FRLFM - YY * FRACDN
        FRSTM = FRSTMM - XX * FRACDN
        IF ( DAS .GE. NDLEAF) THEN
          FRLF = FRLFF
          FRSTM = FRSTMF
        ENDIF
      ENDIF

      FRRT = 1. - FRLF - FRSTM

      TPHFAC = 0.
      DO I = 1,TS
        TPHFAC = TPHFAC + TABEX (YSLATM,XSLATM,TGRO(I),5)
      ENDDO
      TPHFAC = TPHFAC/REAL(TS)
C 24 changed to TS by Bruce Kimball on 3Jul17

      PARSLA = (SLAMN+(SLAMX-SLAMN)*EXP(SLAPAR*PAR))/SLAMX
      TURFSL = MAX(0.1, (1.0 - (1.0 - TURFAC)*TURSLA))
      FFVEG = FVEG * TPHFAC * PARSLA * TURFSL

      F = FFVEG
      IF (XFRT*FRACDN .GE. 0.05) F = FFVEG * (1.0 - XFRT * FRACDN)
      IF (XFRUIT .GT. 0.9999 .AND. DAS .GE. NDLEAF) F = 0.0

      IF (VSTAGE .LT. VSSINK) THEN
        GROYES = GROMAX
        GROMAX = TABEX(YVGROW,XVGROW,VSTAGE,6) * SIZELF/SIZREF
        GAINNW = (GROMAX - GROYES) * PLTPOP
        IF (F .GT. 1.E-5) THEN
          GAINWT = GAINNW/F
        ELSE
          GAINWT = 0.0
        ENDIF
        FRLF = (AGRLF*GAINWT)/(CDMVEG + 0.0001)
        IF (FRLF .GT. FRLFMX) THEN
          GAINWT = (CDMVEG/AGRLF) * FRLFMX
          GAINNW = GAINWT * F
          FRLF = FRLFMX
        ENDIF
        FRSTM = (1. - FRLF) * FRSTM / (FRSTM + FRRT)
        FRRT  = 1. - FRLF - FRSTM
      ENDIF
      AGRVG = AGRLF * FRLF + AGRRT * FRRT + AGRSTM * FRSTM
      AGRVG2 = AGRVG + (FRLF*PROLFI+FRRT*PRORTI+FRSTM*PROSTI)*RPROAV
      NDMVEG = (CDMVEG/AGRVG2) * (FRLF*FNINL+FRSTM*FNINS+
     &   FRRT*FNINR)
      NDMNEW = NDMREP + NDMVEG
      CNOLD = MAX(0.0,PGAVL-CDMREP)
      NDMOLD = 0.0
      IF (DAS .GT. NVEG0 .AND. DAS .LT. NR7 .AND.
     &          CNOLD .GT. 0.0) THEN
        NVSTL = FNINL
        NVSTS = FNINS
        NVSTR = FNINR
        IF (DXR57 .GT.0.0) THEN
           FRNLFT = (NRCVR + (1. - NRCVR) * (1. - DXR57**2))
           NVSTL = PROLFF*0.16 + (FNINL-PROLFF*0.16) * FRNLFT
           NVSTS = PROSTF*0.16 + (FNINS-PROSTF*0.16) * FRNLFT
           NVSTR = PRORTF*0.16 + (FNINR-PRORTF*0.16) * FRNLFT
        ENDIF
        NDMOLD = (WTLF  - WCRLF) * MAX(0.0,(NVSTL - PCNL /100.))
     &         + (STMWT - WCRST) * MAX(0.0,(NVSTS - PCNST/100.))
     &         + (RTWT  - WCRRT) * MAX(0.0,(NVSTR - PCNRT/100.))
        IF (NDMOLD .GT. (CNOLD/RNO3C*0.16)) THEN
          NDMOLD = CNOLD/RNO3C*0.16
        ENDIF
      ENDIF
      NDMTOT = NDMREP + NDMVEG + NDMOLD
      CDMTOT = CDMREP + CDMVEG + NDMOLD*RNO3C/0.16
      GDMSD = GDMSDO

      ENDIF

      RETURN
      END SUBROUTINE DEMAND

      SUBROUTINE IPDMND(
     &  FILECC, FILEGC, FILEIO,
     &  CARMIN, FINREF, FNSDT, FRLFF, FRLFMX,
     &  FRSTMF, LIPOPT, LIPTB, LNGSH, NMOBMX,
     &  NRCVR, NVSMOB, PLIGSD, PMINSD, POASD,
     &  PROLFF, PROLFI, PRORTF, PRORTI, PROSTF, PROSTI,
     &  RCH2O, RLIG, RLIP, RMIN, RNO3C, ROA,
     &  RPRO, SDLIP, SDPRO, SHLAG, SLAMAX, SLAMIN,
     &  SLAPAR, SLAREF, SLAVAR, SLOSUM, SIZELF, SIZREF,
     &  SRMAX, THRESH, TURSLA, TYPSDT, VSSINK, XFRMAX,
     &  XFRUIT, XLEAF, XSLATM, XTRFAC, XVGROW, XXFTEM,
     &  YLEAF, YSLATM, YSTEM, YTRFAC, YVREF, YXFTEM)

      IMPLICIT NONE
      CHARACTER*3   TYPSDT
      CHARACTER*6   ERRKEY
      PARAMETER (ERRKEY = 'DEMAND')
      CHARACTER*6   SECTION
      CHARACTER*6   ECOTYP, ECONO
      CHARACTER*30  FILEIO
      CHARACTER*80  C80
      CHARACTER*92  FILECC, FILEGC
      CHARACTER*255 C255

      INTEGER LUNCRP, LUNIO, LUNECO, ERR, LINC, LNUM, FOUND, ISECT
      INTEGER I, II

      REAL CARMIN, FINREF, FRLFF, FRLFMX, FRSTMF,
     &  LIPOPT, LIPTB, NMOBMX, NRCVR, NVSMOB,
     &  PLIGSD, PMINSD, POASD, PROLFF,
     &  PROLFI, PRORTF, PRORTI, PROSTF, PROSTI,
     &  RCH2O, RLIG, RLIP, RMIN, RNO3C, ROA,
     &  RPRO, SHLAG, SLAMAX, SLAMIN, SLAPAR,
     &  SLAREF, SLAVAR, SLOSUM, SIZELF, SIZREF,
     &  SRMAX, TURSLA, VSSINK, XFRMAX, XFRUIT
        REAL LNGSH, THRESH, SDPRO, SDLIP

        REAL FNSDT(4)
        REAL XVGROW(6), YVREF(6)
        REAL XSLATM(10), YSLATM(10), XTRFAC(10), YTRFAC(10),
     &                  XXFTEM(10), YXFTEM(10)
        REAL XLEAF(25), YLEAF(25), YSTEM(25)

      CALL GETLUN('FILEIO', LUNIO)
      OPEN (LUNIO, FILE = FILEIO,STATUS = 'OLD',IOSTAT=ERR)
      IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,0)
      LNUM = 0
      SECTION = '*CULTI'
      CALL FIND(LUNIO, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILEIO, LNUM)
      ENDIF
      CALL FIND(LUNIO, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILEIO, LNUM)
      ELSE
        READ(LUNIO,'(24X,A6,48X,3F6.0,24X,3F6.0)',IOSTAT=ERR)
     &      ECONO, SLAVAR, SIZELF, XFRUIT, THRESH, SDPRO, SDLIP
        LNUM = LNUM + 1
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,LNUM)
      ENDIF

      CLOSE (LUNIO)

      CALL GETLUN('FILEC', LUNCRP)
      OPEN (LUNCRP,FILE = FILECC, STATUS = 'OLD',IOSTAT=ERR)
      LNUM = 0
      IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)
      SECTION =
      CALL FIND(LUNCRP, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILECC, LNUM)
      ELSE
        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(F6.0,6X,F6.0)',IOSTAT=ERR) RNO3C, RPRO
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(5F6.0)',IOSTAT=ERR)RCH2O,RLIP,RLIG,ROA,RMIN
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)
      ENDIF

      SECTION =
      CALL FIND(LUNCRP, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILECC, LNUM)
      ELSE
        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(F6.0,6X,2F6.0,6X,F6.0)',IOSTAT=ERR)
     &          PROLFI, PROLFF, PROSTI, PROSTF
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(F6.0,6X,F6.0)',IOSTAT=ERR) PRORTI, PRORTF
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(24X,F6.0)',IOSTAT=ERR) PLIGSD
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(24X,F6.0)',IOSTAT=ERR) POASD
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(24X,F6.0)',IOSTAT=ERR) PMINSD
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)
      ENDIF

      SECTION =
      CALL FIND(LUNCRP, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILECC, LNUM)
      ELSE
        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(4F6.0)',IOSTAT=ERR) LIPTB, LIPOPT, SLOSUM, CARMIN
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)
          SLOSUM = SLOSUM / 100.0
      ENDIF

      SECTION =
      CALL FIND(LUNCRP, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILECC, LNUM)
      ELSE
        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(18X,3F6.0)',IOSTAT=ERR) NMOBMX, NVSMOB, NRCVR
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)
      ENDIF

      SECTION =
      CALL FIND(LUNCRP, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILECC, LNUM)
      ELSE
        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(8F6.0)',IOSTAT=ERR)(XLEAF(II),II=1,8)
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(8F6.0)',IOSTAT=ERR)(YLEAF(II),II=1,8)
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(8F6.0)',IOSTAT=ERR)(YSTEM(II),II=1,8)
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(12X,2F6.0)',IOSTAT=ERR) FRSTMF, FRLFF
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(F6.0)',IOSTAT=ERR) FRLFMX
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)
      ENDIF

      SECTION =
      CALL FIND(LUNCRP, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILECC, LNUM)
      ELSE
        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(4F6.0)',IOSTAT=ERR) FINREF, SLAREF, SIZREF, VSSINK
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(4F6.0)',IOSTAT=ERR) SLAMAX, SLAMIN, SLAPAR, TURSLA
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(6F6.0)',IOSTAT=ERR)(XVGROW(II),II=1,6)
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(6F6.0)',IOSTAT=ERR)(YVREF(II),II=1,6)
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(5F6.0)',IOSTAT=ERR)(XSLATM(II),II = 1,5)
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(5F6.0)',IOSTAT=ERR)(YSLATM(II),II = 1,5)
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)
      ENDIF

      SECTION =
      CALL FIND(LUNCRP, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILECC, LNUM)
      ELSE
        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(6X,F6.0)',IOSTAT=ERR) SRMAX
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(6X,2F6.0)',IOSTAT=ERR) XFRMAX, SHLAG
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(4(1X,F5.2),3X,A3)',IOSTAT=ERR)
     &          (FNSDT(II),II=1,4), TYPSDT
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(6F6.0)',IOSTAT=ERR)(XXFTEM(II),II = 1,6)
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(6F6.0)',IOSTAT=ERR)(YXFTEM(II),II = 1,6)
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        DO I=1,5
            CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
          ENDDO
        READ(C80,'(4F6.0)',IOSTAT=ERR)(XTRFAC(II),II = 1,4)
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)

        CALL IGNORE(LUNCRP,LNUM,ISECT,C80)
        READ(C80,'(4F6.0)',IOSTAT=ERR)(YTRFAC(II),II = 1,4)
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILECC,LNUM)
      ENDIF
      CLOSE(LUNCRP)

      CALL GETLUN('FILEE', LUNECO)
      OPEN (LUNECO,FILE = FILEGC,STATUS = 'OLD',IOSTAT=ERR)
      IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEGC,0)
      ECOTYP = '      '
      LNUM = 0
      DO WHILE (ECOTYP .NE. ECONO)
        CALL IGNORE(LUNECO, LNUM, ISECT, C255)
        IF ((ISECT .EQ. 1) .AND. (C255(1:1) .NE. ' ') .AND.
     &        (C255(1:1) .NE. '*')) THEN
          READ (C255,'(A6,66X,F6.0,30X)',IOSTAT=ERR) ECOTYP, LNGSH
          IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEGC,LNUM)
          IF (ECOTYP .EQ. ECONO) THEN
            EXIT
          ENDIF

        ELSE IF (ISECT .EQ. 0) THEN
          IF (ECONO .EQ. 'DFAULT') CALL ERROR(ERRKEY,35,FILEGC,LNUM)
          ECONO = 'DFAULT'
          REWIND(LUNECO)
          LNUM = 0
        ENDIF
      ENDDO

      CLOSE (LUNECO)

      RETURN
      END  SUBROUTINE IPDMND