module bgrid_integrals_mod

!-----------------------------------------------------------------------
!
!   computes diagnostic integrals for the bgrid dynamical core
!
!-----------------------------------------------------------------------

use bgrid_change_grid_mod, only: change_grid, TEMP_GRID, WIND_GRID
use       bgrid_horiz_mod, only: horiz_grid_type
use        bgrid_vert_mod, only:  vert_grid_type, compute_pres_depth
use       bgrid_masks_mod, only:  grid_mask_type
use    bgrid_prog_var_mod, only:   prog_var_type
use      time_manager_mod, only:  time_type, get_time, set_time,  &
                                  operator(+),  operator(-),      &
                                  operator(==), operator(>=),     &
                                  operator(/=), operator(/),      &
                                  operator(*)

use         fms_mod, only: file_exist, open_namelist_file,        &
                           check_nml_error, write_version_number, &
                           stdout, error_mesg, FATAL, NOTE
use   constants_mod, only: CP_AIR

use         mpp_mod, only: mpp_pe, mpp_root_pe, mpp_max, mpp_min, &
                           mpp_sum, stdlog
use      mpp_io_mod, only: mpp_open, mpp_close, MPP_ASCII,  &
                           MPP_OVERWR, MPP_SEQUENTIAL, MPP_SINGLE
use mpp_domains_mod, only: mpp_global_sum, BITWISE_EXACT_SUM

use  field_manager_mod, only: MODEL_ATMOS
use tracer_manager_mod, only: get_tracer_names, get_number_tracers, &
                              get_tracer_index

implicit none
private

!-----------------------------------------------------------------------
!------ interfaces ------

public :: bgrid_integrals, bgrid_integrals_init, bgrid_integrals_end, global_integral

!-----------------------------------------------------------------------
!--------------------- namelist ----------------------------------------

   integer, parameter :: MXCH = 64 ! maximum length of file names

! file_name  = optional file name for output (max length of 64 chars);
!              if no name is specified (the default) then
!              standard output will be used
!                 [character, default: filename  = ' ']

   character(len=MXCH) :: file_name = ' '

! time_units = specifies the time units used for time,
!              the following values are valid strings
!                 time_units = 'seconds'
!                            = 'minutes'
!                            = 'hours'   (default)
!                            = 'days'

   character(len=8) :: time_units = 'hours'

! output_interval = time interval in units of "time_units" for
!                   global b-grid integral diagnostics;
!                   * if an interval of zero is specified then no
!                     diagnostics will be generated
!                       [real, default: output_interval = 0.0]

   real :: output_interval = 0.0

! chksum_file_name = Optional file name for global integral output in
!                    hexadecimal format.  If this file name is set, then
!                    both the hexadecimal output and standard integral
!                    output will be computed using bit-reproducible summations.

   character(len=MXCH) :: chksum_file_name = ' '

! tracer_file_name = Optional file name for global integrals of all tracers.
!                    Up to 99 tracer integrals can be output in this file.

   character(len=MXCH) :: tracer_file_name = ' '

! trsout = Tracer names to be output in the standard integral file.
!          Only up to 4 names can be specified. For more tracer integrals
!          use the "tracer_file_name" option above.
!          A default has been set for the standard atmospheric model runs.

   integer, parameter :: MXTRS = 4
   character(len=MXCH) :: trsout(MXTRS) = &
                           (/'sphum  ','liq_wat','ice_wat','cld_amt'/)

   namelist /bgrid_integrals_nml/ output_interval, time_units,  &
                                  file_name, chksum_file_name,  &
                                  trsout, tracer_file_name

!-----------------------------------------------------------------------
! private interface

interface global_integral
  module procedure global_integral_2d, global_integral_3d
end interface

!-----------------------------------------------------------------------

   type (time_type) :: Next_diag_time, Output_diag_interval,  &
                       Base_time, Zero_time

   integer :: diag_unit   = 0
   integer :: chksum_unit = 0
   integer :: tracer_unit = 0
   logical :: alarm_set  = .false.
   logical :: do_init    = .true.
   logical :: do_header  = .true.
   logical :: do_chksum  = .false.
   logical :: do_decomp_check = .true.

   character(len=128) :: version = '$Id: bgrid_integrals.f90,v 13.0 2006/03/28 21:05:00 fms Exp $'
   character(len=128) :: tag = '$Name: latest $'

   character(len=256) :: frmat   ! format used for standard intergals

! output for tracers
   integer :: ntrout=-1, indout(MXTRS)

! output options
   integer, parameter :: STANDARD=11  ! new format: min temp and TE
   integer, parameter :: TRACER1 =12  ! detailed tracer 1 (for conservation checks)
   integer, parameter :: KENERGY =13  ! old format: zonal mean and eddy KE
   integer :: output_option = STANDARD

! quantities accumulated over the output period
   real :: windspeed_max
   real :: temperature_min
   integer :: num_in_avg  ! not actually used
!-----------------------------------------------------------------------

contains

!#######################################################################

 subroutine bgrid_integrals (Time, Hgrid, Vgrid, Var, Masks)

!-----------------------------------------------------------------------
!  Time  = current/diagnostics time
!  Hgrid = horizontal grid constants
!  Vgrid = vertical grid constants
!  Var   = prognostic variables
!  Masks = grid box masking constants (for eta coordinate)
!-----------------------------------------------------------------------

   type (time_type),      intent(in) :: Time
   type(horiz_grid_type), intent(in) :: Hgrid
   type (vert_grid_type), intent(in) :: Vgrid
   type  (prog_var_type), intent(in) :: Var
   type (grid_mask_type), intent(in) :: Masks

!-----------------------------------------------------------------------

   real, dimension (Hgrid%ilb:Hgrid%iub,          &
                    Hgrid%jlb:Hgrid%jub, Var%nlev) :: dpde, dpde_xy, avg
   real, dimension (Hgrid%ilb:Hgrid%iub,          &
                    Hgrid%jlb:Hgrid%jub)           :: pssl_xy, ps_xy

   real :: avgps, avgke, avgzke, avgeke, avgens, avgtemp, avgpsv, avgte
   real ::  xtime, vmax, tmin
  integer :: i, j, k, n, ntmax, nout, ind

     real, dimension(Var%ntrace) :: avgtrace
     real, dimension(MXTRS)      :: avgtrout
  character(len=21) :: fmt

!-----------------------------------------------------------------------

  if (do_init) call error_mesg ('bgrid_integrals_mod',  &
                                'must call bgrid_integrals_init', FATAL)

! no diagnostics
  if (Output_diag_interval == Zero_time) return
!-----------------------------------------------------------------------
!  the following quantities represent averages over the output period:
!          windspeed_max, temperature_min
!-----------------------------------------------------------------------
! maximum wind speed (use dpde_xy as temp storage)
! get local maximum on current PE then across PEs

  dpde_xy(:,:,:) = sqrt(Var%u(:,:,:)*Var%u(:,:,:)+  &
                        Var%v(:,:,:)*Var%v(:,:,:))

  vmax = maxval (dpde_xy(Hgrid%Vel%is:Hgrid%Vel%ie, Hgrid%Vel%js:Hgrid%Vel%je, :))
  call mpp_max (vmax)
  windspeed_max = max(windspeed_max,vmax)

! minimum temperature

  if (Masks%sigma) then
      tmin = minval (Var%t(Hgrid%Tmp%is:Hgrid%Tmp%ie, Hgrid%Tmp%js:Hgrid%Tmp%je, :))
  else
      tmin = minval (Var%t(Hgrid%Tmp%is:Hgrid%Tmp%ie, Hgrid%Tmp%js:Hgrid%Tmp%je, :), &
       mask=Masks%Tmp%mask(Hgrid%Tmp%is:Hgrid%Tmp%ie, Hgrid%Tmp%js:Hgrid%Tmp%je, :) > .1 )
  endif
  call mpp_min (tmin)
  temperature_min = min(temperature_min,tmin)

! increment counter (not actually used for computing averages)

  num_in_avg = num_in_avg + 1

!-----------------------------------------------------------------------
! check output alarm

  if ( .not. bgrid_integrals_alarm(Time) ) return

!-----------------------------------------------------------------------
! if there is decomposition along x-axis you will not get the
! correct integrals for zonal mean and eddy kinetic energy

  if (do_decomp_check) then
    if (mpp_pe() == mpp_root_pe()) then
      if ( Hgrid%decompx .and. output_option == KENERGY ) then
           call error_mesg ('bgrid_integrals',                    &
             'checksum integrals of zonal and eddy KE will not be &
              &exact with x-axis decomposition', NOTE )
      endif
    endif
    do_decomp_check = .false.
  endif

!-----------------------------------------------------------------------
!  the following quantities represent instantaneous values at the
!  end of the output period:   global-average pressure, temperature,
!              kinetic energy, total energy, enstrophy, and tracers.
!-----------------------------------------------------------------------
! compute pressure weights on mass grid and velocity grid

  call compute_pres_depth (Vgrid, Var%pssl, dpde)
  call change_grid        (Hgrid, TEMP_GRID, WIND_GRID, dpde, dpde_xy)

! global average of surface pressure on mass and velocity grid

  avgps  = global_integral (Hgrid, 1, Var%ps,  do_exact=do_chksum)
  avgpsv = global_integral (Hgrid, 2, dpde_xy, do_exact=do_chksum)

! global average of various kinetic energy terms
! normalize with mean global mass

  if (output_option == KENERGY) then
      call kinetic_energy (Hgrid, Masks, dpde_xy, Var%u, Var%v, avgke, avgzke, avgeke )
      avgke  = avgke /avgpsv  ! total ke
      avgzke = avgzke/avgpsv  ! zonal mean ke
      avgeke = avgeke/avgpsv  ! eddy ke
  else
      call kinetic_energy (Hgrid, Masks, dpde_xy, Var%u, Var%v, avgke )
      avgke  = avgke /avgpsv  ! total ke
  endif

! global average of enstrophy on mass grid
! scale result

  call enstrophy (Hgrid, Masks, dpde, dpde_xy, Var%u, Var%v, avgens)
  avgens = 1.e10*avgens/avgps

! global average of temperature

   avg = Var%t * dpde
   avgtemp = global_integral(Hgrid, 1, avg, Masks, do_chksum) / avgps

! total energy (cp*T+KE)

   avgte = CP_AIR * avgtemp + avgke

! global average of tracer fields

 ! compute integrals for all tracers?
   if (tracer_file_name(1:1) .ne. ' ') then
      do n = 1, Var%ntrace
         avg = Var%r(:,:,:,n) * dpde
         avgtrace(n) = global_integral(Hgrid, 1, avg, Masks, do_chksum) / avgps
      enddo
   endif

 ! determine indices for output tracers (first time only)
   if (ntrout < 0) then
      ntmax = min(MXTRS,Var%ntrace)
      if (output_option == TRACER1) ntmax = 1
      ntrout = 0
    ! first output namelist tracers
      do n = 1, ntmax
         ind = get_tracer_index ( MODEL_ATMOS, trim(trsout(n)) )
         if (ind <= 0) cycle
         ntrout = ntrout+1
         indout(ntrout) = ind
      enddo
    ! then add additional output tracers (if possible)
      if (ntrout < ntmax .and. ntrout < Var%ntrace) then
          do ind = 1, Var%ntrace
             ! checking current list
             do n = 1, ntrout
                if (ind == indout(n)) go to 10
             enddo
             ! adding new tracer index
             ntrout = ntrout + 1
             indout(ntrout) = ind
             if (ntrout == ntmax) exit
          10 continue
          enddo
      endif
   endif

 ! compute integrals for output tracers in B-grid integral file
   do n = 1, ntrout
      if (tracer_file_name(1:1) .ne. ' ') then
          avgtrout(n) = avgtrace(indout(n))
      else
          avg = Var%r(:,:,:,indout(n)) * dpde
          avgtrout(n) = global_integral(Hgrid, 1, avg, Masks, do_chksum) / avgps
      endif
   enddo

! tracer conservation debugging option
   nout = ntrout
   if (output_option == TRACER1 .and. nout == 1) then
      if (indout(1) > 0) then
         avgtrout(2) = minval(Var%r(:,:,:,indout(1)))
         avgtrout(3) = maxval(Var%r(:,:,:,indout(1)))
         call mpp_min (avgtrout(2))
         call mpp_max (avgtrout(3))
         nout = 3
      endif
   endif

!-----------------------------------------------------------------------
! increment diagnostics alarm

  Next_diag_time = Next_diag_time + Output_diag_interval

!-----------------------------------------------------------------------
! output on root PE only

 if ( mpp_pe() == mpp_root_pe() ) then

      xtime = get_axis_time (Time, time_units)

      if (do_header) call diag_header

      select case (output_option)
         case (STANDARD)
            write (diag_unit,trim(frmat)) xtime, avgps, avgtemp, temperature_min, &
                                          windspeed_max, avgke, avgte, avgens,    &
                                          (avgtrout(n),n=1,nout)
         case (TRACER1)
            write (diag_unit,trim(frmat)) xtime, avgps, avgtemp, temperature_min, &
                                          windspeed_max, avgke, avgte, avgens,    &
                                          (avgtrout(n),n=1,nout)
         case (KENERGY)
            write (diag_unit,trim(frmat)) xtime, avgps, avgtemp, windspeed_max, &
                                          avgke, avgzke, avgeke, avgens,        &
                                          (avgtrout(n),n=1,nout)
      end select

      if (do_chksum) then
          write (chksum_unit,8200) xtime, avgps, avgtemp, windspeed_max, avgens, &
                                   avgke, (avgtrout(n),n=1,min(nout,1))
 8200     format (1x,f10.2,2x,6z18)
      endif

!---- output additional tracers ----

     if (tracer_file_name(1:1) .ne. ' ') then
!        ---- open file, write header ----
         if (tracer_unit == 0) then
             call  mpp_open (tracer_unit, trim(tracer_file_name), &
                             form=MPP_ASCII, action=MPP_OVERWR,   &
                             access=MPP_SEQUENTIAL, threading=MPP_SINGLE, &
                             nohdrs=.true.)
             write (tracer_unit,8300)
         endif
         ! output up to 99 tracers
         write (fmt,8310) min(Var%ntrace,99)
         write (tracer_unit,fmt) xtime, (avgtrace(n),n=1,min(Var%ntrace,99))
     endif

 8300 format ('#',6x,'n', 8x, 'tracers --->')
 8310 format ('(1x,f10.2,2x,',i2.2,'e13.6)')

 endif

! reset
  windspeed_max   = 0.
  temperature_min = 500.
  num_in_avg      = 0
!-----------------------------------------------------------------------

 end subroutine bgrid_integrals

!#######################################################################

 subroutine bgrid_integrals_init (Time_init, Time)

!----------------------------------------------------
!  Time_init = base time for experiment
!                the base time will be subtracted from all
!                specified times before that time is output/written.
!  Time      = current time
!----------------------------------------------------

    type (time_type), intent(in) :: Time_init, Time

    integer :: unit, io, ierr, seconds, nc
    type (time_type) :: Time_dif, Last_diag

!-----------------------------------------------------------------------
!       ----- read namelist -----
!      ----- write namelist (to standard output) -----

      if ( file_exist('input.nml')) then
         unit = open_namelist_file ( )
         ierr=1; do while (ierr /= 0)
            read  (unit, nml=bgrid_integrals_nml, iostat=io, end=10)
            ierr = check_nml_error (io, 'bgrid_integrals_nml')
         enddo
  10     call mpp_close (unit)
      endif

      call write_version_number (version,tag)
      if (mpp_pe() == mpp_root_pe()) write (stdlog(), nml=bgrid_integrals_nml)
      do_init = .false.

!----- initialize alarm if not already done -----

      Zero_time = set_time (0,0)
      Base_time = Time_init

    ! set output interval
      if ( output_interval > 0.0 ) then
         Output_diag_interval = set_axis_time (output_interval, time_units)
      else
       ! no diagnostics
         Output_diag_interval = Zero_time
      endif
      if ( Output_diag_interval == Zero_time ) return

    ! current diag time (base time subtracted off)
      Time_dif  = Time - Base_time
    ! last time of diagnostics
      Last_diag = (Time_dif/Output_diag_interval)*Output_diag_interval
      if ( Last_diag == Time_dif ) then
            Next_diag_time = Last_diag ! repeat diag at start of run
      else
            Next_diag_time = Last_diag + Output_diag_interval
      endif

!--- initialize diagnostics output unit/file ? ----

      if ( file_name(1:1) /= ' ' ) then
          call  mpp_open (diag_unit, trim(file_name), form=MPP_ASCII, &
                          action=MPP_OVERWR, access=MPP_SEQUENTIAL,   &
                          threading=MPP_SINGLE, nohdrs=.true.)
      else
          diag_unit = stdout()
      endif

      if ( chksum_file_name(1:1) /= ' ' ) then
          call  mpp_open (chksum_unit, trim(chksum_file_name),  &
                          form=MPP_ASCII, action=MPP_OVERWR,    &
                          access=MPP_SEQUENTIAL, threading=MPP_SINGLE, &
                          nohdrs=.true.)
        do_chksum = .true.
      endif

! reset quantities accumulated over the output period
! NOTE: will need a restart file if the end of the output period
!       does not coincide with the end of the model run.

  windspeed_max   = 0.
  temperature_min = 500.
  num_in_avg      = 0

!-----------------------------------------------------------------------

 end subroutine bgrid_integrals_init

!#######################################################################

 subroutine bgrid_integrals_end

! close all open units
  if (  diag_unit > 0 .and. diag_unit /= stdout()) &
                       call mpp_close (diag_unit)
  if (chksum_unit > 0) call mpp_close (chksum_unit)
  if (tracer_unit > 0) call mpp_close (tracer_unit)

! need to write a restart file if the end of the output period
! does not coincide with the end of the model run

  if (num_in_avg > 0 .and. mpp_pe() == mpp_root_pe()) then
   ! print a note for now
     call error_mesg ('bgrid_integrals_mod',  &
          'end of the output period did not coincide &
           &with the end of the model run', NOTE)
  endif

 end subroutine bgrid_integrals_end

!#######################################################################

 function bgrid_integrals_alarm (Time) result (answer)

    type (time_type), intent(in) :: Time
    logical                      :: answer

!-----------------------------------------------------------------------
!----- check the diagnostics alarm -----

      answer = .false.

!----- sound the diagnostics alarm -----

      if (Time - Base_time >= Next_diag_time) answer = .true.

 end function bgrid_integrals_alarm

!#######################################################################

 subroutine diag_header

 character(len=24) :: lab_time, lab_ps, lab_tavg, lab_tmin, lab_vmax, &
                      lab_ke, lab_zke, lab_eke, lab_te, lab_ens,      &
                      lab_trs, lab_tr1
 character(len=24) :: fmt_time, fmt_ps, fmt_tavg, fmt_tmin, fmt_vmax, &
                      fmt_ke, fmt_zke, fmt_eke, fmt_te, fmt_ens,      &
                      fmt_trs, fmt_tr1
 character(len=256) :: title
 character(len=64)  :: lab_tr, trname
 integer :: n

 lab_time = '''#'',5x,''n'',3x,' ; fmt_time = 'f10.2'
 lab_ps   = '5x,''ps'',4x,'      ; fmt_ps   = ',1x,f10.3'
 lab_tavg = '3x,''tavg'',1x,'    ; fmt_tavg = ',1x,f7.3'
 lab_tmin = '3x,''tmin'',1x,'    ; fmt_tmin = ',1x,f7.3'
 lab_vmax = '3x,''vmax'',2x,'    ; fmt_vmax = ',1x,f8.4'
 lab_ke   = '4x,''ke'',2x,'      ; fmt_ke   = ',1x,f7.2'
 lab_zke  = '4x,''zke'',1x,'     ; fmt_zke  = ',1x,f7.2'
 lab_eke  = '4x,''eke'',1x,'     ; fmt_eke  = ',1x,f7.2'
 lab_te   = '5x,''te'',4x,'      ; fmt_te   = ',1x,f10.3'
 lab_ens  = '6x,''ens'',5x,'     ; fmt_ens  = ',1x,e13.6'
 lab_trs  = '3x'                 ; fmt_trs  = ',2x,4e13.6'
!lab_trs  = '7x,''trs --->'''    ; fmt_trs  = ',2x,4e13.6'
 lab_tr1  = '7x,''tr1 --->'''    ; fmt_tr1  = ',1x,3e22.14'

 select case (output_option)

   case (STANDARD)
     title = '('//trim(lab_time)//trim(lab_ps)//trim(lab_tavg) &
                //trim(lab_tmin)//trim(lab_vmax)//trim(lab_ke) &
                //trim(lab_te)//trim(lab_ens)//trim(lab_trs)
     frmat = '('//trim(fmt_time)//trim(fmt_ps)//trim(fmt_tavg) &
                //trim(fmt_tmin)//trim(fmt_vmax)//trim(fmt_ke) &
                //trim(fmt_te)//trim(fmt_ens)//trim(fmt_trs)//')'

   case (KENERGY)
     title = '('//trim(lab_time)//trim(lab_ps)//trim(lab_tavg) &
                //trim(lab_vmax)//trim(lab_ke)//trim(lab_zke)  &
                //trim(lab_eke)//trim(lab_ens)//trim(lab_trs)
     frmat = '('//trim(fmt_time)//trim(fmt_ps)//trim(fmt_tavg) &
                //trim(fmt_vmax)//trim(fmt_ke)//trim(fmt_zke)  &
                //trim(fmt_eke)//trim(fmt_ens)//trim(fmt_trs)//')'

   case (TRACER1)
     title = '('//trim(lab_time)//trim(lab_ps)//trim(lab_tavg) &
                //trim(lab_tmin)//trim(lab_vmax)//trim(lab_ke) &
                //trim(lab_te)//trim(lab_ens)//trim(lab_trs)
     frmat = '('//trim(fmt_time)//trim(fmt_ps)//trim(fmt_tavg) &
                //trim(fmt_tmin)//trim(fmt_vmax)//trim(fmt_ke) &
                //trim(fmt_te)//trim(fmt_ens)//trim(fmt_tr1)//')'

 end select

   ! labels for tracers
     do n = 1, ntrout
        call get_tracer_names (MODEL_ATMOS,indout(n),trname)
        lab_tr = '4x,'//trim(trname)//''
        write (lab_tr,10) trim(trname)
     10 format (',2x,''',a9,''',2x')
        title = trim(title)//trim(lab_tr)
     enddo
     if (output_option == TRACER1) title = trim(title)//',''(avg,min,max)'''
     title = trim(title)//')'
    !if (mpp_pe() == mpp_root_pe()) print *, 'title=',trim(title)

   ! write the header/labels
     write (diag_unit,trim(title))

   ! for the exact integral file
     if (do_chksum) then
         write (chksum_unit,8002)
     endif
8002 format ('#',6x,'n', 14x, 'ps',  15x,  'temp', 13x, 'max vel', &
                         12x, 'ens', 16x, 'ke', 13x, 'tracer 1')

 do_header = .false.

 end subroutine diag_header

!#######################################################################

 subroutine kinetic_energy (Hgrid, Masks, dpde, u, v,   &
                            gke, gmke, geke )

 type(horiz_grid_type), intent(in)                     :: Hgrid
 type (grid_mask_type), intent(in)                     :: Masks
 real, intent(in) , dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: dpde, u, v
 real, intent(out)                                     :: gke
 real, intent(out), optional                           :: gmke, geke
!-----------------------------------------------------------------------

   real, dimension (Hgrid%ilb:Hgrid%iub, Hgrid%jlb:Hgrid%jub,  &
                    size(u,3)) :: ke, mke, eke
   real, dimension (Hgrid%ilb:Hgrid%iub) :: ustar, vstar
   real    :: usum, vsum, wsum, uavg, vavg
   integer :: i, j, k, is, ie

!-----------------------------------------------------------------------
!---- zero out quantities ----

      mke = 0.;  eke = 0.

!---- total kinetic energy (2x) ----

      ke(:,:,:) = dpde(:,:,:)*(u(:,:,:)**2+v(:,:,:)**2)
      gke = global_integral (Hgrid, 2,  ke, Masks, do_chksum) * 0.50

!---- compute mean zonal and eddy kinetic energy -----

      if (.not.present(gmke) .and. .not.present(geke)) return

      is=Hgrid%Vel%is
      ie=Hgrid%Vel%ie

      do k = 1, size(u,3)
      do j = Hgrid%Vel%js, Hgrid%Vel%je

         wsum = sum(Masks%Vel%mask(is:ie,j,k))

         if (wsum > 0.50) then
          ! zonal mean
            usum = sum(Masks%Vel%mask(is:ie,j,k)*u(is:ie,j,k))
            vsum = sum(Masks%Vel%mask(is:ie,j,k)*v(is:ie,j,k))
            uavg = usum/wsum
            vavg = vsum/wsum

          ! zonal eddy components
            ustar(:) = u(:,j,k)-uavg
            vstar(:) = v(:,j,k)-vavg

          ! zonal mean ke (2x)
            mke(:,j,k) = dpde(:,j,k)*(uavg**2+vavg**2)
          ! eddy ke (2x)
            eke(:,j,k) = dpde(:,j,k)*(ustar(:)**2+vstar(:)**2)
         else
            mke(:,j,k) = 0.0
            eke(:,j,k) = 0.0
         endif

      enddo
      enddo

    ! 3-dim global integrals
      if (present(gmke)) &
          gmke = global_integral (Hgrid, 2, mke, Masks, do_chksum) * 0.50
      if (present(geke)) &
          geke = global_integral (Hgrid, 2, eke, Masks, do_chksum) * 0.50

!-----------------------------------------------------------------------

 end subroutine kinetic_energy

!#######################################################################

 subroutine enstrophy (Hgrid, Masks, dpde, dpde_xy, u, v, avgens)

!-----------------------------------------------------------------------
   type(horiz_grid_type), intent(in)       :: Hgrid
   type (grid_mask_type), intent(in)       :: Masks
      real, intent(in), dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: dpde,  &
                                                          dpde_xy, u, v
      real, intent(out) :: avgens
!-----------------------------------------------------------------------

   real, dimension (Hgrid%ilb:Hgrid%iub, Hgrid%jlb:Hgrid%jub, size(u,3)) :: ens

   real, dimension (Hgrid%ilb:Hgrid%iub, Hgrid%jlb:Hgrid%jub) :: &
                                            vdy,  udx, avdy, audx, vort
   real, dimension (Hgrid%jlb:Hgrid%jub) :: fens

   integer :: i, j, k, is, ie, js, je
   real    :: dysq

!-----------------------------------------------------------------------

      is = Hgrid%Tmp%is;  ie = Hgrid%Tmp%ie
      js = Hgrid%Tmp%js;  je = Hgrid%Tmp%je

!-----------------------------------------------------------------------

      ens = 0.0;  vort = 0.0
      fens = 0.25*Hgrid%Tmp%rarea*Hgrid%Tmp%rarea

      do k = 1, size(u,3)

         do j = js-1, je
            vdy(:,j) = v(:,j,k)*dpde_xy(:,j,k)*Hgrid%Vel%dy
            udx(:,j) = u(:,j,k)*dpde_xy(:,j,k)*Hgrid%Vel%dx(j)
         enddo

         do j = js,   je
         do i = is-1, ie
            avdy(i,j) = vdy(i,j-1)+vdy(i,j)
         enddo
         enddo
         do j = js-1, je
         do i = is,   ie
            audx(i,j) = udx(i-1,j)+udx(i,j)
         enddo
         enddo

!        ------ vorticity * dpde_xy * area ------
         do j = js, je
         do i = is, ie
            vort(i,j)=((avdy(i,j)-avdy(i-1,j))-(audx(i,j)-audx(i,j-1)))
         enddo
         enddo

!        ------ enstrophy ------
         do j = js, je
            ens(:,j,k) = vort(:,j)*vort(:,j)*fens(j)/dpde(:,j,k)
         enddo

      enddo

!-----------------------------------------------------------------------

      avgens = global_integral (Hgrid, 1, ens, Masks, do_chksum)

!-----------------------------------------------------------------------

 end subroutine enstrophy

!#######################################################################
!#######################################################################

function get_axis_time (Time, units) result (atime)

   type(time_type),  intent(in) :: Time
   character(len=*), intent(in) :: units
   real                         :: atime
   integer                      :: sec, day

!---- returns real time in the time axis units ----
!---- convert time type to appropriate real units ----

      call get_time (Time-Base_time, sec, day)

      if (units(1:3) == 'sec') then
         atime = float(sec) + 86400.*float(day)
      else if (units(1:3) == 'min') then
         atime = float(sec)/60. + 1440.*float(day)
      else if (units(1:3) == 'hou') then
         atime = float(sec)/3600. + 24.*float(day)
      else if (units(1:3) == 'day') then
         atime = float(sec)/86400. + float(day)
      endif

end function get_axis_time

!#######################################################################

function set_axis_time (atime, units) result (Time)

   real,             intent(in) :: atime
   character(len=*), intent(in) :: units
   type(time_type)  :: Time
   integer          :: sec, day = 0

!---- returns time type given real time in axis units ----
!---- convert real time units to time type ----

      if (units(1:3) == 'sec') then
         sec = int(atime + 0.5)
      else if (units(1:3) == 'min') then
         sec = int(atime*60. + 0.5)
      else if (units(1:3) == 'hou') then
         sec = int(atime*3600. + 0.5)
      else if (units(1:3) == 'day') then
         sec = int(atime*86400. + 0.5)
      endif

!     --- do not add in base time ---

      Time = set_time (sec, day)

end function set_axis_time

!#######################################################################
!####### global averaging routines for the bgrid model #################
!#######################################################################

function global_integral_2d (Hgrid, grid, data, do_exact)  &
                     result (avg)

   type(horiz_grid_type), intent(in) :: Hgrid
integer, intent(in)  :: grid
   real, intent(in)  :: data(Hgrid%ilb:,Hgrid%jlb:)
logical, intent(in), optional :: do_exact
   real :: avg

   real, dimension(Hgrid%ilb:Hgrid%iub,Hgrid%jlb:Hgrid%jub) :: aa
   real :: asum, wsum
integer :: i, j, isd, ied, vsd, ved
logical :: bitwise_exact

!-----------------------------------------------------------------------

   bitwise_exact = .false.
   if (present(do_exact)) bitwise_exact = do_exact

!  average on mass grid
   select case (grid)
      case(1)
        do j = Hgrid%Tmp%jsd, Hgrid%Tmp%jed
        do i = Hgrid%Tmp%isd, Hgrid%Tmp%ied
           aa(i,j)= data(i,j) * Hgrid%Tmp%area(j)
        enddo
        enddo
        if ( bitwise_exact ) then
            asum = mpp_global_sum ( Hgrid%Tmp%Domain, aa, flags=BITWISE_EXACT_SUM )
        else
            asum = mpp_global_sum ( Hgrid%Tmp%Domain, aa )
        endif
            wsum = Hgrid%Tmp%areasum

!  average on velocity grid
      case(2:3)
      ! must pass data domain to mpp_global_sum
        isd = Hgrid%Vel%isd;  ied = Hgrid%Vel%ied
        vsd = Hgrid%Vel%jsd;  ved = Hgrid%Vel%jed
        do j = vsd, ved
        do i = isd, ied
           aa(i,j)= data(i,j) * Hgrid%Vel%area(j)
        enddo
        enddo
        if ( bitwise_exact ) then
            asum = mpp_global_sum ( Hgrid%Vel%Domain, aa(isd:ied,vsd:ved), &
                                    flags=BITWISE_EXACT_SUM )
        else
            asum = mpp_global_sum ( Hgrid%Vel%Domain, aa(isd:ied,vsd:ved) )
        endif
            wsum = Hgrid%Vel%areasum

   end select

   if (wsum <= 0.0) call error_mesg ('global_integral_2d in bgrid_integrals_mod', &
                                     'wsum=0', FATAL)

   avg = asum/wsum

end function global_integral_2d

!#######################################################################

function global_integral_3d (Hgrid, grid, data, Masks, do_exact)  &
                     result (avg)

type(horiz_grid_type), intent(in) :: Hgrid
integer,               intent(in) :: grid
real,                  intent(in) :: data(Hgrid%ilb:,Hgrid%jlb:,:)
type (grid_mask_type), intent(in), optional :: Masks
logical,               intent(in), optional :: do_exact
real :: avg
real, dimension(size(data,1),size(data,2)) :: aa

!-----------------------------------------------------------------------

 if (present(Masks)) then
   select case (grid)
      case(1)
         aa = sum( data*Masks%Tmp%mask, dim=3 )
      case(2:3)
         aa = sum( data*Masks%Vel%mask, dim=3 )
   end select
 else
         aa = sum( data, dim=3 )
 endif

   avg = global_integral_2d (Hgrid, grid, aa, do_exact)

!-----------------------------------------------------------------------

end function global_integral_3d

!#######################################################################
!#######################################################################

end module bgrid_integrals_mod


  subroutine preequilibriumInterface (gsmObj, gsmRxn, gsmNucleus, &
       & exciton)

! ======================================================================
!
!    Interface to create a preequilibrium class and then simulate it.
!
!    Called by: simulateDecay
!
!    Calls: Preequilibrium, simulate, ststcs, restor1
!
!    CEM95 written by S. G. Mashnik
!    Edited by A. J. Sierk,  LANL  T-2  February, 1996.
!    Edited by A. J. Sierk,  LANL  T-2  November, 1997.
!    Modified by AJS, February-March, 1999.
!    Modified by SGM to include reduced masses, 1999
!    Modified by SGM at 06/16/2000
!    Last modification by SGM of 04/27/01, to get the module for CEM2k
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Modified by A. J. Sierk, LANL T-16, October, 2003.
!    Modified by K. K. Gudima, December, 2004.
!    Edited by AJS, January, 2005.
!    Edited by SGM 07/09/06 to account for the KKG 06/23/06 changes
!      to use Fermi break-up model in Preco and Evap when A < 13.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!    Modified by LMK, 2014-2015, for expanison of preeq to heavy ions
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64, int64
    use gsm_params, only: zro, thousand
    use preequilibriumClass, only : &
         & Preeq => Preequilibrium, &
         & preequilibriumResults, newPreequilibriumResults, &
         & preequilibriumFragment, residualNucleus, preeqExcitonData, &
         ! Flags for progeny origin:
         & preequilibriumProgeny, fermiBreakUpProgenyType, &
         ! Flags for state of the residual nucleus:
         & residualState, compoundState, stableState, fermiBreakupState
    use gsm_derived_types, only: nucleus

    ! Excited Residual Nucleus (ERN) Properties:
    implicit none
    class(GSM),         intent(inout) :: gsmObj
    class(GSMReaction), intent(inout) :: gsmRxn
    type(nucleus),      intent(inout) :: gsmNucleus
    type(excitonData),  intent(in   ) :: exciton

    integer(int32) :: kfr, particleID, prodMech

    ! For the simulation:
    type(residualNucleus) :: excitedResidual
    type(preeqExcitonData) :: preeqExc
    type(preequilibriumFragment), dimension( nint(gsmNucleus%ap) ) :: progenyBnk
    type(preequilibriumResults) :: preeqRes

    type(GSMResults), pointer:: results => NULL()

! ======================================================================

    ! Setup residual data type based on the passed in residual
    excitedResidual%numBaryons  = gsmNucleus%ap
    excitedResidual%numProtons  = gsmNucleus%zp
    excitedResidual%kinEnergy   = gsmNucleus%up
    ! (Linear Momentum)
    excitedResidual%linearMomX = gsmNucleus%pnx
    excitedResidual%linearMomY = gsmNucleus%pny
    excitedResidual%linearMomZ = gsmNucleus%pnz
    ! (Angular Momentum)
    excitedResidual%angularMom(1) = gsmNucleus%elx
    excitedResidual%angularMom(2) = gsmNucleus%ely
    excitedResidual%angularMom(3) = gsmNucleus%elz
    excitedResidual%angMomFlag    = gsmNucleus%ln
    ! (Fission barrier height)
    excitedResidual%fissBarr = gsmNucleus%bf0

    ! Exciton data:
    preeqExc%numTotal    = exciton%numTotal
    preeqExc%numNucleons = dble(exciton%numProtons + exciton%numNeutrons)
    preeqExc%numProtons  = dble(exciton%numProtons)
    preeqExc%numHoles    = dble(exciton%numHoles)

    ! Construct results object:
    preeqRes = newPreequilibriumResults( progenyBnk )

    ! Simulate preequilibrium physics
    call gsmRxn%models%preeq%simulate(excitedResidual, preeqExc, preeqRes)

    ! Check for errors during the simulation:
    if ( preeqRes%simState > 0 ) then
       if ( preeqRes%simState == 1 ) then
          ! Preeq. process didn't finish (to few available progeny elements in the bank)
          write(gsmObj%io%message, 3000)
          call gsmObj%io%print(3, 3, gsmObj%io%message)
       else if ( preeqRes%simState == 10 ) then
          ! Preeq. object wasn't constructed
          write(gsmObj%io%message, 3600)
          call gsmObj%io%print(1, 1, gsmObj%io%message)
          write(gsmObj%io%message, 3999)
          call gsmObj%io%print(1, 1, gsmObj%io%message)
          stop
       else if ( preeqRes%simState == 11 ) then
          ! Preeq. data object failed to construct
          write(gsmObj%io%message, 3700)
          call gsmObj%io%print(1, 1, gsmObj%io%message)
          write(gsmObj%io%message, 3999)
          call gsmObj%io%print(1, 1, gsmObj%io%message)
          stop
       else if ( preeqRes%simState == 12 ) then
          ! PreeqRes object failed to construct
          write(gsmObj%io%message, 3800)
          call gsmObj%io%print(1, 1, gsmObj%io%message)
          write(gsmObj%io%message, 3999)
          call gsmObj%io%print(1, 1, gsmObj%io%message)
          stop
       else
          ! Unknown error
          write(gsmObj%io%message, 3900) preeqRes%simState
          call gsmObj%io%print(2, 2, gsmObj%io%message)
          write(gsmObj%io%message, 3999)
          call gsmObj%io%print(2, 2, gsmObj%io%message)
       end if
    end if

    ! Interface simulation results now:
    results => gsmRxn%results

    ! Obtain progeny from class
    progenyLoop: do kfr = 1, preeqRes%numProgeny

       ! Ensure bank can hold fragment:
       if ( results%numProgeny > results%maxProgenyM1 ) then
          write(gsmObj%io%message, 2000)
          call gsmObj%io%print(3, 3, gsmObj%io%message)
          write(gsmObj%io%message, 2010) preeqRes%numProgeny - kfr + 1
          call gsmObj%io%print(3, 3, gsmObj%io%message)
          exit progenyLoop
       end if

       ! Obtain interim results:
       ! (particle ID)
       particleID = 0
       if ( progenyBnk(kfr)%numProtons <= 2 .and. progenyBnk(kfr)%numBaryons <= 5 ) then
          if ( progenyBnk(kfr)%numProtons == 0 ) then
             if ( progenyBnk(kfr)%numBaryons == 1 ) then
                particleID = 1   ! Neutron
             end if
          else if ( progenyBnk(kfr)%numProtons == 1 ) then
             if ( progenyBnk(kfr)%numBaryons == 1 ) then
                particleID = 2   ! Proton
             else if ( progenyBnk(kfr)%numBaryons == 2 ) then
                particleID = 3   ! Deuteron
             else if ( progenyBnk(kfr)%numBaryons == 3 ) then
                particleID = 4   ! Triton
             end if
          else if ( progenyBnk(kfr)%numProtons == 2 ) then
             if ( progenyBnk(kfr)%numBaryons == 3 ) then
                particleID = 5   ! Helion (He-3)
             else if ( progenyBnk(kfr)%numBaryons == 4 ) then
                particleID = 6   ! Helium
             end if
          end if
       else
          ! Use expanded formula
          particleID = nint (   thousand * progenyBnk(kfr)%numProtons + &
               & ( progenyBnk(kfr)%numBaryons - progenyBnk(kfr)%numProtons )   )
       end if
       if( particleID == 0 ) then
          particleID = nint (   thousand * progenyBnk(kfr)%numProtons + &
               & ( progenyBnk(kfr)%numBaryons - progenyBnk(kfr)%numProtons )   )
          write(gsmObj%io%message, 2100)
          call gsmObj%io%print(3, 3, gsmObj%io%message)
       end if

       if ( progenyBnk(kfr)%origin == preequilibriumProgeny ) then
          prodMech = 100.0_real64   ! Fragment from preequlibrium emission
       else if ( progenyBnk(kfr)%origin == fermiBreakUpProgenyType ) then
          prodMech = 1500.0_real64   ! Fragment from Fermi Break-up of residual
       else
          ! Error - Invalid origin flag
          write(gsmObj%io%message, 1100) progenyBnk(kfr)%origin
          call gsmObj%io%print(3, 3, gsmObj%io%message)
          prodMech = 100.0_real64
       end if

       ! Bank particle:
       results%numProgeny = results%numProgeny + 1
       results%progenyBnk(results%numProgeny)%numBaryons = progenyBnk(kfr)%numBaryons
       results%progenyBnk(results%numProgeny)%numProtons = progenyBnk(kfr)%numProtons
       results%progenyBnk(results%numProgeny)%kinEnergy  = progenyBnk(kfr)%kinEnergy / thousand
       results%progenyBnk(results%numProgeny)%restMass   = progenyBnk(kfr)%restMass / thousand
       results%progenyBnk(results%numProgeny)%phi        = progenyBnk(kfr)%phi
       results%progenyBnk(results%numProgeny)%theta      = progenyBnk(kfr)%theta
       results%progenyBnk(results%numProgeny)%sinTheta   = sin( progenyBnk(kfr)%theta )
       results%progenyBnk(results%numProgeny)%cosTheta   = cos( progenyBnk(kfr)%theta )
       results%progenyBnk(results%numProgeny)%typeID     = particleID
       results%progenyBnk(results%numProgeny)%prodMech   = prodMech
    end do progenyLoop

    if(results%tallySim) then
       ! Obtain distribution of nuclei prior to equilibration
       results%info%residual(1)%numBaryons = preeqRes%initResidual%numBaryons
       results%info%residual(1)%numProtons = preeqRes%initResidual%numProtons
       results%info%residual(1)%energy     = preeqRes%initResidual%thermEnergy
       results%info%residual(1)%linearMomentum = &
            & sqrt(preeqRes%initResidual%linearMomX**2 + &
            &        preeqRes%initResidual%linearMomY**2 + &
            &        preeqRes%initResidual%linearMomZ**2 ) * thousand
       results%info%residual(1)%angMom = preeqRes%initResidual%angMomFlag
    end if

    ! Obtain statistics for stable nuclei
    if ( preeqRes%residual%state == residualState ) then
       ! Preeq. process did not finish due to not enough progeny storage available
       !    (error addressed above)
    else if ( preeqRes%residual%state == compoundState ) then
       ! Preeq. process finished and a compound nucleus exists (undergo evaporation)
    else if ( preeqRes%residual%state == stableState ) then
       ! Accumulate statistics for stable nuclei before decay (no progeny created)
       if (results%tallySim) then
          if (preeqRes%numProgeny == 0) then
             call gsmObj%ststcs (preeqRes%residual%numBaryons, preeqRes%residual%numProtons, &
                  & preeqRes%residual%thermEnergy, preeqRes%residual%angMomFlag, &
                  & preeqRes%residual%fissBarr, 2)
          end if

          ! Accumulate statistics on stable nucleus and store into secondary arrays
          call gsmObj%ststcs (preeqRes%residual%numBaryons, preeqRes%residual%numProtons, &
               & preeqRes%residual%recEnergy, preeqRes%residual%angMomFlag, &
               & preeqRes%residual%fissBarr, 4)
       end if

       call gsmObj%restor1 (preeqRes%residual%numBaryons, preeqRes%residual%numProtons, &
            & preeqRes%residual%recEnergy, preeqRes%residual%restMass, &
            & preeqRes%residual%normSpeed, results)

    else if ( preeqRes%residual%state == fermiBreakupState ) then
       ! Nucleus underwent Fermi Break-up; set flags accordingly
       results%info%fusion = zro
       results%info%wf = zro
       ! Increment uses of Fermi Break-up
       gsmRxn%outData%ifermi = gsmRxn%outData%ifermi + 1

    else
       ! Unknown state flag - write error and assume compoundState
       write(gsmObj%io%message, 3950)
       call gsmObj%io%print(2, 3, gsmObj%io%message)
       write(gsmObj%io%message, 3955)
       call gsmObj%io%print(2, 3, gsmObj%io%message)
       preeqRes%residual%state = compoundState
    end if

    ! Store compound data locally
    gsmNucleus%ap    = preeqRes%residual%numBaryons
    gsmNucleus%zp    = preeqRes%residual%numProtons
    ! (Energies)
    gsmNucleus%up    = preeqRes%residual%kinEnergy
    gsmNucleus%ue    = preeqRes%residual%thermEnergy
    gsmNucleus%trec  = preeqRes%residual%recEnergy
    gsmNucleus%rstMass = preeqRes%residual%restMass
    ! (linear momentum)
    gsmNucleus%pnx   = preeqRes%residual%linearMomX
    gsmNucleus%pny   = preeqRes%residual%linearMomY
    gsmNucleus%pnz   = preeqRes%residual%linearMomZ
    ! (angular momentum)
    gsmNucleus%elx   = preeqRes%residual%angularMom(1)
    gsmNucleus%ely   = preeqRes%residual%angularMom(2)
    gsmNucleus%elz   = preeqRes%residual%angularMom(3)
    gsmNucleus%ln    = preeqRes%residual%angMomFlag
    ! (fission barrier height)
    gsmNucleus%bf0   = preeqRes%residual%fissBarr
    ! (state of nucleus)
    gsmNucleus%state = preeqRes%residual%state

    return
! ======================================================================
1100 format("Invalid fragment origin flag (", i3, ") was detected during ", &
          & "preequilibrium emission.")
2000 format("The GSM progeny bank was filled during the preequilibrium simulation.")
2010 format("   Unable to bank the remaining ", i3, " particles.")
2100 format("Unexpected particle found. Approximation using ZZZNNN identifier.")
3000 format("Not enough memory was given for progeny storage to allow ", &
          & "the preequilibrium simulation to complete.")
3600 format("The preequilibrium object wasn't constructed.")
3700 format("The preequilibrium data object wasn't constructed.")
3800 format("The preequilibrium results object wasn't constructed.")
3900 format("An unknown error (", i3, ") was flagged during the ", &
          & "preequilibrium simulation.")
3950 format("An unknown state (", i3, ") was flagged for the residual nucleus.")
3955 format("   Assuming residual is a compound nucleus...")
3999 format("   Preequilibrium simulation failed. Stopping...")
! ======================================================================
  end subroutine preequilibriumInterface


      subroutine jetreorder(p,q,isub)
c--- Routine to inspect the entries of 'jetlabel' and compare with 'plabel'
c--- in order to put clustered jets back in the correct positions.
c--- This is important if one wants to identify particles in the plotting
c--- routine with those in the process.DAT file.
c--- At present this routine is aimed at top processes with top decay
c--- (i.e. putting b and anti-b jets in correct positions)
c---
c--- Input array of momenta is p, output re-ordered array is q
      implicit none
      include 'constants.f'
      include 'jetlabel.f'
      include 'plabel.f'
      include 'npart.f'
      integer i,j,k,nu,isub,maxjet,ijet(mxpart),jetindex(mxpart)
      double precision p(mxpart,4),q(mxpart,4)
      logical alreadyfound,is_hadronic

c      call writeout(p)

      if (jets .eq. 0) then
        do i=1,mxpart
      do nu=1,4
        q(i,nu)=p(i,nu)
      enddo
      enddo
      return
      endif

      maxjet=0
      do i=3,npart+2-isub
        ijet(i)=0
        if (is_hadronic(i)) then
          maxjet=maxjet+1
          jetindex(maxjet)=i
        ijet(i)=-1 ! If no match is found, this signifies a parton is lost
        if (jets .gt. 0) then
          do j=1,jets
            if (plabel(i) .eq. jetlabel(j)) then
              alreadyfound=.false.
              if (maxjet .gt. 0) then
              do k=1,maxjet
                if (ijet(jetindex(k)) .eq. j) then
                  alreadyfound=.true.
                endif
              enddo
            endif
              if (.not.(alreadyfound)) ijet(i)=j
            endif
          enddo
        endif
      endif
      enddo

c      call writeout(p)

c      do i=3,npart+2-isub
c      write(6,*) i,ijet(i)
c      enddo
c      write(6,*) 'maxjet=',maxjet

c      do j=1,jets
c      write(6,*) j,jetlabel(j)
c      enddo

      do i=3,npart+2-isub
        if     (ijet(i) .eq. 0) then
          j=i ! Not a jet, no swap required
      elseif (ijet(i) .eq. -1) then
        j=-1 ! Jet lost, need to set components to zero
        else
          j=jetindex(ijet(i))
        endif
      if (j .gt. 0) then
        do nu=1,4
          q(i,nu)=p(j,nu)
          enddo
      else
        do nu=1,4
          q(i,nu)=zip
          enddo
      endif
      enddo

      do i=1,2
        do nu=1,4
        q(1,nu)=p(1,nu)
        q(2,nu)=p(2,nu)
      enddo
      enddo

      do i=npart+3-isub,mxpart
      do nu=1,4
         q(i,nu)=zip
      enddo
      enddo

c      call writeout(q)
c      pause

c--- reset jetlabel to correspond to plabel
      do i=1,jets
      jetlabel(i)=plabel(jetindex(i))
c      write(6,*) 'i,jetindex(i),jetlabel(i)',i,jetindex(i),jetlabel(i)
      enddo
c      write(6,*)

c      call writeout(q)
c      write(6,*) 'jets =',jets
c      write(6,*) 'npart,isub',npart,isub
c      pause

      return
      end


c
c    subroutines and functions called by Sdf_lister:
c
c    Calib_lib.for:
c          subroutine read_pha_cal
c          subroutine get_geofactor
c          subroutine get_track_effic
c          subroutine get_ROMboxes
c
c    Decode_lib.for
c          subroutine expand_data_packet
c          integer function decode
c          integer function reames
c
c    Sdf_Hist_Subrout.for:
c          subroutine initial_histogram
c          subroutine reset_histogram
c          logical function fill_histogram
c          logical function write_hist_output
c
c    Sdf_mask_subrout.for:
c          logical function get_expose
c          subroutine check_expose
c          logical function get_mask
c          subroutine check_mask
c          subroutine check_skipday
c
c    Sdf_phaflux_subrout.for:
c          subroutine  reset_phaflux
c          subroutine calc_effic
c          logical function fill_phaflux
c          subroutine calculate_phaflux
c          subroutine calculate_phacounts
c          real function get_sigma_flux
c          real function get_sigma_flux2
c          logical function write_phaflux_output
c
c    Sdf_pha_subrout.for:
c          subroutine evaluate_pha
c          subroutine convert_data
c          real function lininterp
c          subroutine search
c          real function Einc_MeVnuc
c          real function mass_amu
c          function tof_fraction
c          real function spread
c
c    Sdf_subrout1.for:
c          subroutine  initial_global
c          logical function get_config
c          logical function read_script
c          subroutine script_key
c
c    Sdf_subrout2.for:
c          logical function get_data_record
c          integer function check_time
c          subroutine  reset_time
c          subroutine get_spin_period
c
c    Sdf_subrout3.for:
c          logical function cut_interval_test
c          subroutine  cut_PHA_data
c          subroutine  assign_script_flags
c          subroutine  write_titles
c          subroutine strip_blanks20
c          subroutine strip_blanks41
c
c    Sdf_subrout4.for:
c          subroutine update_ROMbox
c          logical function get_ROMbox_history
c          subroutine get_mdata
c
c    Sdf_subrout5.for:
c          subroutine get_exposure
c          subroutine sum_kp
c          subroutine ave_kp
c          subroutine ave_kp_1mf
c          subroutine calculate_rates
c          subroutine calculate_counts
c          subroutine calculate_rates_1mf
c          subroutine calculate_counts_1mf
c
c    Sdf_subrout6.for:
c          logical function open_output
c          subroutine write_header
c          function write_output
c          function write_output_omni
c          subroutine write_line
c
c    Time_Lib.For:
c           subroutine convert_time
c           integer function day_of_year
c           integer function IDAYS_PER_YEAR
c           subroutine convert_to_sampextime
c           subroutine sampex_timcon
c
c    Open_Sdf.for:
c          subroutine open_sdf
c
c
c
c***************************************************

      program Sdf_lister

c***************************************************
c
c      Sdf_lister is a data analysis program for the WIND/STEP instrument.
c      It reads in unformatted SDF files,
c      decodes and processes the data,
c      and writes the output to a kalidagraph and IDL format ASCII file.
c      Include files:
c            Sdf_include.inc
c            Hex_include.inc  ! Also used by L0_to_sdfkp
c
c      version 3.99
c      Written by J. Dwyer, 7/2/98
c          9/16/98 added if (indexi.gt.1) to write in logical function write_output
c          9/21/98 fixed output problem in logical function write_output
c          10/5/98 fixed bug in disc output
c          10/8/98 changed to date_and_time in write_header
c          10/27/98 corrected factor of 2 error in Tel1&2 VSE rate in calculate_rates
c          11/4/98 fixed bug in junk output
c          11/6/98 added subroutine check_skipday, and skip day feature
c          11/6/98 added saturation = 0 at beginning and sat_1mf in get_mdata
c          11/6/98 corrected factor of 2 error in Tel1&2 VSE rate in  calculate_rates_1mf
c          11/10/98 removed data_flag, bas event mass= -99.9
c          11/11/98 fixed bug in fill_histogram
c          12/22/98 changed state from flux to rate
c          1/21/99 added script_stateab_flag cut to cut_PHA_data
c          4/8/99 collection time is 1 mf earlier, subtracted offset from start and end times, change in get_data_record
c          6/21/99 fixed datew output in header
c          6/22/99 changed dt/2 to exponential format
c          8/9/99 added index number to sigma so each title is unique
c          1/13/00 fixed bugs in check_expose and sampex_timcon, problem with call get_geofactor, changed spread to spread1
c          4/21/00 by J. Dwyer added script_stateab_flag = -1 to hist input in read_script
c          1/9/01  allowed position to be gt 220 RE and lt -220 RE in sum_kp
c		   1/24/01 by J. Dwyer increased max mask and expose lines to 9999
c          2/5/01  no longer output at least one PHA record per major frame filled with -1s
c		21-Apr-2008    install on Mac with Absoft fortran compiler /gm
c
c
      include 'Sdf_include.inc'
      include 'Hex_include.inc'
c
c                                        local variable type declarations
c                                     *****************************
      logical	get_config              ! function declaration
      logical	get_ROMbox_history       ! function declaration
      logical	read_script           ! function declaration
      logical	get_data_record   ! function declaration
      logical	fill_histogram     ! function declaration
      integer	idays_per_year       ! function declaration
      logical	open_output     ! function declaration
      logical	write_output    ! function declaration
      logical	write_output_omni    ! function declaration
      logical	fill_phaflux   ! function declaration
      logical	write_hist_output    ! function declaration
      logical	write_phaflux_output    ! function declaration
      logical	get_mask              ! function declaration
      logical	get_expose              ! function declaration
      logical	cut_interval_test      ! function declaration
      integer	check_time             ! function declaration
c
      integer*4      time_flag  ! 0 = continue to skip forward, 1 = continue and analyze, 2 = stop reading and exit
      integer*4      script_number    ! number of script that is being processed
      integer*4      spin_number     ! spin pair number in science record [1,5]
      integer*4      reset_interval_all ! flag to see if all scripts are ready to output
      integer*4      skipday  ! determined by subroutine check_skipday (1 = skip day)
      integer*4      unit_in,
     1     unit_cfg,
     1     unit_script,
     1     unit_out,
     1     unit_ROM,
     1     unit_cal   ! file units
      logical      output_flag   ! .false. = all output files have exceeded maximum number of rows, .true. otherwise
      logical      output_script_flag(Nscripts_max)   ! .false. = individual output file exceeded maximum number of  rows, .true. otherwise
      logical      cut_interval_flag  ! result of cuts (true =  write time interval, false = don't)
      logical      thishistfull(Nscripts_max)    !  .true. = max number of counts reached in a hist
      logical      thisphafluxfull(Nscripts_max)     !  .true. = max number of counts reached in a pha flux array
      logical      end_flag  ! .true. = end of file reached, .false. otherwise
      logical      iflag    !  .true. = open_udf was successfully opened input data file, .false. = otherwise
      logical      ifile                ! test for config. file inquire
      logical      open_flag  ! .true. if file opened successfully, .false. otherwise
      logical      first_record(Nscripts_max)   ! .true. first good science record; .false. otherwise

c ********************** read in the data paths

	include 'include_paths.inc'
	open(unit=10,name='/paths/sdf_lister_paths.txt',status='old',action='read')
	read(10,*)
	read(10,500)	calibration_path			! folder containing input udf files
500	format(a)
	read(10,*)
	read(10,500)	data_path		! folder containing instrument calibration data
	read(10,*)
	read(10,500) control_path
	close(10)
	type *, adjustl(trim(data_path))
	type * ,	adjustl(trim(calibration_path))
	type *, adjustl(trim(control_path))
c***********************

c
c                                        set local variables
c                                   ********************
      unit_in = 1        ! file unit of input STEP data file (SDF)
      unit_cfg = 2
      unit_cal = 3
      unit_script = 4
      unit_ROM = 5
c
      skipday = 0
c                                set initial values of variables
c                                   ********************
      call initial_global  !  set initial values for global variables
c
      output_flag = .true.    ! still want to output data, keep going
      reset_interval_all = 0
      do script_number = 1, Nscripts_max
        first_record(script_number) = .true.       ! first record in a time interval
        output_script_flag(script_number) = .true.   ! write to individual script file
        thishistfull(script_number) =.false.     ! a histogram has enough data
        thisphafluxfull(script_number) =.false.  ! a pha flux array has enough data
      end do
c
c
c                                  get configuration file
c                                   ********************
      configfile = adjustl(trim(control_path)) // 'Sdf_lister.cfg'   ! default value
c
      inquire(file=configfile,exist=ifile )  ! does file exist?
      if (.not.ifile ) then                 ! if it exists, open it and read data
        type *, 'Configuration file ', configfile ,
     1               ' does not exist! '
      end if
      open_flag = get_config(unit_cfg)  ! open config. file and read data
      if (.not.open_flag) then
        type *, 'stopped at config file open'
        stop  ! error opening config file
      end if
c
c                                  get calibration data
c                                   ********************
       call read_pha_cal(unit_cal)
       call get_geofactor(unit_cal)
       call get_track_effic(unit_cal)
c
c                                  get ROM box history data
c                                   ********************
      open_flag =
     1    get_ROMbox_history(unit_cal)  ! open file
      if (.not.open_flag) then
        type *, 'stopped at ROM box history file open'
        stop  ! error opening ROM box history file
      end if
c
c                                  read mask and expose data
c                                   ***********************
      if (expose_flag.eq.1) then
        idelta_t = 0.0    ! don't average over time interval in this version
        open_flag = get_expose(unit_cal)  ! open file and read data
        if (.not.open_flag) then
          type *, 'stopped at expose file open'
          stop  ! error opening expose file
        end if
      end if
c
      if (mask_flag.eq.1) then
        open_flag = get_mask(unit_cal)  ! open file and read data
        if (.not.open_flag) then
          type *, 'stopped at mask file open'
          stop  ! error opening mask file
        end if
      end if
c
c
c                                    open and read script files
c                                        *****************
      if (Nscripts.gt.0) then
        do  i=1, Nscripts
          open_flag = read_script(unit_script, i)
          if (.not.open_flag) then
            type *, 'stopped at script open'
            stop  ! error opening data output file
          end if
        end do
      else
        type *,'No output files requested.'
        type *,'Stopping run.'
        stop
      end  if
c
c
      call script_key   ! get titles for scripts
      start_time = stime_start   ! use this time for first ROM box file call
      call update_ROMbox(unit_ROM)   ! get latest ROM box data file
      call assign_script_flags   !  set appropriate output flags
      if (dohistflag.eq.1) call initial_histogram   !  initialize histograms
      do  i=1, Nscripts
        call  reset_time(i)   !  reset accumulated variables
      end do
c
c                                    open output files
c                                    *****************
      do  i=1, Nscripts
        unit_out = i+10
        open_flag = open_output(unit_out,i)  ! open data output file
        if (.not.open_flag) then
          stop  ! error opening data output file
        end if
      end do
c
c
c
c                               Main loop through multiple UDFs
c                              ********************************
c	  Loop through all days between the start and stop days.
      iyear = istart_year
      iday = istart_day
      zero=0
      secinit=secnds(zero)  ! used to keep track of time since last open_sdf call
c
      do while ((((iday.le.istop_day).and.(iyear.eq.istop_year) ).or.
     1            (iyear.lt.istop_year) ).and.(output_flag) )  ! continue if start date is LE than stop date
c
        if (mask_flag.eq.1)
     1     call check_skipday(iday,iyear,skipday)
c
        iflag = .false.
        if (skipday.eq.1) type *,'skip file',iyear,iday
        if (skipday.eq.0)
     1     call open_Sdf(iyear,iday,unit_in,file_extent_prefix,iflag)  ! open input data file
c
        if (iflag) then  ! check if file exists
c
c	                            Main loop through data packets in UDF
c                                ********************************
c
          end_flag = .false.
          end_flag =  get_data_record(unit_in)   ! read in data
          call expand_data_packet   ! decode data in packet
          call evaluate_pha
          call update_ROMbox(unit_ROM)    ! get latest ROM box data file
          time_flag =  check_time()   ! check if packet is within specified start and stop times
c
          do while ((.not.end_flag).and.(time_flag.ne.2)
     1                    .and.(output_flag))
              if (mask_flag.eq.1) call check_mask    ! test to see if data should be cut
c
c          read data until the EOF is reached,
c          the packet time is not past stop time,
c          and the number of output lines does not exceed specified value
c
            if ((time_flag.eq.1).and. !  process data if packet time is within specifed start and stop times
     1     (nspins.gt.0).and.   ! trap (encountered 1995-01-19 07:29:33)
     1     (((select_calib_mode.eq.0).and.
     1     (sum_cal_mode.eq.0)).or.
     1     ((select_calib_mode.eq.1).and.
     1     (sum_cal_mode.gt.0)).or.
     1     (select_calib_mode.eq.-1)).and.
     1     (mask_interval_flag.eq.0)) then
c                                      process data
c                                    *****************
c
        if (expose_flag.eq.1) then
          call check_expose   ! check if time is in selected interval
        else
          expose_interval_flag = 1   ! process all times
        end if
c
c      cccccccccccccccc output proceedures ccccccccccccccccc
c
          do script_number =1, Nscripts
            unit_out =  script_number+10
            if ((script_output_type(script_number).ne.2).and.
     1          ((reset_interval(script_number).eq.1).and.
     1           ((output_sych_flag(script_number).eq.0)).or.
     1           ((reset_interval_all.eq.1).and.
     1           (output_sych_flag(script_number).eq.1)))) then    ! stop accumulating, process results and write out
              if (time_interval(script_number).gt.0.0) then
                call ave_kp(script_number)    ! browse parameters
                call calculate_rates(script_number)
                cut_interval_flag =
     1            cut_interval_test(script_number,1)
                if (cut_interval_flag) then
                  if (raw_counts_flag.eq.1)
     1              call calculate_counts(script_number)
                  if ((output_script_flag(script_number)).and.
     1               (script_output_type(script_number).eq.1)) then         ! write out rates data, type 1 (no PHA data)
                      output_script_flag(script_number)=
     1                   write_output(unit_out,script_number,
     1                   start_time_avg(script_number),
     1                   stop_time_avg(script_number))
                if (.not.output_script_flag(script_number))  type *,
     1         'maximum # of lines reached in script ' , script_number
                  end if
c
                  if ((output_script_flag(script_number)).and.
     1               (script_output_type(script_number).eq.5)) then         ! write out omni rates data, type 5 (no PHA data)
                      output_script_flag(script_number)=
     1                   write_output_omni(unit_out,script_number,
     1                   start_time_avg(script_number),
     1                   stop_time_avg(script_number))
                if (.not.output_script_flag(script_number))  type *,
     1         'maximum # of lines reached in script ' , script_number
                  end if
c
                  if ((output_script_flag(script_number)).and.
     1               (script_output_type(script_number).eq.3)) then          ! write out hist data, type 3
                     output_script_flag(script_number)=
     1                  write_hist_output(unit_out,script_number,
     1                   start_time_avg(script_number),
     1                   stop_time_avg(script_number))
                if (.not.output_script_flag(script_number))  type *,
     1         'maximum # of lines reached in script ' ,script_number
                  end if
c
                  if ((output_script_flag(script_number)).and.
     1                (script_output_type(script_number).eq.4)) then  ! write out pha flux data, type 4
                    if (raw_counts_flag.eq.0)
     1                 call calculate_phaflux(script_number,
     1                   start_time_avg(script_number),
     1                   stop_time_avg(script_number))
                    if (raw_counts_flag.eq.1)
     1                 call calculate_phacounts(script_number)
                    output_script_flag(script_number)=
     1                write_phaflux_output(unit_out,script_number,
     1                   start_time_avg(script_number),
     1                   stop_time_avg(script_number))
                if (.not.output_script_flag(script_number))  type *,
     1         'maximum # of lines reached in script ' , script_number
                  end if
                end if  ! end if cut_interval_flag
              end if      ! end if time_interval.gt.0.0
              call  reset_time(script_number)   !  reset accumulated variables
              first_record(script_number) = .true.
            end if       ! end if reset_interval.eq.1
          end do  ! end do script_number
c
c      cccccccccccccccc accumulation proceedures ccccccccccccccccc
c
          reset_interval_all = 1
          do script_number =1, Nscripts
            unit_out =  script_number+10
            if (expose_interval_flag.gt.0) then     !  accumulate data to make average
              if (first_record(script_number)) then
                start_time_avg(script_number) = start_time
                first_record(script_number) = .false.
              end if
              stop_time_avg(script_number) = end_time
              call get_spin_period  ! get correct spin_period from kp data if available
              call get_mdata(script_number)   !  accumulate rates data
              call get_exposure(script_number)  ! get accumulation time and exposure
              call ave_kp_1mf(script_number)
              call calculate_rates_1mf(script_number)   ! calculate rates for spin pair data, used for PHA outputs (type 2)
              cut_interval_flag =
     1          cut_interval_test(script_number,2)
              if (cut_interval_flag) then
                if (script_output_type(script_number).ne.1)
     1            call cut_PHA_data(script_number)
                if ((output_script_flag(script_number)).and.
     1            (script_output_type(script_number).eq.2)) then
                  if (raw_counts_flag.eq.1)
     1              call calculate_counts_1mf(script_number)
c
                  output_script_flag(script_number)=
     1              write_output(unit_out,script_number,
     1              start_time, end_time)
             if (.not.output_script_flag(script_number))  type *,
     1      'maximum # of lines reached in script ' , script_number
                end if
c
                if ((output_script_flag(script_number)).and.
     1             (script_output_type(script_number).eq.3)) then   ! accumulate histogram data
                   thishistfull(script_number) =
     1               fill_histogram(script_number)
                end if
c
                if (script_output_type(script_number).ne.2) then
                  call sum_kp(script_number)      ! accumulate browse data
                  if ((output_script_flag(script_number)).and.
     1               (script_output_type(script_number).eq.4))     ! accumulate pha flux data
     1               thisphafluxfull(script_number) =
     1                fill_phaflux(script_number,spin_number)
                end if
              end if  ! end if cut_interval_flag
            end if  ! end if expose_interval_flag.gt.0
c
cccccccccccccccccccc check accumulation cccccccccccccccccccccc
            if (expose_flag.ne.1) then
              if (script_output_type(script_number).eq.1) then
                if (((script_accum_t_flag(script_number).eq.0).or.     ! check to see if accumulation criteria has been meet
     1            ((script_accum_t_flag(script_number).eq.1).and.
     1            (time_interval(script_number).ge.
     1             script_idelta_t(script_number)))).and.
     1            ((script_accum_Nr_flag(script_number).eq.0).or.
     1            ((script_accum_Nr_flag(script_number).eq.1).and.
     1            (Nr_counts(script_number).ge.
     1             script_idelta_Nr(script_number))))) then
                     reset_interval(script_number) = 1   ! stop accumulating
                end if
              end if
              if (script_output_type(script_number).eq.3) then
                 if (((script_accum_t_flag(script_number).eq.0).or.     ! check to see if accumulation criteria has been meet
     1           ((script_accum_t_flag(script_number).eq.1).and.
     1            (time_interval(script_number).ge.
     1             script_idelta_t(script_number)))).and.
     1            ((script_accum_Nr_flag(script_number).eq.0).or.
     1            ((script_accum_Nr_flag(script_number).eq.1).and.
     1            (Nr_counts(script_number).ge.
     1             script_idelta_Nr(script_number)))).and.
     1            ((script_accum_Nh_flag(script_number).eq.0).or.
     1            ((script_accum_Nh_flag(script_number).eq.1).and.
     1            (thishistfull(script_number))))) then
                     reset_interval(script_number) = 1   ! stop accumulating
                end if
              end if
               if (script_output_type(script_number).eq.4) then
                 if (((script_accum_t_flag(script_number).eq.0).or.     ! check to see if accumulation criteria has been meet
     1            ((script_accum_t_flag(script_number).eq.1).and.
     1            (time_interval(script_number).ge.
     1             script_idelta_t(script_number)))).and.
     1            ((script_accum_Nr_flag(script_number).eq.0).or.
     1            ((script_accum_Nr_flag(script_number).eq.1).and.
     1            (Nr_counts(script_number).ge.
     1              script_idelta_Nr(script_number)))).and.
     1            ((script_accum_Nphaf_flag(script_number).eq.0).or.
     1            ((script_accum_Nphaf_flag(script_number).eq.1).and.
     1            (thisphafluxfull(script_number))))) then
                     reset_interval(script_number) = 1   ! stop accumulating
                end if
              end if
            end if
c
c           handle time interval for averaging:
            if ((output_sych_flag(script_number).eq.1).and.
     1          (output_script_flag(script_number)).and.
     1          (script_output_type(script_number).ne.2).and.
     1          (reset_interval(script_number).eq.0))  then
               reset_interval_all = 0
            end if
          end do  ! end do script_number
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
                end if  ! end if time_flag
            end_flag =  get_data_record(unit_in)  ! read in next major frame packet
            call expand_data_packet   ! decode data in packet
            call evaluate_pha
            call update_ROMbox(unit_ROM)
            time_flag =  check_time()   ! check if packet is within specified start and stop times
            output_flag = .false.
            do  script_number = 1, Nscripts
              if (output_script_flag(script_number)) then  ! write data to output file
                 output_flag = .true.   ! still writing to some output files
              end if
            end do
c
          end do  ! end loop that reads in packets
c
          close (unit=unit_in,err=1000)   ! close input file
        end if  ! if not a good file
c
        iday = iday + 1  ! go to next day
c  	  check for a year boundary crossing
	      if (iday.gt.idays_per_year(iyear)) then
	         iday = 1
	         iyear = iyear + 1
        end if
c	    write out time since last call
	      secnow=secnds(zero)
c	seconds elapsed message commented out 28-Jul-2008 to keep down lenght of batch file outputs
c	      type *, ' Seconds elapsed since last open_SDF call: ',
c    1    secnow-secinit
	      secinit=secnow
c
      end do ! end loop through multiple UDF's
c
cccccccccccc write final accumulation to output ccccccccccc
      do script_number =1, Nscripts
        unit_out = script_number+10
        if ((script_output_type(script_number).ne.2).and.
     1     (time_interval(script_number).gt.0.0)) then
           call calculate_rates(script_number)
           cut_interval_flag =
     1       cut_interval_test(script_number,1)
           if (cut_interval_flag) then
             if (raw_counts_flag.eq.1)
     1         call calculate_counts(script_number)
             call ave_kp(script_number)
             if ((output_script_flag(script_number)).and.
     1     (script_output_type(script_number).eq.1)) then
              output_script_flag(script_number) =
     1           write_output(unit_out,script_number,
     1           start_time_avg(script_number),
     1           stop_time_avg(script_number))
             end if
             if ((output_script_flag(script_number)).and.
     1     (script_output_type(script_number).eq.5)) then
              output_script_flag(script_number) =
     1           write_output_omni(unit_out,script_number,
     1           start_time_avg(script_number),
     1           stop_time_avg(script_number))
             end if
             if ((output_script_flag(script_number)).and.
     1       (script_output_type(script_number).eq.3)) then
                output_script_flag(script_number)=
     1           write_hist_output(unit_out,script_number,
     1                   start_time_avg(script_number),
     1                   stop_time_avg(script_number))
             end if
             if ((output_script_flag(script_number)).and.
     1       (script_output_type(script_number).eq.4)) then
               if (raw_counts_flag.eq.0)
     1            call calculate_phaflux(script_number)
               if (raw_counts_flag.eq.1)
     1            call calculate_phacounts(script_number)
               output_script_flag(script_number)=
     1         write_phaflux_output(unit_out,script_number,
     1                   start_time_avg(script_number),
     1                   stop_time_avg(script_number))
             end if
           end if  ! end if cut_interval_flag
        end if  ! end time_interval
      end do ! end script_number loop
c
      do  i=1, Nscripts
         unit_out = i+10
         close (unit=unit_out,err=2000)   ! close output file
      end do
c
c
      type *, 'Sdf_lister is finished'
      stop
c
1000  type *,'Error closing input file!'   ! on error go to here
      stop
2000  type *,'Error closing output file!'   ! on error go to here
      stop
c
      end  ! end Sdf_lister
c
c
c
c


C
C
*+ multi_fit_sys

       subroutine multi_fit_sys( status )
C      ----------------------------------
C
C Setup sub-system for fitting of many maps
C
C Returned:
C    error status
       integer       status
C
C A command line driven sub-system for setting up options to add
C large numbers of maps together with varying weights.
C
C-

       include '../include/anmap_sys_pars.inc'
       include '/mrao/include/iolib_constants.inc'
       include '/mrao/include/iolib_errors.inc'
       include '/mrao/include/chrlib_functions.inc'
       include '/mrao/include/iolib_functions.inc'

C Local variables
C ---------------
C  dummy real*4 argument to map_end_alloc routine
       real*4             dummy_argument
C  command line, length and initial check
       character*120      command_line
       integer            len_com, iout
       logical            exit_on_completion
C  command line interpretation
       integer            number_commands, icom
       parameter         (number_commands = 10)
       character*80       liscom(number_commands)
C  record containing list of maps; this will be a record in the extra
C  redtape slot of a standard format map.  The first 16 bytes of the
C  record containing list of maps; this will be a record in the extra
C  redtape slot of a standard format map.  The first 16 bytes of the
C  record are therefore reserved words.
       integer            map_list(128)
C    number of maps in list
       integer            nmaps
       equivalence       (map_list(5), nmaps)
C    start record for maps in list
       integer            start
       equivalence       (map_list(6), start)
C    length of each record in list
       integer            len_record
       equivalence       (map_list(7), len_record)
C    type of model fit required
       integer            model
       equivalence       (map_list(8),model)
C    number of constants
       integer            nc
       equivalence       (map_list(9), nc)
C    constants
       real*4             c_data(5)
       equivalence       (map_list(10), c_data(1))
C    number of output maps
       integer            num_out
       equivalence       (map_list(15), num_out)
C  define entry for each map
       integer            map_record(4)
       integer            map_entry
       equivalence       (map_record(1), map_entry)
       integer            map_directory
       equivalence       (map_record(2), map_directory)
       real*4             map_xval
       equivalence       (map_record(3), map_xval)
       real*4             map_gate
       equivalence       (map_record(4), map_gate)
C  counters and pointers
       integer            imap, n, nn, i, iwarn, first_map
C  maximum number of maps to be added to list
       integer            max_maps
C  general string and filename
       character          string*256, source*20, program*8
       character          filename*(iolen_file)
C  maximum number of model types defined
       integer            max_model
       parameter         (max_model = 5)
C
       common /map_anal_local_multifit/ map_list
C
C define commands
       data liscom(1) /
     *  'clear-map-list ............... initialise map list'
     *                /
       data liscom(2) /
     *  'add-map-to-list .............. add a map to the list'
     *                /
       data liscom(3) /
     *  'delete-map-from-list ......... delete a map from the list'
     *                /
       data liscom(4) /
     *  'list-maps .................... list the maps in the list'
     *                /
       data liscom(5) /
     *  'set-fit-type ................. set model to fit data'
     *                /
       data liscom(6) /
     *  'set-constant ................. set one of th 5 constants'
     *                /
       data liscom(7) /
     *  'make ......................... run multi-fit offline'
     *                /
       data liscom(8) /
     *  'go ........................... run multi-fit interactively'
     *                /
       data liscom(9) /
     *  'help ......................... help on multi-fit options'
     *                /

C check status on entry
       if (status.ne.0) return
       nc = 5
       num_out = 2
       start = 18
       len_record = 4
       if (model.le.0 .or. model.gt.max_model) then
         model = 1
         call io_wrout('.. model type set to 1')
       end if
       max_maps = (128-start+1)/len_record

C interogate command line and determine whether to return on completion
C of the current command.
       call io_enqcli( command_line, len_com )
       exit_on_completion = len_com.ne.0

100    continue
       status = 0
       call cmd_scncmd( .false., status )
       call cmd_getcmd( 'Multi-Fit> ',liscom,number_commands,
     *                  icom,status)
       call cmd_scncmd( .true., status )
       if (status.ne.0) then
         call cmd_err(status,'Multi-Fit',' ')
         goto 100
       end if
       if (icom.le.0) return

C decode command
       if (chr_cmatch('clear-map-list',liscom(icom))) then
         nmaps = 0
         do n=start,128
           map_list(n) = 0
         end do

       else if (chr_cmatch('add-map-to-list',liscom(icom))) then
         string = ' '
         if (nmaps.ge.max_maps) then
           call io_wrout('*** Maximum number of maps reached in list')
           goto 100
         end if
         write(string,'(A,I2,A)')
     *         'Map-entry for map number ',nmaps+1,' : '
         call mapcat_getmap(string(1:chr_lenb(string)),
     *                      'Default-Map','READ',
     *                      imap,status)
         if (status.eq.IOLIB_OK) then
           iwarn = 0
           if (nmaps.eq.0) then
             first_map = imap
           else
             iwarn = 2
             first_map = map_list( start )
             call redt_comp(first_map,imap,iwarn,status)
           end if
           if (iwarn.le.5) then
             call io_getr('X/t-value : ','1.0',map_xval,status)
             call io_getr('Gate : ','0.0',map_gate,status)
             if (status.eq.IOLIB_OK) then
               map_entry = imap
               nmaps = nmaps + 1
               do i=1,len_record
                 map_list( i + start-1 + (nmaps-1)*len_record ) =
     *               map_record(i)
               end do
             end if
           else
             call io_wrout('*** Map not added to list')
           end if
         end if
         call cmd_err(status,'multi-fit',' ')

       else if (chr_cmatch('delete-map-from-list',liscom(icom))) then
         n = 1
         do while ( n.le.nmaps .and. status.eq.IOLIB_OK)
           do i=1,len_record
             map_record(i) = map_list( i + start-1 + (n-1)*len_record )
           end do
           call mapcat_enqsr(map_entry,source,program,status)
           string = ' '
           write(string,'(A,A,A2,A,A2,I3,A3)')
     *          'Remove map ',source(1:chr_lenb(source)),
     *          ' (',program(1:chr_lenb(program)),') ',map_entry,' ? '
           if (io_yesno(string(1:chr_lenb(string)),'no',status)) then
             if (status.eq.IOLIB_OK) then
               do nn=n+1,nmaps
                 do i=1,len_record
                   map_list( i + start-1 + (n-1)*len_record ) =
     *                 map_list( i + start-1 + (nn-1)*len_record )
                 end do
               end do
               nmaps = nmaps - 1
             end if
           end if
           n = n + 1
         end do
         if (status.eq.USR_BREAK) status = IOLIB_OK
         call cmd_err(status,'do_multi_fit',' ')

       else if (chr_cmatch('list-maps',liscom(icom))) then
         call io_enqout(iout)
         write(iout,'(A,I2,A,5(1PE10.2))')
     *         ' Model-type =',model,' constants =',
     *         (c_data(n), n=1,5)
         n = 1
         do while ( n.le.nmaps .and. status.eq.IOLIB_OK)
           do i=1,len_record
             map_record(i) = map_list( i + start-1 + (n-1)*len_record )
           end do
           call mapcat_enqsr(map_entry,source,program,status)
           if (status.eq.IOLIB_OK) then
              write(iout,'(A,A,A2,A,A2,I3,A,1PE12.2,A,1PE12.2)' )
     *          ' Map: ',source(1:chr_lenb(source)),
     *          ' (',program(1:chr_lenb(program)),') ',map_entry,
     *          ' Xvalue =',map_xval,'  Gate =',map_gate
           end if
           n = n + 1
         end do
         if (status.eq.USR_BREAK) status = IOLIB_OK
         call cmd_err(status,'multi-fit',' ')

       else if (chr_cmatch('set-fit-type',liscom(icom)) ) then
         call io_geti('Model-fit-type (1-3) : ','*',model,status)
         if (model.le.0 .or. model.gt.max_model) then
           call io_wrout('***Illegal model type: out of range')
           model = 1
         end if

       else if (chr_cmatch('set-constant',liscom(icom)) ) then
         call io_geti('Constant-to-set (1-5) : ','*',n,status)
         if (n.gt.0 .and. n.le.5) then
           call io_getr('Constant-value : ','*',c_data(n),status)
         else
           call io_wrout('***No such constant')
         end if

       else if (chr_cmatch('go',liscom(icom)) .or.
     *          chr_cmatch('make',liscom(icom))  ) then
          call redt_load(first_map,status)
          call redt_setxrdt( status )
          call map_alloc_new(0,0,map_list(16),filename,status)
          call stxrec('MULTIFIT',map_list,status)
          call sttype(0.0,-1,'Rho',' ',status)
          call map_end_alloc(map_list(16),dummy_argument,status)
          call map_alloc_new(0,0,map_list(17),filename,status)
          call stxrec('MULTIFIT',map_list,status)
          call sttype(0.0,-1,'Carr',' ',status)
          call map_end_alloc(map_list(17),dummy_argument,status)
          string = multifit_command//' '//filename
          if (chr_cmatch('make',liscom(icom))) then
            call anm_exec(string(1:chr_lenb(string)),
     *           'MAP-ANALYSIS','batch','exact',
     *           status)
          else
            call anm_exec(string(1:chr_lenb(string)),
     *           'MAP-ANALYSIS','background','exact',
     *           status)
          end if

       else if (chr_cmatch('help',liscom(icom))) then
         call hlp_setfil( multifit_helpfile, status )
         call hlp_system( ' ', ' ', .true., .true., status)
         call cmd_err(status,'HELP (Multi-Fit)',' ')

       end if

       if (.not.exit_on_completion) goto 100

       end