C
C $Id: cmfx.f,v 1.7 2008-07-27 00:17:23 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      FUNCTION CMFX (IX)
C
C Given an X coordinate IX in the metacode system, CMFX(IX) is an X
C coordinate in the fractional system.
C
      CMFX=REAL(IX)/32767.
      RETURN
      END


*$ Map-Display Routine Library
*  ===========================
C
C P. Alexander MRAO, Cambridge.
C
*+ plot_sys

       subroutine plot_sys(interp,cdata,map_array,status)
C      --------------------------------------------------
C
C Interactive system to display images
C
C Updated:
C    command interpreter data structure
       integer       interp(*)
C    command language data structure
       integer       cdata(*)
C    map work space
       real*4          map_array(*)
C    error status
       integer         status
C
C A command line driven image plotting sub-system.  The calling program
C must use the MAP-CATALOGUE and stack system.  The work array is
C passed by argument to this routine.  All plotting uses the PGPLOT library.
*-
       include '../include/plt_basic_defn.inc'
       include '../include/plt_image_defn.inc'
       include '../include/anmap_sys_pars.inc'
       include '/mrao/include/chrlib_functions.inc'
       include '/mrao/include/iolib_functions.inc'
       include '/mrao/include/cmd_lang_data.inc'

C define variables to access commands
       integer         number_commands, i_com_done, icomm,
     *                 number_options
       parameter      (number_commands = 26, number_options=10)
       character*70    liscom(number_commands),
     *                 option_list(number_options), option

C parameters holds information on the command line
       character*80    parameters
       integer         len_cli
C map allocation
       integer         ip_map
C logical flag set if the sub-system is called in the form:
C   map-display command-name options
C from another sub-system
       logical         exit_at_end
C counter
       integer         i

C define commands
       data liscom(1)
     *  / 'set-map .................. define map to display'/
       data liscom(2)
     *  / 'overlay-map .............. define second map to display'/
       data liscom(3)
     *  / 'set-pips ................. turn pips on/off [on]'/
       data liscom(4)
     *  / 'set-grid ................. turn grid on/off [off,off]'/
       data liscom(5)
     *  / 'set-uv-range ............. define uv-range to plot [full]'/
       data liscom(6)
     *  / 'set-interpolation ........ interpolation option [off]'/
       data liscom(7)
     *  / 'set-style ................ set various style options'/
       data liscom(8)
     *  / 'grey-scale ............... define (overlay) of grey scale'/
       data liscom(9)
     *  / 'vector-plot .............. define (overlay) of vectors'/
       data liscom(10)
     *  / 'symbol-plot .............. define (overlay) of symbols'/
       data liscom(11)
     *  / 'contours ................. specify a list of contours'/
       data liscom(12)
     *  / 'linear-contours .......... define linear contour levels'/
       data liscom(13)
     *  / 'logarithmic-contours ..... define log. contour levels'/
       data liscom(14)
     *  / 'reset-contour-levels ..... reset all contour levels'/
       data liscom(15)
     *  / 'clear-contour-levels ..... clear all contour levels'/
       data liscom(16)
     *  / 'plot ..................... plot portions of the plot'/
       data liscom(17)
     *  / 'initialise ............... initialise aspects of plot'/
       data liscom(18)
     *  / 'display .................. display options and levels'/
       data liscom(19)
     *  / 'title-plot ............... add title to plot'/
       data liscom(20)
     *  / 'modify-lookup-table ...... modify LUT for non-TV device'/
       data liscom(21)
     *  / 'cursor-position .......... return map position and value'/
       data liscom(22)
     *  / 'get ...................... read options into parameters'/
       data liscom(23)
     *  / 'surface-plot ............. plot a map as a surface relief'/
       data liscom(24)
     *  / 'isometric-plot ........... plot map as isometric surface'/
       data liscom(25)
     *  / 'annotate ................. annotate the plot'/
       data liscom(26)
     *  / 'crosses-file ............. specify a crosses file'/

C check whether to exit on completion of command
       call io_enqcli(parameters,len_cli)
       exit_at_end = len_cli.ne.0
       i_com_done = 0
       do i=1,cmd_data_len
         cmd_data(i) = cdata(i)
       enddo

C initialise graphic structure
       call graphic_init( graphic_image, image_defn, status)
       annot_data(1) = len_annot_data

1000   continue
       status = 0
       if (exit_at_end .and. i_com_done.ne.0) then
         do i=1,cmd_data_len
           cdata(i) = cmd_data(i)
         enddo
         cdata(1) = 100
         call graphic_end( graphic_image, image_defn, status)
         return
       end if

C decode commmands
       call plot_frset(status)
       call cmd_getcmd('Map-Display> ',liscom,
     *                  number_commands,icomm,status)

C check for error
       if (status.ne.0) then
         call cmd_err(status,'MAP-DISPLAY',' ')
         goto 1000
       end if

C exit for basic command
       if (icomm.le.0) then
         do i=1,cmd_data_len
           cdata(i) = cmd_data(i)
         enddo
         cdata(1) = icomm
         call graphic_end( graphic_image, image_defn, status)
         return
       end if

C increment command counter
       i_com_done = i_com_done + 1

C decode command
       if (chr_cmatch('set-map',liscom(icomm))) then
         call plot_setmap(.false.,map_array,status)
         cmd_results = plotsys_setmap_command
       elseif (chr_cmatch('overlay-map',liscom(icomm))) then
         option_list(1) = 'set ........... specify an overlay-map'
         option_list(2) = 'off ........... turn overlay-map off'
         option_list(3) = 'on ............ turn overlay-map on'
         option_list(4) = 'current-main .. select main map as current'
         option_list(5) = 'current-overlay select overlay as current'
         call io_getopt('Overlay-option (?=help) : ','ALL',
     *                   option_list,5,option,status)
         if (chr_cmatch('set',option)) then
           call plot_setmap(.true.,map_array,status)
           overlay_defined = .true.
           overlay_map = .true.
         elseif (chr_cmatch('off',option)) then
           overlay_map = .false.
         elseif (chr_cmatch('on',option)) then
           overlay_map = .true.
         elseif (chr_cmatch('current-main',option)) then
           imap_current = 1
         elseif (chr_cmatch('current-overlay',option)) then
           imap_current = 2
         endif

       elseif (chr_cmatch('set-pips',liscom(icomm))) then
         pips_opt = io_onoff('Pips on/off : ','on',status)
         if (pips_opt) then
            call plot_getpip(.true.,status)
         endif
         if (pips_opt) then
           uvpip_opt = io_onoff('UV-pips on/off : ','off',status)
         else
           uvpip_opt = io_onoff('UV-pips on/off : ','on',status)
         endif

       elseif (chr_cmatch('set-grid',liscom(icomm))) then
         grid_opt = io_onoff('RA/DEC grid on/off : ','off',status)
         uvgrid_opt = io_onoff('UV grid on/off : ','off',status)
         if (uvgrid_opt) then
           call io_getr('Spacing in U (0=default) : ','0',grid_u,status)
           call io_getr('Spacing in V (0=default) : ','0',grid_v,status)
         end if

       elseif (chr_cmatch('set-uv-range',liscom(icomm))) then
         call plot_getuv('UV-range : ','*',uv_range,status)
         call plot_getpip(.false.,status)
         call cmd_exec(plotsys_setuv_command,status)
         cmd_results = plotsys_setuv_command

       elseif (chr_cmatch('set-interpolation',liscom(icomm))) then
         interpolate_opt =
     *      io_onoff('Interpolation on/off : ','off',status)

       elseif (chr_cmatch('set-style',liscom(icomm))) then
         call plot_style(status)

       elseif (chr_cmatch('grey-scale',liscom(icomm))) then
         image_opt = io_onoff('Grey-scaling on/off : ','off',status)
         if (image_opt) then
           image_min = data_range(1,imap_current)
           image_max = data_range(2,imap_current)
           call io_getr('Image-min : ','*',image_min,status)
           call io_getr('Image-max : ','*',image_max,status)
         end if

       elseif (chr_cmatch('vector-plot',liscom(icomm))) then
         call plot_vectors(status)

       elseif (chr_cmatch('symbol-plot',liscom(icomm))) then
         call plot_symbols(status)

       elseif (chr_cmatch('contours',liscom(icomm))) then
         call plot_ctdefine(status)

       elseif (chr_cmatch('linear-contours',liscom(icomm))) then
         call plot_ctlin(status)

       elseif (chr_cmatch('logarithmic-contours',liscom(icomm))) then
         call plot_ctlog(status)

       elseif (chr_cmatch('clear-contour-levels',liscom(icomm))) then
         option_list(1) = 'all ........... clear all levels'
         option_list(2) = 'type .......... clear specific type'
         call io_getopt('Clear-option (?=help) : ','ALL',
     *                   option_list,2,option,status)
         if (chr_cmatch('all',option)) then
           i = 0
         else
           call io_geti('Contour-type (0=all) : ','0',i,status)
         endif
         call plot_ctclear(i,status)

       elseif (chr_cmatch('reset-contour-levels',liscom(icomm))) then
         option_list(1) = 'all ........... clear all levels'
         option_list(2) = 'type .......... clear specific type'
         call io_getopt('Reset-option (?=help) : ','ALL',
     *                   option_list,2,option,status)
         if (chr_cmatch('all',option)) then
           i = 0
         else
           call io_geti('Contour-type (0=all) : ','0',i,status)
         endif
         call plot_ctreset(i,status)

       elseif (chr_cmatch('plot',liscom(icomm))) then
         option_list(1) = 'all .......... plot everything'
         option_list(2) = 'refresh ...... refresh current plot'
         option_list(3) = 'grey ......... plot grey scale'
         option_list(4) = 'frame ........ plot frame'
         option_list(5) = 'contours ..... plot contours'
         option_list(6) = 'symbol ....... plot symbols'
         option_list(7) = 'vectors ...... plot vectors'
         option_list(8) = 'text ......... plot text and titles'
         option_list(9) = 'annotations .. plot annotations'
         option_list(10)= 'crosses ...... plot crosses file'
         call io_getopt('Plot-option (?=help) : ','ALL',
     *                   option_list,10,option,status)
         call plot_doplot(option,map_array,status)
         call cmd_err(status,'PLOT',' ')

       elseif (chr_cmatch('initialise',liscom(icomm))) then
         option_list(1) = 'all .......... initialise everything'
         option_list(2) = 'plot ......... initialise for (re-)plotting'
         option_list(3) = 'options ...... options for the plot'
         option_list(4) = 'setup ........ definition of maps etc.'
         option_list(5) = 'annotations .. initailise annotations'
         option_list(6) = 'title ........ title for plot'
         call io_getopt('Initialise-option (?=help) : ','ALL',
     *                   option_list,6,option,status)

         if ( chr_cmatch(option,'plot') .or.
     *        chr_cmatch(option,'all')    ) then
           call plot_init_plot( status )
           call annotate_init( annot_data, option, status )
         endif
         if ( chr_cmatch(option,'options') .or.
     *        chr_cmatch(option,'all')    ) then
           call plot_init_opt( status )
           call annotate_init( annot_data, option, status )
         endif
         if ( chr_cmatch(option,'setup') .or.
     *        chr_cmatch(option,'all')    ) then
           call plot_init_setup( status )
           call annotate_init( annot_data, option, status )
         endif
         if ( chr_cmatch(option,'annotations') .or.
     *        chr_cmatch(option,'all')    ) then
           call annotate_init( annot_data, 'all', status )
         endif
         if ( chr_cmatch(option,'title') .or.
     *        chr_cmatch(option,'all')    ) then
           title_plot = ' '
           title_opt = .false.
           title_done = .false.
         endif

       elseif (chr_cmatch('display',liscom(icomm))) then
         call plot_display(status)

       elseif (chr_cmatch('title-plot',liscom(icomm))) then
         call io_getstr('Plot-title : ',' ',title_plot,status)
         title_opt = chr_lenb(title_plot).gt.0
         title_done = .false.

       elseif (chr_cmatch('modify-lookup-table',liscom(icomm))) then
         call plot_TVmod(status)

       elseif (chr_cmatch('cursor-position',liscom(icomm))) then
         call map_alloc_in(imap,'DIRECT',map_array,ip_map,status)
         call redt_load( imap, status )
         call plot_cursor_read( map_array(ip_map), .true., status )
         call map_end_alloc( imap, map_array, status )

       elseif (chr_cmatch('get',liscom(icomm))) then
         call plot_get( map_array, status )

       elseif (chr_cmatch('surface-plot',liscom(icomm))) then
         call plot_surface( map_array, status )

       elseif (chr_cmatch('isometric-plot',liscom(icomm))) then
         call plot_isometric( map_array, status )

       elseif (chr_cmatch('annotate',liscom(icomm))) then
         call graphic_open( image_defn, status )
         call plot_frinit( .true., status )
         call annotate( annot_data, status )

       elseif (chr_cmatch('crosses-file',liscom(icomm))) then
         option_list(1) = 'on ........... crosses file plotting on'
         option_list(2) = 'off .......... crosses file plotting off'
         option_list(3) = 'file ......... set name of crosses file'
         option_list(4) = 'size ......... set size of crosses'
         option_list(5) = 'extended ..... file contains style info.'
         call io_getopt('Crosses-option (?=help) : ','off',
     *                   option_list,5,option,status)

         if ( chr_cmatch(option,'on') ) then
           crosses_opt = 1
           if (chr_lenb(crosses_file).eq.0) then
             call io_getfil('Crosses-file : ',' ',crosses_file,status)
           endif
         elseif ( chr_cmatch(option,'extended') ) then
           crosses_opt = 2
           if (chr_lenb(crosses_file).eq.0) then
             call io_getfil('Crosses-file : ',' ',crosses_file,status)
           endif
         elseif ( chr_cmatch(option,'off') ) then
           crosses_opt = 0
         elseif ( chr_cmatch(option,'file') ) then
           call io_getfil('Crosses-file : ',' ',crosses_file,status)
         elseif ( chr_cmatch(option,'size') ) then
           call io_getr('Cross-size : ','*',crosses_size,status)
         endif

       endif

       goto 1000
       end


! Library interface to TWIN: useful for putting TWIN into Muse

module twin_library
   use real_kind
   use mesh, only: nvar

   ! Datastructure for storing all the information for one star
   ! These need to be swapped into and out off the TWIN global variables
   ! We only care about single stars and TWIN mode binaries
   type, private :: twin_star_t
      sequence
      ! Flag to indicate wether this star still needs some initialisation
      logical :: virgin

      integer :: number_of_variables
      integer :: number_of_meshpoints

      ! Array of independent variables and increments since last timestep
      real(double), pointer :: h(:,:)
      real(double), pointer :: dh(:,:)

      real(double) :: zams_mass

      ! Stellar type, as in Hurley & al 2000
      integer :: stellar_type

      ! Iteration control
      integer :: startup_iter
      integer :: normal_iter

      ! Binary parameters; these need to be set because TWIN is a binary code
      real(double) :: bms, per, ecc, p

      ! Don't ask...
      integer :: jf

      ! Module current_model_properties
      real(double) :: ml, ql, xl, uc(21)
      integer :: jmod, jnn, jter, joc, jkh

      ! Module test_variables
      real(double) :: dt
      real(double) :: hspn(2), rlf(2), zet(2), xit(2), age, bm, mc(2), om, bper, sm, enc
      real(double) :: tfr, t0, m0, mta, om0, omta, a0, ata, e0, eta, cdd
      real(double) :: bp, horb, ro, ra2, secc, tn(2), wmh, wmhe, mh, mhe, mco
      real(double) :: be(2), lh, lhe, lc, lnu, lth, mcb(8), msb(6), rcb(8), tct(8)
      real(double) :: prev(81), pprev(81)
      integer :: jhold, jm2, jm1

      ! COMMON block SOLV
      real(double) :: er(nvar)

      ! COMMON block STORE
      real(double), pointer :: hpr(:, :)
      !real(double) :: ht(4, nvar)    ! Used in nucleosynthesis code
      !real(double) :: ms(9999)    ! Mass loss history of primary, non-TWIN mode
      !real(double) :: st(9999)    ! Mass loss history of primary, non-TWIN mode
   end type twin_star_t

   ! Inverse permutation: where each element in the global H is
   ! mapped to in the copy in the struct. This makes it possible to
   ! not store unused elements, reducing the memory requirements.
   integer, private :: inv_var_perm(nvar)
   integer, private :: var_perm(nvar)
   integer, private :: actual_number_of_variables

   ! Data structure to store a number of stars in memory.
   integer, private :: max_stars = -1        ! Maximum number of stars
   type(twin_star_t), private, allocatable, target :: star_list(:)
   integer, private :: current_star = 0      ! Currently selected star
   integer, private :: num_stars = 0         ! Number of allocated stars

   ! Some data read from init.dat that is not saved to COMMON blocks
   integer, private :: kh2, kr1, kr2, ksv, kt5, jch, iter

   ! Layout of the ZAMS library file
   real(double), private :: mlo, dm, mhi
   integer, private :: kdm

   ! Number of models to run before switching to "normal" number of
   ! iterations (from "startup" number of iterations)
   integer, parameter, private :: switch_iterations = 5

   ! Print verbose output to stdout yes or no.
   logical, private :: verbose = .false.

   ! Name of the init.dat input file, if not otherwise specified
   character(len=500), private :: init_dat_name = 'init.dat'

   ! Name of the init.run input file, if not otherwise specified
   character(len=500), private :: init_run_name = 'init.run'

contains

   ! set_init_dat_name:
   !  Change the name of the input file used for the numerical settings and
   !  physics options (default: ./init.dat)
   subroutine set_init_dat_name(new_init_dat_name)
      use real_kind
      use file_exists_module

      implicit none
      character(len=500), intent(in) :: new_init_dat_name;

      if (.not. file_exists(new_init_dat_name) ) then
         if (verbose) print *, "warning: file ",trim(new_init_dat_name)," for ", trim(init_dat_name), " does not exist!"
      end if
      init_dat_name = trim(new_init_dat_name)

   end subroutine set_init_dat_name

   ! set_init_run_name:
   !  Change the name of the input file used for the numerical settings and
   !  physics options (default: ./init.dat)
   subroutine set_init_run_name(new_init_run_name)
      use real_kind
      use file_exists_module

      implicit none
      character(len=500), intent(in) :: new_init_run_name;

      if (.not. file_exists(new_init_run_name) ) then
         if (verbose) print *, "warning: file ",trim(new_init_run_name)," for ", trim(init_run_name), " does not exist!"
      end if
      init_run_name = new_init_run_name;
   end subroutine set_init_run_name

   subroutine open_fortran_output_file(filename, file_number)
      use real_kind

      implicit none
      character(len=*), intent(in) :: filename
      integer, intent(in) :: file_number
      integer :: status;
      close(file_number)
      open(unit = file_number, action = "write", file = filename, iostat=status)
      return
   end subroutine open_fortran_output_file

   function read_atomic_data_file(filename)
      use real_kind

      implicit none
      character(len=*), intent(in) :: filename
      integer :: read_atomic_data_file
      close (26)
      open(unit = 26, action="read", file=filename, iostat=read_atomic_data_file)
      call load_atomic_data(26)
      close (26)
   end function read_atomic_data_file

   function read_reaction_rate_file(filename)
      use real_kind
      use constants
      use neutrinos

      implicit none
      character(len=*), intent(in) :: filename
      integer :: read_reaction_rate_file
      call initialise_constants
      close (42)
      open(unit = 42, action="read", file=filename, iostat=read_reaction_rate_file)
      call load_reaction_neutrino_rates(42)
      close (42)
   end function read_reaction_rate_file

   function read_opacity_file(filename)
      use real_kind
      use opacity

      implicit none
      character(len=*), intent(in) :: filename
      integer :: read_opacity_file
      close (20)
      open(unit = 20, action="read", file=filename, iostat=read_opacity_file)
      call load_opacity_std(20)
      close (20)
   end function read_opacity_file

   function read_co_opacity_file(filename)
      use real_kind
      use opacity_co

      implicit none
      character(len=*), intent(in) :: filename
      integer :: read_co_opacity_file
      close (41)
      open(unit = 41, action="read", file=filename, iostat=read_co_opacity_file)
      call load_opacity_co(41)
      close (41)
   end function read_co_opacity_file

   function read_zams_library_format(filename)
      use real_kind

      implicit none
      character(len=*), intent(in) :: filename
      integer :: read_zams_library_format
      close (19)
      open(unit = 19, action="read", file=filename, iostat=read_zams_library_format)
      read (19, *) mlo, dm, mhi, kdm
      close (19)
   end function read_zams_library_format

   subroutine close_zams_library
      close(16)
   end subroutine close_zams_library

   function open_zams_library(filename)
      use real_kind

      implicit none
      character(len=*), intent(in) :: filename
      integer :: open_zams_library
      close(16)
      open(unit = 16, action="read", file=filename, iostat=open_zams_library)
   end function open_zams_library

   subroutine set_number_of_startup_iterations(new_iter)
      use real_kind

      implicit none
      integer, intent(in) :: new_iter
      kr1 = new_iter
      iter = kr1
   end subroutine set_number_of_startup_iterations

   subroutine set_number_of_iterations(new_iter)
      use real_kind

      implicit none
      integer, intent(in) :: new_iter
      kr2 = new_iter
   end subroutine set_number_of_iterations

   function get_number_of_iterations()
      use real_kind

      implicit none
      integer :: get_number_of_iterations
      get_number_of_iterations = kr2
   end function get_number_of_iterations

   ! initialise_twin:
   !  General TWIN initialisation: load physics datafiles and ZAMS libraries.
   !  Input variables:
   !   evpath - the path to the stellar evolution code, location of the input data
   !            can be set to '.' if datafiles are in the current directory
   !   nstars - The total number of stars (and binaries) for which we want to
   !            allocate space
   !   zstr   - string describing the metallicity, without the leading 0 and decimal
   !            point. So '02' means '0.02'
   !  Returns value:
   !     0 on succes, non zero on failure
   function initialise_twin(evpath, nstars, zstr)
      use real_kind
      use settings
      use file_exists_module
      use constants
      use init_run
      use init_dat
      use current_model_properties
      use mesh
      use opacity
      use opacity_co
      use indices

      implicit none
      integer :: initialise_twin
      character(len=*), intent(in) ::  evpath, zstr
      integer, intent(in) :: nstars

      integer :: i,ii

      integer :: ke1,ke2,ke3,kbc,kev,kfn,kl,kp_var(40),kp_eqn(40),kp_bc(40)

      logical :: status, override_run, override_dat
      integer, parameter :: n_inp_files = 15
      character(len=500) :: inputfilenames(n_inp_files), fname
      integer :: inputunits(n_inp_files)     = (/12, 24, 16, 18, 19, 20, 21, 26, 63, 22, 23, 41, 42, 122, 123/)
      integer :: input_required(n_inp_files) = (/ 0,  0,  1,  1,  1,  0,  1,  1, -1, -1, -1,  0,  1, 1, 1/)

      max_stars = nstars
      if (verbose) then
         print *, 'twin initialisation.'
         print *, 'arguments: evpath =', evpath
         print *, '           nstars =', nstars
         print *, '           zstr =', zstr
      end if

      ! Setup input file names
      inputfilenames(1)=trim(evpath)//"/input/zahb"//trim(zstr)//".mod"
      inputfilenames(2)=trim(evpath)//"/input/zahb"//".dat"
      inputfilenames(3)=trim(evpath)//"/input/zams/zams"//trim(zstr)//".mod"
      inputfilenames(4)=trim(evpath)//"/input/zams/zams"//trim(zstr)//".out"
      inputfilenames(5)=trim(evpath)//"/input/zams/zams"//trim(zstr)//".mas"
      inputfilenames(6)=trim(evpath)//"/input/metals/z"//trim(zstr)//"/phys.z"//trim(zstr)
      inputfilenames(7)=trim(evpath)//"/input/lt2ubv.dat"
      inputfilenames(8)=trim(evpath)//"/input/nucdata.dat"
      !INPUTFILENAMES(9)=TRIM(EVPATH)//"/input/mutate.dat"
      inputfilenames(10)=trim(init_dat_name)
      inputfilenames(11)=trim(init_run_name)
      inputfilenames(12)=trim(evpath)//"/input/COtables/COtables_z"//trim(zstr)
      inputfilenames(13)=trim(evpath)//"/input/physinfo.dat"
      inputfilenames(14)=trim(evpath)//"/run/muse/init.dat" ! Sensible defaults
      inputfilenames(15)=trim(evpath)//"/run/muse/init.run" ! Sensible defaults

      ! We want to override the default init.run and init.dat settings if
      ! init.run and init.dat are present in the current directory.
      override_run = .false.
      override_dat = .false.

      ! Check if all input files exist and open them as needed
      do i=1, n_inp_files
         write (fname, '("fort.",i2)') inputunits(i)
         if (file_exists(inputfilenames(i)) .and. .not. file_exists(fname)) then
            if (verbose) print *, "opening ",trim(inputfilenames(i))," for ", trim(fname)
            open(unit = inputunits(i), action="read", file=inputfilenames(i))
         end if
         ! Check if files exist and act appropriately
         ! If the file is required (INPUT_REQUIRED>0), abort on error
         ! If the file is optional (INPUT_REQUIRED==0), give a warning
         ! If the file is probably unneeded (INPUT_REQUIRED<0), do nothing
         if (.not. (file_exists(inputfilenames(i)) .or. file_exists(fname))) then
            if (input_required(i) > 0) then
               write (0, *) 'required input file ', trim(inputfilenames(i)), ' (', trim(fname), ') not found'
               initialise_twin = -1
               return
            else if (input_required(i) == 0) then
               write (0, *) 'warning: input file ', trim(inputfilenames(i)), ' (', trim(fname), ') not found'
            end if
         end if
      end do

      if ( file_exists(inputfilenames(10)) ) override_dat = .true.
      if ( file_exists(inputfilenames(11)) ) override_run = .true.

      ! We need to have a fort.11 - no, we don't, since we're not using star12!
      !WRITE (11, *) 0
      !CLOSE (11)

      ! We need a scratch file for output we don't want or need
      if (.not. file_exists('fort.25'))&
           open (unit=25, action='write', status = 'scratch')

      ! Other redundant (for our purposes) output we do not want to save but cannot
      ! easily avoid: solver output to fort.1 and opacity table output to fort.10
      open (unit=10, action='write', status = 'scratch')
      !OPEN (UNIT=1, ACTION='WRITE', STATUS = 'SCRATCH')

      if (verbose) print *, 'files initialised, initialising equation of state'
      call setsup

      ! Read layout of the ZAMS library
      read (19, *) mlo, dm, mhi, kdm
      rewind (19)

      if (verbose) print *, 'initialised equation of state, reading run settings'
      call read_init_run(123)    ! Load defaults
      if (override_run) call read_init_run(23)
      ! Create short (`pruned') summary of ZAMS models from long file
      ! Are we using this? Not reall, I think...
      !      CALL PRUNER ( 18, 17, ISB )
      !      CLOSE (17)
      !      CLOSE (18)

      ! Read init.dat file
      !> \todo FIXME: this has an unwanted side effect of resetting options that are not set
      !! in the override file to their defaults, even if the default file we loaded
      !! has them set. In other words, we need an "override init.dat" function.
      !<
      if (verbose) print *, 'reading numerical and physical settings'
      status = read_init_dat(122, kh2, ksv, kt5, jch)   ! Defaults
      if (status .and. override_dat)&
           status = read_init_dat(22, kh2, ksv, kt5, jch)
      if (status .eqv. .false.) then
         initialise_twin = -1
         return
      end if
      if (verbose) print *, 'read settings'
      if (verbose) print *, 'using', kh2, 'meshpoints per star'

      ! Set number of equations and permutations properly from init.dat
      ke1            = id(1)
      ke2            = id(2)
      ke3            = id(3)
      kbc            = id(4)
      kev            = id(5)
      kfn            = id(6)
      kl             = id(7)
      kp_var(1:40)   = id(11:50)
      kp_eqn(1:40)   = id(51:90)
      kp_bc(1:40)    = id(91:130)

      !     Autodetect if we should solve for Mg24 or not by checking if the
      !     corresponding equation is in the list of equations
      use_mg24_eqn = .false.
      do ii = 1, 40
         if (kp_eqn(ii) == EQN_MG24 .or. kp_eqn(ii) == EQN_SUMX) then
            use_mg24_eqn = .true.
            exit
         end if
         if (kp_eqn(ii) == 0) exit   ! Break loop if end of list found
      end do

      ! Convert some things to `cgs' units: 10**11 cm, 10**33 gm, 10**33 erg/s
      cmi = cmi/csy
      cmj = cmj*cmsn/csy
      cms = cms/csy
      cmt = cmt*1.0d-11

      ! Read opacity data and construct splines
      ! KOP (read from init.dat) sets which type of opacity tables
      if (verbose) print *, 'reading opacity tables'
      if (kop<=1) then
         if (verbose) print *, "using opal '92"
         ! Iglesias & Rogers (1992), as implemented by Pols & al. 1995
         call load_opacity(20)
      else
         if (verbose) print *, "using opal '96 with co enhancement"
         ! Iglesias & Rogers (1996), as implemented by Eldridge & Tout 2003
         call load_opacity_co(41)
      end if

      ! Abort if the requested number of meshpoints is larger than the
      ! size of the array
      if (kh2 > nm) then
         write (0, *) 'cannot rezone to ', kh2, 'meshpoints. maximum size is ', nm, 'meshpoints.'
         initialise_twin = -2
         return
      end if

      ! Initialise some more variables
      if ( isb.eq.1 ) ktw = 1
      jb = 1

      ! Setup inverse lookup table for number of variables
      actual_number_of_variables = ke1+ke2+kev
      if (verbose) print *,'will backup',actual_number_of_variables,'variables.'
      inv_var_perm(:) = 0
      do ii=1, actual_number_of_variables
         inv_var_perm(kp_var(ii)) = ii
         var_perm(ii) = kp_var(ii)
      end do

      ! Allocate memory for all the stars we're interested in
      if (allocated(star_list)) deallocate(star_list);
      allocate(star_list(1:max_stars))
      if (verbose) print *, 'allocated memory for ',max_stars, 'stars'

      ! We're not writing any output directly from the library functions
      ! Report success
      initialise_twin = 0;
   end function initialise_twin

   ! Close the temporary files when we're done with them
   ! Sometimes we may need to do this manually
   subroutine close_temporary_files
      use real_kind

      implicit none
      close (25)
      close (10)
   end subroutine close_temporary_files

   ! load_zams_star:
   !  load a ZAMS model from disk
   !  Input variables:
   !   m - the mass, in solar units
   !   t - the starting age, in years. Only used for reporting the star's age
   !  Return value:
   !   >0: The stars ID for identifying it in the array of models
   !   =0: No star allocated, out of memory
   function load_zams_star(mass, age)
      use real_kind
      use mesh
      use constants
      use settings
      use current_model_properties

      implicit none
      type(twin_star_t), pointer :: star
      integer :: load_zams_star
      real(double), intent(in) :: mass, age

      integer :: im1,kh1,kp1,jmod1,jb1,jn1,jf1,i
      real(double) :: tnuc
      real(double) :: hnuc(50, nm)

      !Common blocks:
      real(double) :: sm1, dty1, age1, per1, bms1, ecc1, p1, enc1

      if (verbose) print *, 'create star with mass', mass, 'and age tag', age

      ml = log10(mass)
      sm1 = mass
      im1 = (ml - mlo)/dm + 1.501d0
      call load_star_model(16,im1, h, dh, hnuc, sm1,dty1,age1,per1,bms1,ecc1,p1,enc1,kh1,kp1,jmod1,jb1,jn1,jf1)
      kh = kh1

      ! Special case: a ZAMS star can be loaded even if the library is not
      ! initialised, but then it will not be stored in the array.
      ! This is a convenience for applications that want to call this
      ! function without calling initialise_twin() first
      if (max_stars <= 0) then
         load_zams_star = 1
         return
      end if
      if (num_stars >= max_stars) then
         load_zams_star = 0
         return
      end if
      num_stars = num_stars + 1
      if (verbose) print *, 'setting local pointer to star', num_stars
      star => star_list(num_stars)

      ! Allocate memory to store the star
      star%number_of_variables = actual_number_of_variables
      star%number_of_meshpoints = kh
      allocate(star%h(star%number_of_variables, star%number_of_meshpoints))
      allocate(star%dh(star%number_of_variables, star%number_of_meshpoints))
      allocate(star%hpr(star%number_of_variables, star%number_of_meshpoints))

      ! Make sure we eliminate the redundancy in storing and loading the model
      ! that is in TWIN (main/beginn).
      ! Essentially, we push the initialised data onto the stack
      jnn = 0
      call swap_out_star(num_stars)

      ! Estimate nuclear timescale for this star
      tnuc = 1.0d10 * mass**(-2.8)
      !star%dt = CSY * DTY1
      !star%dt = 3.0e2*CSY
      star%dt = ct3*1.0d-4 * tnuc*csy
      if (mass > 1.0 .and. mass < 1.2) star%dt = 1.0d-2*star%dt
      if (verbose) print *, 'setting initial timestep for star',num_stars,'to',star%dt,'s'

      ! Initialise some more variables
      star%zams_mass = mass
      star%age = age
      if (p1>0) star%p = p1
      star%jhold = 0
      star%jmod = 0
      star%jf = jf1
      star%er(:) = 0.0d0

      star%startup_iter = kr1
      star%normal_iter = kr2

      ! Binary orbital parameters
      if (per1>0) star%per = per1
      if (bms1>0) star%bms = bms1
      if (ecc1>0) star%ecc = ecc1

      ! Determine whether I and phi are computed or not, for OUTPUT
      star%jf = 0
      do i = 11, 50
         if ( id(i)==12 .or. id(i)==14 ) star%jf = star%jf + 1
      end do
      if ( star%jf==1 ) star%jf = 0

      ! The star will still need some initialisation (initial timestep, say)
      star%virgin = .true.

      ! Save all settings
      call swap_in_star(num_stars)
      call swap_out_star(num_stars)

      load_zams_star = num_stars
   end function load_zams_star

   ! evolve_star:
   !  evolve a star for one timestep; essentially star12 without the loop
   !  TODO: ZAHB construction; maybe also for central carbon burning or white dwarfs?
   function twin_evolve()
      use real_kind
      use mesh
      use control
      use constants
      use settings
      use test_variables
      use current_model_properties

      implicit none
      integer :: twin_evolve,jo,it
      real(double) :: dty

      ! We need some kind of initialisation for the star, cf the calls
      ! to printb in star12
      ! Actually, we need to pull some data from printb anyway...

      jo = 0
      ! Solve for structure, mesh, and major composition variables
      joc = 1

      dty = dt/csy
      jter = 0
      if (verbose) print *, 'taking timestep ',dty,'yr for star', current_star

      call smart_solver ( iter, id, kt5, jo )
      if (verbose) print *, 'did', jter, 'out of', iter, 'iterations'

      ! Converged if JO == 0
      if ( jo /= 0 ) then
         if (verbose) print *, 'failed to converge on timestep'
         !        If no convergence, restart from 2 steps back, DT decreased substantially
         !        Abort if timestep below limit
         do while (jo /= 0)
            call backup ( dty, jo )
            if ( jo.eq.2 ) then
               twin_evolve = jo
               return
            end if
            call nextdt ( dty, jo, it )

            if (verbose) print *, 'timestep reduced to', dty,'yr'

            if ( jo.eq.3 ) then
               twin_evolve = jo
               return
            end if
            jnn = jnn + 1
            jo = 0
            call smart_solver ( iter, id, kt5, jo )
         end do
      end if
      if (jo == 0) then
         if (verbose) print *, 'converged on timestep'
         call timestep_heuristic ( jo, 1 )
         call update ( dty )
         call nextdt ( dty, jo, 22 )
         if ( jnn > switch_iterations ) iter = kr2
         jnn = jnn + 1
      end if

      ! Report results
      twin_evolve = 0;
   end function twin_evolve

   ! dump_twin_model:
   !  write the state of star id to a named file, for later retrieval.
   !  The file will be in the format of a TWIN input file
   subroutine dump_twin_model(id, filename)
      use real_kind

      implicit none
      integer, intent(in) :: id
      character(len=500), intent(in) :: filename

      call select_star(id)

      open (unit=40, file=filename, action='write')
      call output(200, 40, 0, 0)
      close (40);

      call flush_star()
   end subroutine dump_twin_model

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   ! get_*
   !  Selection of getter functions for luminosity, mass, radius, time, next dt etc.
   !  These return retarded information from the *previous* timestep (cf Ross)
   !  This makes sure that we will never need to backtrack beyond this point in
   !  case the code needs to go back to a previous model.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   ! get_luminosity:
   !  Returns the star's luminosity, in solar units
   function get_luminosity(id)
      use real_kind
      use constants

      implicit none
      real(double) :: get_luminosity
      integer, intent(in) :: id

      if (id<1 .or. id>num_stars) then
         get_luminosity = -1.0
         return
      end if

      get_luminosity = star_list(id)%hpr(inv_var_perm(8), 1)/clsn
   end function get_luminosity

   ! get_mass:
   !  Returns the star's mass, in solar units
   function get_mass(id)
      use real_kind
      use constants

      implicit none
      real(double) :: get_mass
      integer, intent(in) :: id
      if (id<1 .or. id>num_stars) then
         get_mass = -1.0
         return
      end if

      get_mass = star_list(id)%hpr(inv_var_perm(4), 1)/cmsn
   end function get_mass

   ! get_radius:
   !  Returns the star's radius, in solar units
   function get_radius(id)
      use real_kind
      use constants

      implicit none
      real(double) :: get_radius
      integer, intent(in) :: id

      if (id<1 .or. id>num_stars) then
         get_radius = -1.0
         return
      end if

      get_radius = exp(star_list(id)%hpr(inv_var_perm(7), 1))/crsn
   end function get_radius

   ! get_temperature:
   !  Returns the star's effective temperature, in Kelvin
   function get_temperature(id)
      use real_kind
      use constants

      implicit none
      real(double) :: get_temperature
      integer, intent(in) :: id

      if (id<1 .or. id>num_stars) then
         get_temperature = -1.0
         return
      end if

      get_temperature = exp(star_list(id)%hpr(inv_var_perm(2), 1))
   end function get_temperature

   ! get_age:
   !  Returns the star's age, in years
   function get_age(id)
      use real_kind
      use constants

      implicit none
      real(double) :: get_age
      integer, intent(in) :: id

      if (id<1 .or. id>num_stars) then
         get_age = -1.0
         return
      end if

      get_age = star_list(id)%age
   end function get_age

   ! Return the stellar type of the specified star
   function get_stellar_type(id)
      use real_kind

      implicit none
      integer :: get_stellar_type
      integer, intent(in) :: id

      if (id<1 .or. id>num_stars) then
         get_stellar_type = -1
         return
      end if
      get_stellar_type = star_list(id)%stellar_type
   end function get_stellar_type

   subroutine timestep_heuristic ( jo, jstar )
      use real_kind

      implicit none
      integer, intent(out) :: jo
      integer, intent(in) :: jstar
      integer :: jcm
      integer, external :: find_stellar_type
      call compute_output_quantities ( jstar )
      call update_timestep_parameters ( jstar )
      call check_stop_conditions ( jstar, jo, jcm, 22 )
      star_list(current_star)%stellar_type = find_stellar_type()
   end subroutine timestep_heuristic

   subroutine set_star_iter_parameters( id, kt1, kt2, jnn )
      use real_kind

      implicit none
      integer, intent(in) :: id, kt1, kt2, jnn

      if (id<1 .or. id>num_stars) then
         return
      end if

      if (kt1>0) star_list(id)%startup_iter = kt1
      if (kt2>0) star_list(id)%normal_iter = kt2
      star_list(id)%jnn = jnn
   end subroutine set_star_iter_parameters

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   ! Functions for swapping in and out a particular star: !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   ! swap_in_star:
   !  Swap in a particular star for evolution with the TWIN code
   !  Assumes all stars are evolved with the same set of equations and physical
   !  parameters. This is fine as long as these are not changed on the fly, as
   !  for the post He-flash generation code. This needs to be disabled from
   !  init.run, or we need to swap in and out the data from init.dat and init.run
   subroutine swap_in_star(star_id)
      use real_kind
      use mesh
      use constants
      use settings
      use solver_global_variables, only: er
      use test_variables
      use current_model_properties
      use binary_history, only: hpr

      implicit none
      integer, intent(in) :: star_id
      type(twin_star_t), pointer :: star
      integer :: n, nv, number_of_variables
      integer :: jo,it
      real(double) :: dty,bms,ecc,per,tm,toa

      ! Nothing to do if the star has already been swapped in
      if (current_star == star_id .and. .not. star_list(star_id)%virgin) return

      if (verbose) print *, 'swapping in star', star_id

      current_star = star_id
      star => star_list(star_id)

      ! Store structure and structure changes
      kh = star%number_of_meshpoints
      number_of_variables = star%number_of_variables
      do n=1, number_of_variables
         nv = var_perm(n)
         h(nv, 1:kh) = star%h(n,1 :kh)
         dh(nv, 1:kh) = star%dh(n, 1:kh)
      end do

      ! Module current_model_properties
      ml = star%ml
      ql = star%ql
      xl = star%xl
      uc(:) = star%uc(:)
      jmod = star%jmod
      jnn = star%jnn
      jter = star%jter
      joc = star%joc
      jkh = star%jkh

      ! Module test_variables
      dt = star%dt

      hspn = star%hspn
      rlf = star%rlf
      zet = star%zet
      xit = star%xit
      age = star%age
      bm = star%bm
      mc = star%mc
      om = star%om
      bper = star%bper
      sm = star%sm
      enc = star%enc

      tfr = star%tfr
      t0 = star%t0
      m0 = star%m0
      mta = star%mta
      om0 = star%om0
      omta = star%omta
      a0 = star%a0
      ata = star%ata
      e0 = star%e0
      eta = star%eta
      cdd = star%cdd

      bp = star%bp
      horb = star%horb
      ro = star%ro
      ra2 = star%ra2
      secc = star%secc
      tn = star%tn
      wmh = star%wmh
      wmhe = star%wmhe
      mh = star%mh
      mhe = star%mhe
      mco = star%mco

      be = star%be
      lh = star%lh
      lhe = star%lhe
      lc = star%lc
      lnu = star%lnu
      lth = star%lth
      mcb = star%mcb
      msb = star%msb
      rcb = star%rcb
      tct = star%tct

      prev(:) = star%prev(:)
      pprev(:) = star%pprev(:)
      jhold = star%jhold
      jm2 = star%jm2
      jm1 = star%jm1

      ! COMMON block SOLV. We need to retrieve the typical size of the different
      ! variables. It's not a good idea to leak this information to other stars
      if (allocated(er)) er(1:nvar) = star%er(1:nvar)

      ! COMMON block STORE. We don't need the information about the primary's
      ! mass loss rate
      do n=1, number_of_variables
         nv = var_perm(n)
         hpr(nv, 1:kh) = star%hpr(n,1 :kh)
      end do

      kr1 = star%startup_iter
      kr2 = star%normal_iter
      iter = star%normal_iter
      if (jnn < switch_iterations) iter = star%startup_iter

      ! Does this star need some initialisation?
      if (star%virgin) then
         if (verbose) print *, 'performing one time initialisation for star ', star_id
         star%virgin = .false.

         ! Some tasks from beginn
         jo = 0
         it = 22
         jnn = 0
         dty = dt/csy
         call nextdt ( dty, jo, it )
         ! Do we care about REMESH at this stage? Maybe not!
         bms = cmsn*star%bms
         ecc = star%ecc
         per = star%per
         tm = star%zams_mass * cmsn
         toa = cg1*tm*(bms - tm)*(cg2*per/bms)**c3rd*sqrt(1.0d0 - ecc*ecc)
         call remesh ( kh2, jch, bms, tm, star%p, ecc, toa, 1, star%jf )

         hpr(:,1:kh) = h(:,1:kh)
         dh(:, 1:kh) = 0.0d0
         jhold = 2
         prev(2:81) = (/hspn, rlf, zet, xit, age, bm, mc, om, bper, sm, enc,  &
              0.d0, 0.d0, tfr, t0, m0, mta, om0, omta, a0, ata, e0, eta, cdd,  &
              bp, horb, ro, ra2, 0.d0, secc, tn, wmh, wmhe, mh, mhe, mco,  &
              0.d0, be, lh, lhe, lc, lnu, lth, mcb, msb, rcb, tct/)
         pprev(1:81) = prev(1:81)
         jm1 = jmod

         ! some tasks from printb, notably the timestep control
         ! For now, we just call timestep_heuristic, which means we get some unwanted output
         call timestep_heuristic ( jo, 1 )
         call nextdt ( dty, jo, it )
         jnn = 1

      end if
   end subroutine swap_in_star

   ! swap_out_star:
   !  Swap out a particular star for later evolution with the TWIN code
   !  Assumes all stars are evolved with the same set of equations and physical
   !  parameters. This is fine as long as these are not changed on the fly, as
   !  for the post He-flash generation code. This needs to be disabled from
   !  init.run, or we need to swap in and out the data from init.dat and init.run
   subroutine swap_out_star(star_id)
      use real_kind
      use mesh
      use solver_global_variables, only: er
      use test_variables
      use current_model_properties
      use binary_history, only: hpr

      implicit none
      integer, intent(in) :: star_id
      type(twin_star_t), pointer :: star
      integer :: n, nv, number_of_variables

      if (star_id < 1) return
      if (verbose) print *, 'swapping out star', star_id
      star => star_list(star_id)

      ! Retrieve structure and structure changes
      number_of_variables = star%number_of_variables
      do n=1, number_of_variables
         nv = var_perm(n)
         star%h(n, 1:kh) = h(nv,1 :kh)
         star%dh(n, 1:kh) = dh(nv, 1:kh)
      end do
      star%number_of_meshpoints = kh

      ! Module current_model_properties:
      star%ml = ml
      star%ql = ql
      star%xl = xl
      star%uc(:) = uc(:)
      star%jmod = jmod
      star%jnn = jnn
      star%jter = jter
      star%joc = joc
      star%jkh = jkh

      ! Module test_variables:
      star%dt  = dt

      star%hspn = hspn
      star%rlf = rlf
      star%zet = zet
      star%xit = xit
      star%age = age
      star%bm = bm
      star%mc = mc
      star%om = om
      star%bper = bper
      star%sm = sm
      star%enc = enc

      star%tfr = tfr
      star%t0 = t0
      star%m0 = m0
      star%mta = mta
      star%om0 = om0
      star%omta = omta
      star%a0 = a0
      star%ata = ata
      star%e0 = e0
      star%eta = eta
      star%cdd = cdd

      star%bp = bp
      star%horb = horb
      star%ro = ro
      star%ra2 = ra2
      star%secc = secc
      star%tn = tn
      star%wmh = wmh
      star%wmhe = wmhe
      star%mh = mh
      star%mhe = mhe
      star%mco = mco

      star%be = be
      star%lh = lh
      star%lhe = lhe
      star%lc = lc
      star%lnu = lnu
      star%lth = lth
      star%mcb = mcb
      star%msb = msb
      star%rcb = rcb
      star%tct = tct

      star%prev(:) = prev(:)
      star%pprev(:) = pprev(:)
      star%jhold = jhold
      star%jm2 = jm2
      star%jm1 = jm1

      ! COMMON block SOLV. We need to retrieve the typical size of the different
      ! variables. It's not a good idea to leak this information to other stars
      if (allocated(er)) then
         star%er(1:nvar) = er(1:nvar)
      else
         star%er(1:nvar) = 1.0_dbl
      end if

      ! COMMON block STORE. We don't need the information about the primary's
      ! mass loss rate
      do n=1, number_of_variables
         nv = var_perm(n)
         star%hpr(n, 1:kh) = hpr(nv,1 :kh)
      end do

   end subroutine swap_out_star

   ! select_star:
   !  flushes the data from the current star back to the cache and selects the
   !  requested star as the new current star.
   subroutine select_star(id)
      use real_kind

      implicit none
      integer :: id
      call swap_out_star(current_star)
      call swap_in_star(id)
   end subroutine select_star

   ! flush_star:
   !  flushes the data from the currently selected star back to the cache
   subroutine flush_star()
      use real_kind

      implicit none
      call swap_out_star(current_star)
   end subroutine flush_star

end module twin_library


subroutine cvode99(T0, usol_start, nnq, nnz, t_eval, num_t_eval, rtol, atol, &
                 use_fast_jacobian, solution, success, err)
  use photochem_data, only: neq, nq, nz, jtrop, np, mass, background_mu, rainout_on
  use photochem_vars, only: verbose, lbound, fixedmr, T, den, P, Press, max_cvode_steps, &
                            rpar_init
  use photochem_wrk, only: cvode_stepper, rain, raingc, global_err, rpar

  implicit none

  ! inputs
  double precision, intent(in) :: T0 ! intial time
  double precision, dimension(nnq,nnz) :: usol_start ! initial atmosphere
  integer, intent(in) :: nnq
  integer, intent(in) :: nnz
  double precision, dimension(num_t_eval), intent(in) :: t_eval ! times to evaluate solution
  integer, intent(in) :: num_t_eval ! dimension of t_eval
  double precision, intent(in) :: rtol ! relative tolerance
  double precision, intent(in) :: atol ! absolute tolerance
  logical, intent(in) :: use_fast_jacobian ! if True then use my jacobian
  character(len=1000), intent(out) :: err
  character(len=10) :: message

  ! output
  double precision, dimension(num_t_eval,nnq,nnz),intent(out) :: solution
  logical, intent(out) :: success

  ! other
  integer*4 LNST, LNFE, LNSETUP, LNNI, LNCF, LNETF, LNJE ! for printing stats
  data LNST/3/, LNFE/4/, LNETF/5/,  LNCF/6/, LNNI/7/, LNSETUP/8/, &
      LNJE/17/
  integer*4 :: IER, METH, IATOL, ITASK ! some options
  integer i, j, k, ii

  ! The following declaration specification should match C type long int.
  integer*8 nneq, IOUT(25), IPAR(2), mu, ml
  double precision TT
  double precision U(neq), ROUT(10), RRPAR(1)
  real(8) :: mubar_z(nz)

  cvode_stepper = 0
  err = ''

  nneq = neq ! number of equations
  METH = 2 ! CVODE BDF method
  IATOL = 1 ! scalar absolute tolerance
  mu = nq ! upper diagonal
  ml = nq ! lower diagonal
  ITASK = 1 ! for output

  ! begin stuff that needs to be inizialized
  if (np.gt.0) then
    rpar = rpar_init
  endif
  do i = 1,nz
    call mean_molecular_weight(nq, usol_start(:,i), mass, background_mu, mubar_z(i))
  enddo
  call densty(nz, mubar_z, T, den, P, press)
  if (rainout_on) then
    call rainout(.true.,Jtrop,usol_start,nq,nz, T,den, rain, raingc, err)
    if (len_trim(err) /= 0) return
  else
    rain = 0.d0
    raingc = 0.d0
  endif
  ! end stuff that needs to be inizialized

  ! initial conditions
  DO I=1,NQ
    DO J=1,NZ
      K = I + (J-1)*NQ
      U(K) = usol_start(i,j)
    enddo
  enddo

  CALL FNVINITS(1, nneq, IER)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FNVINITS'
    return
  endif

  ! initialize banded matrix module
  call FSUNBANDMATINIT(1, nneq, mu, ml, mu+ml, ier)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FSUNBANDMATINIT'
    return
  endif

  ! initialize banded linear solver module
  call FSUNBANDLINSOLINIT(1, IER)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FSUNBANDLINSOLINIT'
    return
  endif

  call FCVMALLOC(T0, U, METH, IATOL, RTOL, ATOL, &
                 IOUT, ROUT, IPAR, RRPAR, IER)
  if (ier .ne. 0) then
   err = 'SUNDIALS_ERROR: FCVMALLOC'
   return
  endif

  ! attach matrix and linear solver modules to CVLs interface
  CALL FCVLSINIT(IER)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FCVLSINIT'
    CALL FCVFREE
    return
  endif

  CALL FCVSETIIN('MAX_NSTEPS', 1000000, IER)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FCVSETIIN'
    CALL FCVFREE
    return
  endif

  CALL FCVSETIIN('MAX_ERRFAIL', 15, IER)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FCVSETIIN'
    CALL FCVFREE
    return
  endif

  ! start with tiny step
  call FCVSETRIN('INIT_STEP',1.d-6,ier)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FCVSETRIN'
    CALL FCVFREE
    return
  endif

  if (use_fast_jacobian) then
    CALL FCVBANDSETJAC(1, IER)
    if (ier .ne. 0) then
      err = 'SUNDIALS_ERROR: FCVBANDSETJAC'
      CALL FCVFREE
      return
    endif
  endif

  do ii=1,num_t_eval

    CALL FCVODE(t_eval(ii), TT, U, ITASK, IER)
    if (ier < 0) then ! then there is a problem
      if ((global_err == 'max steps') .and. (ier == -8)) then ! reached max steps
        write(message,'(i10)')  max_cvode_steps
        print*,'CVODE stopped because it reached the maximum number of of specified steps: '//trim(message)
        CALL FCVFREE
        return
      else if ((global_err /= 'max steps') .and. (ier == -8)) then ! err in my rhs
        err = global_err
        CALL FCVFREE
        return
      else
        write(message,'(i4)') ier
        err = 'SUNDIALS_ERROR: FCVODE '//trim(message)
        CALL FCVFREE
        return
      endif
    endif

    ! save the solution
    do I=1,NQ
      do J=1,NZ
        K = I + (J-1)*NQ
        solution(ii,i,j) = U(k)
      enddo
    enddo

    ! fix lbound = 1
    do i=1,nq
      if (lbound(i) .eq.1) then
        solution(ii,i,1) = fixedmr(i)
      endif
    enddo

  enddo

  if (verbose) then
    WRITE(6,80) IOUT(LNFE), IOUT(LNJE), IOUT(LNSETUP), &
               IOUT(LNNI), IOUT(LNCF), IOUT(LNETF)
80  FORMAT(//'Final statistics:'// &
          ' No. f-s = ', I4, &
          '  No. J-s = ', I4, '   No. LU-s = ', I4/ &
          ' No. nonlinear iterations = ', I4/ &
          ' No. nonlinear convergence failures = ', I4/ &
          ' No. error test failures = ', I4)
  endif

  if (ier >= 0) then
    success = .true.
  else
    success = .false.
  endif
  call fcvfree

end subroutine

subroutine cvode_save123(T0, usol_start, nnq, nnz, t_eval, num_t_eval, rtol, atol, &
                      use_fast_jacobian, outfilename, amount2save, success, err)
  use photochem_data, only: neq, nq, nz, jtrop, ispec, np, nr, background_spec, &
                            nw, wavl, z, jchem, kj, ks, photoreac, photonums, photospec, &
                            jchem, nmax, iprod, iloss,nump,numl, nsp, background_mu, mass, rainout_on, &
                            Flux
  use photochem_vars, only: verbose, lbound, fixedmr, T, den, P, Press, max_cvode_steps, &
                            rpar_init, edd
  use photochem_wrk, only: cvode_stepper, rain, raingc, global_err, rpar, surf_radiance, A, yp, yl, D

  implicit none

  ! inputs
  double precision, intent(in) :: T0 ! intial time
  double precision, dimension(nnq,nnz) :: usol_start ! initial atmosphere
  integer, intent(in) :: nnq
  integer, intent(in) :: nnz
  double precision, dimension(num_t_eval), intent(in) :: t_eval ! times to evaluate solution
  integer, intent(in) :: num_t_eval ! dimension of t_eval
  double precision, intent(in) :: rtol ! relative tolerance
  double precision, intent(in) :: atol ! absolute tolerance
  logical, intent(in) :: use_fast_jacobian ! if True then use my jacobian (keep false!)
  character(len=*), intent(in) :: outfilename ! were to save the solution
  integer, intent(in) :: amount2save

  ! output
  logical, intent(out) :: success
  character(len=1000), intent(out) :: err
  character(len=10) :: message

  ! other
  double precision, dimension(nnq,nnz) :: solution_temp
  integer*4 LNST, LNFE, LNSETUP, LNNI, LNCF, LNETF, LNJE ! for printing stats
  data LNST/3/, LNFE/4/, LNETF/5/,  LNCF/6/, LNNI/7/, LNSETUP/8/, &
      LNJE/17/
  integer*4 :: IER, METH, IATOL, ITASK ! some options
  integer i, j, k, ii

  ! The following declaration specification should match C type long int.
  integer*8 nneq, IOUT(25), IPAR(2), mu, ml
  double precision TT
  double precision U(neq), ROUT(10), RRPAR(1)
  real(8), allocatable :: UDOT(:), loss(:,:)
  real(8), allocatable :: photorates(:,:)
  integer :: ind(1)
  real(8) :: mubar_z(nz)

  allocate(UDOT(neq))
  allocate(loss(nq,nz))
  allocate(photorates(ks,nz))

  err = ''

  cvode_stepper = 0

  nneq = neq ! number of equations
  METH = 2 ! CVODE BDF method
  IATOL = 1 ! scalar absolute tolerance
  mu = nq ! upper diagonal
  ml = nq ! lower diagonal
  ITASK = 1 ! for output

  ! begin stuff that needs to be inizialized
  if (np.gt.0) then
    rpar = rpar_init
  endif
  do i = 1,nz
    call mean_molecular_weight(nq, usol_start(:,i), mass, background_mu, mubar_z(i))
  enddo
  call densty(nz, mubar_z, T, den, P, press)
  if (rainout_on) then
    call rainout(.true.,Jtrop,usol_start,nq,nz, T,den, rain, raingc, err)
    if (len_trim(err) /= 0) return
  else
    rain = 0.d0
    raingc = 0.d0
  endif
  ! end stuff that needs to be inizialized

  ! initial conditions
  DO I=1,NQ
    DO J=1,NZ
      K = I + (J-1)*NQ
      U(K) = usol_start(i,j)
    enddo
  enddo
  call right_hand_side(U,UDOT,neq,err)

  ! file prep
  open(2,file=outfilename,status='replace',form="unformatted")
  write(2) nq
  write(2) np
  write(2) nw
  write(2) kj
  write(2) ks
  write(2) nz
  write(2) background_spec ! len=8
  write(2) ispec
  write(2) photospec

  ! new
  write(2) nsp
  write(2) nr
  write(2) nmax
  write(2) jchem
  write(2) iprod
  write(2) iloss
  write(2) nump
  write(2) numl
  write(2) A
  ! new

  write(2) z
  write(2) T
  write(2) edd
  write(2) rpar_init
  write(2) wavl
  write(2) flux

  write(2) num_t_eval
  write(2) amount2save
  close(2)

  CALL FNVINITS(1, nneq, IER)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FNVINITS'
    return
  endif

  ! initialize banded matrix module
  call FSUNBANDMATINIT(1, nneq, mu, ml, mu+ml, ier)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FSUNBANDMATINIT'
    return
  endif

  ! initialize banded linear solver module
  call FSUNBANDLINSOLINIT(1, IER)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FSUNBANDLINSOLINIT'
    return
  endif

  call FCVMALLOC(T0, U, METH, IATOL, RTOL, ATOL, &
                 IOUT, ROUT, IPAR, RRPAR, IER)
  if (ier .ne. 0) then
   err = 'SUNDIALS_ERROR: FCVMALLOC'
   return
  endif

  ! attach matrix and linear solver modules to CVLs interface
  CALL FCVLSINIT(IER)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FCVLSINIT'
    CALL FCVFREE
    return
  endif

  CALL FCVSETIIN('MAX_NSTEPS', 1000000, IER)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FCVSETIIN'
    CALL FCVFREE
    return
  endif

  CALL FCVSETIIN('MAX_ERRFAIL', 15, IER)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FCVSETIIN'
    CALL FCVFREE
    return
  endif

  ! start with tiny step
  call FCVSETRIN('INIT_STEP',1.d-6,ier)
  if (ier .ne. 0) then
    err = 'SUNDIALS_ERROR: FCVSETRIN'
    CALL FCVFREE
    return
  endif

  if (use_fast_jacobian) then
    CALL FCVBANDSETJAC(1, IER)
    if (ier .ne. 0) then
      err = 'SUNDIALS_ERROR: FCVBANDSETJAC'
      CALL FCVFREE
      return
    endif
  endif

  do ii=1,num_t_eval

    CALL FCVODE(t_eval(ii), TT, U, ITASK, IER)
    if (ier < 0) then ! then there is a problem
      if ((global_err == 'max steps') .and. (ier == -8)) then ! reached max steps
        write(message,'(i10)')  max_cvode_steps
        print*,'CVODE stopped because it reached the maximum number of of specified steps: '//trim(message)
        CALL FCVFREE
        return
      else if ((global_err /= 'max steps') .and. (ier == -8)) then ! err in my rhs
        err = global_err
        CALL FCVFREE
        return
      else
        write(message,'(i4)') ier
        err = 'SUNDIALS_ERROR: FCVODE '//trim(message)
        CALL FCVFREE
        return
      endif
    endif

    ! save the solution
    do I=1,NQ
      do J=1,NZ
        K = I + (J-1)*NQ
        solution_temp(i,j) = U(k)
      enddo
    enddo

    ! fix lbound = 1
    do i=1,nq
      if (lbound(i) .eq.1) then
        solution_temp(i,1) = fixedmr(i)
      endif
    enddo

    call right_hand_side(U,UDOT,neq,err)
    photorates = 0.d0
    do j=1,kj
      i = photoreac(j)
      ind = findloc_integer(size(photospec),photospec,i)
      photorates(ind(1),:) = photorates(ind(1),:) + A(photonums(j),:)*solution_temp(i,:)*den
    enddo
    do j = 1,nq
      loss(j,:) = yl(j,:)*solution_temp(j,:)*den
    enddo

    open(2,file=outfilename,status='old',form="unformatted", position="append")
    write(2) 999
    write(2) t_eval(ii)
    ! write(2) solution_temp
    write(2) D
    write(2) den
    if (amount2save == 1) then
      write(2) P
      write(2) surf_radiance
      write(2) photorates
      write(2) yp
      write(2) loss
    endif
    close(2)

  enddo

  if (verbose) then
    WRITE(6,80) IOUT(LNFE), IOUT(LNJE), IOUT(LNSETUP), &
               IOUT(LNNI), IOUT(LNCF), IOUT(LNETF)
80  FORMAT(//'Final statistics:'// &
          ' No. f-s = ', I4, &
          '  No. J-s = ', I4, '   No. LU-s = ', I4/ &
          ' No. nonlinear iterations = ', I4/ &
          ' No. nonlinear convergence failures = ', I4/ &
          ' No. error test failures = ', I4)
  endif

  if (ier >= 0) then
    success = .true.
  else
    success = .false.
  endif
  call fcvfree
  deallocate(UDOT)
  deallocate(loss)
  deallocate(photorates)

end subroutine

subroutine cvode_equilibrium(rtol, atol, use_fast_jacobian, success, err)
  use photochem_data, only: nr, nq, np, nz1, nq1, isl, nz, jtrop, &
                            lh2o, dz, nsp2, jtrop, background_mu, mass, rainout_on, &
                            fix_water_in_troposphere
  use photochem_vars, only: verbose, usol_init, usol_out, &
                            den, fluxo, flow, T, P, den, press, rpar_init, &
                            equilibrium_time
  use photochem_wrk, only: cvode_stepper, wfall, dk, scale_h, h_atm, yp, yl, &
                           bx1x2, raingc, A, rain, rpar
  implicit none
  ! input
  double precision, intent(in) :: rtol ! relative tolerance
  double precision, intent(in) :: atol ! absolute tolerance
  logical, intent(in) :: use_fast_jacobian ! if True then use my jacobian

  ! output
  logical, intent(out) :: success
  character(len=1000), intent(out) :: err

  ! other
  double precision :: T0 = 0.d0 ! intial time
  integer :: num_t_eval = 1
  double precision, dimension(1) :: t_eval
  double precision, dimension(1,nq,nz) :: solution
  double precision, dimension(nq,nz) :: usol
  integer cr, cm, c1, c2
  integer i,j,k,ll
  real*8,dimension(nq1) :: SR, FUP
  double precision :: wnf
  real*8, dimension(nq,nz) :: Fval
  real*8, dimension(nsp2,nz) :: D
  real(8) :: mubar_z(nz)
  err = ''
  cvode_stepper = 0
  ! begin stuff that needs to be inizialized
  if (np.gt.0) then
    rpar = rpar_init
  endif
  do i = 1,nz
    call mean_molecular_weight(nq, usol_init(:,i), mass, background_mu, mubar_z(i))
  enddo
  call densty(nz, mubar_z, T, den, P, press)
  if (rainout_on) then
    call rainout(.true.,Jtrop,usol_init,nq,nz, T,den, rain, raingc, err)
    if (len_trim(err) /= 0) return
  else
    rain = 0.d0
    raingc = 0.d0
  endif
  ! end stuff that needs to be inizialized

  t_eval(1) = equilibrium_time
  call system_clock(count = c1, count_rate = cr, count_max = cm)
  call cvode(T0, usol_init, nq, nz, t_eval, num_t_eval, rtol, atol, &
             use_fast_jacobian, solution, success, err)
  if (len_trim(err) /= 0) return
  call system_clock(count = c2)
  usol = solution(1,:,:)

  if (success) then
    if (verbose) then
      print"('Time to find equilibrium =',f10.3,' seconds')", &
            (c2-c1)/real(cr)
    endif
  ! the output
    do i=1,nq
      do j=1,nz
        usol_out(i,j) = usol(i,j)
      enddo
    enddo

    ! the flux lots of stuff below
    call dochem(0, nr, nsp2, nq, nz, usol, A, isl, jtrop, D, fval)
    DO K=1,NQ
      DO I=1,NZ
      D(K,I) = USOL(K,I)*DEN(I)
      enddo
      DO I=1,NZ-1
        FLUXO(K,I) = - DK(I)*(USOL(K,I+1) - USOL(K,I))/DZ(I)
      enddo
    enddo

    if(NP.GT.0) THEN
      do k=1,np
        do I=1,NZ1
          LL=NQ-NP+K
          WNF = 0.5*(WFALL(I,K)*DEN(I)*USOL(LL,I) + WFALL(I+1,K)*DEN(I+1) &
            *USOL(LL,I+1))
          FLUXO(LL,I) = FLUXO(LL,I) - WNF
        enddo
      enddo
    endif

    do i=1,NZ-1
      do j=1,(NQ-NP)
        fluxo(j,i) = fluxo(j,i) &
                    - bX1X2(j,i)*(usol(j,i+1) - usol(j,i))/dz(i) &
                    + bX1X2(j,i)*0.5*(usol(j,i) + usol(j,i+1)) &
                    *(1./H_atm(i) - 1./scale_H(j,i))
      enddo
    enddo

    DO K=1,NQ
      FLOW(K) = FLUXO(K,1) - (YP(K,1) - YL(K,1)*D(K,1))*DZ(1)
      FUP(K) = FLUXO(K,NZ1) + (YP(K,NZ) - YL(K,NZ)*D(K,NZ))*DZ(NZ)
    enddo
    if (fix_water_in_troposphere) then
      FLOW(LH2O) = FLUXO(LH2O,jtrop)
    endif

    DO I=1,NQ
      SR(I) = 0.
      DO J=1,JTROP
        SR(I) = SR(I) + RAINGC(I,J)*USOL(I,J)*DEN(J)*DZ(J)
      enddo
    enddo

    ! redox state
    call redox_conservation(FLOW,FUP,SR)
  endif ! end if converged

end subroutine


C    @(#)sen_bph2.f	20.8 8/30/00
      subroutine sen_bph2 (mode)
c
c     Mode = 0: Partition phase shifters subsystem
c            1: Restore original phase shifter subsystems
c
      include 'ipfinc/parametr.inc'

      include 'ipfinc/addtbx.inc'
      include 'ipfinc/alpha.inc'
      include 'ipfinc/alpha2.inc'
      include 'ipfinc/amtrx.inc'
      include 'ipfinc/area.inc'
      include 'ipfinc/beta.inc'
      include 'ipfinc/blank.inc'
      include 'ipfinc/bus.inc'
      include 'ipfinc/branch.inc'
      include 'ipfinc/dc.inc'
      include 'ipfinc/dcsln.inc'
      include 'ipfinc/ecvar.inc'
      include 'ipfinc/gendrp.inc'
      include 'ipfinc/ikk.inc'
      include 'ipfinc/intbus.inc'
      include 'ipfinc/lfiles.inc'
      include 'ipfinc/ntotzt.inc'
      include 'ipfinc/optim1.inc'
      include 'ipfinc/prt.inc'
      include 'ipfinc/slnopt.inc'
      include 'ipfinc/slnphs.inc'
      include 'ipfinc/tran.inc'
      include 'ipfinc/ordsta.inc'
      include 'ipfinc/phase.inc'

      common /scratch/ numdiff, ixref(MAXBUS), kdiff(2,MAXBUS),
     &                 fdiff(6,MAXBUS), cdiff(2,MAXBUS),
     &                 lphtx(2,MAXPHS), phtx(6,MAXPHS)
      character cdiff * 1

      double precision aim, bim, angle
      complex * 16 y_16(2,2)
      integer kerr, k1, k2, komp_ykm, sect, p, error
      character id * 1
      logical found
      external komp_ykm, swap_ykm

      kerr = 0

      if (mode. eq. 0) then
c
c        Mode = 0: Partition phase shifters subsystem
c
c        Link TXTIE with new bus numbers
c
         do jt = 1, max0 (jphno, ntxtie)
            lphtx(1,jt) = 0
            lphtx(2,jt) = 0
         enddo
         do jt = 1, ntxtie
            do j = 1, 6
               phtx(j,jt) = 0.0
            enddo
         enddo

         icount = iflag(ntot+1)
         ntopt = 0
         do jt = 1,ntxtie
            k1 = txtie(1,jt)
            k2 = txtie(2,jt)
            it = 1
            found = .false.
            do while (it .le. jphno .and. .not. found)
               k = jphid(1, it)
               m = jphid(2, it)
               if (ordvlt .eq. 1) then
                  kt = k
                  mt = m
               else
                  kt = inp2opt(k)
                  mt = inp2opt(m)
               endif
               if (kt .eq. k1 .and. mt .eq. k2) then
                  lphtx(1,it) = jt
                  lphtx(2,jt) = it
                  found = .true.
               else if (kt .eq. k2 .and. mt .eq. k1) then
                  lphtx(1,it) = -jt
                  lphtx(2,jt) = -it
                  found = .true.
               else
                  it = it + 1
               endif
            enddo
            if (k1 .lt. k2) then
               ntopt = ntopt + 1
               txtie(8,jt) = ntopt
            endif
            ltc = txtie(7,jt)
            if (ltc .gt. 0) then
               txtie(4,jt) = tap(ltc)
            else if (ltc .lt. 0) then
               txtie(4,jt) = -tap(-ltc)
            endif
         enddo

         do jt = 1,ntxtie
            k1 = txtie(1,jt)
            k2 = txtie(2,jt)
            if (k1 .lt. k2) then
            else
               found = .false.
               i = 1
               do while (i .le. ntxtie .and. .not. found)
                  if (txtie(1,i) .eq. k2 .and. txtie(2,i) .eq. k1) then
                     found = .true.
                     txtie(8,jt) = -txtie(8,i)
                  else
                     i = i + 1
                  endif
               enddo
            endif
         enddo

         num_nodes = ntot
c
c        First pass - low to high
c
         do jt = 1,ntxtie
            k1 = txtie(1,jt)
            k2 = txtie(2,jt)
            if (k1 .lt. k2) then
               lt = iabs(lphtx(2,jt))
               if (lt .gt. 0) then
                 call getchr(1, id, jphid(3,lt))
                 sect = jphid(4,lt)
                 p = numbrn (opt2inp(k1), opt2inp(k2), id, sect)
               else
                 p = numbrn (opt2inp(k1), opt2inp(k2), '*', 0)
               endif
               if (brtype(p) .eq. 4) p = brnch_nxt(p)
               call pieqiv (p, y_16, error)
               gkm = dreal(y_16(1,2))
               bkm = dimag(y_16(1,2))
               gmk = dreal(y_16(1,1))
               bmk = dimag(y_16(1,1))
               angle = txtie(4,jt)
               it = txtie(8,jt)
               itx = iabs(it)

               ls = km(k1)
               lf = kmlen(k1) + ls - 1
               l = ls
               found = .false.
               do while (l .le. lf .and. .not. found)
                  if (ikmu(l) .eq. k2) then
                     found = .true.
                  else
                     l = l + 1
                  endif
               enddo
               if (.not. found) call erexit()
C
C              Add residual admittance Y_res = 0.01 - j0.05 to
C              prevent singularity.
C
               gkmu(l) = gkmu(l) - gkm - 0.01d0
               bkmu(l) = bkmu(l) - bkm + 0.05d0
               gkku(k1) = gkku(k1) - gmk + 0.01d0
               bkku(k1) = bkku(k1) - bmk - 0.05d0
               pk = pnetu(k1)
               qk = qnetu(k1)
               call nrpqv (k1, pk, dpk, qk, dqk, vk)
               phtx(1,itx) = dpk
               phtx(2,itx) = dqk
c
c              Insert jflag(*) entity for node k1
c
               if (icount .eq. 0) then
                  do i = 1, num_nodes+1
                     iflag(i) = 1
                  enddo
               endif
               do i = k1+1, num_nodes+1
                  iflag(i) = iflag(i) + 1
               enddo
               next = iflag(k1)
               do i = icount, next, -1
                  jflag(1,i+1) = jflag(1,i)
                  jflag(2,i+1) = jflag(2,i)
               enddo
               jflag(1,next) = 11
               jflag(2,next) = jt
               icount = icount + 1
c
c              Add new pseudo-bus
c
               kt = ntot + itx
               num_nodes = kt
               e(kt) = e(k1) * cos(-angle) - f(k1) * sin(-angle)
               f(kt) = e(k1) * sin(-angle) + f(k1) * cos(-angle)
               pnetu(kt) = 0.0
               qnetu(kt) = 0.0
               kvolt(kt) = 0
               gkku(kt) = gmk
               bkku(kt) = bmk
               yptr = yptr + 1
               km(kt) = yptr
               kmlen(kt) = 1
               ikmu(yptr) = k2
               gkmu(yptr) = -gmk
               bkmu(yptr) = -bmk
               pk = pnetu(kt)
               qk = qnetu(kt)
               call nrpqv (kt, pk, dpk, qk, dqk, vk)
               phtx(3,itx) = dpk
               phtx(4,itx) = dqk
c
c              Insert jflag(*) entity for node kt
c
               next = iflag(kt)
               do i = icount, next+1, -1
                  jflag(1,i+1) = jflag(1,i)
                  jflag(2,i+1) = jflag(2,i)
               enddo
               jflag(1,next) = 12
               jflag(2,next) = jt
               icount = icount + 1
               iflag(kt+1) = icount
C
C              Compute initial flow Pkm in branch
C
               mt = ntot + ntopt + itx
               aim = gmk*e(k1) - bmk*f(k1) + gkm*e(k2) - bkm*f(k2)
               bim = gmk*f(k1) + bmk*e(k1) + gkm*f(k2) + bkm*e(k2)
               e(mt) = e(k1)*aim + f(k1)*bim
               f(mt) = -e(k1)*bim + f(k1)*aim
               phtx(1,itx) = phtx(1,itx) - e(mt)
               phtx(2,itx) = phtx(2,itx) - f(mt)
               phtx(3,itx) = phtx(3,itx) + e(mt)
               phtx(4,itx) = phtx(4,itx) + f(mt)
               write (*, 10000) intbus(k1), intbas(k1), intbus(k2),
     &           intbas(k2), e(mt)*bmva, f(mt)*bmva
10000          format (' Phase shifter ', a8, f6.1, 1x, a8, f6.1,
     &           ' S = ', 2f8.1)

            endif
         enddo
c
c        Second pass - high to low
c
         do jt = 1,ntxtie
            k1 = txtie(1,jt)
            k2 = txtie(2,jt)
            if (k1 .gt. k2) then
               lt = iabs(lphtx(2,jt))
               if (lt .gt. 0) then
                 call getchr(1, id, jphid(3,lt))
                 sect = jphid(4,lt)
                 p = numbrn (opt2inp(k1), opt2inp(k2), id, sect)
               else
                 p = numbrn (opt2inp(k1), opt2inp(k2), '*', 0)
               endif
               if (brtype(p) .eq. 4) p = brnch_nxt(p)
               call pieqiv (p, y_16, error)
               gkm = dreal(y_16(1,2))
               bkm = dimag(y_16(1,2))
               gmk = dreal(y_16(1,1))
               bmk = dimag(y_16(1,1))
               angle = txtie(4,jt)
               it = txtie(8,jt)
               itx = iabs(it)

               ls = km(k1)
               lf = kmlen(k1) + ls - 1
               l = ls
               found = .false.
               do while (l .le. lf .and. .not. found)
                  if (ikmu(l) .eq. k2) then
                     found = .true.
                  else
                     l = l + 1
                  endif
               enddo
               if (.not. found) call erexit()
C
C              Replace branch with symmetric admittance, renumber and
C              resort Y-matrix.
C
               ikmu(l) = ntot + itx
               gkmu(l) = gkmu(l) - gkm - gmk
               bkmu(l) = bkmu(l) - bkm - bmk
               call qiksrt(ls, lf, komp_ykm, swap_ykm)
               pk = pnetu(k1)
               qk = qnetu(k1)
               call nrpqv (k1, pk, dpk, qk, dqk, vk)
               phtx(5,itx) = dpk
               phtx(6,itx) = dqk

            endif
         enddo
c
c        Check modelling accuracy
c
         do jt = 1,ntxtie
            k1 = txtie(1,jt)
            k2 = txtie(2,jt)
            it = txtie(8,jt)
            itx = iabs (it)
            mt = ntot + itx
            if (k1 .lt. k2) then
               if (abs(phtx(1,itx)) .gt. 1.0e-2 .or.
     &             abs(phtx(2,itx)) .gt. 1.0e-2) then
                  write (*, 10010) intbus(k1), intbas(k1), phtx(1,itx),
     &               phtx(2,itx)
10010             format (' Phase shift error - terminal 1 ',
     &               a8, f7.1, ' error = ', 2e11.3)
               endif
               if (abs(phtx(3,itx)) .gt. 1.0e-2 .or.
     &             abs(phtx(4,itx)) .gt. 1.0e-2) then
                  write (*, 10020) intbus(k2), intbas(k2), phtx(3,itx),
     &               phtx(4,itx)
10020             format (' Phase shift error - terminal 2 ',
     &               a8, f7.1, ' error = ', 2e11.3)
               endif
               if (abs(phtx(5,itx)) .gt. 1.0e-2 .or.
     &             abs(phtx(6,itx)) .gt. 1.0e-2) then
                  intbus(mt) = intbus(k1)(1:7) // '&'
                  intbas(mt) = intbas(k1)
                  write (*, 10030) intbus(mt), intbas(mt), phtx(5,itx),
     &               phtx(6,itx)
10030             format (' Phase shift error - terminal 0 ',
     &               a8, f7.1, ' error = ', 2e11.3)
               endif
            endif
         enddo

      else
c
c        Mode = 1: Restore original phase shifter subsystems
c
         do jt = 1,ntxtie
            k1 = txtie(1,jt)
            k2 = txtie(2,jt)
            gkm=txtie(5,jt)
            bkm=txtie(6,jt)
            gmk=txtie(9,jt)
            bmk=txtie(10,jt)
            angle = txtie(4,jt)
            it = txtie(8,jt)

            ls = km(k1)
            lf = kmlen(k1) + ls - 1
            l = ls
            found = .false.
            if (k1 .le. k2) then
               kxx = k2
            else
               kxx = ntot + iabs (it)
            endif
            do while (l .le. lf .and. .not. found)
               if (ikmu(l) .eq. kxx) then
                  found = .true.
               else
                  l = l + 1
               endif
            enddo
            if (.not. found) call erexit()
            if (k1 .lt. k2) then
C
C              Restore admittance Y_res = 0.01 - j0.05 to prevent
C              singularity.
C
               gkmu(l) = gkmu(l) + gkm + 0.01d0
               bkmu(l) = bkmu(l) + bkm - 0.05d0
               gkku(k1) = gkku(k1) + gmk - 0.01d0
               bkku(k1) = bkku(k1) + bmk + 0.05d0
               pk = pnetu(kt)
               qk = qnetu(kt)
               call nrpqv (k1, pk, dpk, qk, dqk, vk)

            else
C
C              Restore branch with assymmetric admittance, renumber and
C              resort Y-matrix.
C
               ikmu(l) = k2
               gkmu(l) = gkmu(l) + gkm + gmk
               bkmu(l) = bkmu(l) + bkm + bmk
               call qiksrt(ls, lf, komp_ykm, swap_ykm)
               pk = pnetu(k2)
               qk = qnetu(k2)
               call nrpqv (k2, pk, dpk, qk, dqk, vk)
            endif
         enddo
      endif
      return
      end