! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

PROGRAM littler_tf_dart

use        types_mod, only : r8, DEG2RAD, RAD2DEG, MISSING_I, MISSING_R8
use    utilities_mod, only : open_file, close_file, file_exist, &
                             get_unit, initialize_utilities, &
                             register_module, error_handler, E_ERR, E_MSG, &
                             finalize_utilities, logfileunit
use obs_sequence_mod, only : obs_type, obs_sequence_type, init_obs_sequence, &
                             insert_obs_in_seq, write_obs_seq, read_obs_seq, &
                             set_qc, set_qc_meta_data, set_obs_values, set_copy_meta_data, &
                             assignment(=), get_obs_time_range, &
                             init_obs, static_init_obs_sequence, get_num_qc, set_obs_def, &
                             get_num_obs, get_max_num_obs, get_obs_values, &
                             get_time_range_keys, get_obs_from_key, get_obs_def, get_qc
use      obs_def_mod, only : copy_obs_def, obs_def_type, &
                             get_obs_def_time, get_obs_def_location, &
                             get_obs_def_error_variance, get_obs_def_type_of_obs, &
                             set_obs_def_type_of_obs, set_obs_def_location, set_obs_def_time, &
                             set_obs_def_error_variance
use     obs_kind_mod, only : RADIOSONDE_U_WIND_COMPONENT, &
                             RADIOSONDE_V_WIND_COMPONENT, &
                             RADIOSONDE_SURFACE_PRESSURE, &
                             RADIOSONDE_TEMPERATURE, &
                             RADIOSONDE_SPECIFIC_HUMIDITY, &
                             max_defined_types_of_obs, get_name_for_type_of_obs, map_type_of_obs_table
use     location_mod, only : location_type, get_location, query_location, set_location
use time_manager_mod, only : time_type, get_time, set_calendar_type, GREGORIAN, get_date, &
                             set_date, operator(/=), set_time

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

type(obs_sequence_type) :: dart_seq
type(obs_type)          :: obs, prev_obs
type(obs_def_type)      :: obs_def
type(location_type)     :: location
type(time_type)         :: time, stime, ftime

INTEGER                 :: iunit, end_of_file

integer                 :: key_bounds(2), obs_kind, which_vert, pwhich_vert
real(r8)                :: obs_value(1), qc(1), erms
real(r8), dimension(3)  :: loc, sloc, floc
real(r8)                :: lon, lat, vloc, pvloc

integer           :: is, ie, iobs, k
integer           :: num_obs, num_copies, num_qc, max_num_obs, dart_seq_num_obs, num_obs_in_set
integer, allocatable :: keys(:)

character(len = 32)  :: obs_name, obs_no_support(max_defined_types_of_obs)
character(len = 129) :: msgstring

integer              :: n_no_support

character(len = 129) :: dart_file_name     = 'obs_seq.out', &
                        littler_file_name = 'little-r.dat'

integer              :: calendar_type      = GREGORIAN

character *20  :: date_char
CHARACTER *120 :: rpt_format
CHARACTER *120 :: meas_format
CHARACTER *120 :: end_format
character *40  :: tst_id, tst_name, tst_pltfrm, tst_src
real(r8)       :: tst_ter, tst_slp, tst_xlat, tst_xlon, tst_Psfc
integer        :: kx, iseq_num, tst_sut, tst_julian
logical        :: tst_sound, tst_bogus, tst_discard
integer        :: i1,i2,i3,i4,i5,i6,i7,i8,i9,i10
integer        :: i11,i12,i13,i14,i15,i16,i17,i18
real(r8)       :: f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12

integer, parameter :: n_wind_pres = 26, n_pres = 15
real(r8)           :: wind_error(n_wind_pres)
real(r8)           :: temp_error(n_pres), specific_humidity_error(n_pres)

! Observational errors are contained in a separate file 'obserr.txt'

CHARACTER (LEN=80) :: filein      != 'obserr.txt'
CHARACTER (LEN=80) :: platform    != 'RAOBS'
CHARACTER (LEN=80) :: sensor_name != 'WIND SENSOR ERRORS'

integer :: wind_pressures(n_wind_pres)
data wind_pressures / 10,   20,   30,   40,   50,  100,  150, &
                     200,  250,  300,  350,  400,  450,  500, &
                     550,  600,  650,  700,  750,  800,  850, &
                     900,  950, 1000, 1050, 1100/

integer :: pressure_levels(n_pres)
data pressure_levels / 1000,  850,  700,  500,  400, &
                        300,  250,  200,  150,  100, &
                         70,   50,   30,   20,   10/

real(r8), allocatable :: z(:),t(:),td(:),spd(:),dir(:), &
                         uu(:), vv(:), p(:), cld(:), ciel(:)
integer, allocatable  :: zpp_qc(:), tt_qc(:), td_qc(:), &
                         zuu_qc(:), zvv_qc(:), p_qc(:), &
                         spd_qc(:), dir_qc(:), cld_qc(:), ciel_qc(:)

logical :: littler_to_dart, out_of_range

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

rpt_format =  ' ( 2f20.5 , 4a40 , f20.5 , 5i10 , 3L10 , ' &
                  // ' 2i10 , a20 ,  13( f13.5 , i7 ) ) '
meas_format =  ' ( 10( f13.5 , i7 ) ) '
end_format = ' ( 3 ( i7 ) ) '

call initialize_utilities('littler_tf_dart')
call register_module(source, revision, revdate)

call set_calendar_type(calendar_type)

write(*,*) 'littler to DART (.true./T) or DART to littler (.false./F)?'

read(*,*) littler_to_dart

tst_id = 'dart_id'
tst_name = 'dart_name'
tst_pltfrm = 'dart_pltfrm'
tst_src = 'dart_src'
tst_ter = MISSING_R8
tst_bogus = .false.
tst_discard = .false.
tst_slp = MISSING_R8
i1 = 0
i2 = 0
iseq_num = 0
i3 = 0
tst_sut = MISSING_I
tst_julian = MISSING_I
i6 = 0
i7 = 0
i8 = 0
i9 = 0
i10 = 0
i11 = 0
i12 = 0
i13 = 0
i14 = 0
i15 = 0
i16 = 0
i17 = 0
i18 = 0
f1 = MISSING_R8
f2 = MISSING_R8
f3 = MISSING_R8
f4 = MISSING_R8
f5 = MISSING_R8
f6 = MISSING_R8
f7 = MISSING_R8
f8 = MISSING_R8
f9 = MISSING_R8
f10 = MISSING_R8
f11 = MISSING_R8
f12 = MISSING_R8
wind_error(:) = -1.0_R8
temp_error(:) = -1.0_R8
specific_humidity_error(:) = -1.0_R8
n_no_support = 0

call static_init_obs_sequence()

num_copies = 1
num_qc = 1

! must use read_obs_seq_header

call init_obs(obs, num_copies, num_qc)

! -------------------------------------------------------------------
! Initialize the counter:

num_obs = 0

if(.not. littler_to_dart) then

   ! Conversion from DART to littler format.
   ! littler format needs soundings

   call read_obs_seq(dart_file_name, 0, 0, 0, dart_seq)

   dart_seq_num_obs = get_num_obs(dart_seq)
   stime = set_time(0, 0)
   ftime = set_time(0, 200000)
   call get_obs_time_range(dart_seq, stime, ftime, key_bounds, num_obs_in_set, &
                           out_of_range)
   if(num_obs_in_set /= dart_seq_num_obs) then
      write(msgstring, *) 'Did not get all obs. Got ',num_obs_in_set, &
           '. In file: ',dart_seq_num_obs
      call error_handler(E_ERR,'littler_tf_dart', &
           msgstring,source,revision,revdate)
   endif
   allocate(keys(dart_seq_num_obs))

   call get_time_range_keys(dart_seq, key_bounds, dart_seq_num_obs, keys)

   ! This should be get_first_obs(), get_last_obs()

   print*,'First obs key: ',keys(1)
   print*,'Last  obs key: ',keys(dart_seq_num_obs)
   print*,'Number of obs: ',dart_seq_num_obs

   iunit = get_unit()
   open(unit=iunit,file=littler_file_name,status='new')

   is = 1
   ie = 1
   do while (ie <= dart_seq_num_obs+1)

      call get_obs_from_key(dart_seq, keys(is), obs)
      call get_obs_def(obs, obs_def)

      sloc = get_location(get_obs_def_location(obs_def))
      stime = get_obs_def_time(obs_def)

      if(ie <= dart_seq_num_obs) then
         call get_obs_from_key(dart_seq, keys(ie), obs)
         call get_obs_def(obs, obs_def)
      endif

      floc = get_location(get_obs_def_location(obs_def))
      ftime = get_obs_def_time(obs_def)

      ! Write to littler file when a full sounding has been read.

      if ( ftime /= stime .or. sloc(1) /= floc(1) .or. &
           sloc(2) /= floc(2) .or. ie == dart_seq_num_obs+1) then

         tst_Psfc = MISSING_R8

         kx = 1
         call get_obs_from_key(dart_seq, keys(is), obs)
         call get_obs_def(obs, obs_def)
         location = get_obs_def_location(obs_def)
         loc = get_location(location)
         pwhich_vert = nint(query_location(location,'which_vert'))
         pvloc = loc(3)

         ! Count the number of pressure levels.

         do iobs = is+1, ie-1
            call get_obs_from_key(dart_seq, keys(iobs), obs)
            call get_obs_def(obs, obs_def)
            location = get_obs_def_location(obs_def)
            loc = get_location(location)
            which_vert = nint(query_location(location,'which_vert'))

!!$            if (which_vert == -1) then
!!$               obs_kind =  map_type_of_obs_table(get_obs_def_type_of_obs(obs_def))
!!$               if (obs_kind == RADIOSONDE_SURFACE_PRESSURE) then
!!$                  call get_obs_values(obs, obs_value, 1)
!!$                  tst_Psfc = obs_value(1)
!!$               endif
!!$            endif

            if (loc(3) /= pvloc .and. which_vert == pwhich_vert) kx = kx + 1
            pvloc = loc(3)
            pwhich_vert = which_vert
         enddo

!!$         if (kx > 1) then
         obs_kind = map_type_of_obs_table(get_obs_def_type_of_obs(obs_def))
         obs_name = get_name_for_type_of_obs(obs_kind)
         if ( obs_name(1:10) == 'RADIOSONDE' ) then
            tst_sound = .true.
            tst_pltfrm = 'FM-35 TEMP'
!!$         else
!!$            tst_sound = .false.
         endif

         call set_str_date(date_char, stime)

         ! In littler format, longitude is defined within [-180,180].

         tst_xlat = loc(2)
         tst_xlon = loc(1)
         if (tst_xlon > 180.0_r8) tst_xlon = tst_xlon - 360.0_r8

         ! Now the header can be written.

         WRITE ( UNIT = iunit , ERR = 19 , FMT = rpt_format ) &
              tst_xlat, tst_xlon, tst_id , tst_name, &
              tst_pltfrm, tst_src, tst_ter, kx, i1, i2, iseq_num, i3, &
              tst_sound, tst_bogus, tst_discard, tst_sut, tst_julian, date_char, &
              tst_slp, i6, f1, i7, f2, i8, f3, i9, tst_Psfc, i10, &
              f5, i11, f6, i12, f7, i13, f8, i14, f9, i15, &
              f10, i16, f11, i17, f12, i18

         allocate(p(kx),p_qc(kx), z(kx),zpp_qc(kx), t(kx),tt_qc(kx), td(kx),td_qc(kx), &
              spd(kx),spd_qc(kx), dir(kx),dir_qc(kx), &
              uu(kx),zuu_qc(kx), vv(kx),zvv_qc(kx), cld(kx),cld_qc(kx), &
              ciel(kx),ciel_qc(kx))

         p(:) = MISSING_R8
         z(:) = MISSING_R8
         t(:) = MISSING_R8
         td(:) = MISSING_R8
         spd(:) = MISSING_R8
         dir(:) = MISSING_R8
         uu(:) = MISSING_R8
         vv(:) = MISSING_R8
         cld(:) = MISSING_R8
         ciel(:) = MISSING_R8

         p_qc(:) = 0
         zpp_qc(:) = 0
         tt_qc(:) = 0
         td_qc(:) = 0
         spd_qc(:) = 0
         dir_qc(:) = 0
         zuu_qc(:) = 0
         zvv_qc(:) = 0
         cld_qc(:) = 0
         ciel_qc(:) = 0

         ! Write data at each (pressure) level.

         k = 1
         call get_obs_from_key(dart_seq, keys(is), obs)
         call get_obs_def(obs, obs_def)
         location = get_obs_def_location(obs_def)
         loc = get_location(location)
         pwhich_vert = nint(query_location(location,'which_vert'))
         pvloc = loc(3)
         do iobs = is, ie-1
            call get_obs_from_key(dart_seq, keys(iobs), obs)
            call get_obs_def(obs, obs_def)
            location = get_obs_def_location(obs_def)
            loc = get_location(location)
            which_vert = nint(query_location(location,'which_vert'))

            if (loc(3) /= pvloc .and. which_vert == pwhich_vert) k = k + 1
            pvloc = loc(3)
            pwhich_vert = which_vert

            if(which_vert == 2) then
               p(k) = loc(3)
!--------------------------------------------------------------------------
!  Flaging all data above 100 hPa.
!--------------------------------------------------------------------------
!!$               if(p(k) < 10000.0_r8) then
!!$                  p_qc(k) = MISSING_I
!!$                  zpp_qc(k) = MISSING_I
!!$                  tt_qc(k) = MISSING_I
!!$                  td_qc(k) = MISSING_I
!!$                  spd_qc(k) = MISSING_I
!!$                  dir_qc(k) = MISSING_I
!!$                  zuu_qc(k) = MISSING_I
!!$                  zvv_qc(k) = MISSING_I
!!$                  cld_qc(k) = MISSING_I
!!$                  ciel_qc(k) = MISSING_I
!!$               endif
            elseif(which_vert == 3) then
               z(k) = loc(3)
            endif

            obs_kind = map_type_of_obs_table(get_obs_def_type_of_obs(obs_def))

            call get_obs_values(obs, obs_value, 1)
            if(obs_kind == RADIOSONDE_U_WIND_COMPONENT) then
               num_obs = num_obs + 1
               uu(k) = obs_value(1)
            elseif(obs_kind == RADIOSONDE_V_WIND_COMPONENT) then
               num_obs = num_obs + 1
               vv(k) = obs_value(1)
               if(p(k) /= MISSING_R8) then
                  call StoreObsErr(get_obs_def_error_variance(obs_def), &
                       nint(0.01_r8 * p(k)), wind_pressures, n_wind_pres, wind_error)
               endif
            elseif(obs_kind == RADIOSONDE_TEMPERATURE) then
               num_obs = num_obs + 1
               t(k) = obs_value(1)
               if(p(k) /= MISSING_R8) then
                  call StoreObsErr(get_obs_def_error_variance(obs_def), &
                       nint(0.01_r8 * p(k)), pressure_levels, n_pres, temp_error)
               endif
!!$            elseif(obs_kind == RADIOSONDE_SPECIFIC_HUMIDITY) then
!!$               num_obs = num_obs + 1
!!$               t(k) = obs_value(1)
!!$               if(p(k) /= MISSING_R8) then
!!$                  call StoreObsErr(1.0e6_r8*get_obs_def_error_variance(obs_def), &
!!$                       nint(0.01_r8 * p(k)), pressure_levels, n_pres, specific_humidity_error)
!!$               endif
!!$            elseif(obs_kind == RADIOSONDE_SURFACE_PRESSURE) then
!!$               num_obs = num_obs + 1
            else
               if (n_no_support == 0) then
                  n_no_support = n_no_support + 1
                  obs_no_support(n_no_support) = get_name_for_type_of_obs(obs_kind)
               elseif (obs_no_support(n_no_support) /= get_name_for_type_of_obs(obs_kind)) then
                  n_no_support = n_no_support + 1
                  obs_no_support(n_no_support) = get_name_for_type_of_obs(obs_kind)
               endif
            endif
         enddo

         do k = 1 , kx

            ! Convert zonal and meridional wind components to
            ! wind speed and direction.

            if (uu(k) /= missing_r8 .and. vv(k) /= missing_r8) then

               spd(k) = sqrt(uu(k)*uu(k) + vv(k)*vv(k))

               if (spd(k) /= 0.0_r8) then

                  if (vv(k) == 0.0_r8) then

                     if (uu(k) > 0.0_r8) dir(k) = 270.0_r8
                     if (uu(k) < 0.0_r8) dir(k) = 90.0_r8

                  else

                     dir(k) = atan(uu(k)/vv(k))*RAD2DEG

                     if (vv(k) >= 0.0_r8) then
                        dir(k) = dir(k) + 180.0_r8
                     else
                        if (uu(k) >= 0.0_r8) dir(k) = dir(k) + 360.0_r8
                     endif

                  endif

               else

                  dir(k) = 0.0_r8

               endif

            endif

            WRITE ( UNIT = iunit , ERR = 20 , FMT = meas_format ) &
                 p(k),0, z(k),zpp_qc(k), t(k),tt_qc(k),td(k),td_qc(k), &
                 spd(k),zvv_qc(k), dir(k),zuu_qc(k), &
                 uu(k),zuu_qc(k), vv(k),zvv_qc(k), MISSING_R8,0, MISSING_R8,0

         enddo

         ! Write "footer" of the sounding.

         WRITE ( UNIT = iunit , ERR = 21 , FMT = meas_format ) &
              -777777.,0, -777777.,0,float(kx),0, &
              MISSING_R8,0, MISSING_R8,0, MISSING_R8,0, &
              MISSING_R8,0, MISSING_R8,0, MISSING_R8,0, MISSING_R8,0

         WRITE ( UNIT = iunit , ERR = 21 , FMT = end_format )  kx, 0, 0

         deallocate(p,p_qc, z,zpp_qc, t,tt_qc, td,td_qc, &
              spd,spd_qc, dir,dir_qc, &
              uu,zuu_qc, vv,zvv_qc, cld,cld_qc, &
              ciel,ciel_qc)

         is = ie

      endif

      ie = ie + 1

   enddo

   deallocate(keys)

   close(iunit)

   ! Write out the obserr.txt.

   open(unit=iunit,file='obserr.txt',status='new')

   write(iunit, FMT = ' ( 7f6.1 , "      BOGUS   WIND SENSOR ERRORS" ) ') wind_error(1:7)
   write(iunit, FMT = ' ( 7f6.1 , "        :" ) ') wind_error(8:14)
   write(iunit, FMT = ' ( 7f6.1 , "        :" ) ') wind_error(15:21)
   write(iunit, FMT = ' ( 7f6.1 , "        :" ) ') wind_error(22:26),wind_error(26),wind_error(26)
   write(iunit, FMT = ' ( 7f6.1 , "      RAOBS" ) ') wind_error(1:7)
   write(iunit, FMT = ' ( 7f6.1 , "        :" ) ') wind_error(8:14)
   write(iunit, FMT = ' ( 7f6.1 , "        :" ) ') wind_error(15:21)
   write(iunit, FMT = ' ( 7f6.1 , "        :" ) ') wind_error(22:26),wind_error(26),wind_error(26)
   write(iunit, FMT = ' ( 5f6.1 , "      BOGUS   TEMP SENSOR ERRORS" ) ') temp_error(1:5)
   write(iunit, FMT = ' ( 5f6.1 , "        :" ) ') temp_error(6:10)
   write(iunit, FMT = ' ( 5f6.1 , "        :" ) ') temp_error(11:15)
   write(iunit, FMT = ' ( 5f6.1 , "      RAOBS" ) ') temp_error(1:5)
   write(iunit, FMT = ' ( 5f6.1 , "        :" ) ') temp_error(6:10)
   write(iunit, FMT = ' ( 5f6.1 , "        :" ) ') temp_error(11:15)
   write(iunit, FMT = ' ( 5f6.2 , "      BOGUS   SPECIFIC HUMIDITY SENSOR ERRORS" ) ') specific_humidity_error(1:5)
   write(iunit, FMT = ' ( 5f6.2 , "        :" ) ') specific_humidity_error(6:10)
   write(iunit, FMT = ' ( 5f6.2 , "        :" ) ') specific_humidity_error(11:15)
   write(iunit, FMT = ' ( 5f6.2 , "      RAOBS" ) ') specific_humidity_error(1:5)
   write(iunit, FMT = ' ( 5f6.2 , "        :" ) ') specific_humidity_error(6:10)
   write(iunit, FMT = ' ( 5f6.2 , "        :" ) ') specific_humidity_error(11:15)

   close(iunit)

   if (n_no_support /= 0) then

      write(*,*) 'Observations not supported yet:'
      do k = 1 , n_no_support
         write(*,*) k,'. ',trim(adjustl(obs_no_support(k)))
      enddo

   endif

else

   ! Conversion from littler to DART format.

   ! Read in the observational errors from file 'obserr.txt'.

   filein = 'obserr.txt'
   platform = 'RAOBS'
   sensor_name = 'WIND SENSOR ERRORS'
   call READ_OBSERR (filein, platform, sensor_name, wind_error, n_wind_pres)
   sensor_name = 'TEMP SENSOR ERRORS'
   call READ_OBSERR (filein, platform, sensor_name, temp_error, n_pres)

   max_num_obs = 500000

   ! Initialize an obs_sequence structure
   call init_obs_sequence(dart_seq, num_copies, num_qc, max_num_obs)

   call set_copy_meta_data(dart_seq, 1, 'littler observations')
   call set_qc_meta_data(  dart_seq, 1, 'littler QC')

   iunit = open_file(littler_file_name, action = 'read')

   end_of_file=0

   ! Read littler until end of file.

   do while (end_of_file == 0)

      ! Read header of sounding.

      READ ( UNIT=iunit,ERR=19,FMT=rpt_format,iostat=end_of_file,end=25 ) &
           tst_xlat, tst_xlon, tst_id, tst_name, &
           tst_pltfrm, tst_src, tst_ter, kx, i1, i2, iseq_num, i3, &
           tst_sound, tst_bogus, tst_discard, tst_sut, tst_julian, date_char, &
           tst_slp, i6, f1,i7, f2,i8, f3,i9, tst_Psfc,i10, f5,i11, &
           f6,i12, f7,i13, f8,i14, f9,i15, f10,i16, f11,i17, f12,i18

      allocate(p(kx),p_qc(kx), z(kx),zpp_qc(kx), t(kx),tt_qc(kx), td(kx),td_qc(kx), &
           spd(kx),spd_qc(kx), dir(kx),dir_qc(kx), &
           uu(kx),zuu_qc(kx), vv(kx),zvv_qc(kx), cld(kx),cld_qc(kx), &
           ciel(kx),ciel_qc(kx))

      if (.not. tst_sound ) kx = 1

      ! Read each level of the sounding.

      do k = 1 , kx
         READ (UNIT=iunit,ERR=20,FMT=meas_format,iostat=end_of_file,end=25) &
              p(k),p_qc(k), z(k),zpp_qc(k), t(k),tt_qc(k), &
              td(k),td_qc(k), &
              spd(k),spd_qc(k), dir(k),dir_qc(k), &
              uu(k),zuu_qc(k), vv(k),zvv_qc(k), cld(k),cld_qc(k), &
              ciel(k),ciel_qc(k)

         if (p(k) /= missing_r8) then

            vloc = p(k)
            which_vert = 2

!!$         elseif (z(k)/= missing_r8) then
!!$
!!$            vloc = p(k)
!!$            which_vert = 3
!!$
         else

            call error_handler(E_ERR,'littler_tf_dart', &
                 'No vertical coordinate.', source, revision, revdate)

         endif

         ! In DART format, longitude is defined within [0, 360].

         if(tst_xlon < 0.0_r8) tst_xlon = tst_xlon + 360.0_r8
         lon = tst_xlon
         lat = tst_xlat

         location = set_location(lon, lat, vloc, which_vert)
         call set_obs_def_location(obs_def, location)

         call set_dart_time(date_char, time)
         call set_obs_def_time(obs_def, time)

         ! Insert obs into DART obs sequence.

         ! Observational errors are interpolated from data
         ! in obserr.txt

         if (t(k) /= missing_r8) then

            if (tst_pltfrm == 'FM-35 TEMP') then

               num_obs = num_obs + 1

               call set_obs_def_type_of_obs(obs_def, RADIOSONDE_TEMPERATURE)

               erms = intplog (p(k)*0.01_r8, pressure_levels, temp_error)

               call set_obs_def_error_variance(obs_def, erms*erms)

               call set_obs_def(obs, obs_def)

               obs_value(1) = t(k)
               call set_obs_values(obs, obs_value)
               qc(1) = tt_qc(k)   ! translate this from little-r to dart numbers?
               call set_qc(obs, qc)

               if(num_obs == 1) then
                  call insert_obs_in_seq(dart_seq, obs)
               else
                  call insert_obs_in_seq(dart_seq, obs, prev_obs)
               endif

               prev_obs = obs

            endif

         endif

         ! Littler may carry wind speed and direction:
         ! convert to zonal and meridional wind components.

         if (uu(k) == missing_r8 .and. vv(k) == missing_r8 .and. &
              spd(k) /= missing_r8 .and. dir(k) /= missing_r8) then

            dir(k) = dir(k)*DEG2RAD
            uu(k) = -spd(k)*SIN(dir(k))
            vv(k) = -spd(k)*COS(dir(k))

         endif

         if (uu(k) /= missing_r8) then

            if (tst_pltfrm == 'FM-35 TEMP') then

               num_obs = num_obs + 1

               call set_obs_def_type_of_obs(obs_def, RADIOSONDE_U_WIND_COMPONENT)

               erms = intplin (p(k)*0.01_r8, wind_pressures, wind_error)

               call set_obs_def_error_variance(obs_def, erms*erms)

               call set_obs_def(obs, obs_def)

               obs_value(1) = uu(k)
               call set_obs_values(obs, obs_value)
               qc(1) = zuu_qc(k)   ! translate this from little-r to dart numbers?
               call set_qc(obs, qc)

               if(num_obs == 1) then
                  call insert_obs_in_seq(dart_seq, obs)
               else
                  call insert_obs_in_seq(dart_seq, obs, prev_obs)
               endif

               prev_obs = obs

            endif

         endif

         if (vv(k) /= missing_r8) then

            if (tst_pltfrm == 'FM-35 TEMP') then

               num_obs = num_obs + 1

               call set_obs_def_type_of_obs(obs_def, RADIOSONDE_V_WIND_COMPONENT)

               erms = intplin (p(k)*0.01_r8, wind_pressures, wind_error)

               call set_obs_def_error_variance(obs_def, erms*erms)

               call set_obs_def(obs, obs_def)

               obs_value(1) = vv(k)
               call set_obs_values(obs, obs_value, 1)
               qc(1) = zvv_qc(k)   ! translate this from little-r to dart numbers?
               call set_qc(obs, qc)

               if(num_obs == 1) then
                  call insert_obs_in_seq(dart_seq, obs)
               else
                  call insert_obs_in_seq(dart_seq, obs, prev_obs)
               endif

               prev_obs = obs

            endif

         endif

      enddo

      deallocate(p,p_qc, z,zpp_qc, t,tt_qc, td,td_qc, &
           spd,spd_qc, dir,dir_qc, &
           uu,zuu_qc, vv,zvv_qc, cld,cld_qc, &
           ciel,ciel_qc)

      READ ( UNIT = iunit , ERR = 21 , FMT = meas_format ) &
           f1,i1, f2,i2, f3,i3, f4,i4, f5,i5, f6,i6, &
           f7,i7, f8,i8, f9,i9, f10,i10

      READ ( UNIT = iunit , ERR = 21 , FMT = end_format )  kx, i1, i2

   enddo

25 print*,"FOUND END"

   close(iunit)

! Write out the sequence
   call write_obs_seq(dart_seq, dart_file_name)

endif

write(unit=*, fmt='(5x,a,i7)') &
     'Total number of observations:  ', num_obs

goto 26

! These are for error messages when regarding littler files.

19 continue
call error_handler(E_ERR,'littler_tf_dart', &
     'Error when reading or writing header of sounding.', source, revision, revdate)
20 continue
call error_handler(E_ERR,'littler_tf_dart', &
     'Error when reading or writing sounding.', source, revision, revdate)
21 continue
call error_handler(E_ERR,'littler_tf_dart', &
     'Error when reading or writing footer of the sounding.', source, revision, revdate)

26 continue

call error_handler(E_MSG, 'littler_tf_dart', 'FINISHED littler_tf_dart.')
call error_handler(E_MSG, 'littler_tf_dart', 'Finished successfully.',&
                   source,revision,revdate)
call finalize_utilities()

contains

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

subroutine set_str_date(timestring, dart_time)

implicit none

type(time_type),   intent(in)  :: dart_time
character(len=20), intent(out) :: timestring

integer           :: year, month, day, hour, minute, second

character(len=4)  :: ch_year
character(len=2)  :: ch_month, ch_day, ch_hour, ch_minute, ch_second

call get_date(dart_time, year, month, day, hour, minute, second)

write(ch_year,'(i4)') year
write(ch_month,'(i2.2)') month
write(ch_day,'(i2.2)') day
write(ch_hour,'(i2.2)') hour
write(ch_minute,'(i2.2)') minute
write(ch_second,'(i2.2)') second

timestring(1:6)   = "      "
timestring(7:10)  = ch_year
timestring(11:12) = ch_month
timestring(13:14) = ch_day
timestring(15:16) = ch_hour
timestring(17:18) = ch_minute
timestring(19:20) = ch_second

end subroutine set_str_date

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

subroutine set_dart_time(tstring, dart_time)

implicit none

type(time_type),   intent(out) :: dart_time
character(len=20), intent(in)  :: tstring

integer           :: year, month, day, hour, minute, second

read(tstring(7:10),'(i4)') year
read(tstring(11:12),'(i2)') month
read(tstring(13:14),'(i2)') day
read(tstring(15:16),'(i2)') hour
read(tstring(17:18),'(i2)') minute
read(tstring(19:20),'(i2)') second

dart_time = set_date(year, month, day, hour, minute, second)

end subroutine set_dart_time

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

Subroutine StoreObsErr(obs_err_var, pres, plevel, nlev, obs_err_std)

implicit none

integer,  intent(in)    :: nlev, pres
real(r8), intent(in)    :: obs_err_var
integer,  intent(in)    :: plevel(nlev)
real(r8), intent(inout) :: obs_err_std(nlev)

integer :: level_index

level_index = GetClosestLevel(pres, plevel, nlev)

if ( plevel(level_index) == pres ) then
   if ( obs_err_std(level_index) == -1.0_R8 ) then
      obs_err_std(level_index) = sqrt(obs_err_var)
   elseif (obs_err_std(level_index) /= sqrt(obs_err_var)) then
      print*,'Various observation errors at same level: ', &
           obs_err_std(level_index), sqrt(obs_err_var), ' level = ',pres
   endif
endif

end Subroutine StoreObsErr

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

Function GetClosestLevel(ilev, vlev, nlev) result (level_index)

implicit none

integer,  intent(in) :: nlev, ilev
integer,  intent(in) :: vlev(nlev)

integer                  :: level_index, a(1)
integer, dimension(nlev) :: dx

dx = abs(ilev - vlev)
a = minloc(dx)
level_index = a(1)

end Function GetClosestLevel

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

SUBROUTINE READ_OBSERR (filein, platform, sensor_name, err, nlevels)
!------------------------------------------------------------------------------!
!
! Read observational error on pressure levels (in hPa)
!
!------------------------------------------------------------------------------!
  IMPLICIT NONE
!------------------------------------------------------------------------------!

  CHARACTER (LEN=80), intent(in) :: filein      != 'obserr.txt'
  CHARACTER (LEN=80), intent(in) :: platform    != 'RAOBS'
  CHARACTER (LEN=80), intent(in) :: sensor_name != 'WIND SENSOR ERRORS'
  INTEGER,            intent(in) :: nlevels

  REAL(r8), intent(out) :: err(nlevels)

  character(len=129)  :: msgstring
  INTEGER             :: io_error, i, iunit, ncol
  CHARACTER (LEN=80)  :: fmt_err                    != '(5(1X,F5.1))'
  CHARACTER (LEN=80)  :: line1, line2, line3, line4
  LOGICAL             :: sensor_found, found

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

! 1.  OPEN INPUT FILE
! ===================

  iunit = get_unit()
  OPEN (UNIT = iunit , FILE = filein , FORM = 'FORMATTED'  , &
       ACTION = 'READ' , STATUS = 'OLD', IOSTAT = io_error)

  IF (io_error /= 0) THEN
     write(msgstring, *) 'Unable to open input observational error file ',TRIM (filein)
     call error_handler(E_ERR,'READ_OBSERR', &
          msgstring, source, revision, revdate)
  ENDIF

! 2.  READ DATA
! =============

! Read file until sensor_name is found
  found          = .FALSE.
  sensor_found   = .FALSE.
  io_error= 0

  DO WHILE (io_error == 0.)

     READ (UNIT = iunit, IOSTAT = io_error, FMT = '(A)') line1
     !  Exit when error or at end of file

     IF (io_error /= 0 .OR. (line1 (1:2) == '*.')) EXIT

     IF (TRIM (sensor (line1)) == 'BOGUS') THEN

        IF (TRIM (obstype (line1)) == TRIM (sensor_name)) sensor_found = .TRUE.

     ENDIF

     IF (sensor_found .and. (TRIM (sensor (line1)) == TRIM (platform))) THEN

        found = .TRUE.
        READ (UNIT = iunit, IOSTAT = io_error, FMT = '(A)') line2
        READ (UNIT = iunit, IOSTAT = io_error, FMT = '(A)') line3
        IF (TRIM (sensor_name) == 'WIND SENSOR ERRORS') &
          READ (UNIT = iunit, IOSTAT = io_error, FMT = '(A)') line4
        EXIT

     ELSE

        !  If obstype is not found, keep on reading

        CYCLE

     ENDIF

  ENDDO

  IF (found) THEN

     !  Sensor_name has been found, Error at mandatory pressure levels follow
     !  Break down data upon obs type

     SELECT CASE (TRIM (sensor_name))
     CASE ('WIND SENSOR ERRORS')
        ncol = 7
        fmt_err = '(7(1X,F5.1))'
     CASE ('RH SENSOR ERRORS')
        ncol = 5
        fmt_err = '(5(1X,F5.2))'
     CASE DEFAULT
        ncol = 5
        fmt_err = '(5(1X,F5.1))'
     END SELECT

     READ (line1, fmt_err) (err (i), i =        1,   ncol)
     READ (line2, fmt_err) (err (i), i =   ncol+1, 2*ncol)
     READ (line3, fmt_err) (err (i), i = 2*ncol+1, 3*ncol)
     !  Winds are given over 4 lines, any other data are given over 3 lines
     IF (TRIM (sensor_name) == 'WIND SENSOR ERRORS') &
     READ (line4, fmt_err) (err (i), i = 3*ncol+1, min(4*ncol,nlevels))

  ELSE

     WRITE (*, FMT = '(/,A,A,A,/)') TRIM (sensor_name), &
          ' were not found in file ', TRIM (filein)

  ENDIF

! 3.  CLOSE INPUT FILE
! ====================

  CLOSE (UNIT = iunit)

END SUBROUTINE READ_OBSERR

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

FUNCTION obstype (line) RESULT (f_obstype)
!------------------------------------------------------------------------------!

  ! Read in a line the string present after keyword 'BOGUS'

!------------------------------------------------------------------------------!
  IMPLICIT NONE
  CHARACTER (LEN= 80), intent(in) :: line

  CHARACTER (LEN= 80) :: f_obstype
  INTEGER :: b,c
!------------------------------------------------------------------------------!

!  Find keyword bogus

  DO c = 1, LEN_TRIM (line) - 5
     IF (line (c:c+4) == 'BOGUS') EXIT
  ENDDO

  c = c + 5

!  Skip blank until next word

  DO b = c, LEN_TRIM (line)
     IF (line (b:b) /= ' ') EXIT
  ENDDO

!  String follows

  f_obstype = TRIM (line (b:LEN_TRIM (line)))

END FUNCTION obstype

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

FUNCTION sensor (line) RESULT (f_sensor)

  ! Read first in a string after numbers

!------------------------------------------------------------------------------!
  IMPLICIT NONE
  CHARACTER (LEN= 80), intent(in) :: line

  CHARACTER (LEN= 80) :: f_sensor
  INTEGER :: b,c
!------------------------------------------------------------------------------!

!  Find the first non-blank, non point and non-number character

  DO c = 1, LEN_TRIM (line)
     IF (((iachar (line(c:c)) /= 32)  .AND. &
          (iachar (line(c:c)) /= 46)) .AND. &
          ((iachar (line(c:c)) .LT. 48)  .OR.  &
          (iachar (line(c:c)) .GT. 57)))      &
          EXIT
  ENDDO

  DO b = c, LEN_TRIM (line)
     IF (line (b:b) == ' ') EXIT
  ENDDO

  f_sensor = line (c:b-1)

END FUNCTION sensor

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

FUNCTION intplin (x,xx,yy) RESULT (val)
!------------------------------------------------------------------------------!
  IMPLICIT NONE

  INTEGER,  DIMENSION (:), intent(in) :: xx
  REAL(r8), DIMENSION (:), intent(in) :: yy
  REAL(r8),                intent(in) :: x

  REAL(r8) :: val

  INTEGER :: n,m,jl
!------------------------------------------------------------------------------!

  n = size (xx)
  m = size (yy)

  IF (n /= m) THEN
     call error_handler(E_ERR,'intplin', &
          'arrays xx and yy must have same size', source,revision,revdate)
  ENDIF

  jl = locate (x,xx)

  IF (jl .LE. 0) THEN
     if (yy (1) >= 0.0_r8) then
        val = yy (1)
     else
        call error_handler(E_ERR,'intplin', &
             'bad value in yy(1)', source,revision,revdate)
     endif
  ELSE IF (jl .GE. n) THEN
     if (yy (n) >= 0.0_r8) then
        val = yy (n)
     else
        call error_handler(E_ERR,'intplin', &
             'bad value in yy(n)', source,revision,revdate)
     endif
  ELSE
     if (yy (jl) >= 0.0_r8 .and. yy (jl+1) >= 0.0_r8) then
        val = (xx (jl+1) - x) * yy (jl) + (x - xx (jl)) * yy (jl+1)
        val = val / (xx (jl+1) - xx (jl))
     else
        call error_handler(E_ERR,'intplin', &
             'bad value in yy(jl) or yy(jl+1)', source,revision,revdate)
     endif
  ENDIF

END FUNCTION intplin

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

FUNCTION intplog (x,xx,yy) RESULT (val)
!------------------------------------------------------------------------------!
  IMPLICIT NONE

  INTEGER,  DIMENSION (:), intent(in) :: xx
  REAL(r8), DIMENSION (:), intent(in) :: yy
  REAL(r8),                intent(in) :: x

  REAL(r8) :: val

  INTEGER :: n,m,jl
!------------------------------------------------------------------------------!

  n = size (xx)
  m = size (yy)

  IF (n /= m) THEN
     call error_handler(E_ERR,'intplog', &
          'arrays xx and yy must have same size', source,revision,revdate)
  ENDIF

  jl = locate (x,xx)

  IF (jl .LE. 0) THEN
     if (yy (1) >= 0.0_r8) then
        val = yy (1)
     else
        call error_handler(E_ERR,'intplog', &
             'bad value in yy(1)', source,revision,revdate)
     endif
  ELSE IF (jl .GE. n) THEN
     if (yy (n) >= 0.0_r8) then
        val = yy (n)
     else
        call error_handler(E_ERR,'intplog', &
             'bad value in yy(n)', source,revision,revdate)
     endif
  ELSE
     if (yy (jl) >= 0.0_r8 .and. yy (jl+1) >= 0.0_r8) then
        val = log (real(xx(jl+1)) / x) * yy (jl) + log (x / real(xx(jl))) * yy (jl+1)
        val = val / log (real(xx(jl+1)) / real(xx(jl)))
     else
        call error_handler(E_ERR,'intplog', &
             'bad value in yy(jl) or yy(jl+1)', source,revision,revdate)
     endif
  ENDIF

END FUNCTION intplog

FUNCTION locate (x,xx) RESULT (level_index)
!------------------------------------------------------------------------------!
  IMPLICIT NONE

  INTEGER, DIMENSION (:), intent(in) :: xx
  REAL(r8),               intent(in) :: x

  INTEGER :: level_index

  INTEGER :: n,jl,jm,ju
  LOGICAL :: ascnd
!------------------------------------------------------------------------------!

  n = size (xx)
  ascnd = (xx (n) >= xx (1))   ! True if ascending order, false otherwise
  jl = 0                       ! Initialize lower limit
  ju = n+1                     ! Initialize upper limit

  DO

     IF (ju-jl <= 1) EXIT      ! Repeat until this condition is satisfied

     jm = (ju+jl) / 2.         ! Compute a mid point

     IF (ascnd .EQV. (x >= xx (jm))) THEN
        jl = jm               ! Replace mid point by lower limit
     ELSE
        ju = jm               ! Replace mid point by upper limit
     ENDIF

  ENDDO

  IF (x == xx (1)) THEN      ! Set the output, being carefull with endpoints
     level_index = 1
  ELSE IF (x == xx (n)) THEN
     level_index = n-1
  ELSE
     level_index = jl
  ENDIF

END FUNCTION LOCATE

END PROGRAM littler_tf_dart

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


      SUBROUTINE HDECAY_lightCPV(IND)

      IMPLICIT NONE

      INTEGER IND,INDA,K,L,N0,VFLAG,MIXPROB

      DOUBLE PRECISION MH,EPS,PI,aux
      DOUBLE PRECISION BETA,X,SP,QCD0,HQCDM,HQCD,QCDH,TQCDH,RATCOUP
      DOUBLE PRECISION AQCDM,AQCD,QCDA,TQCDA
      DOUBLE PRECISION FPI,THETAE,MPI,MPIC,MPI8,MPI9,META,METAP,MKc,MK0
      DOUBLE PRECISION MS2,GamS2,MS3,GamS3,MSIG,GamSIG
      DOUBLE PRECISION DM3,DM8,DM9,MMIX(4,4),VALP(4),VECP(4,4)
     .                 ,OMIX(4,4)
      DOUBLE PRECISION AHee,AHmumu,AHtata,MG0,GamG0
      DOUBLE PRECISION RMS,ASH,ASH2,AS3,AS4,HIGTOP,ALPHAS,RUNM
      DOUBLE PRECISION AH2Pi,AHPiE,GamH2Pi,GamH2PiC,GamHPiE,GamHPiEP
      DOUBLE PRECISION AH2K,GamH2KC,GamH2K0,AH2E,GamH2E,GamHEEP,GamH2EP
      DOUBLE PRECISION AHuu,AHdd,AHss,GamHuu,GamHdd,GamHss,GamHjj
      DOUBLE PRECISION MD,DCC,RMC,MBm,DBB,RMB,runmb,HTWW,HTZZ
      DOUBLE PRECISION GamAGAGA,GamAee,GamAmumu,GamAtata,GamAhadr,
     . GamAcc,GamAbb
      DOUBLE PRECISION CGPI,CGETA,CGETAP
      DOUBLE PRECISION APIee,AEee,AEPee
      DOUBLE PRECISION APImumu,AEmumu,AEPmumu
      DOUBLE PRECISION YUE,YDE,YSE
      DOUBLE PRECISION AA3Pi,API3Pi,AE3Pi,AEP3Pi,GamA3Pi,KinA3Pi
      DOUBLE PRECISION AAPi3PiC,APIPi3PiC,AEPi3PiC,AEPPi3PiC,GamAPi3PiC
     .                 ,KinAPi3PiC
      DOUBLE PRECISION AAEPi3,APIEPi3,AEEPi3,AEPEPi3,GamAEPi3
     .                 ,KinAEPi3
      DOUBLE PRECISION AAEPiC,APIEPiC,AEEPiC,AEPEPiC,GamAEPiC
     .                 ,KinAEPiC
      DOUBLE PRECISION AAEPPi3,APIEPPi3,AEEPPi3,AEPEPPi3,GamAEPPi3
     .                 ,KinAEPPi3
      DOUBLE PRECISION AAEPPiC,APIEPPiC,AEEPPiC,AEPEPPiC,GamAEPPiC
     .                 ,KinAEPPiC
      DOUBLE PRECISION AAPiEE,APIPiEE,AEPiEE,AEPPiEE,GamAPiEE,KinAPiEE
      DOUBLE PRECISION AAPiEEP,APIPiEEP,AEPiEEP,AEPPiEEP,GamAPiEEP
     .                 ,KinAPiEEP
      DOUBLE PRECISION AAPiEPEP,APIPiEPEP,AEPiEPEP,AEPPiEPEP,GamAPiEPEP
     .                 ,KinAPiEPEP
      DOUBLE PRECISION AA3E,API3E,AE3E,AEP3E,GamA3E,KinA3E
      DOUBLE PRECISION AAE2EP,APIE2EP,AEE2EP,AEPE2EP,GamAE2EP,KinAE2EP
      DOUBLE PRECISION AAEEp2,APIEEp2,AEEEp2,AEPEEp2,GamAEEp2,KinAEEp2
      DOUBLE PRECISION AA3EP,API3EP,AE3EP,AEP3EP,GamA3EP,KinA3EP
      DOUBLE PRECISION AAPiKC,APIPiKC,AEPiKC,AEPPiKC,GamAPiKC,KinAPiKC
      DOUBLE PRECISION AAPiK0,APIPiK0,AEPiK0,AEPPiK0,GamAPiK0,KinAPiK0
      DOUBLE PRECISION AAPiKCK0,APIPiKCK0,AEPiKCK0,AEPPiKCK0,GamAPiKCK0
     .                 ,KinAPiKCK0
      DOUBLE PRECISION AAEKC,APIEKC,AEEKC,AEPEKC,GamAEKC,KinAEKC
      DOUBLE PRECISION AAEK0,APIEK0,AEEK0,AEPEK0,GamAEK0,KinAEK0
      DOUBLE PRECISION AAEPKC,APIEPKC,AEEPKC,AEPEPKC,GamAEPKC,KinAEPKC
      DOUBLE PRECISION AAEPK0,APIEPK0,AEEPK0,AEPEPK0,GamAEPK0,KinAEPK0
      DOUBLE PRECISION AARhogam,APIRhogam,AERhogam,AEPRhogam,GamARhogam
     .                 ,KinARhogam
      DOUBLE PRECISION AAuu,AAdd,AAss,GamAuu,GamAdd,GamAss,GamAjj
      DOUBLE PRECISION METAC,DMC,CMIX,KinAPiDD
      DOUBLE PRECISION METAB1,METAB2,METAB3,DMB1,DMB2,DMB3,KinAPiBB

      DOUBLE COMPLEX XXC,TC,BC,CC,LC,MC,EC,CH1C,CH2C,WC,HC,PropI,PropII
      DOUBLE COMPLEX ULC,URC,DLC,DRC,T1C,T2C,B1C,B2C,LLC,LRC,L1C,L2C
      DOUBLE COMPLEX CJH,CGH,CJA,CGA,F0,FF,FS,FV,CM,FGG

      DOUBLE PRECISION ALEM0
      DOUBLE PRECISION MHC,XC(2,2),MH0(5),XH(5,5),MA2
      DOUBLE PRECISION MCH2(2),U(2,2,2),V(2,2,2)
      DOUBLE PRECISION MNEU(5),NEU(5,5,2)
      DOUBLE PRECISION CU(5),CUP(5),CD(5),CDP(5),CB(5),CBP(5),CJ(5),
     . CJP(5),CI(5),CG(5),CGP(5),CV(5),CZG(5),CZGP(5)
      DOUBLE PRECISION GF,MZ,MW,g1,g2,alSMZ,S2TW,ALEMMZ
      DOUBLE PRECISION mt,mb,mtau,mmuon,mel,MS,MCC,MBP,MPI0,MSTRANGE
      DOUBLE PRECISION XLAMBDA,MC0,MB0,MT0
      DOUBLE PRECISION MST2(2),UT(2,2,2),MSB2(2),UB(2,2,2),MSL2(2),
     . UTAU(2,2,2),MSNT2
      DOUBLE PRECISION MSU2(2),MSD2(2),MSE2(2),MSNE2,MSMU2(2),
     . UMU(2,2,2)
      DOUBLE PRECISION MST2P(2),MSB2P(2),MSU2P(2),MSD2P(2)
      DOUBLE PRECISION GRHSTST(5,2,2),GRHSBSB(5,2,2),GRHSLSL(5,2,2),
     . GRHSUSU(5,2,2),GRHSDSD(5,2,2),GRHSESE(5,2,2),GRHSNSN(5)
      DOUBLE PRECISION GIHSTST(5,2,2),GIHSBSB(5,2,2),GIHSLSL(5,2,2)
      DOUBLE PRECISION GRHCSTSB(2,2),GRHCSNSL(2),GRHCSUSD(2,2),
     . GRHCSNSE(2),GIHCSTSB(2,2),GIHCSNSL(2)
      DOUBLE PRECISION COH0CH(5,2,2,2),COH0NEU(5,5,5,2),
     . COHPNEUCHM(2,5,2,2),COHMNEUCHP(2,5,2,2)
      DOUBLE PRECISION gH0H0H0(5,5,5),gRH0HPHM(5,2,2),gIH0HPHM(5,2,2)
      DOUBLE PRECISION QSTSB
      DOUBLE PRECISION GamHGAGA,GamHee,GamHmumu,GamHtata,GamHhadr,
     . GamHcc,GamHbb,GamHinv(3),GamHWW,GamHZZ,GamHAA
      DOUBLE PRECISION DDCOS,DDSIN

      COMMON/ALEM0/ALEM0
      COMMON/HISPEC/MHC,XC,MH0,XH,MA2
      COMMON/CHASPEC/MCH2,U,V
      COMMON/NEUSPEC/MNEU,NEU
      COMMON/HNSMCOUP/CU,CUP,CD,CDP,CB,CBP,CJ,CJP,CI,CG,CGP,CV,CZG,CZGP
      COMMON/EWPAR/GF,MZ,MW,g1,g2,alSMZ,S2TW,ALEMMZ
      COMMON/SMFERM/mt,mb,mtau,mmuon,mel,MS,MCC,MBP,MPI0,MSTRANGE
      COMMON/ALS/XLAMBDA,MC0,MB0,MT0,N0
      COMMON/SFERM3SPEC/MST2,UT,MSB2,UB,MSL2,UTAU,MSNT2
      COMMON/SFERM1SPEC/MSU2,MSD2,MSE2,MSNE2,MSMU2,UMU
      COMMON/SFERMPSPEC/MST2P,MSB2P,MSU2P,MSD2P
      COMMON/HISFCOUP/GRHSTST,GRHSBSB,GRHSLSL,GRHSUSU,GRHSDSD,
     . GRHSESE,GRHSNSN,GIHSTST,GIHSBSB,GIHSLSL,GRHCSTSB,GRHCSNSL,
     . GRHCSUSD,GRHCSNSE,GIHCSTSB,GIHCSNSL
      COMMON/HINOCOUP/COH0CH,COH0NEU,COHPNEUCHM,COHMNEUCHP
      COMMON/HICOUP/gH0H0H0,gRH0HPHM,gIH0HPHM
      COMMON/STSBSCALE/QSTSB
      COMMON/VFLAG/VFLAG
      COMMON/LIGHTHDECAYS/GamHGAGA,GamHee,GamHmumu,GamHtata,GamHhadr,
     . GamHcc,GamHbb,GamHinv,GamHWW,GamHZZ,GamHAA

      CM(X)= DCMPLX(MIN(1d3,X)**2,-EPS/4d0)
      F0(XXC)=-CDLOG((CDSQRT(1d0-4d0*XXC)-1d0)
     .               /(CDSQRT(1d0-4d0*XXC)+1d0))**2/4d0
      FF(XXC)=8d0*XXC*(1d0+(1d0-4d0*XXC)*F0(XXC))
      FS(XXC)=2d0*XXC*(4d0*XXC*F0(XXC)-1d0)
      FV(XXC)=-(2d0+12d0*XXC+24d0*XXC*(1d0-2d0*XXC)*F0(XXC))
      FGG(XXC)=2d0*XXC
     .        *CDLOG((CDSQRT(1d0-4d0*XXC)-1d0)
     .               /(CDSQRT(1d0-4d0*XXC)+1d0))**2
      BETA(X)= DSQRT(1d0-4d0*X)
      QCd0(X)= (1d0+X**2)*(4d0*SP((1d0-X)/(1d0+X))
     . +2d0*SP((X-1d0)/(X+1d0))
     . - 3d0*DLOG((1d0+X)/(1d0-X))*DLOG(2d0/(1d0+X))
     . - 2d0*DLOG((1d0+X)/(1d0-X))*DLOG(X))
     . - 3d0*X*DLOG(4d0/(1d0-X**2))-4d0*X*DLOG(X)
      HQCDM(X)= QCd0(X)/X+(3d0+34d0*X**2-13d0*X**4)/16d0/X**3
     . * DLOG((1d0+X)/(1d0-X))+3d0/8d0/X**2*(7d0*X**2-1d0)
      HQCD(X)=(4d0/3d0*HQCDM(BETA(X))
     .   +2d0*(4d0/3d0-DLOG(X))*(1d0-10d0*X)/(1d0-4d0*X))*ASH/PI
     .   + (29.14671d0 + RATCOUP*(1.570d0 - 2d0*DLOG(HIGTOP)/3d0
     .   + DLOG(X)**2/9d0))*(ASH/PI)**2
     .   +(164.14d0 - 25.77d0*5 + 0.259d0*5**2)*(ASH/PI)**3
      QCDH(X)= 1d0+HQCD(X)
      TQCDH(X)= 1d0+4d0/3d0*HQCDM(BETA(X))*ASH/PI
      AQCDM(X)= QCd0(X)/X+(19d0+2d0*X**2+3d0*X**4)/16d0/X
     . * DLOG((1d0+X)/(1d0-X))+3d0/8d0*(7d0-X**2)
      AQCD(X)=(4d0/3d0*AQCDM(BETA(X))
     .   +2d0*(4d0/3d0-DLOG(X))*(1d0-6d0*X)/(1d0-4d0*X))*ASH/PI
     .   + (29.14671d0 + RATCOUP*(23d0/6d0 - DLOG(HIGTOP)
     .   + DLOG(X)**2/6d0))*(ASH/PI)**2
     .   + (164.14d0 - 25.77d0*5 + 0.259d0*5**2)*(ASH/PI)**3
      QCDA(X)= 1d0+AQCD(X)
      TQCDA(X)= 1d0+4d0/3d0*AQCDM(BETA(X))*ASH/PI

      EPS=1d-8
      PI=4d0*DATAN(1d0)

      MH=dsqrt(MH0(IND))

      FPI=0.093d0
      THETAE=-13d0*Pi/180d0
      MPI=0.135d0
      MPIC=0.1396d0
      META=0.548d0
      METAP=0.958d0
      MKc=0.494d0
      MK0=0.498d0
      MPI8=dsqrt(META**2*DDCOS(THETAE)**2+METAP**2*DDSIN(THETAE)**2)
      MPI9=dsqrt(META**2*DDSIN(THETAE)**2+METAP**2*DDCOS(THETAE)**2)

C	Coupling to photons / gluons

      TC=CM(MT/MH)
      BC=CM(MBP/MH)
      CC=CM(MCC/MH)
      LC=CM(MTAU/MH)
      MC=CM(MMUON/MH)
      EC=CM(MEL/MH)
      CH1C=CM(dsqrt(MCH2(1))/MH)
      CH2C=CM(dsqrt(MCH2(2))/MH)
      WC=CM(MW/MH)
      HC=CM(dsqrt(MHC)/MH)
      ULC=CM(dsqrt(MSU2P(1))/MH)
      URC=CM(dsqrt(MSU2P(2))/MH)
      DLC=CM(dsqrt(MSD2P(1))/MH)
      DRC=CM(dsqrt(MSD2P(2))/MH)
      T1C=CM(dsqrt(MST2P(1))/MH)
      T2C=CM(dsqrt(MST2P(2))/MH)
      B1C=CM(dsqrt(MSB2P(1))/MH)
      B2C=CM(dsqrt(MSB2P(2))/MH)
      LLC=CM(dsqrt(MSE2(1))/MH)
      LRC=CM(dsqrt(MSE2(2))/MH)
      L1C=CM(dsqrt(MSL2(1))/MH)
      L2C=CM(dsqrt(MSL2(2))/MH)

      CJH=DSQRT(dsqrt(2d0)*GF)/4d0*(CU(IND)*(FF(TC)+FF(CC))
     .                                                 +CB(IND)*FF(BC))
     .  +(gRHSUSU(IND,1,1)*FS(ULC)/MSU2P(1)
     .   +gRHSUSU(IND,2,2)*FS(URC)/MSU2P(2)
     .   +gRHSDSD(IND,1,1)*FS(DLC)/MSD2P(1)
     .   +gRHSDSD(IND,2,2)*FS(DRC)/MSD2P(2))/2d0
     .  +DCMPLX(GRHSTST(IND,1,1),GIHSTST(IND,1,1))*FS(T1C)/4d0/MST2P(1)
     .  +DCMPLX(GRHSTST(IND,2,2),GIHSTST(IND,2,2))*FS(T2C)/4d0/MST2P(2)
     .  +DCMPLX(GRHSBSB(IND,1,1),GIHSBSB(IND,1,1))*FS(B1C)/4d0/MSB2P(1)
     .  +DCMPLX(GRHSBSB(IND,2,2),GIHSBSB(IND,2,2))*FS(B2C)/4d0/MSB2P(2)

      CGH=DSQRT(dsqrt(2d0)*GF)/2d0*(4d0/3d0*CU(IND)*(FF(TC)+FF(CC))
     .             +CB(IND)*FF(BC)/3d0+CD(IND)*(FF(LC)+FF(MC)+FF(EC))
     .                                               +CV(IND)*FV(WC))
     .  +GRH0HPHM(IND,2,2)*FS(HC)/2d0/MHC
     .  +COH0CH(IND,1,1,1)/dsqrt(MCH2(1))*FF(CH1C)/2d0
     .  +COH0CH(IND,2,2,1)/dsqrt(MCH2(2))*FF(CH2C)/2d0
     .  +2d0/3d0*(
     .    DCMPLX(GRHSTST(IND,1,1),GIHSTST(IND,1,1))*FS(T1C)/MST2P(1)
     .   +DCMPLX(GRHSTST(IND,2,2),GIHSTST(IND,2,2))*FS(T2C)/MST2P(2)
     .   +2d0*gRHSUSU(IND,1,1)*FS(ULC)/MSU2P(1)
     .   +2d0*gRHSUSU(IND,2,2)*FS(URC)/MSU2P(2))
     .  +1d0/6d0*(
     .    DCMPLX(GRHSBSB(IND,1,1),GIHSBSB(IND,1,1))*FS(B1C)/MSB2P(1)
     .   +DCMPLX(GRHSBSB(IND,2,2),GIHSBSB(IND,2,2))*FS(B2C)/MSB2P(2)
     .   +2d0*gRHSDSD(IND,1,1)*FS(DLC)/MSD2P(1)
     .   +2d0*gRHSDSD(IND,2,2)*FS(DRC)/MSD2P(2))
     .  +GRHSESE(IND,1,1)*FS(LLC)/MSE2(1)
     .  +GRHSESE(IND,1,1)*FS(LRC)/MSE2(2)
     .  +DCMPLX(GRHSLSL(IND,1,1),GIHSLSL(IND,1,1))*FS(L1C)/MSL2(1)/2d0
     .  +DCMPLX(GRHSLSL(IND,2,2),GIHSLSL(IND,2,2))*FS(L2C)/MSL2(2)/2d0

      CJA=-DSQRT(dsqrt(2d0)*GF)/4d0
     .         *(CUP(IND)*(FGG(TC)+FGG(CC))+CBP(IND)*FGG(BC))

      CGA=-DSQRT(dsqrt(2d0)*GF)/2d0*(4d0/3d0*CUP(IND)*(FGG(TC)+FGG(CC))
     .        +CBP(IND)/3d0*FGG(BC)+CDP(IND)*(FGG(LC)+FGG(MC)+FGG(EC)))
     . -COH0CH(IND,1,1,2)/dsqrt(MCH2(1))*FGG(CH1C)/2d0
     . -COH0CH(IND,2,2,2)/dsqrt(MCH2(2))*FGG(CH2C)/2d0

C	Leptonic decays

C  * H -> ee
      AHee=MEL*CD(IND)*DSQRT(dsqrt(2d0)*GF)
      GamHee=AHee**2/(8d0*Pi)*MH
     .               *dsqrt(max(0d0,1d0-4d0*MEL**2/MH**2))**3

      AHee=MEL*CDP(IND)*DSQRT(dsqrt(2d0)*GF)
      GamAee=AHee**2/(8d0*Pi)*MH*dsqrt(max(0d0,1d0-4d0*MEL**2/MH**2))

C  * H -> mumu
      AHmumu=MMUON*CD(IND)*DSQRT(dsqrt(2d0)*GF)
      GamHmumu=AHmumu**2/(8d0*Pi)*MH
     .               *dsqrt(max(0d0,1d0-4d0*MMUON**2/MH**2))**3

      AHmumu=MMUON*CDP(IND)*DSQRT(dsqrt(2d0)*GF)
      GamAmumu=AHmumu**2/(8d0*Pi)*MH
     .               *dsqrt(max(0d0,1d0-4d0*MMUON**2/MH**2))

C  * H -> tautau
      AHtata=MTAU*CD(IND)*DSQRT(dsqrt(2d0)*GF)
      GamHtata=AHtata**2/(8d0*Pi)*MH
     .               *dsqrt(max(0d0,1d0-4d0*MTAU**2/MH**2))**3

      AHtata=MTAU*CDP(IND)*DSQRT(dsqrt(2d0)*GF)
      GamAtata=AHtata**2/(8d0*Pi)*MH
     .               *dsqrt(max(0d0,1d0-4d0*MTAU**2/MH**2))

C  * A -> 2gamma
      GamAGAGA=8d0*CDABS(CGA)**2*MH**3
     .          /(32d0*Pi)*(ALEM0/4d0/Pi)**2

c	Decay to light neutralinos

      IF(MH.LE.2d0*DSQRT(MNEU(1)))THEN
       GamHinv(1)=0d0
      ELSE
       aux=COH0NEU(IND,1,1,1)**2
       GamHinv(1)=aux**2/(16d0*PI)*MH*dsqrt(1d0-4d0*MNEU(1)/MH**2)**3
       aux=COH0NEU(IND,1,1,2)**2
       GamHinv(1)=GamHinv(1)+aux**2/(16d0*PI)*MH
     .                               *dsqrt(1d0-4d0*MNEU(1)/MH**2)
      ENDIF

      IF(MH.LE.DSQRT(MNEU(1))+DSQRT(MNEU(2)))THEN
       GamHinv(2)=0d0
      ELSE
       aux=COH0NEU(IND,1,2,1)**2
       GamHinv(2)=aux**2/(8d0*PI)*MH
     .   *dsqrt(1d0-((dsqrt(MNEU(1))+dsqrt(MNEU(2)))/MH)**2)**3
     .   *dsqrt(1d0-((dsqrt(MNEU(1))-dsqrt(MNEU(2)))/MH)**2)

       aux=COH0NEU(IND,1,2,2)**2
       GamHinv(2)=GamHinv(2)+aux**2/(8d0*PI)*MH
     .   *dsqrt(1d0-((dsqrt(MNEU(1))+dsqrt(MNEU(2)))/MH)**2)
     .   *dsqrt(1d0-((dsqrt(MNEU(1))-dsqrt(MNEU(2)))/MH)**2)**3
      ENDIF

      IF(MH.LE.2d0*DSQRT(MNEU(2)))THEN
       GamHinv(3)=0d0
      ELSE
       aux=COH0NEU(IND,2,2,1)**2
       GamHinv(3)=aux**2/(16d0*PI)*MH*dsqrt(1d0-4d0*MNEU(2)/MH**2)**3

       aux=COH0NEU(IND,2,2,2)**2
       GamHinv(3)=GamHinv(3)+aux**2/(16d0*PI)*MH
     .                       *dsqrt(1d0-4d0*MNEU(2)/MH**2)
      ENDIF

c	Decay to light Higgs states

       IF(MH.LE.2d0*dsqrt(MH0(1)))THEN
        GamHAA=0d0
       ELSE
        aux=GH0H0H0(IND,1,1)

        GamHAA=aux**2/(32d0*PI*MH)*dsqrt(1d0-4d0*MH0(1)/MH**2)
       ENDIF

c	Decay to W*W*/Z*Z*

      IF(VFLAG.ne.0)then

        CALL HTOVV(MW,2.08856d0,MH,HTWW)
        GamHWW= 3d0/2d0*GF*MW**4/DSQRT(2d0)/PI/MH**3*HTWW*CV(IND)**2

        CALL HTOVV(MZ,2.49581d0,MH,HTZZ)
        GamHZZ= 3d0/4d0*GF*MZ**4/DSQRT(2d0)/PI/MH**3*HTZZ*CV(IND)**2

      ELSE

       GamHWW=0d0
       GamHZZ=0d0

      ENDIF

C	Initializing the strong coupling constant and running masses
      IF(MH.ge.2d0)then
       HIGTOP=(MH/MT)**2
       MT0=3.D8
       ASH=ALPHAS(MH,2)
       MC0=1d8
       MB0=2d8
       AS3=ALPHAS(MH,2)
       ASH2=AS3*dsqrt(1d0+AS3/Pi*(95d0/4d0-3d0*7d0/6d0))
       MC0=MCC
       AS4=ALPHAS(MH,2)
       MB0=MBP
       MT0=MT
       RMS=RUNM(MH,3)
      ELSE
       IF(MH.lt.0.8d0)ASH2=Pi/3d0
       IF(MH.ge.0.8d0.and.MH.lt.2d0)ASH2=
     . (Pi/3d0-0.458d0)*dexp(-((MH-0.8d0)/0.732d0)**2)+0.458d0
       IF(MH.gt.1d0)RMS=RUNM(MH,3)
      ENDIF

C	Mixing with mesons [1612.06538[hep-ph]]

      GamHhadr=0d0
      GamAhadr=0d0

      IF(MH.lt.4d0)then

      DM3=-DSQRT(dsqrt(2d0)*GF)/2d0*FPI*MPI**2*(CUP(IND)-CDP(IND))
      DM8=-DSQRT(dsqrt(2d0)*GF)/2d0*FPI*(-dsqrt(3d0)*MPI8**2*CDP(IND)
     .                      +MPI**2/dsqrt(3d0)*(CUP(IND)+2d0*CDP(IND)))
      DM9=-DSQRT(dsqrt(2d0)*GF)/2d0*FPI*(dsqrt(3d0/2d0)*MPI8**2
     .             *CDP(IND)+MPI**2/dsqrt(6d0)*(2d0*CUP(IND)+CDP(IND)))
     .    -dsqrt(2d0/3d0)*DREAL(CJA)*FPI*(MPI9**2-(MPI8**2+MPI**2)/2d0)

      MMIX(1,1)=MPI**2
      MMIX(1,2)=0d0
      MMIX(1,3)=0d0
      MMIX(1,4)=DM3
      MMIX(2,1)=0d0
      MMIX(2,2)=META**2
      MMIX(2,3)=0d0
      MMIX(2,4)=DDCOS(THETAE)*DM8-DDSIN(THETAE)*DM9
      MMIX(3,1)=0d0
      MMIX(3,2)=0d0
      MMIX(3,3)=METAP**2
      MMIX(3,4)=DDSIN(THETAE)*DM8+DDCOS(THETAE)*DM9
      MMIX(4,1)=DM3
      MMIX(4,2)=DDCOS(THETAE)*DM8-DDSIN(THETAE)*DM9
      MMIX(4,3)=DDSIN(THETAE)*DM8+DDCOS(THETAE)*DM9
      MMIX(4,4)=MH**2
     .    +2d0/3d0*FPI**2*(MPI9**2-(MPI8**2+MPI**2)/3d0)*CDABS(CJA)**2

      CALL DIAGN(4,MMIX,VALP,VECP,EPS)
      CALL SORTN(4,VALP,VECP)
      DO K=1,4
       DO L=1,4
        OMIX(K,L)=VECP(L,K)
       ENDDO
      ENDDO

      INDA=1
      DO K=1,4
       IF(dabs(OMIX(INDA,4))**2.lt.dabs(OMIX(K,4))**2)INDA=K
      ENDDO
      IF(dabs(OMIX(INDA,4))**2.lt.0.6d0)MIXPROB=1

C	Diphoton decay A -> 2gamma - CP-odd modes

      CGPI=-dsqrt((6.582d-25/8.52d-17*0.98823d0)
     .            /(8d0*(ALEM0/(4d0*Pi))**2*MPI**3/(32d0*Pi)))
      CGETA=dsqrt((1.31d-6*0.3941d0)
     .            /(8d0*(ALEM0/(4d0*Pi))**2*META**3/(32d0*Pi)))
     . *(-(DDCOS(THETAE)-2d0*dsqrt(2d0)*DDSIN(THETAE))
     .    /dabs(DDCOS(THETAE)-2d0*dsqrt(2d0)*DDSIN(THETAE)))
      CGETAP=dsqrt((0.000197d0*0.0221d0)
     .            /(8d0*(ALEM0/(4d0*Pi))**2*METAP**3/(32d0*Pi)))
     . *(-(DDSIN(THETAE)+2d0*dsqrt(2d0)*DDCOS(THETAE))
     .    /dabs(DDSIN(THETAE)+2d0*dsqrt(2d0)*DDCOS(THETAE)))

      aux=OMIX(INDA,1)*CGPI+OMIX(INDA,2)*CGETA+OMIX(INDA,3)*CGETAP
     .          +OMIX(INDA,4)*DREAL(CGA)
      GamAGAGA=8d0*(aux**2+(OMIX(INDA,4)*DIMAG(CGA))**2)*MH**3
     .          /(32d0*Pi)*(ALEM0/4d0/Pi)**2

C	Leptonic decays - CP-odd modes

C  * A -> ee
      AHee=MEL*CDP(IND)*DSQRT(dsqrt(2d0)*GF)
      APiee=dsqrt(6.582d-25/8.52d-17*6.46d-8
     .            *8d0*Pi/(MPI*dsqrt(1d0-4d0*MEL**2/MPI**2)))
      AEee=0d0
      AEPee=0d0

      aux=OMIX(INDA,1)*APiee+OMIX(INDA,2)*AEee+OMIX(INDA,3)*AEPee
     .          +OMIX(INDA,4)*AHee
      GamAee=aux**2/(8d0*Pi)*MH*dsqrt(max(0d0,1d0-4d0*MEL**2/MH**2))

C  * A -> mumu
      AHmumu=MMUON*CDP(IND)*DSQRT(dsqrt(2d0)*GF)
      APimumu=0d0
      AEmumu=dsqrt(5.8d-6*1.31d-6
     .            *8d0*Pi/(META*dsqrt(1d0-4d0*MMUON**2/META**2)))
      AEPmumu=0d0

      aux=OMIX(INDA,1)*APimumu+OMIX(INDA,2)*AEmumu+OMIX(INDA,3)*AEPmumu
     .          +OMIX(INDA,4)*AHmumu
      GamAmumu=aux**2/(8d0*Pi)*MH
     .               *dsqrt(max(0d0,1d0-4d0*MMUON**2/MH**2))

C  * A -> tautau
      AHtata=MTAU*CDP(IND)*DSQRT(dsqrt(2d0)*GF)
      GamAtata=(OMIX(INDA,4)*AHtata)**2/(8d0*Pi)*MH
     .               *dsqrt(max(0d0,1d0-4d0*MTAU**2/MH**2))

C	Hadronic decays

c              - 2 meson channels (CP-even modes)

      MS2=1d0
      GamS2=0.18d0

      MS3=1.5d0
      GamS3=0.1d0

      MSIG=1d0
      GamSIG=0.7d0

      MG0=1.6d0
      GamG0=0.06d0

C  * H -> 2Pi0
      AH2Pi=CDABS(-DSQRT(dsqrt(2d0)*GF)/2d0*PropII(MH,MS2,GamS2)
     . *((MPI**2+MKC**2-MK0**2)*CU(IND)+(MPI**2+MK0**2-MKC**2)*CD(IND))
     .  -2d0*ASH2/PI/3d0*CJH*(MH**2+MPI**2)*PropII(MH,MSIG,GamSIG))**2

      GamH2Pi=AH2Pi/(32d0*PI*MH)*dsqrt(max(0d0,1d0-4d0*(MPI/MH)**2))

C  * H -> Pi+Pi-
      AH2Pi=CDABS(-DSQRT(dsqrt(2d0)*GF)/2d0*PropII(MH,MS2,GamS2)
     . *((MPI**2+MKC**2-MK0**2)*CU(IND)+(MPI**2+MK0**2-MKC**2)*CD(IND))
     . -2d0*ASH2/PI/3d0*CJH*(MH**2+MPIC**2)*PropII(MH,MSIG,GamSIG))**2

      GamH2PiC=AH2Pi/(16d0*PI*MH)*dsqrt(max(0d0,1d0-4d0*(MPIC/MH)**2))

C  * H -> EtaPi0
      AHPiE=CDABS(-DSQRT(dsqrt(2d0)*GF/3d0)/2d0*PropII(MH,MS2,GamS2)
     . *((MPI**2+MKC**2-MK0**2)*CU(IND)-(MPI**2+MK0**2-MKC**2)*CD(IND))
     .        -2d0*ASH2/PI/dsqrt(3d0)*CJH*PropII(MH,MSIG,GamSIG)
     .                   *(MKC**2-MK0**2-MPIC**2+MPI**2))**2

      GamHPiE=AHPiE/(16d0*PI*MH)
     .       *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))**2
     .       *dsqrt(max(0d0,1d0-(MPI+META)**2/MH**2))
     .       *dsqrt(max(0d0,1d0-(MPI-META)**2/MH**2))

C  * H -> Eta'Pi0
      AHPiE=CDABS(-DSQRT(dsqrt(2d0)*GF/3d0)/2d0*PropII(MH,MS2,GamS2)
     . *((MPI**2+MKC**2-MK0**2)*CU(IND)-(MPI**2+MK0**2-MKC**2)*CD(IND))
     .        -2d0*ASH2/PI/dsqrt(3d0)*CJH*PropII(MH,MSIG,GamSIG)
     .                   *(MKC**2-MK0**2-MPIC**2+MPI**2))**2

      GamHPiEP=AHPiE/(16d0*PI*MH)
     .       *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))**2
     .       *dsqrt(max(0d0,1d0-(MPI+METAP)**2/MH**2))
     .       *dsqrt(max(0d0,1d0-(MPI-METAP)**2/MH**2))

C  * H -> K+K-
      AH2K=CDABS(-DSQRT(dsqrt(2d0)*GF)/2d0
     .     *((MPI**2+MKC**2-MK0**2)*CU(IND)*PropII(MH,MS2,GamS2)
     .      +(MKC**2+MK0**2-MPI**2)*CD(IND)*PropII(MH,MS3,GamS3))
     . -2d0*ASH2/PI/3d0*CJH*(MH**2+MKC**2)*PropII(MH,MSIG,GamSIG))**2

      GamH2KC=AH2K/(16d0*PI*MH)
     .       *dsqrt(max(0d0,1d0-4d0*MKC**2/MH**2))

C  * H -> K0K0b
      AH2K=CDABS(-DSQRT(dsqrt(2d0)*GF)/2d0
     .     *((MPI**2+MK0**2-MKC**2)*CD(IND)*PropII(MH,MS2,GamS2)
     .      +(MKC**2+MK0**2-MPI**2)*CD(IND)*PropII(MH,MS3,GamS3))
     . -2d0*ASH2/PI/3d0*CJH*(MH**2+MK0**2)*PropII(MH,MSIG,GamSIG))**2

      GamH2K0=AH2K/(16d0*PI*MH)
     .       *dsqrt(max(0d0,1d0-4d0*MK0**2/MH**2))

C  * H -> 2Eta
      AH2E=CDABS(-DSQRT(dsqrt(2d0)*GF)/6d0*
     . (((MPI**2+MKC**2-MK0**2)*CU(IND)+(MPI**2+MK0**2-MKC**2)*CD(IND))
     . *PropII(MH,MS2,GamS2)*(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))**2
     .   +4d0*(MKC**2+MK0**2-MPI**2)*CD(IND)*PropII(MH,MS3,GamS3)
     .              *(DDCOS(THETAE)+DDSIN(THETAE)/dsqrt(2d0))**2)
     .        -2d0*ASH2/PI/3d0*CJH*(PropII(MH,MSIG,GamSIG)
     .     *(MH**2-2d0*META**2+MPI**2*(DDCOS(THETAE)
     .       -dsqrt(2d0)*DDSIN(THETAE))**2+2d0*(MKC**2+MK0**2-MPI**2)
     .          *(DDCOS(THETAE)+DDSIN(THETAE)/dsqrt(2d0))**2)
     .     +PropI(MH,MG0,GamG0)*DDSIN(THETAE)**2))**2

      GamH2E=AH2E/(32d0*PI*MH)*dsqrt(max(0d0,1d0-4d0*(META/MH)**2))

C  * H -> 2Eta'
      AH2E=CDABS(-DSQRT(dsqrt(2d0)*GF)/6d0*
     . (((MPI**2+MKC**2-MK0**2)*CU(IND)+(MPI**2+MK0**2-MKC**2)*CD(IND))
     . *PropII(MH,MS2,GamS2)*(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))**2
     .   +4d0*(MKC**2+MK0**2-MPI**2)*CD(IND)*PropII(MH,MS3,GamS3)
     .              *(DDSIN(THETAE)-DDCOS(THETAE)/dsqrt(2d0))**2)
     .        -2d0*ASH2/PI/3d0*CJH*(PropII(MH,MSIG,GamSIG)
     .    *(MH**2-2d0*METAP**2+MPI**2*(DDSIN(THETAE)
     .       +dsqrt(2d0)*DDCOS(THETAE))**2+2d0*(MKC**2+MK0**2-MPI**2)
     .          *(DDSIN(THETAE)-DDCOS(THETAE)/dsqrt(2d0))**2)
     .     +PropI(MH,MG0,GamG0)*DDCOS(THETAE)**2))**2

      GamH2EP=AH2E/(32d0*PI*MH)*dsqrt(max(0d0,1d0-4d0*(METAP/MH)**2))

C  * H -> EtaEta'
      AH2E=CDABS(-DSQRT(dsqrt(2d0)*GF)/6d0*
     . (((MPI**2+MKC**2-MK0**2)*CU(IND)+(MPI**2+MK0**2-MKC**2)*CD(IND))
     .  *PropII(MH,MS2,GamS2)*(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))
     .              *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))
     .   +4d0*(MKC**2+MK0**2-MPI**2)*CD(IND)*PropII(MH,MS3,GamS3)
     .              *(DDSIN(THETAE)-DDCOS(THETAE)/dsqrt(2d0))
     .              *(DDCOS(THETAE)+DDSIN(THETAE)/dsqrt(2d0)))
     .        -2d0*ASH2/PI/3d0*CJH*(PropII(MH,MSIG,GamSIG)*(
     .       MPI**2*(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))
     .             *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))
     .       +2d0*(MKC**2+MK0**2-MPI**2)
     .          *(DDSIN(THETAE)-DDCOS(THETAE)/dsqrt(2d0))
     .          *(DDCOS(THETAE)+DDSIN(THETAE)/dsqrt(2d0)))
     .     +PropI(MH,MG0,GamG0)*DDSIN(THETAE)*DDCOS(THETAE)))**2

      GamHEEP=AH2E/(16d0*PI*MH)
     .                  *dsqrt(max(0d0,1d0-((META+METAP)/MH)**2))
     .                  *dsqrt(max(0d0,1d0-((META-METAP)/MH)**2))

c              - 3 meson channels (CP-odd modes)

C   Effective yukawas
      YUE=MPI**2*CUP(IND)*DSQRT(2d0*dsqrt(2d0)*GF/3d0)/FPI
      YDE=MPI**2*CDP(IND)*DSQRT(2d0*dsqrt(2d0)*GF/3d0)/FPI
      YSE=(MKC**2+MK0**2-MPI**2)*CDP(IND)*DSQRT(2d0*dsqrt(2d0)*GF/3d0)
     .                                  /FPI

C  * A -> 3Pi0
      IF(MH.lt.1.1d0)then
       AA3Pi=-DSQRT(dsqrt(2d0)*GF)*MPI**2/(2d0*FPI)*(CUP(IND)-CDP(IND))
      ELSE
       IF(MH.lt.1.3d0)then
        AA3Pi=-DSQRT(dsqrt(2d0)*GF)*MPI**2/(2d0*FPI)
     .        *(CUP(IND)-CDP(IND))*(1d0-(MH-1.1d0)/.2d0)
     . +dsqrt(6d0*(YUE**2+YDE**2)/16d0)*SIGN(1d0,CDP(IND)-CUP(IND))
     .        *(MH-1.1d0)/.2d0
       ELSE
        AA3Pi=dsqrt(6d0*(YUE**2+YDE**2)/16d0)
     .      *SIGN(1d0,CDP(IND)-CUP(IND))
       ENDIF
      ENDIF
      APi3Pi=(MPI/FPI)**2
      AE3Pi=0.722665d0
      AEP3Pi=0.278538d0

      aux=OMIX(INDA,1)*APi3Pi+OMIX(INDA,2)*AE3Pi+OMIX(INDA,3)*AEP3Pi
     .          +OMIX(INDA,4)*AA3Pi
      GamA3Pi=aux**2/(6d0*2d0**8*Pi**3*MH)*KinA3Pi(MH)

C  * A -> Pi0Pi+Pi-
      IF(MH.lt.1.1d0)then
       AAPi3PiC=-DSQRT(dsqrt(2d0)*GF)*MPI**2/(6d0*FPI)
     .                                 *(CUP(IND)-CDP(IND))
      ELSE
       IF(MH.lt.1.3d0)then
        AAPi3PiC=-DSQRT(dsqrt(2d0)*GF)*MPI**2/(6d0*FPI)
     .        *(CUP(IND)-CDP(IND))*(1d0-(MH-1.1d0)/.2d0)
     . +dsqrt((YUE**2+YDE**2)/24d0)*SIGN(1d0,CDP(IND)-CUP(IND))
     .        *(MH-1.1d0)/.2d0
       ELSE
        AAPi3PiC=dsqrt((YUE**2+YDE**2)/24d0)
     .       *SIGN(1d0,CDP(IND)-CUP(IND))
       ENDIF
      ENDIF
      APiPi3PiC=(MPI/FPI)**2/3d0
      AEPi3PiC=0.262726d0
      AEPPi3PiC=0.151766d0

      aux=OMIX(INDA,1)*APiPi3PiC+OMIX(INDA,2)*AEPi3PiC+OMIX(INDA,3)
     .          *AEPPi3PiC+OMIX(INDA,4)*AAPi3PiC
      GamAPi3PiC=aux**2/(2d0**8*Pi**3*MH)*KinAPi3PiC(MH)

C  * A -> Eta2Pi0
      IF(MH.lt.1.1d0)then
       AAEPi3=-DSQRT(3d0*dsqrt(2d0)*GF)*MPI**2/(6d0*FPI)
     .                                  *(CUP(IND)+CDP(IND))
      ELSE
       IF(MH.lt.1.3d0)then
        AAEPi3=-DSQRT(3d0*dsqrt(2d0)*GF)*MPI**2/(6d0*FPI)
     .        *(CUP(IND)+CDP(IND))*(1d0-(MH-1.1d0)/.2d0)
     . -dsqrt(2d0*(YUE**2+YDE**2)/16d0)*SIGN(1d0,CDP(IND)+CUP(IND))
     .           *(MH-1.1d0)/.2d0
       ELSE
        AAEPi3=-dsqrt(2d0*(YUE**2+YDE**2)/16d0)
     .        *SIGN(1d0,CDP(IND)+CUP(IND))
       ENDIF
      ENDIF
      AAEPi3=AAEPi3*(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))
      APIEPi3=(MKC**2-MK0**2-MPIC**2+MPI**2)/(dsqrt(3d0)*FPI**2)
     .        *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))
      AEEPi3=(MPI/FPI)**2/3d0*(DDCOS(THETAE)
     .       -dsqrt(2d0)*DDSIN(THETAE))**2
      AEPEPi3=6.33755d0

      aux=OMIX(INDA,1)*APIEPi3+OMIX(INDA,2)*AEEPi3+OMIX(INDA,3)
     .          *AEPEPi3+OMIX(INDA,4)*AAEPi3
      GamAEPi3=aux**2/(2d0*2d0**8*Pi**3*MH)*KinAEPi3(MH)

C  * A -> EtaPi+Pi-
      IF(MH.lt.1.1d0)then
       AAEPiC=-DSQRT(3d0*dsqrt(2d0)*GF)*MPI**2/(6d0*FPI)
     .                                  *(CUP(IND)+CDP(IND))
      ELSE
       IF(MH.lt.1.3d0)then
        AAEPiC=-DSQRT(3d0*dsqrt(2d0)*GF)*MPI**2/(6d0*FPI)
     .        *(CUP(IND)+CDP(IND))*(1d0-(MH-1.1d0)/.2d0)
     . -dsqrt((YUE**2+YDE**2)/8d0)*SIGN(1d0,CDP(IND)+CUP(IND))
     .             *(MH-1.1d0)/.2d0
       ELSE
        AAEPiC=-dsqrt((YUE**2+YDE**2)/8d0)*SIGN(1d0,CDP(IND)+CUP(IND))
       ENDIF
      ENDIF
      AAEPiC=AAEPiC*(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))
      APIEPiC=(MKC**2-MK0**2-MPIC**2+MPI**2)/(3d0*dsqrt(3d0)*FPI**2)
     .        *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))
      AEEPiC=(MPI/FPI)**2/3d0*(DDCOS(THETAE)
     .       -dsqrt(2d0)*DDSIN(THETAE))**2
      AEPEPiC=6.60772d0

      aux=OMIX(INDA,1)*APIEPiC+OMIX(INDA,2)*AEEPiC+OMIX(INDA,3)
     .          *AEPEPiC+OMIX(INDA,4)*AAEPiC
      GamAEPiC=aux**2/(2d0**8*Pi**3*MH)*KinAEPiC(MH)

C  * A -> Eta'2Pi0
      IF(MH.lt.1.1d0)then
       AAEPPi3=-DSQRT(3d0*dsqrt(2d0)*GF)*MPI**2/(6d0*FPI)
     .                                  *(CUP(IND)+CDP(IND))
      ELSE
       IF(MH.lt.1.3d0)then
        AAEPPi3=-DSQRT(3d0*dsqrt(2d0)*GF)*MPI**2/(6d0*FPI)
     .        *(CUP(IND)+CDP(IND))*(1d0-(MH-1.1d0)/.2d0)
     . -dsqrt(2d0*(YUE**2+YDE**2)/16d0)*SIGN(1d0,CDP(IND)+CUP(IND))
     .             *(MH-1.1d0)/.2d0
       ELSE
        AAEPPi3=-dsqrt(2d0*(YUE**2+YDE**2)/16d0)
     .            *SIGN(1d0,CDP(IND)+CUP(IND))
       ENDIF
      ENDIF
      AAEPPi3=AAEPPi3*(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))
      APIEPPi3=(MKC**2-MK0**2-MPIC**2+MPI**2)/(dsqrt(3d0)*FPI**2)
     .        *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))
      AEEPPi3=(MPI/FPI)**2/3d0*(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))
     .                        *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))
      AEPEPPi3=5.65362d0

      aux=OMIX(INDA,1)*APIEPPi3+OMIX(INDA,2)*AEEPPi3+OMIX(INDA,3)
     .          *AEPEPPi3+OMIX(INDA,4)*AAEPPi3
      GamAEPPi3=aux**2/(2d0*2d0**8*Pi**3*MH)*KinAEPPi3(MH)

C  * A -> Eta'Pi+Pi-
      IF(MH.lt.1.1d0)then
       AAEPPiC=-DSQRT(3d0*dsqrt(2d0)*GF)*MPI**2/(6d0*FPI)
     .                                      *(CUP(IND)+CDP(IND))
      ELSE
       IF(MH.lt.1.3d0)then
        AAEPPiC=-DSQRT(3d0*dsqrt(2d0)*GF)*MPI**2/(6d0*FPI)
     .        *(CUP(IND)+CDP(IND))*(1d0-(MH-1.1d0)/.2d0)
     . -dsqrt((YUE**2+YDE**2)/8d0)*SIGN(1d0,CDP(IND)+CUP(IND))
     .           *(MH-1.1d0)/.2d0
       ELSE
        AAEPPiC=-dsqrt((YUE**2+YDE**2)/8d0)*SIGN(1d0,CDP(IND)+CUP(IND))
       ENDIF
      ENDIF
      AAEPPiC=AAEPPiC*(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))
      APIEPPiC=(MKC**2-MK0**2-MPIC**2+MPI**2)/(3d0*dsqrt(3d0)*FPI**2)
     .        *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))
      AEEPPiC=(MPI/FPI)**2/3d0*(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))
     .        *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))
      AEPEPPiC=5.89464d0

      aux=OMIX(INDA,1)*APIEPPiC+OMIX(INDA,2)*AEEPPiC+OMIX(INDA,3)
     .          *AEPEPPiC+OMIX(INDA,4)*AAEPPiC
      GamAEPPiC=aux**2/(2d0**8*Pi**3*MH)*KinAEPPiC(MH)

C  * A -> Pi02Eta
      IF(MH.lt.1.1d0)then
       AAPiEE=-DSQRT(dsqrt(2d0)*GF)*MPI**2/(6d0*FPI)
     .                                 *(CUP(IND)-CDP(IND))
      ELSE
       IF(MH.lt.1.3d0)then
        AAPiEE=-DSQRT(dsqrt(2d0)*GF)*MPI**2/(6d0*FPI)
     .        *(CUP(IND)-CDP(IND))*(1d0-(MH-1.1d0)/.2d0)
     . +dsqrt(2d0*(YUE**2+YDE**2)/48d0)*SIGN(1d0,CDP(IND)-CUP(IND))
     .           *(MH-1.1d0)/.2d0
       ELSE
        AAPiEE=dsqrt(2d0*(YUE**2+YDE**2)/48d0)
     .     *SIGN(1d0,CDP(IND)+CUP(IND))
       ENDIF
      ENDIF
      AAPiEE=AAPiEE*(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))**2
      APIPiEE=(MPI/FPI)**2/3d0
     .        *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))**2
      AEPiEE=(MKC**2-MK0**2-MPIC**2+MPI**2)/(3d0*dsqrt(3d0)*FPI**2)
     .        *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))**3
      AEPPiEE=(MKC**2-MK0**2-MPIC**2+MPI**2)/(3d0*dsqrt(3d0)*FPI**2)
     .        *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))**2
     .        *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))

      aux=OMIX(INDA,1)*APIPiEE+OMIX(INDA,2)*AEPiEE+OMIX(INDA,3)
     .          *AEPPiEE+OMIX(INDA,4)*AAPiEE
      GamAPiEE=aux**2/(2d0*2d0**8*Pi**3*MH)*KinAPiEE(MH)

C  * A -> Pi0EtaEta'
      AAPiEEP=dsqrt((YUE**2+YDE**2)/24d0)*SIGN(1d0,CDP(IND)+CUP(IND))
      AAPiEEP=AAPiEEP*(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))
     .               *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))
      APIPiEEP=(MPI/FPI)**2/3d0
     .               *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))
     .               *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))
      AEPiEEP=(MKC**2-MK0**2-MPIC**2+MPI**2)/(3d0*dsqrt(3d0)*FPI**2)
     .        *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))**2
     .        *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))
      AEPPiEEP=(MKC**2-MK0**2-MPIC**2+MPI**2)/(3d0*dsqrt(3d0)*FPI**2)
     .        *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))
     .        *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))**2

      aux=OMIX(INDA,1)*APIPiEEP+OMIX(INDA,2)*AEPiEEP+OMIX(INDA,3)
     .          *AEPPiEEP+OMIX(INDA,4)*AAPiEEP
      GamAPiEEP=aux**2/(2d0**8*Pi**3*MH)*KinAPiEEP(MH)

C  * A -> Pi02Eta'
      AAPiEPEP=dsqrt(2d0*(YUE**2+YDE**2)/48d0)
     .        *SIGN(1d0,CDP(IND)+CUP(IND))
      AAPiEPEP=AAPiEPEP*(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))**2
      APIPiEPEP=(MPI/FPI)**2/3d0
     .        *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))**2
      AEPiEPEP=(MKC**2-MK0**2-MPIC**2+MPI**2)/(3d0*dsqrt(3d0)*FPI**2)
     .        *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))**2
     .        *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))
      AEPPiEPEP=(MKC**2-MK0**2-MPIC**2+MPI**2)/(3d0*dsqrt(3d0)*FPI**2)
     .        *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))**3

      aux=OMIX(INDA,1)*APIPiEPEP+OMIX(INDA,2)*AEPiEPEP+OMIX(INDA,3)
     .          *AEPPiEPEP+OMIX(INDA,4)*AAPiEPEP
      GamAPiEPEP=aux**2/(2d0*2d0**8*Pi**3*MH)*KinAPiEPEP(MH)

C  * A -> 3Eta
      AA3E=-dsqrt(6d0*(YUE**2+YDE**2+64d0*YSE**2)/432d0)*SIGN(1d0,
     . CUP(IND)*(MKC**2+MPI**2-MK0**2)+CDP(IND)
     .    *(MK0**2+MPI**2-MKC**2)-8d0*CDP(IND)*(MKC**2+MK0**2-MPI**2))
      API3E=(MKC**2-MK0**2-MPIC**2+MPI**2)/(3d0*dsqrt(3d0)*FPI**2)
!     .        *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))**3
      AE3E=(2d0*MPI**2+16d0*(MKC**2+MK0**2-MPI**2))/(9d0*FPI**2)
      AEP3E=dsqrt(2d0)*(2d0*MPI**2-8d0*(MKC**2+MK0**2-MPI**2))
     .             /(9d0*FPI**2)

      aux=OMIX(INDA,1)*API3E+OMIX(INDA,2)*AE3E+OMIX(INDA,3)
     .          *AEP3E+OMIX(INDA,4)*AA3E
      GamA3E=aux**2/(6d0*2d0**8*Pi**3*MH)*KinA3E(MH)

C  * A -> 2EtaEta'
      AAE2EP=-dsqrt(2d0*(YUE**2+YDE**2+16d0*YSE**2)/72d0)*SIGN(1d0,
     . CUP(IND)*(MKC**2+MPI**2-MK0**2)+CDP(IND)
     .     *(MK0**2+MPI**2-MKC**2)+4d0*CDP(IND)*(MKC**2+MK0**2-MPI**2))
      APIE2EP=(MKC**2-MK0**2-MPIC**2+MPI**2)/(3d0*dsqrt(3d0)*FPI**2)
     .        *dsqrt(2d0)
!     .        *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))**2
!     .        *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))
      AEE2EP=dsqrt(2d0)*(2d0*MPI**2-8d0*(MKC**2+MK0**2-MPI**2))
     .             /(9d0*FPI**2)
      AEPE2EP=2d0*(2d0*MPI**2+4d0*(MKC**2+MK0**2-MPI**2))
     .             /(9d0*FPI**2)

      aux=OMIX(INDA,1)*APIE2EP+OMIX(INDA,2)*AEE2EP+OMIX(INDA,3)
     .          *AEPE2EP+OMIX(INDA,4)*AAE2EP
      GamAE2EP=aux**2/(2d0*2d0**8*Pi**3*MH)*KinAE2EP(MH)

C  * A -> Eta2Eta'
      AAEEP2=-dsqrt(2d0*(YUE**2+YDE**2+4d0*YSE**2)/36d0)*SIGN(1d0,
     . CUP(IND)*(MKC**2+MPI**2-MK0**2)+CDP(IND)
     .    *(MK0**2+MPI**2-MKC**2)-2d0*CDP(IND)*(MKC**2+MK0**2-MPI**2))
      APIEEP2=(MKC**2-MK0**2-MPIC**2+MPI**2)/(3d0*dsqrt(3d0)*FPI**2)
     .        *dsqrt(2d0)**2
!     .        *(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE))
!     .        *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))**2
      AEEEP2=2d0*(2d0*MPI**2+4d0*(MKC**2+MK0**2-MPI**2))
     .             /(9d0*FPI**2)
      AEPEEP2=2d0*dsqrt(2d0)*(2d0*MPI**2-2d0*(MKC**2+MK0**2-MPI**2))
     .             /(9d0*FPI**2)

      aux=OMIX(INDA,1)*APIEEP2+OMIX(INDA,2)*AEEEP2+OMIX(INDA,3)
     .          *AEPEEP2+OMIX(INDA,4)*AAEEP2
      GamAEEP2=aux**2/(2d0*2d0**8*Pi**3*MH)*KinAEEP2(MH)

C  * A -> 3Eta'
      AA3EP=-dsqrt(6d0*(YUE**2+YDE**2+YSE**2)/54d0)*SIGN(1d0,
     . CUP(IND)*(MKC**2+MPI**2-MK0**2)+CDP(IND)
     .    *(MK0**2+MPI**2-MKC**2)+CDP(IND)*(MKC**2+MK0**2-MPI**2))
      API3EP=(MKC**2-MK0**2-MPIC**2+MPI**2)/(3d0*dsqrt(3d0)*FPI**2)
     .        *dsqrt(2d0)**3
!     .        *(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE))**3
      AE3EP=2d0*dsqrt(2d0)*(2d0*MPI**2-2d0*(MKC**2+MK0**2-MPI**2))
     .             /(9d0*FPI**2)
      AEP3EP=4d0*(2d0*MPI**2+(MKC**2+MK0**2-MPI**2))/(9d0*FPI**2)

      aux=OMIX(INDA,1)*API3EP+OMIX(INDA,2)*AE3EP+OMIX(INDA,3)
     .          *AEP3EP+OMIX(INDA,4)*AA3EP
      GamA3EP=aux**2/(6d0*2d0**8*Pi**3*MH)*KinA3EP(MH)

C  * A -> Pi0K+K-
      IF(MH.lt.1.1d0)then
       AAPiKC=-DSQRT(dsqrt(2d0)*GF)/(6d0*FPI)
     .   *(MKC**2*(2d0*CUP(IND)+CDP(IND))
     .    +(MPI**2-MK0**2)*(2d0*CUP(IND)-CDP(IND)))
      ELSE
       IF(MH.lt.1.3d0)then
        AAPiKC=-DSQRT(dsqrt(2d0)*GF)/(6d0*FPI)
     .    *(MKC**2*(2d0*CUP(IND)+CDP(IND))+(MPI**2-MK0**2)
     .               *(2d0*CUP(IND)-CDP(IND)))*(1d0-(MH-1.1d0)/.2d0)
     . -dsqrt((4d0*YUE**2+YSE**2)/24d0)*SIGN(1d0,MKC**2*(2d0*CUP(IND)
     .    +CDP(IND))+(MPI**2-MK0**2)*(2d0*CUP(IND)-CDP(IND)))
     .               *(MH-1.1d0)/.2d0
       ELSE
        AAPiKC=-dsqrt((4d0*YUE**2+YSE**2)/24d0)*SIGN(1d0,
     .    MKC**2*(2d0*CUP(IND)+CDP(IND))+(MPI**2-MK0**2)
     .    *(2d0*CUP(IND)-CDP(IND)))
       ENDIF
      ENDIF
      APIPiKC=(2d0*MKC**2-MK0**2+MPI**2)/(6d0*FPI**2)
      AEPiKC=(-3d0*dsqrt(2d0)*DDSIN(THETAE)*MKC**2
     .        -(MK0**2-MPI**2)*(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE)))
     . /(6d0*dsqrt(3d0)*FPI**2)
      AEPPiKC=(3d0*dsqrt(2d0)*DDCOS(THETAE)*MKC**2
     .        -(MK0**2-MPI**2)*(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE)))
     . /(6d0*dsqrt(3d0)*FPI**2)

      aux=OMIX(INDA,1)*APIPiKC+OMIX(INDA,2)*AEPiKC+OMIX(INDA,3)
     .          *AEPPiKC+OMIX(INDA,4)*AAPiKC
      GamAPiKC=aux**2/(2d0**8*Pi**3*MH)*KinAPiKC(MH)

C  * A -> Pi0K0K0b
      IF(MH.lt.1.1d0)then
       AAPiK0=-DSQRT(dsqrt(2d0)*GF)/(6d0*FPI)*CDP(IND)
     .                              *(MKC**2-MPI**2-3d0*MK0**2)
      ELSE
       IF(MH.lt.1.3d0)then
        AAPiK0=-DSQRT(dsqrt(2d0)*GF)/(6d0*FPI)*CDP(IND)
     .                              *(MKC**2-MPI**2-3d0*MK0**2)
     .               *(1d0-(MH-1.1d0)/.2d0)
     . -dsqrt((4d0*YDE**2+YSE**2)/24d0)*SIGN(1d0,
     .    CDP(IND)*(MKC**2-MPI**2-3d0*MK0**2))
     .
     .               *(MH-1.1d0)/.2d0
       ELSE
        AAPiK0=-dsqrt((4d0*YDE**2+YSE**2)/24d0)
     .    *SIGN(1d0,CDP(IND)*(MKC**2-MPI**2-3d0*MK0**2))
       ENDIF
      ENDIF
      APIPiK0=(2d0*MK0**2-MKC**2+MPI**2)/(6d0*FPI**2)
      AEPiK0=(3d0*dsqrt(2d0)*DDSIN(THETAE)*MK0**2
     .        +(MKC**2-MPI**2)*(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE)))
     . /(6d0*dsqrt(3d0)*FPI**2)
      AEPPiK0=(-3d0*dsqrt(2d0)*DDCOS(THETAE)*MK0**2
     .        -(MKC**2-MPI**2)*(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE)))
     . /(6d0*dsqrt(3d0)*FPI**2)

      aux=OMIX(INDA,1)*APIPiK0+OMIX(INDA,2)*AEPiK0+OMIX(INDA,3)
     .          *AEPPiK0+OMIX(INDA,4)*AAPiK0
      GamAPiK0=aux**2/(2d0**8*Pi**3*MH)*KinAPiK0(MH)

C  * A -> PiK+K0b + PiK-K0
      IF(MH.lt.1.1d0)then
       AAPiKCK0=-DSQRT(2d0*dsqrt(2d0)*GF)/(6d0*FPI)
     .     *(CUP(IND)*(MKC**2+MPI**2-MK0**2)+2d0*CDP(IND)*MK0**2)
      ELSE
       IF(MH.lt.1.3d0)then
        AAPiKCK0=-DSQRT(2d0*dsqrt(2d0)*GF)/(6d0*FPI)
     .     *(CUP(IND)*(MKC**2+MPI**2-MK0**2)+2d0*CDP(IND)*MK0**2)
     .               *(1d0-(MH-1.1d0)/.2d0)
     . -dsqrt((YUE**2+YDE**2+YSE**2)/12d0)
     .  *SIGN(1d0,CUP(IND)*(MKC**2+MPI**2-MK0**2)+2d0*CDP(IND)*MK0**2)
     .    *(MH-1.1d0)/.2d0
       ELSE
        AAPiKCK0=-dsqrt((YUE**2+YDE**2+YSE**2)/12d0)
     .  *SIGN(1d0,CUP(IND)*(MKC**2+MPI**2-MK0**2)+2d0*CDP(IND)*MK0**2)
       ENDIF
      ENDIF
      APIPiKCK0=(MKC**2-MK0**2+MPI**2-MPIC**2)/(6d0*dsqrt(2d0)*FPI**2)
      AEPiKCK0=((2d0*MPI**2-MKC**2-MK0**2)*DDCOS(THETAE)
     .    -2d0*dsqrt(2d0)*(MPI**2+MKC**2+MK0**2)*DDSIN(THETAE))
     . /(6d0*dsqrt(6d0)*FPI**2)
      AEPPiKCK0=((2d0*MPI**2-MKC**2-MK0**2)*DDSIN(THETAE)
     .    +2d0*dsqrt(2d0)*(MPI**2+MKC**2+MK0**2)*DDCOS(THETAE))
     . /(6d0*dsqrt(6d0)*FPI**2)

      aux=OMIX(INDA,1)*APIPiKCK0+OMIX(INDA,2)*AEPiKCK0+OMIX(INDA,3)
     .          *AEPPiKCK0+OMIX(INDA,4)*AAPiKCK0
      GamAPiKCK0=2d0*aux**2/(2d0**8*Pi**3*MH)*KinAPiKCK0(MH)

C  * A -> EtaK+K-
      AAEKC=dsqrt((YSE**2)/8d0)
      APIEKC=-(MK0**2-MPI**2)/(6d0*dsqrt(3d0)*FPI**2)
c     (-3d0*dsqrt(2d0)*DDSIN(THETAE)*MKC**2
c     .        -(MK0**2-MPI**2)*(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE)))
c     . /(6d0*dsqrt(3d0)*FPI**2)
      AEEKC=(MKC**2+(MK0**2-MPI**2)/2d0)/3d0/FPI**2
c     ((MKC**2+(MK0**2-MPI**2)/2d0)*DDCOS(THETAE)**2
c     .  +dsqrt(2d0)*(MKC**2+MK0**2-MPI**2)*DDCOS(THETAE)*DDSIN(THETAE)
c     .  +MKC**2*DDSIN(THETAE)**2)/3d0/FPI**2
      AEPEKC=-dsqrt(2d0)*(MKC**2+MK0**2-MPI**2)/6d0/FPI**2
c    ((2d0*MKC**2+MK0**2-MPI**2)*DDCOS(THETAE)*DDSIN(THETAE)
c     .  -dsqrt(2d0)*(MKC**2+MK0**2-MPI**2)*DDCOS(2d0*THETAE)
c     .  -2d0*MKC**2*DDSIN(THETAE)*DDCOS(THETAE))/6d0/FPI**2

      aux=OMIX(INDA,1)*APIEKC+OMIX(INDA,2)*AEEKC+OMIX(INDA,3)
     .          *AEPEKC+OMIX(INDA,4)*AAEKC
      GamAEKC=aux**2/(2d0**8*Pi**3*MH)*KinAEKC(MH)

C  * A -> EtaK0K0b
      AAEK0=dsqrt((YSE**2)/8d0)
     .     *SIGN(1d0,CDP(IND)*(MKC**2+MK0**2-MPI**2))
      APIEK0=(MKC**2-MPI**2)/(6d0*dsqrt(3d0)*FPI**2)
c     (3d0*dsqrt(2d0)*DDSIN(THETAE)*MK0**2
c     .        +(MKC**2-MPI**2)*(DDCOS(THETAE)-dsqrt(2d0)*DDSIN(THETAE)))
c     . /(6d0*dsqrt(3d0)*FPI**2)
      AEEK0=(MK0**2+(MKC**2-MPI**2)/2d0)/3d0/FPI**2
c     ((MK0**2+(MKC**2-MPI**2)/2d0)*DDCOS(THETAE)**2
c     .  +dsqrt(2d0)*(MK0**2+MKC**2-MPI**2)*DDCOS(THETAE)*DDSIN(THETAE)
c     .  +MK0**2*DDSIN(THETAE)**2)/3d0/FPI**2
      AEPEK0=-dsqrt(2d0)*(MK0**2+MKC**2-MPI**2)/6d0/FPI**2
c     ((2d0*MK0**2+MKC**2-MPI**2)*DDCOS(THETAE)*DDSIN(THETAE)
c     .  -dsqrt(2d0)*(MK0**2+MKC**2-MPI**2)*DDCOS(2d0*THETAE)
c     .  -2d0*MK0**2*DDSIN(THETAE)*DDCOS(THETAE))/6d0/FPI**2

      aux=OMIX(INDA,1)*APIEK0+OMIX(INDA,2)*AEEK0+OMIX(INDA,3)
     .          *AEPEK0+OMIX(INDA,4)*AAEK0
      GamAEK0=aux**2/(2d0**8*Pi**3*MH)*KinAEK0(MH)

C  * A -> Eta'K+K-
      AAEPKC=-dsqrt((YUE**2+YSE**2)/4d0)*SIGN(1d0,CUP(IND)*(MPI**2+
     . MKC**2-MK0**2)+CDP(IND)*(MK0**2+MPI**2-MKC**2))
      APIEPKC=dsqrt(2d0/3d0)*(3d0*MKC**2-(MK0**2-MPI**2))/(6d0*FPI**2)
c     (3d0*dsqrt(2d0)*DDCOS(THETAE)*MKC**2
c     .        -(MK0**2-MPI**2)*(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE)))
c     . /(6d0*dsqrt(3d0)*FPI**2)
      AEEPKC=-dsqrt(2d0)*(MKC**2+MK0**2-MPI**2)/6d0/FPI**2
c     ((2d0*MKC**2+MK0**2-MPI**2)*DDCOS(THETAE)*DDSIN(THETAE)
c     .  -dsqrt(2d0)*(MKC**2+MK0**2-MPI**2)*DDCOS(2d0*THETAE)
c     .  -2d0*MKC**2*DDSIN(THETAE)*DDCOS(THETAE))/6d0/FPI**2
      AEPEPKC=MKC**2/3d0/FPI**2
c     ((MKC**2+(MK0**2-MPI**2)/2d0)*DDSIN(THETAE)**2
c     .  -dsqrt(2d0)*(MKC**2+MK0**2-MPI**2)*DDCOS(THETAE)*DDSIN(THETAE)
c     .  +MKC**2*DDCOS(THETAE)**2)/3d0/FPI**2

      aux=OMIX(INDA,1)*APIEPKC+OMIX(INDA,2)*AEEPKC+OMIX(INDA,3)
     .          *AEPEPKC+OMIX(INDA,4)*AAEPKC
      GamAEPKC=aux**2/(2d0**8*Pi**3*MH)*KinAEPKC(MH)

C  * A -> Eta'K0K0b
      AAEPK0=dsqrt((YDE**2+YSE**2)/4d0)
      APIEPK0=dsqrt(2d0/3d0)*(-3d0*MK0**2-MKC**2+MPI**2)/(6d0*FPI**2)
c     (-3d0*dsqrt(2d0)*DDCOS(THETAE)*MK0**2
c     .        -(MKC**2-MPI**2)*(DDSIN(THETAE)+dsqrt(2d0)*DDCOS(THETAE)))
c     . /(6d0*dsqrt(3d0)*FPI**2)
      AEEPK0=-dsqrt(2d0)*(MK0**2+MKC**2-MPI**2)/6d0/FPI**2
c     ((2d0*MK0**2+MKC**2-MPI**2)*DDCOS(THETAE)*DDSIN(THETAE)
c     .  -dsqrt(2d0)*(MK0**2+MKC**2-MPI**2)*DDCOS(2d0*THETAE)
c     .  -2d0*MK0**2*DDSIN(THETAE)*DDCOS(THETAE))/6d0/FPI**2
      AEPEPK0=MK0**2/3d0/FPI**2
c     ((MK0**2+(MKC**2-MPI**2)/2d0)*DDSIN(THETAE)**2
c     .  -dsqrt(2d0)*(MK0**2+MKC**2-MPI**2)*DDCOS(THETAE)*DDSIN(THETAE)
c     .  +MK0**2*DDCOS(THETAE)**2)/3d0/FPI**2

      aux=OMIX(INDA,1)*APIEPK0+OMIX(INDA,2)*AEEPK0+OMIX(INDA,3)
     .          *AEPEPK0+OMIX(INDA,4)*AAEPK0
      GamAEPK0=aux**2/(2d0**8*Pi**3*MH)*KinAEPK0(MH)

C	Radiative hadronic decays

C  * A -> gamma (Rho,omega->)Pi+Pi-
      AARhogam=0d0
      APIRhogam=1d0
      AERhogam=1.22374d0
      AEPRhogam=1.39445d0

      aux=OMIX(INDA,1)*APIRhogam+OMIX(INDA,2)*AERhogam+OMIX(INDA,3)
     .          *AEPRhogam+OMIX(INDA,4)*AARhogam
      GamARhogam=aux**2/(2d0**8*Pi**3*MH)*KinARhogam(MH)

C	Total hadronic decays

      GamHhadr=GamH2Pi+GamH2PiC+GamHPiE+GamHPiEP+GamH2KC+GamH2K0
     .         +GamH2E+GamH2EP+GamHEEP

      GamAhadr=GamA3Pi+GamAPi3PiC+GamAEPi3+GamAEPiC+GamAEPPi3+GamAEPPiC
     .   +GamAPiEE+GamAPiEEP+GamAPiEPEP+GamA3E+GamAE2EP+GamAEEP2
     .   +GamA3EP+GamAPiKC+GamAPiK0+GamAPiKCK0+GamAEKC+GamAEK0
     .   +GamAEPKC+GamAEPK0+GamARhogam

C	Diphoton decays - CP-even mode

      GamHGAGA=CDABS(ALEM0*CGH/Sqrt(2d0)/Pi
     .         +DSQRT(dsqrt(2d0)*GF)/2d0*PropI(MH,MS2,GamS2)
     . *((MPI**2+MKC**2-MK0**2)*CU(IND)+(MPI**2+MK0**2-MKC**2)*CD(IND))
     .   *dsqrt(16d0*Pi*6.7d-7/MS2**3)/2.5d0
     .         +DSQRT(dsqrt(2d0)*GF)/2d0*PropI(MH,MS3,GamS3)
     . *(MKC**2+MK0**2-MPI**2)*CD(IND)*dsqrt(16d0*Pi*4d-7/MS3**3)/2.7d0
     . +2d0*ASH2/PI/3d0*CJH*
     .  (MSIG**2*PropI(MH,MSIG,GamSIG)*dsqrt(16d0*Pi*2d-7/MSIG**3)/5d0
     .   +MG0**2*PropI(MH,MG0,GamG0)*dsqrt(16d0*Pi*1d-6/MG0**3)/2d0)
     .          )**2*MH**3/(32d0*Pi)

      ENDIF

      aux=8d0*CDABS(CGH)**2*MH**3
     .          /(32d0*Pi)*(ALEM0/4d0/Pi)**2
      IF(MH.ge.3d0)then
       IF(MH.lt.4d0)THEN
        GamHGAGA=GamHGAGA*(1d0-((MH-3d0)/1d0)**2)+((MH-3d0)/1d0)**2*aux
       ELSE
        GamHGAGA=aux
       ENDIF
      ENDIF

C	Light-quark and gluon decays

      AHuu=2d-3*CU(IND)*DSQRT(dsqrt(2d0)*GF)
      AHdd=4d-3*CD(IND)*DSQRT(dsqrt(2d0)*GF)
      AHss=MS*CD(IND)*DSQRT(dsqrt(2d0)*GF)

      AAuu=2d-3*CUP(IND)*DSQRT(dsqrt(2d0)*GF)
      AAdd=4d-3*CDP(IND)*DSQRT(dsqrt(2d0)*GF)
      AAss=MS*CDP(IND)*DSQRT(dsqrt(2d0)*GF)

      IF(MH.LT.2d0)THEN
       GamHuu=0d0
       GamHdd=0d0
       GamHss=0d0
       GamHjj=0d0
       GamAuu=0d0
       GamAdd=0d0
       GamAss=0d0
       GamAjj=0d0
      ELSE

       RATCOUP=1d0
       GamHuu=3d0*dabs(AHuu)**2/(8d0*Pi)*MH
     .        *(4d0*(2d-3/MH)**2*TQCDH((2d-3/MH)**2)
     .   +(1d0-4d0*(2d-3/MH)**2)*max(0d0,QCDH((2d-3/MH)**2)))
     .               *dsqrt(max(0d0,1d0-4d0*(2d-3/MH)**2))**3

       GamAuu=3d0*dabs(AAuu)**2/(8d0*Pi)*MH
     .        *(4d0*(2d-3/MH)**2*TQCDA((2d-3/MH)**2)
     .   +(1d0-4d0*(2d-3/MH)**2)*max(0d0,QCDA((2d-3/MH)**2)))
     .               *dsqrt(max(0d0,1d0-4d0*(2d-3/MH)**2))

       RATCOUP=0d0
       IF(CD(IND).NE.0d0)RATCOUP=CU(IND)/CD(IND)
       GamHdd=3d0*dabs(AHdd)**2/(8d0*Pi)*MH
     .         *(4d0*(4d-3/MH)**2*TQCDH((4d-3/MH)**2)
     .   +(1d0-4d0*(4d-3/MH)**2)*max(0d0,QCDH((4d-3/MH)**2)))
     .               *dsqrt(max(0d0,1d0-4d0*(4d-3/MH)**2))**3
       GamHss=3d0*dabs(AHss)**2/(8d0*Pi)*MH
     .         *(4d0*(MS/MH)**2*TQCDH((MS/MH)**2)
     .   +(1d0-4d0*(MS/MH)**2)*max(0d0,(RMS/MS)**2*QCDH((RMS/MH)**2)))
     .               *dsqrt(max(0d0,1d0-4d0*(MS/MH)**2))**3
       GamHjj=CDABS(CJH)**2/(8d0*PI**3)*MH**3
     .     *AS3**2*(1d0+AS3/Pi*(95d0/4d0-3d0*7d0/6d0))

       RATCOUP=0d0
       IF(CDP(IND).NE.0d0)RATCOUP=CUP(IND)/CDP(IND)
       GamAdd=3d0*dabs(AAdd)**2/(8d0*Pi)*MH
     .         *(4d0*(4d-3/MH)**2*TQCDA((4d-3/MH)**2)
     .   +(1d0-4d0*(4d-3/MH)**2)*max(0d0,QCDA((4d-3/MH)**2)))
     .               *dsqrt(max(0d0,1d0-4d0*(4d-3/MH)**2))
       GamAss=3d0*dabs(AAss)**2/(8d0*Pi)*MH
     .         *(4d0*(MS/MH)**2*TQCDA((MS/MH)**2)
     .   +(1d0-4d0*(MS/MH)**2)*max(0d0,(RMS/MS)**2*QCDA((RMS/MH)**2)))
     .               *dsqrt(max(0d0,1d0-4d0*(MS/MH)**2))
       GamAjj=CDABS(CJA)**2/(8d0*PI**3)*MH**3
     .     *AS3**2*(1d0+AS3/Pi*(97d0/4d0-3d0*7d0/6d0))
      ENDIF

      aux=GamHhadr
      IF(MH.lt.3d0)then
       GamHhadr=aux
      ELSE
       IF(MH.lt.4d0)THEN
        GamHhadr=aux*(1d0-((MH-3d0)/1d0))
     .          +((MH-3d0)/1d0)*(0d0*GamHuu+0d0*GamHdd+GamHss+GamHjj)
       ELSE
        GamHhadr=0d0*GamHuu+0d0*GamHdd+GamHss+GamHjj
       ENDIF
      ENDIF

      aux=GamAhadr
      IF(MH.lt.3d0)then
       GamAhadr=aux
      ELSE
       IF(MH.lt.4d0)THEN
        GamAhadr=aux*(4d0-MH)+(MH-3d0)*(0d0*GamAuu+0d0*GamAdd
     .                                         +GamAss+GamAjj)
       ELSE
        GamAhadr=0d0*GamAuu+0d0*GamAdd+GamAss+GamAjj
       ENDIF
      ENDIF

C	Mixing with the Eta_c(1S)

      METAC=2.9834d0
! eta_c(1S) wave-function from J/Psi(1S)->e+e-
      DMC=dsqrt(3d0/4d0*METAC**3*0.05971d0*92.9d-6*2d0*dsqrt(2d0)*GF)
     .    *3.0969d0*CUP(IND)/(4d0*Pi*ALEM0*2d0/3d0)

c      IF(MH.gt.2d0.and.MH.lt.2d0*MTAU)THEN
       CMIX=0d0
       aux=Max(0d0,min(1d0,MH-1d0))
       IF(DMC.ne.0d0)THEN
        CMIX=datan(2d0*DMC
     .        /(MH**2-METAC**2+dsqrt((MH**2-METAC**2)**2+4d0*DMC**2)))
       ENDIF
       IF(DDCOS(CMIX)**2.gt.DDSIN(CMIX)**2)then
        GamAhadr=GamAhadr*DDCOS(CMIX)**2+31.8d-3*aux*DDSIN(CMIX)**2
        GamAee=GamAee*DDCOS(CMIX)**2
        GamAmumu=GamAmumu*DDCOS(CMIX)**2
        GamAgaga=GamAgaga*DDCOS(CMIX)**2+31.8d-3*1.59d-4*aux
     .                                                 *DDSIN(CMIX)**2
       ELSE
        GamAhadr=GamAhadr*DDSIN(CMIX)**2+31.8d-3*aux*DDCOS(CMIX)**2
        GamAee=GamAee*DDSIN(CMIX)**2
        GamAmumu=GamAmumu*DDSIN(CMIX)**2
        GamAgaga=GamAgaga*DDSIN(CMIX)**2+31.8d-3*1.59d-4*aux
     .                                                 *DDCOS(CMIX)**2
       ENDIF
c      ENDIF
! We neglect the mixing with the eta_c(2,3S) because they matter after the opening of the tautau channel

C	H -> cc decays

      MD=1.865d0

      IF(MH.LE.2d0*MD)THEN
       GamHcc= 0d0
      ELSE
       RMC=RUNM(MH,4)
       RATCOUP= 1d0

       DCC=CDABS(CJH)**2/(8d0*PI**3)*MH**3
     .     *(AS4**2*(1d0+AS4/Pi*(95d0/4d0-4d0*7d0/6d0))
     .      -AS3**2*(1d0+AS3/Pi*(95d0/4d0-3d0*7d0/6d0)))

       GamHcc=4d0*(MCC/MH)**2*
     .        3d0*GF*(MCC*CU(IND))**2*MH/(4d0*dsqrt(2d0)*Pi)
     .        *TQCDH((MCC/MH)**2)*dsqrt(1d0-4d0*MCC**2/MH**2)**3
     .         +(1d0-4d0*(MCC/MH)**2)*max(0d0,
     .         3d0*GF*(RMC*CU(IND))**2*MH/(4d0*dsqrt(2d0)*Pi)
     .         *QCDH((RMC/MH)**2)*dsqrt(1d0-4d0*RMC**2/MH**2)**3+DCC)

      IF(MH.lt.50d0)then
       GamHcc=GamHcc*((1d0-(MH-2d0*MD)/(50d0-2d0*MD))*
     . (dsqrt(1d0-4d0*MD**2/MH**2)/dsqrt(1d0-4d0*MCC**2/MH**2))**3
     . +(MH-2d0*MD)/(50d0-2d0*MD))
      ENDIF
      ENDIF

      IF(MH.LE.2d0*MD+MPI)THEN
       GamAcc= 0d0
      ELSE
       RMC=RUNM(MH,4)
       RATCOUP= 1d0

       DCC=CDABS(CJA)**2/(8d0*PI**3)*MH**3
     .     *(AS4**2*(1d0+AS4/Pi*(97d0/4d0-4d0*7d0/6d0))
     .      -AS3**2*(1d0+AS3/Pi*(97d0/4d0-3d0*7d0/6d0)))

       GamAcc=4d0*(MCC/MH)**2*
     .        3d0*GF*(MCC*CUP(IND))**2*MH/(4d0*dsqrt(2d0)*Pi)
     .        *TQCDA((MCC/MH)**2)*dsqrt(1d0-4d0*MCC**2/MH**2)
     .         +(1d0-4d0*(MCC/MH)**2)*max(0d0,
     .         3d0*GF*(RMC*CUP(IND))**2*MH/(4d0*dsqrt(2d0)*Pi)
     .        *QCDA((RMC/MH)**2)*dsqrt(1d0-4d0*RMC**2/MH**2)+DCC)
! Modifying the shape of the phase space function, so that it looks "3-body" at low mass
       IF(MH.lt.50d0)THEN
        GamAcc=GamAcc*dsqrt(1d0-(2d0*MD+MPI)**2/MH**2)
     .                /dsqrt(1d0-4d0*MCC**2/MH**2)
     . *(KinAPiDD(MH)*((50d0-MH)/(50d0-(2d0*MD+MPI)))**2
     .                 +1d0-((50d0-MH)/(50d0-(2d0*MD+MPI)))**2)
       ENDIF
      ENDIF

C	Mixing with the Eta_b(1,2,3S) [1105.1722[hep-ph]]

      METAB1=9.399d0
      METAB2=9.999d0
      METAB3=10.343d0

      DMB1=0.14d0*CBP(IND)
      DMB2=0.11d0*CBP(IND)
      DMB3=0.10d0*CBP(IND)

c      IF(MA.gt.4d0.and.MA.lt.2d0*5.2795d0+MPI)THEN

       MMIX(1,1)=METAB1**2
       MMIX(1,2)=0d0
       MMIX(1,3)=0d0
       MMIX(1,4)=DMB1
       MMIX(2,1)=0d0
       MMIX(2,2)=METAB2**2
       MMIX(2,3)=0d0
       MMIX(2,4)=DMB2
       MMIX(3,1)=0d0
       MMIX(3,2)=0d0
       MMIX(3,3)=METAB3**2
       MMIX(3,4)=DMB3
       MMIX(4,1)=DMB1
       MMIX(4,2)=DMB2
       MMIX(4,3)=DMB3
       MMIX(4,4)=MH**2

       CALL DIAGN(4,MMIX,VALP,VECP,EPS)
       CALL SORTN(4,VALP,VECP)
       DO K=1,4
        DO L=1,4
         OMIX(K,L)=VECP(L,K)
        ENDDO
       ENDDO

       INDA=1
       DO K=1,4
        IF(dabs(OMIX(INDA,4))**2.lt.dabs(OMIX(K,4))**2)INDA=K
       ENDDO

       aux=Max(0d0,min(1d0,MH/2d0-1.5d0))
       GamAhadr=GamAhadr*OMIX(INDA,4)**2+aux*(11.8d-3*OMIX(INDA,1)**2
     .                 +5.4d-3*OMIX(INDA,2)**2+3.9d-3*OMIX(INDA,3)**2)
       GamAee=GamAee*OMIX(INDA,4)**2
       GamAmumu=GamAmumu*OMIX(INDA,4)**2
       GamAgaga=GamAgaga*OMIX(INDA,4)**2
       GamAcc=GamAcc*OMIX(INDA,4)**2
! GamAhadr also contains contributions to the cc final state
c      ENDIF

C	H -> bb decays

      MBm=5.2795d0

      IF(MH.LE.2d0*MBm)THEN
       GamHbb= 0d0
      ELSE
       RMB=RUNMB(MH)
       IF(CB(IND).ne.0d0)THEN
	RATCOUP= CU(IND)/CB(IND)
       ELSE
	RATCOUP=0d0
       ENDIF

       DBB=CDABS(CJH)**2/(8d0*PI**3)*MH**3
     .     *(ASH**2*(1d0+ASH/Pi*(95d0/4d0-5d0*7d0/6d0))
     .      -AS4**2*(1d0+AS4/Pi*(95d0/4d0-4d0*7d0/6d0)))

       GamHbb=4d0*(MBP/MH)**2*
     .        3d0*GF*(MBP*CB(IND))**2*MH/(4d0*dsqrt(2d0)*Pi)
     .        *TQCDH((MBP/MH)**2)*dsqrt(1d0-4d0*MBP**2/MH**2)**3
     .         +(1d0-4d0*(MBP/MH)**2)*max(0d0,
     .         3d0*GF*(RMB*CB(IND))**2*MH/(4d0*dsqrt(2d0)*Pi)
     .         *QCDH((RMB/MH)**2)*dsqrt(1d0-4d0*RMB**2/MH**2)**3+DBB)
	aux=GamHbb
       IF(MH.lt.50d0)THEN
        GamHbb=GamHbb*((1d0-(MH-2d0*MBm)/(50d0-2d0*MBm))*
     . (dsqrt(1d0-4d0*MBm**2/MH**2)/dsqrt(1d0-4d0*MBP**2/MH**2))**3
     . +(MH-2d0*MBm)/(50d0-2d0*MBm))
       ENDIF
      ENDIF

      IF(MH.LE.2d0*MBm+MPI)THEN
       GamAbb= 0d0
      ELSE
       RMB=RUNMB(MH)
       IF(CBP(IND).ne.0d0)THEN
        RATCOUP= CUP(IND)/CBP(IND)
       ELSE
	RATCOUP=0d0
       ENDIF

       DBB=CDABS(CJA)**2/(8d0*PI**3)*MH**3
     .     *(ASH**2*(1d0+ASH/Pi*(97d0/4d0-5d0*7d0/6d0))
     .      -AS4**2*(1d0+AS4/Pi*(97d0/4d0-4d0*7d0/6d0)))

       GamAbb=4d0*(MBP/MH)**2*
     .        3d0*GF*(MBP*CBP(IND))**2*MH/(4d0*dsqrt(2d0)*Pi)
     .        *TQCDA((MBP/MH)**2)*dsqrt(1d0-4d0*MBP**2/MH**2)
     .         +(1d0-4d0*(MBP/MH)**2)*max(0d0,
     .         3d0*GF*(RMB*CBP(IND))**2*MH/(4d0*dsqrt(2d0)*Pi)
     .         *QCDA((RMB/MH)**2)*dsqrt(1d0-4d0*RMB**2/MH**2)+DBB)
! Modifying the shape of the phase space function, so that it looks "3-body" at low mass
       IF(MH.lt.50d0)THEN
        GamAbb=GamAbb*dsqrt(1d0-(2d0*MBm+MPI)**2/MH**2)
     .                /dsqrt(1d0-4d0*MBP**2/MH**2)
     . *(KinAPiBB(MH)*((50d0-MH)/(50d0-(2d0*MBm+MPI)))**2
     .                 +1d0-((50d0-MH)/(50d0-(2d0*MBm+MPI)))**2)
       ENDIF
      ENDIF

       GamHGAGA=GamHGAGA+GamAGAGA
       GamHee=GamHee+GamAee
       GamHmumu=GamHmumu+GamAmumu
       GamHtata=GamHtata+GamAtata
       GamHhadr=GamHhadr+GamAhadr
       GamHcc=GamHcc+GamAcc
       GamHbb=GamHbb+GamAbb

      RETURN
      END


c     Response function factor = 0.64054
      subroutine avhrr22(z0, p0, t0, u0, ux, nlev,
     *co2, n2o, f11, f12, ch4,
     *od, wght, ntau)
      INCLUDE "avhrr.inc"
      real co2, n2o, ch4, f11, f12
      real z0(mm)
      real od(5,mm)
      real wght(5)
      integer ntau,nlev
      real wi(8),xi(8),p0(mq),p(mm),t0(mq),t(mm),bnu(mm),u0(mq),u(mm),
     *ux(mq),tau(6,mm),delw,x(mm,8),y(mm,8),
     *sx(6,mm),sy(6,mm),f(6),fac(mm),tsx(mq),tsy(mq)
      data xi /.01986,.10167,.23723,.40828,
     *         .59172,.76277,.89833,.98014/
      data wi /.05062,.11119,.15685,.18134,
     *         .18134,.15685,.11119,.05062/
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
      omega=10600.0
      delw=800.0
      sigma=5.67e-05
      sconst=1.368e+06
      tsun=5710.0
      fsun=sigma*tsun**4
      mlv=nlyr
      do 5 m=1,nlyr
        t(m)=(t0(m)+t0(m+1))/2.0
        p(m)=(p0(m)+p0(m+1))/2.0
        call flux_22(bnu(m),omega,t(m))
        fac(m)=z0(m+1)-z0(m)
        u(m)=fac(m)*(u0(m)+u0(m+1))/2.0
 5    continue
      do 7 m=1,nlev
        tsx(m)=0.0
        tsy(m)=0.0
 7    continue
      call flux_22(back,omega,t0(1))
      call flux_22(bsun,omega,tsun)
      bsun=bsun/fsun*sconst
      call ck_22(ni,mlv,u,delw,f,p,t,tau)
      do 90 i=1,ni
        do 30 m=nlyr,1,-1
          do 20 j=1,8
           if(m.eq.nlyr)then
c           y(m,j)=bnu(m)*(1.0-exp(-tau(i,m)/xi(j)))
            y(m,j)=bsun*0.6*exp(-tau(i,m)/xi(j))+
     *             bnu(m)*(1.0-exp(-tau(i,m)/xi(j)))
           else
            y(m,j)=y(m+1,j)*exp(-tau(i,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tau(i,m)/xi(j)))
           end if
 20       continue
 30     continue
        do 50 m=1,nlyr
          sx(i,m)=0.0
          sy(i,m)=0.0
          do 40 j=1,8
           if(m.eq.1)then
            x(m,j)=(0.10*y(m,j)+0.90*back)*exp(-tau(i,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tau(i,m)/xi(j)))
           else
            x(m,j)=x(m-1,j)*exp(-tau(i,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tau(i,m)/xi(j)))
           end if
 40       continue
 50     continue
        do 70 m=1,nlyr
          do 60 j=1,8
            sx(i,m)=sx(i,m)+2.0*x(m,j)*wi(j)*xi(j)
            sy(i,m)=sy(i,m)+2.0*y(m,j)*wi(j)*xi(j)
 60       continue
 70     continue
        do 80 m=1,nlyr
           tsx(m+1)=tsx(m+1)+sx(i,m)*delw*f(i)
           tsy(m)=tsy(m)+sy(i,m)*delw*f(i)
 80     continue
c        tb=tb+(0.10*tsy(1))+0.90*back*delw*f(i)
        tb=tb+back*delw*f(i)
c        tsx(1)=tsx(1)+0.10*tsy(1)
c        tsy(nlev)=tsy(nlev)+bsun*0.60*delw*f(i)
 90   continue
      tb=0.10*tsy(1)+0.90*tb
      tsx(1)=tb
      tsy(nlev)=tsy(nlev)+bsun*0.60*delw
      do 95 m=1,nlev
cbm         write(6,100)m-1,tsx(m),tb-tsx(m),tsy(m)
 95   continue
      do i1=1,5
       do m=1,nlyr
        od(1+(i1-1),m) =
     *tau(i1,m)
        wght(1+(i1-1)) =
     *f(i1)
       enddo
      enddo
      ntau=5
 100  format(i3,3f15.7)
      end
c *********************************************************************
      subroutine flux_22(bnu,omega,t)
      INCLUDE "avhrr.inc"
      bnu=0.0
      z=3.14159
      bnu=z/1000.0*((2.*6.625e-27)*(2.997925e+10)**2
     *    *omega**3)/(exp(min(88.0,1.4388*omega/t))-1.0)
      return
      end
c *********************************************************************
      subroutine ck_22(ni,mlv,u,delw,f,p,t,tau)
      INCLUDE "avhrr.inc"
      real f(6),k(mm),tau(6,mm),delw,p(mm),t(mm),u(mm),coefk(6,3,19),
     *     stp(19),fkg(6,mm),pmb(mm)
      ni=5
      f(1)=0.082056
      f(2)=0.540035
      f(3)=0.298713
      f(4)=0.072936
      f(5)=0.006260
      k(1)=0.003088904
      do i=2,ni
        k(i)=12.0*k(i-1)
      end do
      data ( (coefk(1,jt,jp), jp = 1, 19), jt = 1, 3)/
     *0.0000,0.0000,0.0000,0.0000,0.0000,0.0000,0.0000,0.0000,0.0000,
     *0.0000,0.00089,0.00762,0.0323,0.0974,0.2229,0.4383,0.7740,1.2958,
     *2.0899,
     *0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
     *0.000e+00,0.000e+00,0.000e+00,0.000e+00,-4.750e-06,-4.500e-06,
     *1.475e-05,6.225e-05,1.215e-04,2.625e-04,5.704e-04,9.451e-04,
     *1.794e-03,
     *0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,
     *0.000e+00,0.000e+00,0.000e+00,0.000e+00,-4.375e-08,-1.063e-07,
     *-4.250e-07,-1.031e-06,-1.731e-06,-3.775e-06,-4.028e-06,-8.328e-06,
     *-1.568e-05/
      data ( (coefk(2,jt,jp), jp = 1, 19), jt = 1, 3)/
     *0.0048,0.0048,0.0048,0.0048,0.0048,0.0048,0.0048,0.0048,0.0048,
     *0.0144,0.0330,0.0652,0.1187,0.2040,0.3324,0.5251,0.8187,1.2202,
     *1.7427,
     *1.425e-05,1.425e-05,1.425e-05,1.425e-05,1.425e-05,1.425e-05,
     *1.425e-05,1.425e-05,1.425e-05,3.850e-05,7.850e-05,1.431e-04,
     *2.311e-04,3.545e-04,5.670e-04,8.243e-04,1.211e-03,1.816e-03,
     *2.560e-03,
     *-6.875e-08,-6.875e-08,-6.875e-08,-6.875e-08,-6.875e-08,-6.875e-08,
     *-6.875e-08,-6.875e-08,-6.875e-08,-1.937e-07,-3.375e-07,-6.344e-07,
     *-1.028e-06,-1.494e-06,-2.100e-06,-3.050e-06,-4.481e-06,-6.525e-06,
     *-5.297e-06/
      data ( (coefk(3,jt,jp), jp = 1, 19), jt = 1, 3)/
     *0.0853,0.0853,0.0853,0.0853,0.0853,0.0853,0.0853,0.0853,0.0853,
     *0.1094,0.1427,0.1906,0.2579,0.3513,0.4792,0.6491,0.8781,1.1362,
     *1.4139,
     *5.881e-04,5.881e-04,5.881e-04,5.881e-04,5.881e-04,5.881e-04,
     *5.881e-04,5.881e-04,5.881e-04,6.406e-04,6.406e-04,6.811e-04,
     *7.330e-04,7.964e-04,8.890e-04,9.834e-04,1.115e-03,1.235e-03,
     *1.395e-03,
     *1.084e-06,1.084e-06,1.084e-06,1.084e-06,1.084e-06,1.084e-06,
     *1.084e-06,1.084e-06,1.084e-06,7.906e-07,7.031e-07,3.719e-07,
     *4.375e-08,-1.844e-07,-3.500e-07,-8.281e-07,-1.813e-06,-2.475e-06,
     *-3.419e-06/
      data ( (coefk(4,jt,jp), jp = 1, 19), jt = 1, 3)/
     *0.5405,0.5405,0.5405,0.5405,0.5405,0.5405,0.5405,0.5405,0.5405,
     *0.5545,0.5764,0.6096,0.6567,0.7180,0.7933,0.8747,0.9673,1.0333,
     *1.0743,
     *2.195e-03,2.195e-03,2.195e-03,2.195e-03,2.195e-03,2.195e-03,
     *2.195e-03,2.195e-03,2.195e-03,2.093e-03,1.947e-03,1.751e-03,
     *1.512e-03,1.249e-03,1.008e-03,7.746e-04,5.860e-04,3.907e-04,
     *1.921e-04,
     *-1.600e-06,-1.600e-06,-1.600e-06,-1.600e-06,-1.600e-06,-1.600e-06,
     *-1.600e-06,-1.600e-06,-1.600e-06,-1.481e-06,-7.656e-07,-1.875e-07,
     *1.688e-07,8.250e-07,2.469e-07,5.312e-08,6.227e-05,-1.125e-07,
     *1.066e-06/
      data ( (coefk(5,jt,jp), jp = 1, 19), jt = 1, 3)/
     *1.7739,1.7739,1.7739,1.7739,1.7739,1.7739,1.7739,1.7739,1.7739,
     *1.7518,1.7172,1.6684,1.5989,1.5045,1.3830,1.2377,1.0877,0.9158,
     *0.7495,
     *-1.725e-03,-1.725e-03,-1.725e-03,-1.725e-03,-1.725e-03,-1.725e-03,
     *-1.725e-03,-1.725e-03,-1.725e-03,-1.637e-03,-1.530e-03,-1.364e-03,
     *-1.147e-03,-9.054e-04,-6.973e-04,-5.326e-04,-3.981e-04,-2.995e-04,
     *-2.284e-04,
     *2.200e-06,2.200e-06,2.200e-06,2.200e-06,2.200e-06,2.200e-06,
     *2.200e-06,2.200e-06,2.200e-06,1.269e-06,2.163e-06,1.566e-06,
     *1.259e-06,5.156e-07,1.206e-06,1.072e-06,1.047e-06,1.519e-06,
     *2.084e-06/
	data stp / 0.251, 0.398, 0.631, 1.000, 1.58, 2.51,
     *	             3.98, 6.31, 10.0, 15.8, 25.1, 39.8, 63.1,
     *	             100.0, 158.0, 251.0, 398.0, 631.0, 1000.0/
      do i=1,ni
      do m=1,mlv
        ml=1
        pmb(m)=p(m)*1013.25
        if(pmb(m).lt.stp(1))then
         x1=coefk(i,1,1)+coefk(i,2,1)*(t(m)-250.0)
     *   +coefk(i,3,1)*(t(m)-250.0)**2
         fkg(i,m)=x1*pmb(m)/stp(1)
        else if (pmb(m).gt.stp(19)) then
         x1=coefk(i,1,18)+coefk(i,2,18)*(t(m)-250.0)
     *   +coefk(i,3,18)*(t(m)-250.0)**2
         x2=coefk(i,1,19)+coefk(i,2,19)*(t(m)-250.0)
     *   +coefk(i,3,19)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(19)-stp(18))
     *  *(pmb(m)-stp(18))
        else
         do while(pmb(m).ge.stp(ml))
           ml=ml+1
         end do
         x1=coefk(i,1,ml-1)+coefk(i,2,ml-1)*(t(m)-250.0)
     *   + coefk(i,3,ml-1)*(t(m)-250.0)**2
         x2=coefk(i,1,ml)+coefk(i,2,ml)*(t(m)-250.0)
     *   + coefk(i,3,ml)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(ml)-stp(ml-1))
     *   *(pmb(m)-stp(ml-1))
        end if
      end do
      end do
      do i=1,ni
        do m=1,mlv
          tau(i,m)=k(i)*u(m)*fkg(i,m)
c         write(6,*)m,i,u(m),k(i),fkg(i,m),tau(i,m)
        end do
      end do
      return
      end