      subroutine zero_urbn

!!    ~ ~ ~ PURPOSE ~ ~ ~

!!    this subroutine zeros all array values used in urban modeling

      use parm

	urban_flag = 0
	sci = 0.

	hhsurf_bs = 0.
      bf_flg = 0.
      ubnrunoff = 0.
      ubntss = 0.
      abstinit = 0.
      iabstr = 0.

!!	subdaily sediment modeling by J.Jeong
	hhsedy=0.
	spl_eros = 0.
	rill_mult = 0.
	eros_expo = 0.
	sig_g = 0.
	ch_d50 = 0.
	rhy = 0.
	dratio = 0.
	c_factor = 0.
	iuh = 1
	uhalpha = 1.
	rchhr = 0.
	init_abstrc = 0

!!    subdaily bmp modeling
      lu_nodrain = "    "
      bmpdrain = 0
      !sed-fil
      num_sf = 0
      sf_fr = 0.
      sf_dim = 0
      sf_typ = 0.
      sf_im = 0.
      sf_iy = 0.
      sp_sa = 0.
      sp_pvol = 0.
      sp_qi = 0.
      sp_pd = 0.
      sp_bpw = 0.
      sp_k = 0.
      sp_sedi = 0.
      sp_sede = 0.
      sp_dp = 0.
      ft_sa = 0.
      ft_fsa = 0.
      ft_dep = 0.
      ft_h = 0.
      ft_pd = 0.
      ft_bpw = 0.
      ft_k = 0.
      ft_dp = 0.
      ft_dc = 0.
      ft_por = 0.4
      tss_den = 0.
      ft_alp = 0.
      sub_ha_imp = 0.
      sub_ha_urb = 0.
	ft_qpnd = 0.
	ft_qsw = 0.
	ft_qin = 0.
	ft_qout = 0.
	ft_sedpnd = 0.
	ft_sed_cumul = 0.
	sp_sed_cumul = 0.
	ft_qfg = 0
	sp_qfg = 0
	sf_ptp = 0
	ft_fc = 0
	!detention pond
	dtp_subnum = 0
	dtp_imo = 0
	dtp_iyr = 0
	dtp_numweir = 0
	dtp_numstage = 0
	stp_stagdis = 0
	dtp_reltype = 0
	dtp_onoff = 0
	dtp_evrsv = 0.
	dtp_inflvol = 0.
	dtp_totwrwid = 0.
	dtp_lwratio = 0.
	dtp_wdep = 0.
	dtp_totdep = 0.
	dtp_watdepact = 0.
	dtp_outflow = 0.
	dtp_totrel = 0.
	dtp_backoff = 0.
	dtp_seep_sa = 0.
	dtp_evap_sa = 0.
	dtp_pet_day = 0.
	dtp_pcpvol = 0.
	dtp_seepvol = 0.
	dtp_evapvol = 0.
	dtp_flowin = 0.
	dtp_backup_length = 0.
	dtp_intcept = 0.
	dtp_expont = 0.
	dtp_coef1 = 0.
	dtp_coef2 = 0.
	dtp_coef3 = 0.
	dtp_dummy1 = 0.
	dtp_dummy2 = 0.
	dtp_dummy3 = 0.
	dtp_wdratio = 0.
	dtp_depweir = 0.
	dtp_diaweir = 0.
	dtp_retperd = 0.
	dtp_pcpret = 0.
	dtp_cdis = 1.
	dtp_wrwid = 0.
	dtp_weirtype = 0.
	dtp_weirdim = 0.
	dtp_addon = 0.
	dtp_ivol = 0.
	dtp_ised = 0.
	dtp_flowrate = 0.
      !retention-irrigation
      ri_luflg(:) = 0
      ri_sed = 0.
      ri_sed = 0.
      ri_fr = 0.
      ri_dim = 0.
      ri_im = 0.
      ri_iy = 0.
      ri_sa = 0.
      ri_vol = 0.
      ri_qi = 0.
      ri_sedi = 0.
      ri_k = 0.
      ri_dd = 0.
      ri_evrsv = 0.
      ri_nirr = "    "
      ri_dep = 0.
      ri_ndt = 0.
      ri_subkm = 0.
      num_ri = 0
      hrnopcp = 100.
      ri_sed_cumul = 0.
      irmmdt = 0.
      subdr_kg = 0.
      subdr_ickm = 0.
      num_noirr = 0
      ri_qloss = 0
      ri_pumpv = 0

      !! wet pond
      wtp_subnum = 0
      wtp_onoff = 0
      wtp_imo = 0
      wtp_iyr = 0
      wtp_dim = 0
      wtp_stagdis = 0
      wtp_sdtype = 0
      wtp_pvol = 0.
      wtp_pdepth = 0.
      wtp_sdslope = 0.
      wtp_lenwdth = 0.
      wtp_extdepth = 0.
      wtp_hydeff = 0.
      wtp_evrsv = 0.
      wtp_sdintc = 0.
      wtp_sdexp = 0.
      wtp_sdc1 = 0.
      wtp_sdc2 = 0.
      wtp_sdc3 = 0.
      wtp_pdia = 0.
      wtp_plen = 0.
      wtp_pmann = 0.
      wtp_ploss = 0.
      sub_cn2 = 0.
 	  wtp_dp = 0.
	  wtp_sedi = 0.
	  wtp_sede = 0.
	  wtp_qi = 0.
      ovrlnd_dt = 0.
      bmp_recharge = 0.
      sfsedmean = 0.
      sfsedstdev = 0.

      return
      end


!----------------------------------------------------------------------------
! This file is part of UCLALES.
!
! UCLALES is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! UCLALES is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! Copyright 1999-2007, Bjorn B. Stevens, Dep't Atmos and Ocean Sci, UCLA
!----------------------------------------------------------------------------
!
MODULE advf
  USE mo_structured_datatypes

  IMPLICIT NONE

  INTEGER :: lmtr = 3

CONTAINS
  !
  !----------------------------------------------------------------------
  ! Subroutine fadvect: This is the driver for scalar advection.  It
  ! advects using the average of the velocities at the current and past
  ! times.
  !
  SUBROUTINE fadvect
    USE mo_progn_state, ONLY: a_qp
    USE mo_vector_state, ONLY : a_up, a_vp, a_wp, a_uc, a_vc, a_wc
    USE mo_aux_state, ONLY: dzt, dzm,dn0
    USE grid, ONLY : newsclr, nscl, a_sp, a_st, nxp, nyp, nzp, dtlt,  &
                     dxi, dyi, isgstyp
    !USE stat, ONLY : sflg, updtst
    USE util, ONLY : get_avg3

    REAL    :: a_tmp1(nzp,nxp,nyp), a_tmp2(nzp,nxp,nyp)
    INTEGER :: n
    LOGICAL :: iw
    !
    ! diagnose liquid water flux
    !
    !IF (sflg .AND. level > 1) THEN
    !   a_tmp1 = a_rc
    !   CALL add_vel(nzp,nxp,nyp,a_tmp2,a_wp,a_wc,.FALSE.)
    !   CALL mamaos(nzp,nxp,nyp,a_tmp2,a_rc,a_tmp1,zt,dzm,dn0,dtlt,.FALSE.)
    !   CALL get_avg3(nzp,nxp,nyp,a_tmp2,v1da)
    !   CALL updtst(nzp,'adv',0,v1da,1)
    !END IF
    !
    ! loop through the scalar table, setting iscp and isct to the
    ! appropriate scalar pointer and do the advection, also add large
    ! scale subsidence.  Don't advect TKE here since it resides at a
    ! w-point
    !
    DO n = 1, nscl
      CALL newsclr(n)

      IF ( ANY(a_sp /= 0.0 ) ) THEN ! TR added: no need to calculate advection for zero arrays
         a_tmp1 = a_sp

         IF (isgstyp > 1 .AND. associated(a_qp%d,a_sp)) THEN
            iw = .TRUE.
         ELSE
            iw = .FALSE.
         END IF

         CALL add_vel(nzp,nxp,nyp,a_tmp2,a_vp%d,a_vc%d,iw)
         CALL mamaos_y(nzp,nxp,nyp,a_tmp2,a_sp,a_tmp1,dyi,dtlt)

         CALL add_vel(nzp,nxp,nyp,a_tmp2,a_up%d,a_uc%d,iw)
         CALL mamaos_x(nzp,nxp,nyp,a_tmp2,a_sp,a_tmp1,dxi,dtlt)

         CALL add_vel(nzp,nxp,nyp,a_tmp2,a_wp%d,a_wc%d,iw)
         CALL mamaos(nzp,nxp,nyp,a_tmp2,a_sp,a_tmp1,dzt,dzm,dn0,dtlt,iw)

         !IF (sflg) THEN
         !   CALL get_avg3(nzp,nxp,nyp,a_tmp2,v1da)
         !   CALL updtst(nzp,'adv',n,v1da,1)
         !END IF

         CALL advtnd(nzp,nxp,nyp,a_sp,a_tmp1,a_st,dtlt)

      !ELSE IF (sflg) THEN
      !   ! Averages & statistics even for zeros (might be non-zero elsewhere)
      !   a_tmp2(:,:,:) = 0.
      !   CALL get_avg3(nzp,nxp,nyp,a_tmp2,v1da)
      !   !CALL updtst(nzp,'adv',n,v1da,1)
      END IF

    END DO

  END SUBROUTINE fadvect
  !
  !----------------------------------------------------------------------
  ! Subroutine newdroplet: Calculates the actual tendency in cloud droplets
  ! and aerosols due to cloud activation.
  !
  SUBROUTINE newdroplet(pactmask)
    USE mo_submctl, ONLY : ncld,nbins,ica,fca,eps,spec
    USE grid, ONLY : nxp,nyp,nzp,a_nactd,a_vactd
    USE mo_vector_state, ONLY : a_wp, a_wc
    USE mo_progn_state, ONLY : a_naerop, a_naerot, a_maerop, a_maerot,  &
                               a_ncloudt, a_mcloudt, a_rt
    USE mo_aux_state, ONLY : dzt

    IMPLICIT NONE

    LOGICAL, INTENT(in) :: pactmask(nzp,nxp,nyp)
    REAL    :: zw(nxp,nyp)
    INTEGER :: ii,jj,kk,bb,bbpar,ss,mm,mmpar,kp1,nc
    REAL    :: frac(nxp,nyp)
    REAL    :: fix_flux(nxp,nyp)
    REAL    :: dn(nxp,nyp),dv(nxp,nyp)

    ! Calculate the rate of change in cloud droplets due to cloud activation

    DO kk = 2, nzp-1

       kp1 = kk + 1 ! Tendency is applied in the level above where the potential number of activated is computed
       zw = 0.25*( a_wp%d(kk,:,:) + a_wc%d(kk,:,:) + a_wp%d(kp1,:,:) + a_wc%d(kp1,:,:) )
       frac = 0.

       DO bb = ica%cur, fca%cur

          bbpar = ica%par + (bb-ica%cur)

          dn(:,:) = zw(:,:)*a_nactd(kk,:,:,bb)*dzt%d(kk)

          DO jj = 3, nyp-2
             DO ii = 3, nxp-2
                fix_flux(ii,jj) = max(min(1.0,a_naerot%d(kp1,ii,jj,bbpar)/max(eps,dn(ii,jj))),0.8)
             END DO
          END DO

          ! Add to cloud droplets
          a_ncloudt%d(kp1,:,:,bb) = a_ncloudt%d(kp1,:,:,bb) +   &
                                  MERGE( dn(:,:)*fix_flux(:,:), 0., pactmask(kk,:,:) )

          ! Remove from aerosols
          a_naerot%d(kp1,:,:,bbpar) = a_naerot%d(kp1,:,:,bbpar) -   &
                                    MERGE( dn(:,:)*fix_flux(:,:), 0., pactmask(kk,:,:) )

          ! Change in dry ccn/aerosol mass
          DO ss = 1, spec%getNSpec(type="dry")

             mm = (ss-1)*ncld + bb
             mmpar = (ss-1)*nbins + bbpar

             dv(:,:) = zw(:,:)*a_vactd(kk,:,:,mm)*dzt%d(kk)

             DO jj = 3, nyp-2
                DO ii = 3, nxp-2
                   fix_flux(ii,jj) = max(min(1.0,a_maerot%d(kp1,ii,jj,mmpar)/max(eps,dv(ii,jj))),0.8)
                END DO
             END DO

             ! Add to cloud droplets
             a_mcloudt%d(kp1,:,:,mm) = a_mcloudt%d(kp1,:,:,mm) +   &
                                     MERGE( dv(:,:)*fix_flux(:,:), 0., pactmask(kk,:,:) )

             ! Remove from aerosols
             a_maerot%d(kp1,:,:,mmpar) = a_maerot%d(kp1,:,:,mmpar) -   &
                                       MERGE( dv(:,:)*fix_flux(:,:), 0., pactmask(kk,:,:) )

          END DO ! ss

          ! Change in water content
          ! Assume that existing condensate from aerosols bins is taken in the same relation
          ! as the number concentration....
          frac(:,:) = a_nactd(kk,:,:,bb)/MAX(a_naerop%d(kk,:,:,bbpar),1.)

          nc = spec%getIndex('H2O')
          mm = (nc-1)*ncld + bb
          mmpar = (nc-1)*nbins + bbpar

          ! Amount of water condensed from vapor
          a_rt%d(kp1,:,:) = a_rt%d(kp1,:,:) -   &
               MERGE( fix_flux(:,:)*zw(:,:)*(a_vactd(kk,:,:,mm)-frac(:,:) * &
                      a_maerop%d(kk,:,:,mmpar))*dzt%d(kk),                  &
                      0., pactmask(kk,:,:) )

          ! Add to cloud droplets
          a_mcloudt%d(kp1,:,:,mm) = a_mcloudt%d(kp1,:,:,mm) +       &
                                    MERGE( fix_flux(:,:)*zw(:,:) *  &
                                    a_vactd(kk,:,:,mm)*dzt%d(kk),   &
                                    0., pactmask(kk,:,:) )

          ! Remove from aerosols
          a_maerot%d(kp1,:,:,mmpar) = a_maerot%d(kp1,:,:,mmpar) -               &
                                      MERGE( fix_flux(:,:)*zw(:,:)*frac(:,:) *  &
                                      a_maerop%d(kk,:,:,mmpar)*dzt%d(kk),       &
                                      0., pactmask(kk,:,:) )

       END DO ! bb

    END DO ! kk

    ! Mask the number of activated for diagnostic output to be shown only in
    ! the points defined by the activation mask (0 elsewhere)
    DO bb = ica%cur, fca%cur
       a_nactd(:,:,:,bb) = MERGE(a_nactd(:,:,:,bb),0.,pactmask(:,:,:))
       DO ss = 1, spec%getNSpec(type="wet")
          mm = (ss-1)*ncld + bb
          a_vactd(:,:,:,mm) = MERGE(a_vactd(:,:,:,mm),0.,pactmask(:,:,:))
       END DO
    END DO

  END SUBROUTINE newdroplet

  !
  !----------------------------------------------------------------------
  ! Subroutine add_vel: Adds current and past timelevels of velocities
  ! into scratch arrays for advection
  !
  SUBROUTINE add_vel(n1,n2,n3,su,up,uc,lwpt)

    INTEGER, INTENT(in)  ::  n1,n2,n3
    REAL, INTENT(in)     ::  up(n1,n2,n3),uc(n1,n2,n3)
    LOGICAL, INTENT (in) ::  lwpt
    REAL, INTENT(out)    ::  su(n1,n2,n3)

    INTEGER :: i,j,k

    IF (lwpt) THEN
       DO j= 1, n3
          DO i= 1, n2
             DO k= 1, n1-1
                su(k,i,j) = 0.25*(up(k,i,j)+uc(k,i,j)+up(k+1,i,j)+uc(k+1,i,j))
             END DO
             su(n1,i,j) = su(n1-1,i,j)
          END DO
       END DO
    ELSE
       DO j = 1, n3
          DO i = 1, n2
             DO k = 1, n1
                su(k,i,j) = 0.5*(up(k,i,j)+uc(k,i,j))
             END DO
          END DO
       END DO
    END IF

  END SUBROUTINE add_vel
  !
  ! ----------------------------------------------------------------------
  ! Subroutine advtnd: Backs out the advective tendencies
  !
  SUBROUTINE advtnd(n1,n2,n3,varo,varn,tnd,dt)

    INTEGER, INTENT(in) :: n1,n2,n3
    REAL, INTENT(in)    :: varo(n1,n2,n3),varn(n1,n2,n3),dt
    REAL, INTENT(inout) :: tnd(n1,n2,n3)

    REAL    :: dti
    INTEGER :: i,j,k

    dti = 1./dt

    DO j = 3, n3-2
       DO i = 3, n2-2
          tnd(1,i,j) = 0.
          DO k = 2, n1-1
             tnd(k,i,j) = tnd(k,i,j)+(varn(k,i,j)-varo(k,i,j))*dti
          END DO
          tnd(n1,i,j) = 0.
       END DO
    END DO

    !tnd(n1-1:n1,:,:) = 0.

  END SUBROUTINE advtnd
  !
  !----------------------------------------------------------------------
  ! Subroutine mamaos: An alternative second order flux limited scheme
  ! written by Verica and Christiana as part of the MAMAOS program.
  !
  ! July 21, 2003
  !
  SUBROUTINE mamaos(n1,n2,n3,wp,scp0,scp,dzt,dzm,dn0,dt,lwpt)
    USE mpi_interface, ONLY : myid, appl_abort
    INTEGER, INTENT (in)            :: n1,n2,n3
    REAL, INTENT (in)               :: scp0(n1,n2,n3)
    TYPE(FloatArray1d), INTENT (in) :: dn0,dzt,dzm
    REAL, INTENT (in)               :: dt
    LOGICAL, INTENT (in)            :: lwpt
    REAL, INTENT (inout)            :: wp(n1,n2,n3),scp(n1,n2,n3)

    REAL    :: density(n1)   ! averaged density
    REAL    :: dzt_local(n1) ! grid spacing for scalars
    REAL    :: dzm_local(n1) ! grid spacing for velocity
    REAL    :: cfl(n1)       ! cfl numbers at the interface (staggered)
    REAL    :: C(n1)         ! limiter
    REAL    :: r(n1)         ! slope ratio
    REAL    :: wpdn(n1)      ! momentum: wp*density
    INTEGER :: i, j, k, kp1, k1, k2
    INTEGER :: gamma

    r = 0.
    C = 0.

    !
    ! initialize fields for use later
    !
    DO k = 1, n1
       kp1 = min(k+1,n1)
       density(k) = 0.5 * (dn0%d(k) + dn0%d(kp1))
       IF (lwpt) THEN
          dzt_local(k) = dzm%d(k)
          dzm_local(k) = dzt%d(kp1)
       ELSE
          dzt_local(k) = dzt%d(k)
          dzm_local(k) = dzm%d(k)
       END IF
    END DO

    DO j = 3, n3-2
       DO i = 3, n2-2
          !
          ! compute CFL and momentum
          !
          DO k = 1, n1-1
             cfl(k)  = wp(k,i,j) * dt * dzm_local(k)
             wpdn(k) = wp(k,i,j) * density(k)
             IF (abs(cfl(k)) > 1.0) THEN
                IF (myid == 0) WRITE(*,*) '  ABORTING: mamaos_z', cfl(k),wp(k,i,j),k,i,j
                CALL appl_abort (0)
             END IF
          END DO
          !
          ! calculate the ratio of slopes
          !
          DO k = 1, n1-1
             gamma = -INT(sign(1.,cfl(k)))
             IF (ABS(scp0(k+1,i,j)-scp0(k,i,j)) > 1.e-40  ) THEN!> SPACING(scp0(k,i,j)) ) THEN !.AND. scp0(k+1,i,j)-scp0(k,i,j) > 1.e-40) THEN
                k2 = max(1,k+gamma)
                k1 = min(n1,k+gamma+1)
                r(k) = (scp0(k1,i,j) - scp0(k2,i,j)) / (scp0(k+1,i,j) - scp0(k,i,j))
             ELSE
                r(k) = 0.
             END IF
          END DO
          !
          ! calculate the flux limiters
          !
          SELECT CASE (lmtr)
          CASE (1) ! minmod
             DO k = 1, n1-2
                C(k) = max(0., min(1., r(k)))
             END DO
          CASE(2)  ! superbee
             DO k = 1, n1-2
                C(k) = max(0., min(1., 2.*r(k)), min(2., r(k)))
             END DO
          CASE(3)  ! mc
             DO k = 1, n1-2
                C(k) = max(0., min(2.*r(k),(1.+r(k))/2., 2.))
             END DO
          CASE(4)  ! van Leer
             DO k = 1, n1-2
                C(k) = (r(k) + abs(r(k)))/(1. + abs(r(k)))
             END DO
          CASE DEFAULT ! no limiter
             DO k = 1, n1-2
                C(k) = 1.0
             END DO
          END SELECT

          wp(1,i,j) = 0.
          wp(n1-1,i,j) = 0.
          DO k = 2, n1-2
             wp(k,i,j) = 0.5 * wpdn(k) * (scp0(k+1,i,j)+scp0(k,i,j)) - &
                         0.5 * (scp0(k+1,i,j)-scp0(k,i,j)) *           &
                         ((1.-C(k))*abs(wpdn(k)) + wpdn(k)*cfl(k)*C(k))
          END DO
          DO k = 2, n1-1
             scp(k,i,j) = scp(k,i,j) - ((wp(k,i,j)-wp(k-1,i,j)) -      &
                          scp0(k,i,j)*(wpdn(k)-wpdn(k-1))) *           &
                          dt*dzt_local(k)/dn0%d(k)
          END DO

       END DO
    END DO

  END SUBROUTINE mamaos
 !
  !----------------------------------------------------------------------
  ! Subroutine mamaos_x: An alternative second order flux limited scheme
  ! for advection in the x direction.  (adapted from mamaos)
  !
  ! September 3, 2003
  !
  SUBROUTINE mamaos_x(n1,n2,n3,up,scp0,scp,dxi,dt)

    USE mpi_interface, ONLY : myid, appl_abort

    INTEGER, INTENT (in) :: n1,n2,n3
    REAL, INTENT (in)    :: dxi,dt
    REAL, INTENT (in)    :: scp0(n1,n2,n3),up(n1,n2,n3)
    REAL, INTENT (inout) :: scp(n1,n2,n3)

    REAL    :: cfl(n2,n1)       ! cfl numbers at the interface (staggered)
    REAL    :: C(n2,n1)         ! limiter
    REAL    :: r(n2,n1)         ! slope ratio
    REAL    :: scr(n2,n1)       ! flux scratch array
    INTEGER :: i, j, k, i1, i2
    INTEGER :: gamma
    !
    r = 0.
    C = 0.

    DO j = 3, n3-2
       !
       ! compute CFL and scr array for down-grid value of scalar
       !
       DO k = 2, n1-1
          DO i = 1, n2-1
             cfl(i,k) = up(k,i,j) * dt * dxi
             scr(i,k) = scp0(k,i+1,j)
             IF (abs(cfl(i,k)) > 1.0) THEN
                IF (myid == 0) PRINT *, '  ABORTING: mamaos_x'
                CALL appl_abort(0)
             END IF
          END DO
       END DO
          !
          ! calculate the ratio of slopes
          !
       DO k = 2, n1-1
          DO i = 2, n2-2
             gamma = INT(-sign(1.,cfl(i,k)))
             IF (abs(scr(i,k) - scp0(k,i,j)) > 1.e-40 ) THEN !> SPACING(scr(i,k))) THEN
                i2 = i+gamma
                i1 = i+gamma+1
                r(i,k) = (scp0(k,i1,j)-scp0(k,i2,j))/(scr(i,k)-scp0(k,i,j))
             ELSE
                r(i,k) = 0.
             END IF

             SELECT CASE (lmtr)
             CASE (1) ! minmod
                C(i,k) = max(0., min(1., r(i,k)))
             CASE(2)  ! superbee
                C(i,k) = max(0., min(1., 2.*r(i,k)), min(2., r(i,k)))
             CASE(3)  ! mc
                C(i,k) = max(0., min(2.*r(i,k),(1.+r(i,k))/2., 2.))
             CASE(4)  ! van Leer
                C(i,k) = (r(i,k) + abs(r(i,k)))/(1. + abs(r(i,k)))
             CASE DEFAULT ! no limiter
                C(i,k) = 1.0
             END SELECT

             scr(i,k) = 0.5 * up(k,i,j) * (scr(i,k)+scp0(k,i,j)) -      &
                        0.5 * (scr(i,k)-scp0(k,i,j)) *                  &
                        ((1.-C(i,k))*abs(up(k,i,j)) + up(k,i,j)*cfl(i,k)*C(i,k))
          END DO

          DO i = 3, n2-2
             scp(k,i,j) = scp(k,i,j) - ((scr(i,k)-scr(i-1,k)) -         &
                          scp0(k,i,j)*(up(k,i,j)-up(k,i-1,j)))*dt*dxi
          END DO
       END DO

    END DO

  END SUBROUTINE mamaos_x
  !
  !----------------------------------------------------------------------
  ! Subroutine mamaos_y: An alternative second order flux limited scheme
  ! for advection in the y direction.  (adapted from mamaos)
  !
  ! September 3, 2003
  !
  SUBROUTINE mamaos_y(n1,n2,n3,vp,scp0,scp,dyi,dt)

    USE mpi_interface, ONLY : myid, appl_abort

    INTEGER, INTENT (in) :: n1,n2,n3
    REAL, INTENT (in)    :: dyi,dt
    REAL, INTENT (in)    :: scp0(n1,n2,n3),vp(n1,n2,n3)
    REAL, INTENT (inout) :: scp(n1,n2,n3)

    REAL    :: cfl(n3,n1)       ! cfl numbers at the interface (staggered)
    REAL    :: C(n3,n1)         ! limiter
    REAL    :: r(n3,n1)         ! slope ratio
    REAL    :: scr(n3,n1)       ! flux scratch array
    INTEGER :: i, j, k, j1, j2
    INTEGER :: gamma
    !
    r = 0.
    C = 0.

    DO i = 1, n2
       !
       ! compute CFL and scr array for down-grid value of scalar
       !
       DO k = 2, n1-1
          DO j = 1, n3-1
             cfl(j,k) = vp(k,i,j) * dt * dyi
             scr(j,k) = scp0(k,i,j+1)
             IF (abs(cfl(j,k)) > 1.0) THEN
                IF (myid == 0) PRINT *, '  ABORTING: mamaos_y'
                CALL appl_abort(0)
             END IF
          END DO
       END DO
          !
          ! calculate the ratio of slopes
          !
       DO k = 2, n1-1
          DO j = 2, n3-2
             gamma = INT(-sign(1.,cfl(j,k)))
             IF (ABS(scr(j,k) - scp0(k,i,j)) > 1.e-40 ) THEN !> SPACING(scr(j,k)) ) THEN
                j2 = j+gamma
                j1 = j+gamma+1
                r(j,k) = (scp0(k,i,j1)-scp0(k,i,j2))/(scr(j,k)-scp0(k,i,j))
             ELSE
                r(j,k) = 0.
             END IF

             SELECT CASE (lmtr)
             CASE (1) ! minmod
                C(j,k) = max(0., min(1., r(j,k)))
             CASE(2)  ! superbee
                C(j,k) = max(0., min(1., 2.*r(j,k)), min(2., r(j,k)))
             CASE(3)  ! mc
                C(j,k) = max(0., min(2.*r(j,k),(1.+r(j,k))/2., 2.))
             CASE(4)  ! van Leer
                C(j,k) = (r(j,k) + abs(r(j,k)))/(1. + abs(r(j,k)))
             CASE DEFAULT ! no limiter
                C(j,k) = 1.0
             END SELECT

             scr(j,k) = 0.5 * vp(k,i,j) * (scr(j,k)+scp0(k,i,j)) -      &
                        0.5 * (scr(j,k)-scp0(k,i,j)) *                  &
                        ((1.-C(j,k))*abs(vp(k,i,j)) + vp(k,i,j)*cfl(j,k)*C(j,k))
          END DO

          DO j = 3, n3-2
             scp(k,i,j) = scp(k,i,j) - ((scr(j,k)-scr(j-1,k)) -         &
                          scp0(k,i,j)*(vp(k,i,j)-vp(k,i,j-1)))*dt*dyi
          END DO
       END DO

    END DO

  END SUBROUTINE mamaos_y

END MODULE advf


C
C	$Id: fdvdld.f,v 1.6 2008-07-27 00:23:04 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
      SUBROUTINE FDVDLD (IENTRY,IIX,IIY)
C
C Software dashed line package with character capability, smoothing,
C and the capability of removing crowded lines.
C
C PURPOSE                DASHSUPR is a software dashed line package with
C                        smoothing capabilities and the capability of
C                        removing crowded lines.
C
C USAGE                  First, do
C                             CALL RESET
C
C                        Then, either
C                             CALL DASHDB (IPAT)
C                        where IPAT is a 16-bit dash pattern as
C                        described in the subroutine DASHDB (see
C                        DASHLINE documentation), or
C                             CALL DASHDC (IPAT,JCRT,JSIZE)
C                        as described below.
C
C                        Then, call any of the following:
C                             CALL CURVED (X,Y,N)
C                             CALL FRSTD (X,Y)
C                             CALL VECTD (X,Y)
C                             CALL LASTD
C
C                        LASTD is called only after the last
C                        point of a line has been processed in VECTD.
C
C                        The following may also be called, but no
C                        smoothing will result:
C                             CALL LINED (XA,YA,XB,YB)
C
C                        PWRTM can be called to draw characters and
C                        mark, in the model picture, the regions where
C                        the characters have been drawn.
C                             CALL PWRTM (X,Y,IDPC,ISIZ,IOR,ICNT)
C                        For details, see the subroutine PWRTM in
C                        this package.
C
C ARGUMENTS              IPAT
C ON INPUT                 A character string of arbitrary length
C TO DASHDC                (60 characters seems to be a practical
C                          limit) which specifies the dash pattern
C                          to be used.  A dollar sign in IPAT
C                          indicates solid; an apostrophe indicates
C                          a gap; blanks are ignored.  Any character
C                          in IPAT which is not a dollar sign,
C                          apostrophe, or blank is considered to be
C                          part of a line label.  Each line label
C                          can be at most 15 characters in length.
C                          Sufficient white space is reserved in the
C                          dashed line for writing line labels.
C
C                        JCRT
C                          The length in plotter address units per
C                          $ or apostrophe.
C
C                        JSIZE
C                          Is the size of the plotted characters:
C                          . If between 0 and 3 , it is 1., 1.5, 2.
C                            and 3. times an 8 plotter address unit
C                            width.
C                          . If greater than 3, it is the character
C                            width in plotter address units.
C
C
C ARGUMENTS TO           CURVED(X,Y,N)
C OTHER LINE-DRAWING       X and Y are arrays of world coordinate values
C ROUTINES                 of length N or greater.  Line segments obeying
C                          the specified dash pattern are drawn to
C                          connect the N points.
C
C                        FRSTD(X,Y)
C                          The current pen position is set to
C                          the world coordinate value (X,Y)
C
C                        VECTD(X,Y)
C                          A line segment is drawn between the
C                          world coordinate value (X,Y) and the
C                          most recent pen position.  (X,Y) then
C                          becomes the most recent pen position.
C
C                        LINED(XA,XB,YA,YB)
C                          A line is drawn between world coordinate
C                          values (XA,YA) and (XB,YB).
C
C                        LASTD
C                          When using FRSTD and VECTD, LASTD must be
C                          called (no arguments needed).  LASTD sets up
C                          the calls to the smoothing routines MSKRV1
C                          and MSKRV2.
C
C
C                        PWRTM (X,Y,IDPC,ISIZ,IOR,ICNT)
C                          The arguments for PWRTM are the same as those
C                          for the utility support routine WTSTR.
C
C ON OUTPUT                All arguments are unchanged for all routines.
C
C NOTE                     When switching from the regular plotting
C                          routines to a dashed line package the first
C                          call should not be to VECTD.
C
C ENTRY POINTS             DASHDB, DASHDC, CURVED, FRSTD, VECTD, LINED,
C                          RESET, LASTD, CFVLD, FDVDLD, DRAWPV, DASHBD,
C                          DASHBDX, CUTUP, REMOVE, MARKL, PWRTM
C
C COMMON BLOCKS            INTPR, DASHD1, DASHD2, DDFLAG, DCFLAG, DSAVE1,
C                          DSAVE6, DSAVE3, DSAVE4, DSAVE5, CFFLAG, SMFLAG,
C                          DFFLAG,
C
C REQUIRED LIBRARY         The ERPRT77 package and the SPPS.
C ROUTINES
C
C REQUIRED GKS LEVEL       0A
C
C I/O                      Plots solid or dashed lines, possibly with
C                          characters at intervals in the line.
C                          The lines may also be smoothed.
C
C PRECISION                Single
C
C LANGUAGE                 FORTRAN
C
C HISTORY                  Originally written by Tom Reid at Texas A & M.
C                          Made portable in 1977 for all machines which
C                          support plotters with up to 15 bit resolution.
C                          Converted to FORTRAN77 and GKS in June, 1984.
C
C ALGORITHM                Points for each line
C                          segment are processed and passed to the
C                          routines, MSKRV1 and MSKRV2, which compute
C                          splines under tension passing through these
C                          points.  New points are generated between the
C                          given points, resulting in smooth lines.
C                          As each line is drawn, a test is done to see if
C                          that part of the plotting plane has been drawn
C                          on.  If it has, then that line, or part of that
C                          line, is not drawn.  As the lines are drawn,
C                          they are also marked into the model picture.
C
C                          The model picture is a bit map, 1024 X 1024
C                          which marks each pixel as it is used.
C
C                          Note:  The user should draw all lines of major
C                                 importance first and then lines
C                                 of minor importance since the algorithm
C                                 removes the last line drawn if line
C                                 removal is necessary.
C
C ACCURACY                 Plus or minus .5 plotter address units per call.
C                          There is no cumulative error.
C
C TIMING                   About four times as long as DASHCHAR.
C
C PORTABILITY              FORTRAN77
C
C INTERNAL PARAMETERS      NAME   DEFAULT  FUNCTION  DECLARED IN BLOCK DATA
C                          ----   -------  --------
C
C                          IPAU      3     Number of plotter addresses per
C                                          element in the dash pattern for
C                                          solid lines and gaps. The
C                                          pattern is repeated every
C                                          IPAU*16 plotter address units.
C
C                          FPART     1.    Multiplicative factor for
C                                          first solid line segment.
C                                          This can be used to off-set
C                                          labels.  For example, if
C                                          FPART = .5, the first solid
C                                          line segment is only
C                                          one-half as long as the other
C                                          solid line segments.  This
C                                          moves all labels on this
C                                          line towards the beginning,
C                                          which reduces the
C                                          probability of the label
C                                          being written on top of a
C                                          label of a nearby line
C                                          drawn with FPART = 1.
C
C                          IGP       9     Flag to control whether a gap
C                                          is left for characters when
C                                          plotting.
C                                            = 9  Gap is left.
C                                            = 0  No gap is left.
C
C                          IOFFS     0     Flag to turn on smoothing code.
C                                            = 0  Smoothing.
C                                            = 1  No smoothing.
C
C                          TENSN     2.5   Tension factor.  Must be
C                                          greater than 0.  A large
C                                          tension factor (30.) would
C                                          essentially turn off smoothing.
C
C                          NP        150   Twice the maximum number of
C                                          interpolated points on a
C                                          horizontal line with length
C                                          equal to that of the grid.
C                                          More points per unit length are
C                                          interpolated for short lines
C                                          than for long lines.
C
C                          SMALL     128.  Minimum distance in metacode
C                                          address units between points
C                                          which are saved.  When the
C                                          points on a line are being
C                                          processed, only the first of two
C                                          consecutive points is saved if
C                                          the points are less than SMALL
C                                          metacode address units apart.
C                                          This procedure is to prevent
C                                          cusps.
C
C                          L1        70    The maximum number of points
C                                          saved at one time.  If there
C                                          are more than L1 points on a
C                                          given line, L1 points are
C                                          processed, then the next L1,
C                                          until the entire line is
C                                          processed.  Smoothness between
C                                          segments is maintained
C                                          automatically.  If L1 is
C                                          increased, the dimensions of
C                                          XSAVE, YSAVE, XP, YP, TEMP,
C                                          and SLEN in FDVDLD must be
C                                          increased to the new value
C                                          of L1.
C
C                          ADDLR     2.    Number of plotter address units
C                                          added to each character string,
C                                          on the left and the right, as
C                                          free space.
C
C                          ADDTB     2.    Number of plotter address units
C                                          added to each character string,
C                                          on the top and on the bottom, as
C                                          free space.
C
C                          MLLINE    384   The maximum length in each
C                                          coordinate of a single line to
C                                          be processed by the crowded
C                                          line algorithm.  Lines longer
C                                          than MLLINE metacode address
C                                          units in a coordinate are broken
C                                          into smaller segments each of
C                                          which is processed separately.
C                                          This is done to prevent
C                                          anomalies in the removal of
C                                          long lines since only the
C                                          starting point and end point of
C                                          each line is checked in that
C                                          process.
C
C                          ICLOSE    6     An internal or external call to
C                                          set the pen (pen-up) to a
C                                          specific position is executed
C                                          only if this position is
C                                          more than ICLOSE metacode
C                                          address units away from the
C                                          current pen position (distance=
C                                          difference in X-coordinates +
C                                          difference in Y-coordinates).
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C***********************************************************************
C
C IMPLEMENTATION INSTRUCTIONS:
C
C   1.) SET THE MACHINE AND MODEL DEPENDENT CONSTANTS AND DECLARATIONS
C       IN SUBROUTINE REMOVE (SEE COMMENTS IN REMOVE FOR DETAILS).
C
C   2.) SET THE CONSTANT ISKIP IN BLOCK DATA DASHBDX.
C       SEE COMMENTS IN DASHBDX FOR DETAILS.
C
C END OF IMPLEMENTATION INTRUCTIONS
C
C***********************************************************************
C
C
C FDVDLD RECEIVES IN ITS ARGUMENTS THE POINTS TO BE PROCESSED FOR A
C LINE SEGMENT. IT PASSES THESE POINTS TO THE ROUTINES MSKRV1 AND MSKRV2
C WHICH COMPUTE SPLINES UNDER TENSION PASSING THROUGH THESE POINTS.
C FDVDLD THEN CALLS CFVLD TO CONNECT THE POINTS GENERATED IN MSKRV2.
C
      DIMENSION       XP(70),  YP(70),  TEMP(70),  SLEN(70)
C
C THE VARIABLES IN DSAVE5 HAVE TO BE SAVED FOR THE NEXT CALL TO FDVDLD.
C
      COMMON /DSAVE5/ XSAVE(70), YSAVE(70), XSVN, YSVN, XSV1, YSV1,
     1                SLP1, SLPN, SSLP1, SSLPN, N, NSEG
C
C IOFFS IS AN INTERNAL PARAMETER. IT IS INITIALIZED IN DASHBDX AND
C REFERENCED IN FDVDLD AND DRAWPV.
C
      COMMON /SMFLAG/ IOFFS
C
C IFSTF2 IS A FLAG TO CONTROL THAT FRSTD IS CALLED BEFORE VECTD IS
C CALLED.
C
      COMMON /DFFLAG/ IFSTF2
C
C IFLAG CONTROLS IF LASTD CAN BE CALLED DIRECTLY OR IF IT WAS JUST
C CALLED FROM BY VECTD SO THAT THIS CALL CAN BE IGNORED.
C
      COMMON /FDFLAG/ IFLAG
C
C NOTE THAT THIS IFSTF2 FLAG CANNOT BE IDENTICAL TO THE IFSTFL FLAG
C IN THE ROUTINE CFVLD, BECAUSE A CALL TO THE FRSTD ENTRY OF FDVDLD DOES
C NOT ELIMINATE THE NECESSITY OF A CALL TO THE FRSTD ENTRY OF CFVLD,
C AND REVERSE.
C
      COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE,
     1    ICLOSE
      SAVE
C
C
C OTHER CONSTANTS.
C
      DATA PI /3.14159265358/
      DATA IDUMMY /0/
C
C
      GO TO (10,15,35),IENTRY
C
C *************************************
C
C ENTRY  FRSTD (XX,YY)
C
   10 DEG = 180./PI
C
      MX = IIX
      MY = IIY
      IFSTF2 = 0
      SSLP1 = 0.0
      SSLPN = 0.0
      XSVN = 0.0
      YSVN = 0.0
      IF (IOFFS .GE. 1) CALL CFVLD (1,MX,MY)
      IF (IOFFS .GE. 1) RETURN
C
C INITIALIZE THE POINT AND SEGMENT COUNTER
C N COUNTS THE NUMBER OF POINTS/SEGMENT
C
      N = 0
C
C NSEG = 0       FIRST SEGMENT
C NSEG = 1       MORE THAN ONE SEGMENT
C
      NSEG = 0
C
C SAVE THE X,Y COORDINATES OF THE FIRST POINT
C XSV1           CONTAINS THE X COORDINATE OF THE FIRST POINT
C                OF A LINE
C YSV1           CONTAINS THE Y COORDINATE OF THE FIRST POINT
C                OF A LINE
C
      XSV1 = MX
      YSV1 = MY
      GO TO 30
C
C *************************************
C
C     ENTRY VECTD (XX,YY)
C
   15 CONTINUE
C
C TEST FOR PREVIOUS FRSTD CALL
C
      IF (IFSTF2 .EQ. 0) GO TO 20
C
C INFORM USER - NO PREVIOUS CALL TO FRSTD. TREAT CALL AS FRSTD CALL.
C
      CALL SETER(' FDVDLD- VECTD CALL OCCURS BEFORE A CALL TO FRSTD.',
     -            1,1)
      GO TO 10
   20 MX = IIX
      MY = IIY
C
C VECTD          SAVES THE X,Y COORDINATES OF THE ACCEPTED
C                POINTS ON A LINE SEGMENT
C
      IF (IOFFS .GE. 1) CALL CFVLD (2,MX,MY)
      IF (IOFFS .GE. 1) RETURN
C
C IF THE NEW POINT IS TOO CLOSE TO THE PREVIOUS POINT, IGNORE IT
C
      IF (ABS(REAL(INT(XSVN)-MX))+ABS(REAL(INT(YSVN)-MY)) .LT.
     1    SMALL) RETURN
      IFLAG = 0
   30 N = N+1
C
C SAVE THE X,Y COORDINATES OF EACH POINT OF THE SEGMENT
C XSAVE          THE ARRAY OF X COORDINATES OF LINE SEGMENT
C YSAVE          THE ARRAY OF Y COORDINATES OF LINE SEGMENT
C
      XSAVE(N) = MX
      YSAVE(N) = MY
      XSVN = XSAVE(N)
      YSVN = YSAVE(N)
      IF (N .GE. L1-1) GO TO 40
      RETURN
C
C *************************************
C
C     ENTRY LASTD
C
   35 CONTINUE
      IF (IFSTF2 .NE. 0) RETURN
      IFSTF2 = 1
C
C LASTD          CHECKS FOR PERIODIC LINES AND SETS UP
C                  THE CALLS TO MSKRV1 AND MSKRV2
C
      IF (IOFFS .GE. 1) CALL CFVLD (3,IDUMMY,IDUMMY)
      IF (IOFFS .GE. 1) RETURN
C
C IFLAG = 0      OK TO CALL LASTD DIRECTLY
C IFLAG = 1      LASTD WAS JUST CALLED FROM BY VECTD
C                IGNORE CALL TO LASTD
C
      IF (IFLAG .EQ. 1) RETURN
C
C COMPARE THE LAST POINT OF SEGMENT WITH FIRST POINT OF LINE
C
   40 IFLAG = 1
C
C IPRD = 0       PERIODIC LINE
C IPRD = 1       NON-PERIODIC LINE
C
      IPRD = 1
      IF (ABS(XSV1-XSVN)+ABS(YSV1-YSVN) .LT. SMALL) IPRD = 0
C
C TAKE CARE OF THE CASE OF ONLY TWO DISTINCT P0INTS ON A LINE
C
      IF (NSEG .GE. 1) GO TO 60
      IF (N-2) 150,140,50
   50 IF (N .GE. 4) GO TO 60
C
      IF (IPRD .NE. 0) GO TO 60
      DX = XSAVE(2)-XSAVE(1)
      DY = YSAVE(2)-YSAVE(1)
      SLOPE = ATAN2(DY,DX)*DEG+90.
      IF (SLOPE .GE. 360.) SLOPE = SLOPE-360.
      IF (SLOPE .LE. 0.) SLOPE = SLOPE+360.
      SLP1 = SLOPE
      SLPN = SLOPE
      ISLPSW = 0
      SIGMA = TENSN
      GO TO 100
   60 SIGMA = TENSN
      IF (IPRD .GE. 1) GO TO 80
      IF (NSEG .GE. 1) GO TO 70
C
C SET UP FLAGS FOR A  1  SEGMENT, PERIODIC LINE
C
      ISLPSW = 4
      XSAVE(N) = XSV1
      YSAVE(N) = YSV1
      GO TO 100
C
C SET UP FLAGS FOR AN N-SEGMENT, PERIODIC LINE
C
   70 SLP1 = SSLPN
      SLPN = SSLP1
      ISLPSW = 0
      GO TO 100
   80 IF (NSEG .GE. 1) GO TO 90
C
C SET UP FLAGS FOR THE 1ST SEGMENT OF A NON-PERIODIC LINE
C
      ISLPSW = 3
      GO TO 100
C
C SET UP FLAGS FOR THE NTH SEGMENT OF A NON-PERIODIC LINE
C
   90 SLP1 = SSLPN
      ISLPSW = 1
C
C CALL THE SMOOTHING ROUTINES
C
  100 CALL MSKRV1 (N,XSAVE,YSAVE,SLP1,SLPN,XP,YP,TEMP,SLEN,SIGMA,ISLPSW)
C
C DETERMINE THE NUMBER OF POINTS TO INTERPOLATE FOR EACH SEGMENT
C
      IF (NSEG.GE.1 .AND. N.LT.L1-1) GO TO 110
      NPRIME = REAL(NP)-(SLEN(N)*REAL(NP)*.5)/32767.
      IF (SLEN(N) .GE. 32767.) NPRIME = .5*REAL(NP)
      NPL = MAX(REAL(NPRIME)*SLEN(N)/32767.,2.5)
  110 DT = 1./REAL(NPL)
      IX = INT (XSAVE(1))
      IY = INT (YSAVE(1))
      IF (NSEG .LE. 0) GO TO 112
      CALL DRAWPV (IX,IY,0)
      GO TO 114
  112 CONTINUE
      CALL CFVLD (1,IX,IY)
  114 CONTINUE
      T = 0.0
      NSLPSW = 1
      IF (NSEG .GE. 1) NSLPSW = 0
      NSEG = 1
      CALL MSKRV2 (T,XS,YS,N,XSAVE,YSAVE,XP,YP,SLEN,SIGMA,NSLPSW,SLP)
C
C SAVE SLOPE AT THE FIRST POINT OF THE LINE
C
      IF (NSLPSW .GE. 1) SSLP1 = SLP
      NSLPSW = 0
      DO 120 I=1,NPL
         T = T+DT
         IF (I .EQ. NPL) NSLPSW = 1
         CALL MSKRV2 (T,XS,YS,N,XSAVE,YSAVE,XP,YP,SLEN,SIGMA,NSLPSW,SLP)
C
C SAVE THE LAST SLOPE OF THIS LINE SEGMENT
C
         IF (NSLPSW .GE. 1) SSLPN = SLP
C
C DRAW EACH PART OF THE LINE SEGMENT
C
         IX = INT (XS)
         IY = INT (YS)
         CALL CFVLD (2,IX,IY)
  120 CONTINUE
      IF (IPRD .NE. 0) GO TO 130
C
C CONNECT THE LAST POINT WITH THE FIRST POINT OF A PERIODIC LINE
C
      IX = INT (XSV1)
      IY = INT (YSV1)
      CALL CFVLD (2,IX,IY)
C
C BEGIN THE NEXT LINE SEGMENT WITH THE LAST POINT OF THIS SEGMENT
C
  130 XSAVE(1) = XS
      YSAVE(1) = YS
      N = 1
      IF (IFSTF2 .EQ. 1) CALL CFVLD (3,IDUMMY,IDUMMY)
      GO TO 150
C
C FOR THE CASE WHEN THERE ARE ONLY 2 DISTINCT POINTS ON A LINE.
C
  140 CONTINUE
      IX1 = INT (XSAVE(1))
      IY1 = INT (YSAVE(1))
      IX2 = INT (XSAVE(N))
      IY2 = INT (YSAVE(N))
      CALL CUTUP (IX1,IY1,IX2,IY2)
C
  150 CONTINUE
      RETURN
      END


C
C 			Lyon's Cochlear Model, The Program
C 	   			   Malcolm Slaney
C 			     Advanced Technology Group
C 				Apple Computer, Inc.
C 				 malcolm@apple.com
C 				   November 1988
C
C 	This program implements a model of acoustic propagation and detection
C 	in the human cochlea.  This model was first described by Richard F.
C 	Lyon.  Please see
C 		Malcolm Slaney, "Lyon's Cochlear Model, the Mathematica
C 		Notebook," Apple Technical Report #13, 1988
C 	for more information.  This report is available from the Apple
C 	Corporate Library.
C
C 	Warranty Information
C 	Even though Apple has reviewed this software, Apple makes no warranty
C 	or representation, either express or implied, with respect to this
C 	software, its quality, accuracy, merchantability, or fitness for a
C 	particular purpose.  As a result, this software is provided "as is,"
C 	and you, its user, are assuming the entire risk as to its quality
C 	and accuracy.
C
C 	Copyright (c) 1988-1990 by Apple Computer, Inc
C
C  $Header: ftopix.f,v 2.2 90/12/17 18:02:27 malcolm Exp $
C
C  $Log:	ftopix.f,v $
c Revision 2.2  90/12/17  18:02:27  malcolm
c Cleaned up and moved ALIMIT subroutine to this file.
c
c Revision 2.1  90/01/28  15:37:01  malcolm
c Added capability (MRKPXL subroutine) so that an arbitrary pixel in the
c image can be marked with red.
c
c Revision 2.0  89/07/25  18:58:42  malcolm
c Completely debugged and tested version on the following machines (roughly
c in order of performance):
c Cray, Stellar, SGI, Sun-4, Sequent Balance, Sun-3, VAX, Macintosh under
c both MPW and LightSpeed C.
c
c Revision 1.4  89/07/19  17:04:47  malcolm
c Added code to expand picture by different amounts in x and y.
c
c Revision 1.3  89/03/24  15:02:39  malcolm
c Everything turned upside down.  Top and bottom of the picture were
c flipped so that high frequencies (low channel numbers) are at the top.
c Also, high energy points in the picture are now black like they are in
c a conventional spectrogram.
c
c Revision 1.2  88/12/06  21:14:54  malcolm
c Added comments and rearranged declarations
c
c Revision 1.1  88/10/23  22:42:47  malcolm
c Initial revision
c
C
C
C***********************************************************************
C	FTOPIX - Routine to convert an array of floats into pixels for
C	the ultra frame buffer.  This routine takes as arguments an
C	incore frame buffer (dest), an array of floating point numbers
C	(source), the width and height of the data and the min and max
C	of the data.  No checks are made that the data doesn't exceed
C	the limits passed as arguments.
C
C	The incore frame buffer is an array of integers (64 bits each).
C	Each word of the frame buffer holds two pixels.  The format of the
C	data in the word is as follows
C		|			64 bit word			     |
C		| Left Pixel (32 bits)	    |   Right Pixel (32 bits)	     |
C		| Empty|Blue |  Green | Red |	Empty | Blue |  Green | Red  |
C	Each of the RGB values is one byte.  The magic number 0x10101 is
C	used to take a single gray scale level (between 0 and 255) and to
C	fill in the Red, Green and Blue values in the word.
C
C	Finally, one more performance hack.  It is necessary to shift the
C	left pixel into place instead of incorporating the shift into the
C	multiplication by 0x10101 because Cray integer arithmetic is only
C	48 bits long.
C
C	The UltraBuffer is represented in memory as a array of words in TV
C	raster order (top left pixel first).  This routine puts the image
C	centered on the screen with the first byte of the input array at the
C	lower left of the screen.
C
C	The CMIC$ directives enable microtasking of the loop.
C
C	The magic numbers that are used here are:
C	255 - Maximum value for a pixel
C	1280 - Width in pixels of the ultra display
C	1024 - Height in pixels of the ultra display
C	65793 - Equal to 0x10101 - Needed to convert gray scale level into RGB
C

CMIC$ MICRO
      subroutine FTOPIX(dest, source, width, height, minimum, maximum)
      integer dest(1280/2,*), i, j, width, height, expand
      integer xexpand, yexpand, oldpixel, mask, newpixel
      real source(width,height), minimum, maximum, scale, minvalue
      common /PIXEL/ markedx, markedy

C	For high resolution monitor
C     parameter (nwidth=1280, nheight=1024)
C	For NTSC resolution monitor
C     parameter (nwidth=750, nheight=484)

      parameter (nwidth=780, nheight=480)
C     parameter (nwidth=1280, nheight=1024)

C
C	There is a special hack installed in this version of ftopix that
C	allows the user to mark a pixel in the image with a bright color.
C	This color is specified by the following parameter.  (It is just
C	jammed into the pixel after putting everything else in place.)
      parameter (color=255)

c     scale = maximum
c     maximum = minimum
c     minimum = scale
c     print *,maximum, minimum, scale

      scale = 255.0/(maximum - minimum)

      minvalue = maximum
      scale = 255.0/(minimum - maximum)

      xexpand = 1
      if (width*2 .lt. nwidth) xexpand = 2
      if (width*4 .lt. nwidth) xexpand = 4

      yexpand = 1
      if (height*2 .lt. nheight) yexpand = 2
      if (height*4 .lt. nheight) yexpand = 4

      expand = yexpand
      if (xexpand .lt. yexpand) expand = xexpand

      if (expand .eq. 1) then
        if (xexpand .eq. 1 .and. yexpand .ge. 2) then
CMIC$ DO GLOBAL
          do 300 j = 1, height
CDIR$ IVDEP
             do 400 i = 1, width, 2
              dest(nwidth/2/2-width/2/2+i/2, nheight/2-height+2*j) =
     +         SHIFTL(INT((source(i+1,j)-minvalue)*scale)*65793, 32).OR.
     +                INT((source(i  ,j)-minvalue)*scale)*65793
              dest(nwidth/2/2-width/2/2+i/2, nheight/2-height+2*j+1) =
     +         SHIFTL(INT((source(i+1,j)-minvalue)*scale)*65793, 32).OR.
     +                INT((source(i  ,j)-minvalue)*scale)*65793
  400        continue
  300      continue
	   if (markedx .gt. 0 .and. markedx .le. width .and.
     +         markedy .gt. 0 .and. markedy .le. height) then
	     if (mod(markedx,2) .eq. 1) then
	       newpixel = SHIFTL(color,32)
	       mask = 16777215
	     else
	       newpixel = color
	       mask = SHIFTL(16777215,32)
	     endif

	     oldpixel = dest(nwidth/2/2-width/2/2+markedx/2,
     +                       nheight/2-height+2*markedy)
	     dest(nwidth/2/2-width/2/2+markedx/2,
     +            nheight/2-height+2*markedy) =
     +                  (mask .and. oldpixel) + color
	     oldpixel = dest(nwidth/2/2-width/2/2+markedx/2,
     +                       nheight/2-height+2*markedy+1)
	     dest(nwidth/2/2-width/2/2+markedx/2,
     +            nheight/2-height+2*markedy+1) =
     +                  (mask .and. oldpixel) + color
	   endif
         else

CMIC$ DO GLOBAL
           do 1100 j = 1, height
CDIR$ IVDEP
            do 1200 i = 1, width, 2
              dest(nwidth/2/2-width/2/2+i/2, nheight/2-height/2+j) =
     +         SHIFTL(INT((source(i+1,j)-minvalue)*scale)*65793,32).OR.
     +                INT((source(i  ,j)-minvalue)*scale)*65793
 1200       continue
 1100      continue
	   if (markedx .gt. 0 .and. markedx .le. width .and.
     +         markedy .gt. 0 .and. markedy .le. height) then
	     if (mod(markedx,2) .eq. 1) then
	       newpixel = SHIFTL(color,32)
	       mask = 16777215
	     else
	       newpixel = color
	       mask = SHIFTL(16777215,32)
	     endif

	     oldpixel = dest(nwidth/2/2-width/2/2+markedx/2,
     +                       nheight/2-height/2+markedy)
	     dest(nwidth/2/2-width/2/2+markedx/2,
     +            nheight/2-height/2+markedy) =
     +                  (mask .and. oldpixel) + color
	   endif
	 endif
       endif

       if (expand .eq. 2) then
CMIC$ DO GLOBAL
         do 2100 j = 1, height
CDIR$ IVDEP
            do 2200 i = 1, width
             dest(nwidth/2/2-width/2+i, nheight/2-height+2*j) =
     +          SHIFTL(INT((source(i,j)-minvalue)*scale)*65793, 32).OR.
     +                 INT((source(i,j)-minvalue)*scale)*65793
             dest(nwidth/2/2-width/2+i, nheight/2-height+2*j+1) =
     +          SHIFTL(INT((source(i,j)-minvalue)*scale)*65793, 32).OR.
     +                 INT((source(i,j)-minvalue)*scale)*65793
 2200       continue
 2100    continue
	 if (markedx .gt. 0 .and. markedx .le. width .and.
     +       markedy .gt. 0 .and. markedy .le. height) then
	   dest(nwidth/2/2-width/2+markedx,
     +          nheight/2-height+2*markedy) =
     +         SHIFTL(color,32) + color
	   dest(nwidth/2/2-width/2+markedx,
     +          nheight/2-height+2*markedy+1) =
     +         SHIFTL(color,32) + color
	 endif
       endif

       if (expand .eq. 4) then
CMIC$ DO GLOBAL
         do 4100 j = 1, height
CDIR$ IVDEP
            do 4200 i = 1, width
             dest(nwidth/2/2-width+2*i, nheight/2-2*height+4*j) =
     +          SHIFTL(INT((source(i,j)-minvalue)*scale)*65793, 32).OR.
     +                 INT((source(i,j)-minvalue)*scale)*65793
             dest(nwidth/2/2-width+2*i, nheight/2-2*height+4*j+1) =
     +          SHIFTL(INT((source(i,j)-minvalue)*scale)*65793, 32).OR.
     +                 INT((source(i,j)-minvalue)*scale)*65793
             dest(nwidth/2/2-width+2*i, nheight/2-2*height+4*j+2) =
     +          SHIFTL(INT((source(i,j)-minvalue)*scale)*65793, 32).OR.
     +                 INT((source(i,j)-minvalue)*scale)*65793
             dest(nwidth/2/2-width+2*i, nheight/2-2*height+4*j+3) =
     +          SHIFTL(INT((source(i,j)-minvalue)*scale)*65793, 32).OR.
     +                 INT((source(i,j)-minvalue)*scale)*65793
             dest(nwidth/2/2-width+2*i+1, nheight/2-2*height+4*j) =
     +          SHIFTL(INT((source(i,j)-minvalue)*scale)*65793, 32).OR.
     +                 INT((source(i,j)-minvalue)*scale)*65793
             dest(nwidth/2/2-width+2*i+1, nheight/2-2*height+4*j+1) =
     +          SHIFTL(INT((source(i,j)-minvalue)*scale)*65793, 32).OR.
     +                 INT((source(i,j)-minvalue)*scale)*65793
             dest(nwidth/2/2-width+2*i+1, nheight/2-2*height+4*j+2) =
     +          SHIFTL(INT((source(i,j)-minvalue)*scale)*65793, 32).OR.
     +                 INT((source(i,j)-minvalue)*scale)*65793
             dest(nwidth/2/2-width+2*i+1, nheight/2-2*height+4*j+3) =
     +          SHIFTL(INT((source(i,j)-minvalue)*scale)*65793, 32).OR.
     +                 INT((source(i,j)-minvalue)*scale)*65793
 4200       continue
 4100    continue
	 if (markedx .gt. 0 .and. markedx .le. width .and.
     +       markedy .gt. 0 .and. markedy .le. height) then
	   dest(nwidth/2/2-width+2*markedx,
     +          nheight/2-2*height+4*markedy) =
     +         SHIFTL(color,32) + color
	   dest(nwidth/2/2-width+2*markedx+1,
     +          nheight/2-2*height+4*markedy) =
     +         SHIFTL(color,32) + color
	   dest(nwidth/2/2-width+2*markedx,
     +          nheight/2-2*height+4*markedy+1) =
     +         SHIFTL(color,32) + color
	   dest(nwidth/2/2-width+2*markedx+1,
     +          nheight/2-2*height+4*markedy+1) =
     +         SHIFTL(color,32) + color
	   dest(nwidth/2/2-width+2*markedx,
     +          nheight/2-2*height+4*markedy+2) =
     +         SHIFTL(color,32) + color
	   dest(nwidth/2/2-width+2*markedx+1,
     +          nheight/2-2*height+4*markedy+2) =
     +         SHIFTL(color,32) + color
	   dest(nwidth/2/2-width+2*markedx,
     +          nheight/2-2*height+4*markedy+3) =
     +         SHIFTL(color,32) + color
	   dest(nwidth/2/2-width+2*markedx+1,
     +          nheight/2-2*height+4*markedy+3) =
     +         SHIFTL(color,32) + color
	 endif
       endif

      return
      end

      subroutine MRKPXL(x,y)
      common /PIXEL/ markedx, markedy
      integer x, y

      markedx = x
      markedy = y

      return
      end

      block data PixState
      common /PIXEL/ markedx, markedy
      data markedx/-1/, markedy/-1/
      end

      subroutine alimit(array,n,fmin,fmax)
      integer n, i
      real array(n), fmin, fmax

c     write *, "n is ",n,", fmin is ",fmin,", fmax is ",fmax
      do 10 i=1,n
	 array(i) = amax1(amin1(array(i),fmax),fmin)
c	 array(i) = array(i)*.5
   10 continue
      return
      end


!--------------------------------------------------------------------
! This file is part of HiggsSignals (TS 03/03/2013)
!--------------------------------------------------------------------
module io
!--------------------------------------------------------------------

 use usefulbits, only : Hneut,Hplus,Chineut,Chiplus
 use input, only : count_columns, getfilelength, stem_array, required, f_orig
 implicit none

 contains

!--------------------------------------------------------------------
 subroutine setup_input_for_hs
!--------------------------------------------------------------------
! * if inputmethod='datfile' finds np,Exptdata
! * if inputmethod='datfile', finds infile1 (prefix for input/output filenames)
! * sets ndat (number of parameter points considered)
! * sets n_additional (number of additional data values for each parameter point)
! * allocates theo, g2, partR
!--------------------------------------------------------------------
  use usefulbits, only : np,ndat,n_additional,theo,effC,g2,partR, &
         &               inputmethod,whichinput, &
         &               debug,infile1,infile2, &
         &               allocate_hadroncolliderextras_parts,allocate_dataset_parts, &
         &               allocate_couplratio_parts,allocate_sqcouplratio_parts,fill_pdesc
  use input, only : getshortcommandline,check_number_of_particles, fill_stem_array,  &
         &          file_name_msg
  use theory_BRfunctions
  implicit none
  !-----------------------------------internal
  integer :: f,ios,cc,g
  character(LEN=50) :: stem
  !-------------------------------------------

  call fill_pdesc

  select case(inputmethod)
  case('datfile')
   call getbasiccommandline_for_hs!get whichanalyses,whichinput,numbers of particles
   call getshortcommandline(infile1,infile2)! get infile1
  case('subrout')
   !np(Hneut),np(Hplus)  are already set
   call check_number_of_particles
!   call check_whichanalyses
   !haven't yet set whichanalyses,whichinput
   infile1=''
  case default
   stop 'incorrect value for inputmethod'
  end select

  !getting ndat and n_additional...
  select case(inputmethod)
  case('datfile')
   f=f_orig
   n_additional=0
   select case(whichinput)
   case('part','effC','hadr')

    call fill_stem_array

    g=1
    stem=stem_array(g)
    f=f_orig+g

    open(f,file=trim(infile1)//trim(stem)//'.dat',status='old',action='read',iostat=ios)
    if(ios.ne.0)then
     call file_name_msg(f)
     write(*,*)'Check that <prefix> was specified correctly'
     write(*,*)'and that file exists.'
     call flush(6)
     stop 'Problem opening file: see standard output for more info'
    endif

    ndat=getfilelength(f) ! number of data sets (i.e. lines) in input

    if((ndat.le.0))stop 'error getting ndat'
    close(f)

    g=ubound(stem_array,dim=1)
    stem=stem_array(g)
    f=f_orig+g
    !the last element in stem_array should be 'additional'
    if(trim(stem_array(g)).ne.'additional')stop 'Error in subroutine setup_input (a)'

    required(g)=.False.

    open(f,file=trim(infile1)//trim(stem)//'.dat',status='old',action='read',iostat=ios)

    if(ios.eq.0)then

     cc=count_columns(f)

     if(cc.gt.1)then
      if(getfilelength(f).eq.ndat)then
       n_additional=cc-1
       required(g)=.True.
      endif
     endif
    endif
    close(f)

   case('SLHA')
    ndat=1  ;  n_additional=0
   case default
    stop  'error in subroutine do_input (1a)'
   end select
  case('website','subrout')
   ndat=1   ;  n_additional=0
  case default
   stop 'error in subroutine do_input (1b)'
  end select
  !...finished getting ndat and n_additional

  if(debug)then
   write(*,*)'np(Hneut)=',np(Hneut)
   write(*,*)'ndat=',ndat
   write(*,*)'n_additional=',n_additional
  endif

  allocate(theo(ndat))

  call allocate_dataset_parts(theo,n_additional)

! - Outdated:
  allocate(g2(ndat))
  call allocate_sqcouplratio_parts(g2)
! -
  allocate(effC(ndat))
  call allocate_couplratio_parts(effC)

  allocate(partR(ndat))
  call allocate_hadroncolliderextras_parts(partR)

 end subroutine setup_input_for_hs
!--------------------------------------------------------------------
 subroutine getbasiccommandline_for_hs
!--------------------------------------------------------------------
 ! finds whichanalyses,whichinput,np from command line
!--------------------------------------------------------------------
  !nb iargc and getarg are non-standard
  use usefulbits, only : np,pdesc,whichinput,inputmethod
  use usefulbits_hs, only : Exptdir, runmode, pdf
  use input, only : check_number_of_particles, check_whichinput, nargs_datfile
  implicit none
  !-----------------------------------internal
  character(LEN=100) :: temp
  character(LEN=5) :: nHtemp, pdftemp
  integer :: i,x
  integer :: number_args
  logical :: wrong_args
  !-------------------------------------------
  number_args = IARGC()

 !Exptdir, runmode, pdf, whichinput, np(Hneut), np(Hplus) , prefix
  nargs_datfile =  4+         2        +1
  np(Chineut)=0
  np(Chiplus)=0

  wrong_args= (number_args .ne. nargs_datfile)

  if( wrong_args )then
   write(*,*) "Incorrect number of parameters given on command line"
   call command_line_how2_for_hs
   stop "Error: command line entered incorrectly (see standard output for more info)"
  endif

  ! Read arguments into text strings.
  i=1

  temp=""
  call GETARG(i,temp)
  Exptdir = ""
  Exptdir = trim(temp)
  i=i+1

  temp=""
  call GETARG(i,temp)
  runmode = ""
  runmode = trim(temp)
  i=i+1

  temp=""
  call GETARG(i,temp)
  pdftemp = ""
  pdftemp = trim(temp)
  i=i+1

  if(verify(pdftemp," 1234567890").gt.0)then
    ! checks that the string nHtemp just contains the characters " 1234567890"
    ! the function verify is standard in fortran 95
    write(*,*)'Incorrect pdf: not a number.'
    write(*,*)'(you entered pdf="'//trim(adjustl(pdftemp))//'")'
    call command_line_how2_for_hs
    stop "Error: command line entered incorrectly (see standard output for more info)"
   endif

   read(pdftemp,*) pdf

  temp=""
  call GETARG(i,temp)
  whichinput = ""
  whichinput = trim(temp)
  i=i+1

  do x=1,2
   temp=""
   call GETARG(i,temp)
   nHtemp = ""
   nHtemp = trim(temp)
   i=i+1

   if(verify(nHtemp," 1234567890").gt.0)then
    ! checks that the string nHtemp just contains the characters " 1234567890"
    ! the function verify is standard in fortran 95
    write(*,*)'Incorrect n'//trim(adjustl(pdesc(x)%short))//': not a number.'
    write(*,*)'(you entered n'//trim(adjustl(pdesc(x)%short))//&
&             '="'//trim(adjustl(nHtemp))//'")'
    write(*,*)'n'//trim(adjustl(pdesc(x)%short))//' is the number of '//&
&             trim(adjustl(pdesc(x)%long))//'s'
    call command_line_how2_for_hs
    stop "Error: command line entered incorrectly (see standard output for more info)"
   endif

   read(nHtemp,*) np(x)
  enddo

  call check_number_of_particles
  call check_whichinput

 end subroutine getbasiccommandline_for_hs
!--------------------------------------------------------------------
 subroutine command_line_how2_for_hs
!--------------------------------------------------------------------
  use usefulbits, only : np,inputmethod

   write(*,*)'The correct syntax for the command line is:'

   write(*,*)' ./HiggsSignals <expdata> <mode> <pdf> ',&
&            '<whichinput> <nHzero> <nHplus> <prefix>'
   write(*,*)'e.g.'
   write(*,*)' ./HiggsSignals latestresults peak 2 part 3 1 example_data/random/HB_randomtest50points_'

   write(*,*)'See HiggsSignals manual for more details.'
   call flush(6)
 end subroutine command_line_how2_for_hs
!--------------------------------------------------------------------
 subroutine do_output_for_hs
 ! Writes output to file or screen, depending on whether
 ! inputmethod='datfile' or inputmethod='website'
!--------------------------------------------------------------------
  use usefulbits, only : theo,ndat,inputmethod,np,fullHBres, &
          &              n_additional, file_id_common, file_id_common2,  & !input
        &              whichanalyses,whichinput,pr,listprocesses,infile1
  use usefulbits_hs, only : analyses, StrCompress, pdf, runmode,  HSres, HSvers, Exptdir,&
&  Nparam

!  use extra_bits_for_web
!  use S95tables
!  use extra_bits_for_SLHA

  implicit none
  !-----------------------------------internal
  integer :: i,j,ii,jj,x,n,n_sum,kk
  character(LEN=1) :: nHchar
  character(LEN=3) :: addchar,tempchar
  character(LEN=8) :: createdate
  character(LEN=10) :: createtime
  character(LEN=19) :: createdateandtime
  character(LEN=100) :: format43
  character(LEN=500) :: columndescription
  type(listprocesses) :: proc
  character(LEN=200):: descrip
  double precision, allocatable :: Mhall(:,:)
  character(LEN=100) :: formatspec
  character(LEN=13) :: pdf_desc(3) = (/'box         ','gaussian    ','box+gaussian'/)
  !-------------------------------------------

 select case(inputmethod)
 case('datfile')
  select case(whichinput)
  case('SLHA')
   call HiggsSignals_outputSLHAdata(infile1)
  case('effC','part','hadr')

   if((np(Hneut)>0).or.(np(Hplus)>0))then
     allocate(Mhall(ndat,np(Hneut)+np(Hplus)))
     do jj=1,ndat
      ii=0
      if(np(Hneut)>0)then
       do i=1,np(Hneut)
        Mhall(jj,i)=theo(jj)%particle(Hneut)%M(i)
       enddo
       ii=np(Hneut)
      endif
      if(np(Hplus)>0)then
       do i=1,np(Hplus)
        Mhall(jj,ii+i)=theo(jj)%particle(Hplus)%M(i)
       enddo
      endif
     enddo
   else
    stop 'error in subroutine do_output(1)'
   endif

   format43='(1I14,'
   write(nHchar,'(I1)')np(Hneut)
   if(np(Hneut)>0)format43=trim(adjustl(format43))//nHchar//'G16.6,'

   write(nHchar,'(I1)')np(Hplus)
   if(np(Hplus)>0)format43=trim(adjustl(format43))//nHchar//'G16.6,'

   format43=trim(adjustl(format43))//'3G16.6,3I6,1G16.6'

   write(addchar,'(I3)')n_additional
   if(n_additional>0)format43=trim(adjustl(format43))//','//trim(adjustl(addchar))//'G16.6'

   format43=trim(adjustl(format43))//')'

   open(file_id_common,file=trim(infile1)//"HiggsSignals_results.dat")
   if(runmode.eq.'peak'.or.runmode.eq.'both') then
    open(file_id_common2,file=trim(infile1)//"peakobservables.dat")
   endif

   call date_and_time(createdate,createtime)

   createdateandtime=createdate(7:8)//'.' &
         &  //createdate(5:6)//'.' &
         &  //createdate(1:4)//' at '&
         &  //createtime(1:2)//':' &
         &  //createtime(3:4)

   write(file_id_common,*)'# generated with HiggsSignals version '//&
&                         trim(adjustl(HSvers))//' on '//createdateandtime
   write(file_id_common,*)'# settings: '//adjustl(trim(Exptdir))//', '//whichinput//', '&
&                         //runmode//', '//adjustl(trim(pdf_desc(pdf)))
   write(file_id_common,*)'#'
   write(file_id_common,*)'# column abbreviations'
   write(file_id_common,*)'#   n          : line id of input'
   if(np(Hneut)>0)write(file_id_common,*)'#   Mh(i)      : ',&
&                                        'Neutral Higgs boson masses in GeV'
   if(np(Hplus)>0)write(file_id_common,*)'#   Mhplus(i)  : ',&
&                                        'Charged Higgs boson masses in GeV'
   write(file_id_common,*)'#   csq(mu)    : Chi^2 from the signal strengths observables'
   write(file_id_common,*)'#   csq(mh)    : Chi^2 from the Higgs mass observables'
   write(file_id_common,*)'#   csq(tot)   : total Chi^2'
   write(file_id_common,*)'#   nobs(mu)   : number of signal strength observables'
   write(file_id_common,*)'#   nobs(mh)   : number of Higgs mass observables'
   write(file_id_common,*)'#   nobs(tot)  : total number of observables'
   write(file_id_common,"(A,I3)")'#   Pvalue     : Probability, given csq(tot) and ndf=nobs(tot)-',Nparam
   if(n_additional>0)then
    write(file_id_common,*)'#   additional : ',&
&       'optional additional data stored in <prefix>additional.dat (e.g. tan beta)'
   endif
   write(file_id_common,*)'#'

   if(runmode.eq.'peak'.or.runmode.eq.'both') then
    formatspec='(I3,8X,I10,3X,F6.2,1X,4F9.4,7X,A3,6X,F6.2,5X,F6.2,3X,I3,3X,A40,5X,A)'
    write(file_id_common2,*) "# List of peak observables used from " &
&                            //trim(adjustl(Exptdir))//":"
    write(file_id_common2,*)'#'
    write(file_id_common2,*)'# Number        : HS internal numbering of analysis'
    write(file_id_common2,*)'# Analysis-ID   : identity number of analysis'
    write(file_id_common2,*)'# mh_obs        : Mass position of peak observable',&
&                         ' (hypothetical Higgs mass where signal strength was measured)'
    write(file_id_common2,*)'# mu_obs        : Observed (best-fit) signal strength value'
    write(file_id_common2,*)'# dmu_low       : Lower 1s (cyan band) signal strength value'
    write(file_id_common2,*)'# dmu_high      : Upper 1s (cyan band) signal strength value'
    write(file_id_common2,*)'# dmh_exp       : Experimental mass uncertainty of analysis'
    write(file_id_common2,*)'# collaboration : ',&
&                             'Exp. collaboration which published the data'
    write(file_id_common2,*)'# energy        : ',&
&                             'center-of-mass energy of the experiment (TeV)'
    write(file_id_common2,*)'# luminosity    : ',&
&                             'integrated luminosity used for the measurement (fb-1)'
    write(file_id_common2,*)'# mass-chi2     : ',&
&                             'Mass measurement entering the Chi^2 (1/0=yes/no)'
    write(file_id_common2,*)'# description   : Higgs process of analysis'
    write(file_id_common2,*)'# reference     : ',&
&                             'Experimental publication of the data/analysis'
    write(file_id_common2,*)'#'
    write(file_id_common2,*)'# Number Analysis-ID   mh_obs    mu_obs  dmu_low dmu_high ',&
& 				" dmh_exp  collaboration  energy  luminosity  mass-chi2               ", &
&               "          description     reference"
    write(file_id_common2,*) "#"
    kk=0
    do i=lbound(analyses,dim=1),ubound(analyses,dim=1)
     do j=lbound(analyses(i)%peaks,dim=1),ubound(analyses(i)%peaks,dim=1)
      kk=kk+1
      write(file_id_common2,formatspec)kk,analyses(i)%id,analyses(i)%peaks(j)%mpeak,&
    & analyses(i)%peaks(j)%mu, analyses(i)%peaks(j)%dmulow,analyses(i)%peaks(j)%dmuup,	&
    & analyses(i)%table%deltam,analyses(i)%table%collaboration, analyses(i)%table%energy,&
    & analyses(i)%table%lumi, analyses(i)%table%mhchisq, &
    & trim(strcompress(analyses(i)%table%desc)), analyses(i)%table%label
     enddo
    enddo
   close(file_id_common2)
   endif

   columndescription='#cols:  n'

   if(np(Hneut)>0)then
    do i=1,np(Hneut)
     write(tempchar,'(I3)')i
     columndescription=trim(columndescription)//'           Mh('//&
    &                  trim(adjustl(tempchar))//')  '
    enddo
   endif

   if(np(Hplus)>0)then
    do i=1,np(Hplus)
     write(tempchar,'(I3)')i
     columndescription=trim(columndescription)//'       Mhplus('// &
   &                   trim(adjustl(tempchar))//')  '
    enddo
   endif

   columndescription=trim(columndescription)//'         csq(mu)         csq(mh)      '//&
&   '   csq(tot) nobs(mu) nobs(mh) nobs(tot)    Pvalue'

   if(n_additional>0)then
    do i=1,n_additional
     write(tempchar,'(I3)')i
     columndescription=trim(columndescription)//'   additional('// &
     &                 trim(adjustl(tempchar))//')   '
    enddo
   endif

   write(file_id_common,*)trim(columndescription)
   write(file_id_common,*)'#'

   if(n_additional>0)then
    do jj=1,ndat
     write(file_id_common,fmt=trim(format43))jj,(Mhall(jj,i),i=1,np(Hneut)+np(Hplus)), &
          &      HSres(jj)%Chisq_mu,HSres(jj)%Chisq_mh,HSres(jj)%Chisq,              &
          &      HSres(jj)%nobs_mpred+HSres(jj)%nobs_peak_mu,HSres(jj)%nobs_peak_mh, &
          &      HSres(jj)%nobs,HSres(jj)%Pvalue,(theo(jj)%additional(i),i=1,n_additional)
    enddo
   else
    do jj=1,ndat
   write(file_id_common,fmt=trim(format43))jj,(Mhall(jj,i),i=1,np(Hneut)+np(Hplus)), &
          &      HSres(jj)%Chisq_mu,HSres(jj)%Chisq_mh,HSres(jj)%Chisq,              &
          &      HSres(jj)%nobs_mpred+HSres(jj)%nobs_peak_mu,HSres(jj)%nobs_peak_mh, &
          &      HSres(jj)%nobs,HSres(jj)%Pvalue
    enddo
   endif

  close(file_id_common)
  deallocate(Mhall)
  case default
   stop 'error in subroutine do_output (*2)'
  end select
! case('website')
!    do jj=1,ndat
!-----NOTE: Need to change weboutput in extra_bits_for_web for the new all-Higgses mode!!!
!      call weboutput(res(jj))
!    enddo
 case('subrout')
    select case(whichinput)
    case('SLHA')
       call HiggsSignals_outputSLHAdata(infile1)
    case default
       stop  'error in subroutine do_output(c)'
    end select
 case default
    stop  'error in subroutine do_output (*1)'
 end select

 end subroutine do_output_for_hs
!--------------------------------------------------------------------
subroutine setup_output_for_hs
!-Allocates the HBresults array.
!--------------------------------------------------------------------
  use usefulbits, only : ndat !input
  use usefulbits_hs, only : HSres !input

  implicit none

  allocate(HSres(ndat))

end subroutine setup_output_for_hs
!--------------------------------------------------------------------
subroutine get_ID_of_peakobservable(ii, ID)
 use usefulbits_hs, only : HSres

 implicit none
 integer, intent(in) :: ii
 integer, intent(out) :: ID

 if(ii.gt.size(HSres(1)%obsID,dim=1).or.ii.le.0) then
  write(*,*) 'WARNING in get_peakinfo_from_HSresults: Peak observable ',		&
&			 ii,' unkwown! Returning zero.'
  ID = 0
 else
  ID = HSres(1)%obsID(ii)
 endif

end subroutine get_ID_of_peakobservable
!--------------------------------------------------------------------
subroutine get_peakinfo(obsID, muobs, dmuup, dmulow, mpeak, dm)
!--------------------------------------------------------------------
 use usefulbits_hs, only : obs
 implicit none
 integer, intent(in) :: obsID
 double precision, intent(out) :: muobs, dmuup, dmulow, mpeak, dm
 integer :: pos, ii

 pos = -1
 do ii=lbound(obs,dim=1),ubound(obs,dim=1)
  if(obs(ii)%id.eq.obsID) then
   pos = ii
   exit
  endif
 enddo

 if(pos.ne.-1) then
  mpeak = obs(pos)%peak%mpeak
  dm = obs(pos)%peak%dm
  muobs = obs(pos)%peak%mu
  dmuup = obs(pos)%peak%dmuup
  dmulow = obs(pos)%peak%dmulow
 else
  write(*,*) "WARNING in get_peakinfo: ID unknown."
 endif
end subroutine get_peakinfo
!--------------------------------------------------------------------
subroutine get_more_peakinfo(obsID, mhchisq)
!--------------------------------------------------------------------
 use usefulbits_hs, only : obs
 implicit none
 integer, intent(in) :: obsID
 integer, intent(out) :: mhchisq
 integer :: pos, ii

 pos = -1
 do ii=lbound(obs,dim=1),ubound(obs,dim=1)
  if(obs(ii)%id.eq.obsID) then
   pos = ii
   exit
  endif
 enddo

 if(pos.ne.-1) then
  mhchisq = obs(pos)%table%mhchisq
 else
  write(*,*) "WARNING in get_peakinfo: ID unknown."
 endif

end subroutine get_more_peakinfo
!--------------------------------------------------------------------
subroutine get_peak_channels(obsID, Nc, IDs, efficiencies)
!--------------------------------------------------------------------
 use usefulbits_hs, only : obs
 implicit none
 integer, intent(in) :: obsID
 integer, intent(out) :: Nc
 integer, allocatable, intent(out) :: IDs(:)
 double precision, allocatable, intent(out) :: efficiencies(:)

 integer :: pos, ii

 pos = -1
 do ii=lbound(obs,dim=1),ubound(obs,dim=1)
  if(obs(ii)%id.eq.obsID) then
   pos = ii
   exit
  endif
 enddo

 if(pos.ne.-1) then
  Nc = obs(pos)%table%Nc
  allocate(IDs(Nc),efficiencies(Nc))
  IDs = obs(pos)%table%channel_id
  efficiencies = obs(pos)%table%channel_eff
 else
  write(*,*) "WARNING in get_peakinfo: ID unknown."
 endif
end subroutine get_peak_channels
!--------------------------------------------------------------------
subroutine get_peakinfo_from_HSresults(obsID, mupred, domH, nHcomb)
!--------------------------------------------------------------------
 use usefulbits_hs, only : HSres

 implicit none
 integer, intent(in) :: obsID
 double precision, intent(out) :: mupred
 integer, intent(out) :: domH, nHcomb
 integer :: pos, ii

 pos = -1
 do ii=lbound(HSres(1)%nH,dim=1),ubound(HSres(1)%nH,dim=1)
  if(obsID.eq.HSres(1)%obsID(ii)) then
   pos = ii
   exit
  endif
 enddo

 if(pos.ne.-1) then
  mupred = HSres(1)%mupred(ii)
  domH = HSres(1)%domH(ii)
  nHcomb = HSres(1)%nH(ii)
 else
  write(*,*) 'WARNING in get_peakinfo_from_HSresults: Peak observable ',		&
&			 obsID,' unkwown! Returning zeros.'
  mupred = 0.0D0
  domH = 0
  nHcomb = 0
 endif

end subroutine get_peakinfo_from_HSresults
!--------------------------------------------------------------------
subroutine get_number_of_observables(ntotal, npeakmu, npeakmh, nmpred, nanalyses)
!--------------------------------------------------------------------
 use usefulbits_hs, only : HSres

 implicit none
 integer, intent(out) :: ntotal, npeakmu, npeakmh, nmpred, nanalyses

 ntotal = HSres(1)%nobs
 npeakmu = HSres(1)%nobs_peak_mu
 npeakmh = HSres(1)%nobs_peak_mh
 nmpred = HSres(1)%nobs_mpred
 nanalyses = HSres(1)%nanalysis

end subroutine get_number_of_observables
!--------------------------------------------------------------------
subroutine HiggsSignals_SLHA_output(detailed)
!--------------------------------------------------------------------
use usefulbits, only : whichinput,just_after_run
use usefulbits_hs, only : SLHAdetailed
integer, intent(in) :: detailed

if(detailed.eq.0) SLHAdetailed = .False.

!use output, only : do_output
!!!integer, intent(in) :: i

  if(.not.just_after_run)then
   stop  'subroutine run_HiggsSignals should be called'//&
   	   ' before subroutine HiggsSignals_SLHA_output'
  endif

  select case(whichinput)
  case('SLHA')
    call do_HiggsSignals_output
  case default
    stop 'The subroutine HiggsSignals_SLHA_output should'//&
    ' only be used if an input SLHA file is given.'
  end select

end subroutine HiggsSignals_SLHA_output
!--------------------------------------------------------------------
 subroutine do_HiggsSignals_output
!--------------------------------------------------------------------
  use usefulbits, only : inputmethod,whichanalyses,whichinput,infile1

  implicit none

 select case(inputmethod)
 case('datfile')
  select case(whichinput)
  case('SLHA')
   call HiggsSignals_outputSLHAdata(infile1)
   case default
    stop 'error in subroutine do_output (*2)'
   end select
 case('subrout')
    select case(whichinput)
    case('SLHA')
       call HiggsSignals_outputSLHAdata(infile1)
    case default
       stop 'error in subroutine do_output(c)'
    end select
 case default
    stop 'error in subroutine do_output (*1)'
 end select

 end subroutine do_HiggsSignals_output
!--------------------------------------------------------------------
subroutine HiggsSignals_create_SLHA_output_default(detailed)
! Wrapper subroutine of HiggsSignals_create_SLHA_output with a fixed
! name of output file ("HS-output.slha").
!--------------------------------------------------------------------
 implicit none
 integer, intent(in) :: detailed

 call HiggsSignals_create_SLHA_output("HS-output.slha", detailed)

end subroutine HiggsSignals_create_SLHA_output_default
!--------------------------------------------------------------------
subroutine HiggsSignals_create_SLHA_output(infile, detailed)
!--------------------------------------------------------------------
 use usefulbits, only : just_after_run, file_id_common
 use usefulbits_hs, only : SLHAdetailed, newSLHAfile
 implicit none

  character(len=*),intent(in) :: infile
  integer, intent(in) :: detailed
  integer :: ios
  character(len=80) :: infile_80

  if(detailed.eq.0) SLHAdetailed = .False.

  write(infile_80,*) infile
  if(trim(adjustl(infile_80)).ne.trim(adjustl(infile))) then
   write(*,*) "WARNING: SLHA output file name is too long (> 80 elements)!"
  endif

  if(.not.just_after_run)then
   stop 'subroutine run_HiggsSignals should be called'//&
   	   ' before subroutine HiggsSignals_SLHA_output'
  endif

  open(unit=file_id_common,file=trim(adjustl(infile_80)),status='new',iostat=ios)
  if(ios.ne.0) then
   write(*,*) 'Problem creating the SLHA file: $'//trim(adjustl(infile))//'$'
   write(*,*) 'This file may already exist. SLHA output writing is skipped.'
  else
   close(file_id_common)
   newSLHAfile=.True.
   call HiggsSignals_outputSLHAdata(infile_80)
   newSLHAfile=.False.
  endif

end subroutine HiggsSignals_create_SLHA_output
!************************************************************
 subroutine HiggsSignals_outputSLHAdata(infile)
 !************************************************************
  use usefulbits, only : whichanalyses,file_id_common
  use extra_bits_for_SLHA, only : h
  use usefulbits_hs, only : HSvers, HSres, runmode, pdf, analyses, Exptdir, SLHAdetailed,&
 &                          newSLHAfile
  use SLHA_manip		! n.b.: needed for readSLHAfile, writeSLHAfile_except, finishwithSLHA

  implicit none
  !--------------------------------------input
  character(len=80),intent(in) :: infile
  !-----------------------------------internal
  integer :: i,j,ios,a
  integer :: k_out, Nh
  character(LEN=200):: descrip, formatstring
  !-------------------------------------------

  open(file_id_common,file=trim(adjustl(infile)),status='old',iostat=ios)
  if(ios.ne.0)then
    write(*,*)'problem opening the SLHA file: $'//trim(adjustl(infile))//'$'
  else

    k_out=file_id_common

    if(.not.newSLHAfile) then
     call readSLHAfile(file_id_common,.True.)
     rewind(file_id_common)
     call writeSLHAfile_except(k_out,'HiggsSignalsResults','HiggsSignalsPeakObservables',&
& 	  'HiggsSignalsMassCenteredObservables')
    endif

    write(k_out,'(a)')'BLOCK HiggsSignalsResults'
    write(k_out,'(3X,I2,17X,A2,A,A2,15X,A)') 0,'||',trim(adjustl(HSvers)),'||',		&
&    '# HiggsSignals version'
    write(k_out,'(3X,I2,9X,A2,A,A2,15X,A)')1,'||',trim(adjustl(Exptdir)),'||',	&
&    '# experimental data set'
	select case(runmode)
	 case('peak')
    write(k_out,'(3X,I2,25X,I1,15X,A)') 2,1,								&
&   '# Chi-squared method ("peak"(1) or "mass"(2)-centered or "both"(3))'
	 case('mass')
    write(k_out,'(3X,I2,25X,I1,15X,A)') 2,2,								&
&   '# Chi-squared method ("peak"(1) or "mass"(2)-centered or "both"(3))'
	 case('both')
    write(k_out,'(3X,I2,25X,I1,15X,A)') 2,3,								&
&   '# Chi-squared method ("peak"(1) or "mass"(2)-centered or "both"(3))'
	end select
	write(k_out,'(3X,I2,11X,I15,15X,A)') 3,pdf,											&
&	'# Parametrization of Higgs mass uncertainty (1:box, 2:gaussian, 3:box+gaussian)'
    write(k_out,'(3X,I2,11X,I15,15X,A)') 4,HSres(1)%nobs_peak_mu,			&
&	'# Number of signal strength peak observables'
    write(k_out,'(3X,I2,11X,I15,15X,A)') 5,HSres(1)%nobs_peak_mh,			&
&   '# Number of Higgs mass peak observables'
    write(k_out,'(3X,I2,11X,I15,15X,A)') 6,HSres(1)%nobs_mpred,				&
&   '# Number of mass-centered observables'
    write(k_out,'(3X,I2,11X,I15,15X,A)') 7,HSres(1)%nobs,					&
&   '# Number of observables (total)'
    write(k_out,'(3X,I2,11X,F15.8,15X,A)') 8,HSres(1)%Chisq_peak_mu,		&
&   '# chi^2 from signal strength peak observables'
    write(k_out,'(3X,I2,11X,F15.8,15X,A)') 9,HSres(1)%Chisq_mh,				&
&   '# chi^2 from Higgs mass peak observables'
    write(k_out,'(3X,I2,11X,F15.8,15X,A)') 10,HSres(1)%Chisq_mpred,			&
&   '# chi^2 from mass-centered observables'
    write(k_out,'(3X,I2,11X,F15.8,15X,A)') 11,HSres(1)%Chisq_mu,			&
&   '# chi^2 from signal strength (total)'
    write(k_out,'(3X,I2,11X,F15.8,15X,A)') 12,HSres(1)%Chisq,'# chi^2 (total)'
    write(k_out,'(3X,I2,11X,F15.8,15X,A)') 13,HSres(1)%Pvalue,				&
&   '# Probability (total chi^2, total number observables)'

    if(SLHAdetailed) then
     select case(runmode)
	  case('peak')
	   call writeSLHAblock_HiggsSignalsPeakObservables(k_out)

	  case('mass')
	   call writeSLHAblock_HiggsSignalsMassCenteredObservables(k_out)

	  case('both')
	   call writeSLHAblock_HiggsSignalsPeakObservables(k_out)
	   call writeSLHAblock_HiggsSignalsMassCenteredObservables(k_out)

	  case default
	 end select
    endif
    SLHAdetailed=.True.

    close(file_id_common)
    if(k_out.ne.file_id_common)close(k_out)

    if(.not.newSLHAfile) then
     call finishwithSLHA
    endif

  endif
 end subroutine HiggsSignals_outputSLHAdata
!--------------------------------------------------------------------
 subroutine writeSLHAblock_HiggsSignalsPeakObservables(k_out)
  use usefulbits_hs, only : analyses, StrCompress
  use extra_bits_for_SLHA, only : h
  implicit none
  integer, intent(in) :: k_out
  integer :: i,j,a, Nh
  character(LEN=200):: formatstring

  write(k_out,'(a)')'BLOCK HiggsSignalsPeakObservables'
  write(k_out,'(A6,3X,A4,25X,A5,3X,A)')'#  OBS','FLAG','VALUE','# DESCRIPTION'
  a=0
   do i=lbound(analyses,dim=1),ubound(analyses,dim=1)
    do j=lbound(analyses(i)%peaks,dim=1),ubound(analyses(i)%peaks,dim=1)
	a=a+1
    Nh = size(analyses(i)%peaks(j)%Higgs_comb)
    write(k_out,'(3X,I3,4X,I2,1X,I30,3X,A)')a,1,analyses(i)%table%id,'# Analysis ID'
    write(k_out,'(3X,I3,4X,I2,5X,A2,A,A2,8X,A)')a,2,'||',trim(analyses(i)%table%label),	&
&    '||','# Reference to publication'
    write(k_out,'(3X,I3,4X,I2,5X,A2,A,A2,6X,A)')a,3,'||',								&
&    trim(strcompress(analyses(i)%table%desc)),'||','# Description (Search channel)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.2,3X,A)')a,4,analyses(i)%table%energy,			&
&   '# Center-of-mass energy'
    write(k_out,'(3X,I3,4X,I2,23X,F8.2,3X,A)')a,5,analyses(i)%table%lumi,			&
&   '# Luminosity'
    write(k_out,'(3X,I3,4X,I2,23X,F8.2,3X,A)')a,6,analyses(i)%table%dlumi*100.0D0,	&
&   '# Luminosity uncertainty (in %)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.2,3X,A)')a,7,analyses(i)%table%deltam,		&
&	'# Mass resolution (GeV)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.2,3X,A)')a,8,analyses(i)%peaks(j)%mpeak,	&
&	'# Mass value at peak position (in GeV)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,9,analyses(i)%peaks(j)%mu,	&
&	'# Observed signal strength modifier (mu)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,10,analyses(i)%peaks(j)%dmulow,	&
&	'# Lower 68%C.L. uncertainty on observed mu'
    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,11,analyses(i)%peaks(j)%dmuup,	&
&	'# Upper 68%C.L. uncertainty on observed mu'
!    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,12,analyses(i)%peaks(j)%dmulow0sq,	&
!&	'# Intrinsic squared lower 68%C.L. cyan band value on observed mu (corrected by HS)'
!    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,13,analyses(i)%peaks(j)%dmuup0sq,	&
!&	'# Intrinsic squared upper 68%C.L. cyan band value on observed mu (corrected by HS)'
!	write(formatstring,'(A13,I2,A2,I2,A8)') '(3X,I3,4X,I2,',31-1*Nh,'X,',Nh,'I1,3X,A)'
!	write(k_out,formatstring) a,12,analyses(i)%peaks(j)%Higgs_comb,				&
!&	'# Higgs combination (= indices of Higgs bosons which have been used)'
	write(formatstring,'(A13,I2,A3,I1,A1,I1,A6)') &
&	                   '(3X,I3,4X,I2,',31-1*Nh,'X,I',Nh,'.',Nh,',3X,A)'
	write(k_out,formatstring) a,12, &
&     convert_Higgscomb_to_bin(analyses(i)%peaks(j)%Higgs_comb), &
&     '# Assigned Higgs combination'
!-------TODO: List the pdg numbers here of these combinations!
     write(k_out,'(3X,I3,4X,I2,23X,I8,3X,A)')a,13,analyses(i)%peaks(j)%domH,&
&	 '# Index of dominant Higgs boson'
	if(analyses(i)%peaks(j)%domH.eq.0) then
     write(k_out,'(3X,I3,4X,I2,23X,A8,3X,A)')a,14,'NaN',						&
&    '# pdg number of dominant Higgs boson'
	 write(k_out,'(3X,I3,4X,I2,23X,A8,3X,A)')a,15,'NaN',						&
&	 '# Mass of the dominant Higgs boson'
	 write(k_out,'(3X,I3,4X,I2,23X,A8,3X,A)')a,16,'NaN',						&
&	 '# Signal strength modifier of the dominant Higgs boson'
    else
     write(k_out,'(3X,I3,4X,I2,23X,I8,3X,A)')a,14,h(analyses(i)%peaks(j)%domH),	&
&    '# pdg number of dominant Higgs boson'
	 write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,15,	&
&	 analyses(i)%peaks(j)%Higgses(analyses(i)%peaks(j)%domH)%m,		&
&	 '# Mass of dominant Higgs boson'
	 write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,16,	&
&	 analyses(i)%peaks(j)%Higgses(analyses(i)%peaks(j)%domH)%mu,	&
&	 '# Signal strength modifier of dominant Higgs boson'
	endif
    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,17,analyses(i)%peaks(j)%total_mu,&
&	'# Total predicted signal strength modifier mu'
    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,18,analyses(i)%peaks(j)%chisq_mu,&
&	'# Chi-squared value (mu-part)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,19,analyses(i)%peaks(j)%chisq_mh,&
&	'# Chi-squared value (mh-part)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,20,analyses(i)%peaks(j)%chisq_tot,&
&   '# Chi-squared value (total)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,21,analyses(i)%peaks(j)%chisq_max,&
&	'# Chi-squared value for no predicted signal (mu=0)'
   enddo
  enddo

end subroutine writeSLHAblock_HiggsSignalsPeakObservables
!--------------------------------------------------------------------
 subroutine writeSLHAblock_HiggsSignalsMassCenteredObservables(k_out)
!--------------------------------------------------------------------
  use usefulbits_hs, only : analyses, StrCompress
  use usefulbits, only : np, Hneut
!  use extra_bits_for_SLHA, only : h
  implicit none
  integer, intent(in) :: k_out
  integer :: i,j,a, Nh
  character(LEN=200):: formatstring
  Nh = np(Hneut)

  write(k_out,'(a)')'BLOCK HiggsSignalsMassCenteredObservables'
  write(k_out,'(A6,3X,A4,25X,A5,3X,A)')'#  OBS','FLAG','VALUE','# DESCRIPTION'
  a=0
  do i=lbound(analyses,dim=1),ubound(analyses,dim=1)
   do j=lbound(analyses(i)%mpred%mp_Higgses,dim=1),										&
&	    ubound(analyses(i)%mpred%mp_Higgses,dim=1)
    a=a+1
    write(k_out,'(3X,I3,4X,I2,1X,I30,3X,A)')a,1,analyses(i)%table%id,'# Analysis ID'
    write(k_out,'(3X,I3,4X,I2,5X,A2,A,A2,8X,A)')a,2,'||',trim(analyses(i)%table%label),	&
&    '||','# Reference to publication'
    write(k_out,'(3X,I3,4X,I2,5X,A2,A,A2,6X,A)')a,3,'||',								&
&    trim(strcompress(analyses(i)%table%desc)),'||','# Description (Search channel)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.2,3X,A)')a,4,analyses(i)%table%energy,				&
&   '# Center-of-mass energy'
    write(k_out,'(3X,I3,4X,I2,23X,F8.2,3X,A)')a,5,analyses(i)%table%lumi,				&
&   '# Luminosity'
    write(k_out,'(3X,I3,4X,I2,23X,F8.2,3X,A)')a,6,analyses(i)%table%dlumi*100.0D0,		&
&   '# Luminosity uncertainty (in %)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.2,3X,A)')a,7,analyses(i)%table%deltam,				&
&	'# Mass resolution (GeV)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.2,3X,A)')a,8,analyses(i)%mpred%mp_Higgses(j)%m,	&
    '# Mass of tested Higgs boson (GeV)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.2,3X,A)')a,9,analyses(i)%mpred%mp_Higgses(j)%dm,	&
&   '# Mass uncertainty of tested Higgs boson (GeV)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,10,analyses(i)%mpred%mp_Higgses(j)%mu,	&
&   '# Signal strength of tested Higgs boson'
    write(k_out,'(3X,I3,4X,I2,23X,I8,3X,A)')a,11,										&
&   size(analyses(i)%mpred%mp_Higgses(j)%Higgses,dim=1),								&
&   '# Number of combined Higgs bosons'
	write(formatstring,'(A13,I2,A3,I1,A1,I1,A6)') &
&	                   '(3X,I3,4X,I2,',31-1*Nh,'X,I',Nh,'.',Nh,',3X,A)'
	write(k_out,formatstring) a,12, &
&     convert_Higgscombint_to_bin(analyses(i)%mpred%mp_Higgses(j)%Higgscomb), &
&     '# Combined Higgs boson code'
    write(k_out,'(3X,I3,4X,I2,23X,F8.2,3X,A)')a,13,										&
&   analyses(i)%mpred%mp_Higgses(j)%m_obs,'# Observed mass value (GeV)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,14,										&
&   analyses(i)%mpred%mp_Higgses(j)%mu_obs,												&
&   '# Observed signal strength  (from experiment)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,15,										&
&   analyses(i)%mpred%mp_Higgses(j)%dmu_low_obs,										&
&   '# Lower 68%C.L. uncertainty of observed signal strength'
    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,16,										&
&   analyses(i)%mpred%mp_Higgses(j)%dmu_up_obs,											&
&   '# Upper 68%C.L. uncertainty of observed signal strength'
!    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,16,										&
!&   analyses(i)%mpred%mp_Higgses(j)%dmu_low0_obs,										&
!&   '# Intrinsic lower 68%C.L. cyan band value of observed mu (corrected by HS)'
!    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,17,										&
!&   analyses(i)%mpred%mp_Higgses(j)%dmu_up0_obs,										&
!&   '# Intrinsic upper 68%C.L. cyan band value of observed mu (corrected by HS)'
    write(k_out,'(3X,I3,4X,I2,23X,F8.4,3X,A)')a,17,analyses(i)%mpred%mp_Higgses(j)%chisq,&
&	'# Chi-squared value'
	enddo
   enddo

end subroutine writeSLHAblock_HiggsSignalsMassCenteredObservables
!--------------------------------------------------------------------
function convert_Higgscomb_to_bin(Higgscomb)
!--------------------------------------------------------------------
 implicit none
 integer, dimension(:), intent(in) :: Higgscomb
 integer :: convert_Higgscomb_to_bin
 integer :: i, j
 integer :: decnum

 decnum=0
 do i=lbound(Higgscomb,dim=1),ubound(Higgscomb,dim=1)
  if(Higgscomb(i).eq.0) decnum=decnum+0
  if(Higgscomb(i).eq.1) decnum=decnum+1
  if(Higgscomb(i).eq.2) decnum=decnum+2
  if(Higgscomb(i).eq.3) decnum=decnum+4
  if(Higgscomb(i).eq.4) decnum=decnum+8
  if(Higgscomb(i).eq.5) decnum=decnum+16
  if(Higgscomb(i).eq.6) decnum=decnum+32
  if(Higgscomb(i).eq.7) decnum=decnum+64
  if(Higgscomb(i).eq.8) decnum=decnum+128
  if(Higgscomb(i).eq.9) decnum=decnum+256
 enddo

 convert_Higgscomb_to_bin = convert_dec_to_bin(decnum)

end function convert_Higgscomb_to_bin
!--------------------------------------------------------------------
function convert_Higgscombint_to_bin(Higgscomb)
!--------------------------------------------------------------------
 implicit none
 integer, intent(in) :: Higgscomb
 integer :: convert_Higgscombint_to_bin
 integer :: i, j
 integer :: decnum, Higgscombtmp

 Higgscombtmp = Higgscomb

 decnum=0
 do while(Higgscombtmp > 0)
  i=MOD(Higgscombtmp,10)
  if(i.eq.0) decnum=decnum+0
  if(i.eq.1) decnum=decnum+1
  if(i.eq.2) decnum=decnum+2
  if(i.eq.3) decnum=decnum+4
  if(i.eq.4) decnum=decnum+8
  if(i.eq.5) decnum=decnum+16
  if(i.eq.6) decnum=decnum+32
  if(i.eq.7) decnum=decnum+64
  if(i.eq.8) decnum=decnum+128
  if(i.eq.9) decnum=decnum+256
  Higgscombtmp=(Higgscombtmp-i)/10
 enddo

 convert_Higgscombint_to_bin = convert_dec_to_bin(decnum)

end function convert_Higgscombint_to_bin
!------------------------------------------------------------
subroutine read_matrix_from_file(length, filename, m, status)
!------------------------------------------------------------
 use usefulbits, only : file_id_common3
 implicit none
! use store_pathname_hs, only : pathname_HS
! use usefulbits_hs, only : delta_rate
 integer, intent(in) :: length
 character(LEN=*), intent(in) :: filename
 double precision, dimension(:,:), intent(inout) :: m
 logical, intent(out) :: status
 integer :: n, ios
 double precision, dimension(length) :: dblline

 status=.False.
 if((size(m,dim=1).ne.length).or.(size(m,dim=2).ne.length)) then
  write(*,*) 'Problem in subroutine read_matrix_from_file!'
 else
  open(file_id_common3, file=filename,form='formatted')
  n=0
  do
   read(file_id_common3,*, iostat=ios) dblline
   if(ios.ne.0) exit
   n=n+1
   m(n,:)=dblline(:)
  enddo

  if(n.ne.length) then
   write(*,*) 'Problem with reading in the matrix from ',filename
  else
   status=.True.
  endif
 endif

 close(file_id_common3)

end subroutine read_matrix_from_file
!--------------------------------------------------------------------
function convert_dec_to_bin(dec)
!--------------------------------------------------------------------
! implicit none
 integer, intent(in) :: dec
 integer :: convert_dec_to_bin
 integer :: bineq
 integer :: power
 integer :: temp

 bineq = 0
 power = 0
 temp = dec

 do while(temp > 0)
  bineq = bineq + (MOD(temp, 2) * (MOD(temp, 2) * (10 ** power)))
  power = power + 1
  temp = temp / 2
 enddo

 convert_dec_to_bin = bineq

end function convert_dec_to_bin
!--------------------------------------------------------------------
end module io
!--------------------------------------------------------------------