!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
! File:  control.f90
! Contains general control subroutines for all version of snctrl.
! This is the module which the user includes.
!
! 26 Dec 2008: v4 of the control interface.
! 09 Feb 2010: v5.
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

module control
  use precision,   only : ip, rp
  use ctUsrModule, only : ctProb
  use ctGlobal,    only : iIntf, iDisc, iRefn, iCprt, iRefL, ncOde, ncAlg, refTol
  use ct10spec,    only : ctrl3opt
  use ct30ker,     only : c3ker
  implicit none

  private
  public :: sncTitle, sncInit, sncSpec, snctrlS, snctrlD, snctrlA, snctrl, &
            sncSet, sncSeti, sncSetr, sncGet, sncGeti, sncGetr, sncGetc

  interface snctrl
     module procedure snctrlS
  end interface

contains

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine sncTitle ( title )
    character(30), intent(out) :: title

    !===========================================================================
    title  = 'S N C T R L  5      (Feb 2010)'
    !         123456789|123456789|123456789|

  end subroutine sncTitle

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine snctrlA ( Start, prob, x, hs, odecon, algcon, varbds, &
                       INFO, mincw, miniw, minrw, nS, nInf, sInf, &
                       cu, lencu, iu, leniu, ru, lenru, &
                       cw, lencw, iw, leniw, rw, lenrw )
    integer(ip), intent(in)    :: Start, lencu, leniu, lenru, lencw, leniw, lenrw
    integer(ip), intent(inout) :: nS, nInf, iu(leniu), iw(leniw)
    real(rp),    intent(inout) :: sInf, rw(lenrw), ru(lenru)
    character(8),intent(inout) :: cw(lencw), cu(lencu)
    integer(ip), intent(inout), pointer :: hs(:)
    real(rp),    intent(inout), pointer :: x(:)
    integer(ip), intent(out)   :: INFO, mincw, miniw, minrw
    external     :: odecon, algcon, varbds
    type(ctProb) :: prob

    !===========================================================================
    ! snctrlA, A version of the optimal control interface.
    !   ( dense version, 1 node )
    !
    ! 31 Jan 2009: Current version snctrlA.
    !===========================================================================
    iIntf = 2
    call c3ker ( Start, prob, x, hs, odecon, algcon, varbds, &
                 INFO, mincw, miniw, minrw, nS, nInf, sInf, &
                 cu, lencu, iu, leniu, ru, lenru, &
                 cw, lencw, iw, leniw, rw, lenrw )

  end subroutine snctrlA

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine snctrlD ( Start, prob, x, hs, odecon, algcon, varbds, &
                       INFO, mincw, miniw, minrw, nS, nInf, sInf, &
                       cu, lencu, iu, leniu, ru, lenru, &
                       cw, lencw, iw, leniw, rw, lenrw )
    integer(ip), intent(in) :: Start, lencu, leniu, lenru, lencw, leniw, lenrw
    integer(ip), intent(inout) :: nS, nInf, iu(leniu), iw(leniw)
    real(rp),    intent(inout) :: sInf, rw(lenrw), ru(lenru)
    character(8),intent(inout) :: cw(lencw), cu(lencu)
    integer(ip), intent(inout), pointer :: hs(:)
    real(rp),    intent(inout), pointer :: x(:)
    integer(ip), intent(out)   :: INFO, mincw, miniw, minrw
    external     :: odecon, algcon, varbds
    type(ctProb) :: prob

    !===========================================================================
    ! snctrlD, D version of the optimal control interface.
    !   ( dense version, all nodes )
    !
    ! 29 Jan 2008: Current version snctrlD.
    !===========================================================================
    iIntf = 1
    call c3ker ( Start, prob, x, hs, odecon, algcon, varbds, &
                 INFO, mincw, miniw, minrw, nS, nInf, sInf, &
                 cu, lencu, iu, leniu, ru, lenru, &
                 cw, lencw, iw, leniw, rw, lenrw )

  end subroutine snctrlD

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine snctrlS ( Start, prob, x, hs, odecon, algcon, varbds, &
                       INFO, mincw, miniw, minrw, nS, nInf, sInf, &
                       cu, lencu, iu, leniu, ru, lenru, &
                       cw, lencw, iw, leniw, rw, lenrw )
    integer(ip), intent(in)    :: Start, lencu, leniu, lenru, lencw, leniw, lenrw
    integer(ip), intent(inout) :: nS, nInf, iu(leniu), iw(leniw)
    real(rp),    intent(inout) :: sInf, rw(lenrw), ru(lenru)
    character(8),intent(inout) :: cw(lencw), cu(lencu)
    integer(ip), intent(inout), pointer :: hs(:)
    real(rp),    intent(inout), pointer :: x(:)
    integer(ip), intent(out)   :: INFO, mincw, miniw, minrw
    external     :: odecon, algcon, varbds
    type(ctProb) :: prob

    !===========================================================================
    ! snctrlS, S version of the optimal control interface.
    ! ( sparse structures, user defines elements at every node)
    !
    ! 02 Jan 2008: Current version snctrlS.
    ! 29 Jan 2009: Moved some stuff from wrp here.
    !===========================================================================
    iIntf = 0
    call c3ker ( Start, prob, x, hs, odecon, algcon, varbds, &
                 INFO, mincw, miniw, minrw, nS, nInf, sInf, &
                 cu, lencu, iu, leniu, ru, lenru, &
                 cw, lencw, iw, leniw, rw, lenrw )

  end subroutine snctrlS

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine sncInit ( iPrint, iSumm, prob, cw, lencw, iw, leniw, rw, lenrw )
    integer(ip),  intent(in)    :: iPrint, iSumm, lencw, leniw, lenrw
    integer(ip),  intent(inout) :: iw(leniw)
    real(rp),     intent(inout) :: rw(lenrw)
    character(8), intent(inout) :: cw(lencw)
    type(ctProb), target :: prob

    !===========================================================================
    ! Sets control options to default.  Calls snInit.
    !
    ! 16 Aug 2008: Current version of sncInit.
    ! 18 Nov 2008: Added snctrl title/version print out.
    ! 24 Dec 2008: Updated for v4 of snctrl.
    !===========================================================================
    character(30) :: ttl
    character(30), parameter :: str = '-------------------------------'

    prob%probName = ''
    prob%nY   = 0
    prob%nU   = 0
    prob%nP   = 0
    prob%nC   = 0
    prob%nPhs = 0

    prob%objL  => null()
    prob%ytype => null()
    prob%ctype => null()
    prob%npInt => null()
    prob%phsPt => null()
    prob%neJ   => null()
    prob%neG   => null()

    ! Default settings.
    prob%iIntf  =  0
    prob%iDisc  =  1       ! was 0
    prob%iRefn  =  1       ! was 0
    prob%iRefL  = -1
    prob%iCPrt  =  0
    prob%refTol = 1.0d-4   ! was 1.0d-2

    iIntf  => prob%iIntf
    iDisc  => prob%iDisc
    iRefn  => prob%iRefn
    iRefL  => prob%iRefL
    iCPrt  => prob%iCPrt
    refTol => prob%refTol
    ncOde  =  0
    ncAlg  =  0

    call snInit ( iPrint, iSumm, cw, lencw, iw, leniw, rw, lenrw )

    ! Print out a title for SNCTRL !
    call sncTitle ( ttl )
    call snPRNT ( 13, ' '//str, iw, leniw )
    call snPRNT (  3, ' '//ttl, iw, leniw )
    call snPRNT (  3, ' '//str, iw, leniw )

  end subroutine sncInit

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine sncSpec ( iSpecs, iExit, cw, lencw, iw, leniw, rw, lenrw )
    integer(ip),  intent(in)    :: iSpecs, lencw, leniw, lenrw
    integer(ip),  intent(inout) :: iw(leniw)
    real(rp),     intent(inout) :: rw(lenrw)
    character(8), intent(inout) :: cw(lencw)
    integer(ip),  intent(out)   :: iExit

    !===========================================================================
    ! sncSpec  may be called by the user to read a Specs file.
    ! The control version of s3opt (ctrl3opt) is passed to s3file.
    !
    ! 24 Jan 2008: SNOPT version of snSpec adapted for control interface
    ! 23 Jul 2008: Current F90 version of sncSpec.
    !===========================================================================
    character   :: Solver*6, str*80, str2*80
    integer(ip) :: Errors, iPrint, iSumm, Calls
    !---------------------------------------------------------------------------
    Solver = 'CTSPEC'

    if (lencw < 500 .OR. leniw < 500 .OR. lenrw < 500) then
       !----------------------------------------------------------------
       ! Not enough workspace to do ANYTHING!
       ! Print and exit without accessing the work arrays.
       !----------------------------------------------------------------
       iExit = 81        ! Work arrays must have at least 500 elements
       call snWRAP ( iExit, Solver, str, str2, iw, leniw )
       go to 999
    end if

    if (iSpecs <= 0  .OR.  iSpecs > 99) then
       iExit = 131            ! iSPECS out of range
       go to 800
    end if

    iw( 11)  = iSpecs         ! Sspecs (options) file

    iPrint    = iw( 12)       ! Print file
    iSumm     = iw( 13)       ! Summary file

    Calls     = 1

    ! ------------------------------------------------------------------
    ! Read the Specs file.
    ! snopt  will check the options later and maybe print them.
    ! ------------------------------------------------------------------
    call s3file ( iExit, Calls, iSpecs, ctrl3opt, ' ', iPrint, iSumm, Errors, &
                  cw, lencw, iw, leniw, rw, lenrw )

800 if (iExit == 0) then
       if (Errors == 0) then
          iExit = 101         ! SPECS file read successfully
       else
          iExit = 107         ! some SPECS keywords not recognized
       end if
    end if

    call snWRAP ( iExit, Solver, str, str2, iw, leniw )

999 return

  end subroutine sncSpec

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine sncSet ( buffer, iPrint, iSumm, Errors, &
                      cw, lencw, iw, leniw, rw, lenrw )
    character*(*) :: buffer
    integer(ip)   :: iPrint, iSumm, Errors, lencw, leniw, lenrw, iw(leniw)
    real(rp)      :: rw(lenrw)
    character(8)  :: cw(lencw)

    !===========================================================================
    ! sncSet  decodes the option contained in  buffer.
    !
    ! The buffer is output to file iPrint, minus trailing blanks.
    ! Error messages are output to files iPrint and iSumm.
    ! Buffer is echoed to iPrint but normally not to iSumm.
    ! It is echoed to iSumm before any error msg.
    !
    ! On entry,
    ! iPrint is the print   file.  no output occurs if iPrint .le 0.
    ! iSumm  is the Summary file.  no output occurs if iSumm  .le 0.
    ! Errors is the number of errors so far.
    !
    ! On exit,
    ! Errors is the number of errors so far.
    !
    ! 27 Jan 2008: Copy of snSet adapted for control interface.
    ! 23 Jul 2008: F90 version.
    !===========================================================================
    integer(ip) :: ivalue
    real(rp)    :: rvalue
    character   :: cvalue*8, key*16

    call ctrl3opt ( .true., buffer, key, cvalue, ivalue, rvalue, &
                    iPrint, iSumm, Errors, cw, lencw, iw, leniw, rw, lenrw )

  end subroutine sncSet

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine sncSeti ( buffer, ivalue, iPrint, iSumm, Errors, &
                       cw, lencw, iw, leniw, rw, lenrw )
    character*(*) :: buffer
    integer(ip)   :: ivalue, iPrint, iSumm, Errors, lencw, leniw, lenrw, iw(leniw)
    real(rp)      :: rw(lenrw)
    character(8)  :: cw(lencw)

    !===================================================================
    ! sncSeti decodes the option contained in  buffer // ivalue.
    ! The parameters other than ivalue are as in snSet.
    !
    ! 27 Jan 2008: Copy of snSeti adapted for control interface.
    ! 23 Jul 2008: F90 version.
    !===================================================================
    integer(ip) :: ivalxx, lenbuf
    real(rp)    :: rvalue
    character   :: cvalue*8, key*16, buff72*72

    write(key, '(i16)') ivalue
    lenbuf = len(buffer)
    buff72 = buffer
    buff72(lenbuf+1:lenbuf+16) = key
    ivalxx = ivalue
    call ctrl3opt ( .true., buff72, key, cvalue, ivalxx, rvalue, &
                    iPrint, iSumm, Errors, cw, lencw, iw, leniw, rw, lenrw )

  end subroutine  sncSeti

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine sncSetr ( buffer, rvalue, iPrint, iSumm, Errors, &
                       cw, lencw, iw, leniw, rw, lenrw )
    character*(*) :: buffer
    integer(ip)   :: iPrint, iSumm, Errors, lencw, leniw, lenrw, iw(leniw)
    real(rp)      :: rvalue, rw(lenrw)
    character(8)  :: cw(lencw)

    !===========================================================================
    ! sncSetr decodes the option contained in  buffer // rvalue.
    ! The parameters other than rvalue are as in snSet.
    !
    ! 27 Jan 2008: Copy of snSetr adapted for control interface.
    ! 23 Jul 2008: F90 version.
    !===========================================================================
    integer(ip) :: ivalue, lenbuf
    character   :: cvalue*8, key*16, buff72*72
    real(rp)    :: rvalxx

    write(key, '(1p, e16.8)') rvalue
    lenbuf = len(buffer)
    buff72 = buffer
    buff72(lenbuf+1:lenbuf+16) = key
    rvalxx = rvalue
    call ctrl3opt ( .true., buff72, key, cvalue, ivalue, rvalxx, &
                    iPrint, iSumm, Errors, cw, lencw, iw, leniw, rw, lenrw )

  end subroutine sncSetr

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  integer function sncGet ( buffer, Errors, cw, lencw, iw, leniw, rw, lenrw )
    character*(*) :: buffer
    integer(ip)   :: Errors, lencw, leniw, lenrw, iw(leniw)
    real(rp)      :: rw(lenrw)
    character(8)  :: cw(lencw)

    !===========================================================================
    ! sncGet  decodes the option contained in  buffer
    ! and returns 1 if the option has previously been set, else 0.
    ! For example,
    ! i = snGet ( 'Maximize', Errors, cw, lencw, iw, leniw, rw, lenrw )
    !
    ! 27 Jan 2008: Copy of snGet adapted for control interface.
    ! 23 Jul 2008: F90 version.
    !===========================================================================
    integer(ip) :: ivalue
    real(rp)    :: rvalue
    character   :: cvalue*8, key*16

    call ctrl3opt ( .false., buffer, key, cvalue, ivalue, rvalue, &
                    0_ip, 0_ip, Errors, cw, lencw, iw, leniw, rw, lenrw )
    sncGet  = ivalue

  end function sncGet

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine sncGetc ( buffer, cvalue, Errors, cw, lencw, iw, leniw, rw, lenrw )
    character*(*) :: buffer
    integer(ip)   :: Errors, lencw, leniw, lenrw, iw(leniw)
    character(8)  :: cvalue, cw(lencw)
    real(rp)      :: rw(lenrw)

    !===========================================================================
    ! sncGetc gets the value of the option contained in  buffer.
    ! The parameters other than cvalue are as in snSet.
    !
    ! 27 Jan 2008: Copy of snGetc adapted for control interface.
    ! 23 Jul 2008: F90 version.
    !===========================================================================
    integer(ip) :: ivalue
    real(rp)    :: rvalue
    character   :: key*16

    call ctrl3opt ( .false., buffer, key, cvalue, ivalue, rvalue, &
                    0_ip, 0_ip, Errors, cw, lencw, iw, leniw, rw, lenrw )

  end subroutine sncGetc

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine sncGeti ( buffer, ivalue, Errors, cw, lencw, iw, leniw, rw, lenrw )
    character*(*) :: buffer
    integer(ip)   :: ivalue, Errors, lencw, leniw, lenrw, iw(leniw)
    character(8)  :: cw(lencw)
    real(rp)      :: rw(lenrw)

    !===========================================================================
    ! sncGeti gets the value of the option contained in  buffer.
    ! The parameters other than ivalue are as in snSet.
    !
    ! 27 Jan 2008: Copy of snGeti adapted for control interface.
    ! 23 Jul 2008: F90 version.
    !===========================================================================
    real(rp)  :: rvalue
    character :: key*16, cvalue*8

    call ctrl3opt ( .false., buffer, key, cvalue, ivalue, rvalue, &
                    0_ip, 0_ip, Errors, cw, lencw, iw, leniw, rw, lenrw )

  end subroutine sncGeti

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine sncGetr ( buffer, rvalue, Errors, cw, lencw, iw, leniw, rw, lenrw )
    character*(*) :: buffer
    integer(ip)   :: Errors, lencw, leniw, lenrw, iw(leniw)
    real(rp)      :: rvalue, rw(lenrw)
    character(8)  :: cw(lencw)

    !===========================================================================
    ! sncGetr gets the value of the option contained in  buffer.
    ! The parameters other than rvalue are as in snSet.
    !
    ! 27 Jan 2008: Copy of snGetr adapted for control interface.
    ! 23 Jul 2008: F90 version.
    !===========================================================================
    integer(ip) :: ivalue
    character   :: key*16, cvalue*8

    call ctrl3opt ( .false., buffer, key, cvalue, ivalue, rvalue, &
                    0_ip, 0_ip, Errors, cw, lencw, iw, leniw, rw, lenrw )

  end subroutine sncGetr

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

end module control

