MODULE module_mosaic_addemiss
   integer, parameter :: mosaic_addemiss_active = 1
   integer, parameter :: mosaic_addemiss_masscheck = -1
CONTAINS
   subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, &
               config_flags, chem, slai, ust, smois, ivgtyp, isltyp, &
               emis_ant,ebu,biom_active,dust_opt, &
               ktau,p8w, u_phy,v_phy,rho_phy,g,dx,erod, &
               dust_emiss_active, seasalt_emiss_active, &
               ids,ide, jds,jde, kds,kde, &
               ims,ime, jms,jme, kms,kme, &
               its,ite, jts,jte, kts,kte )
   USE module_configure, only: grid_config_rec_type
   USE module_state_description
   USE module_data_mosaic_asect
   IMPLICIT NONE
   TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
   INTEGER, INTENT(IN ) :: id, &
                                  ids,ide, jds,jde, kds,kde, &
                                  ims,ime, jms,jme, kms,kme, &
                                  its,ite, jts,jte, kts,kte
   INTEGER, INTENT(IN) :: dust_emiss_active, seasalt_emiss_active, biom_active, dust_opt
   INTEGER, INTENT(IN) :: ktau
   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
          INTENT(IN) :: p8w, u_phy,v_phy,rho_phy
   REAL, INTENT(IN ) :: dx, g
   REAL, DIMENSION( ims:ime, jms:jme,3),&
         INTENT(IN ) :: erod
   REAL, INTENT(IN ) :: dtstep
   REAL, DIMENSION( ims:ime , jms:jme ) , &
          INTENT(IN ) :: u10, v10, xland, slai, ust
   INTEGER, DIMENSION( ims:ime , jms:jme ) , &
          INTENT(IN ) :: ivgtyp, isltyp
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
         INTENT(INOUT ) :: chem
   REAL, DIMENSION( ims:ime, 1:config_flags%kemit, jms:jme,num_emis_ant ), &
         INTENT(IN ) :: &
                         emis_ant
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme,num_ebu ), &
         INTENT(IN ) :: &
         ebu
   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
          INTENT(IN ) :: alt, dz8w
   REAL, DIMENSION( ims:ime, config_flags%num_soil_layers, jms:jme ) , &
          INTENT(INOUT) :: smois
   integer i, j, k, l, n
   integer iphase, itype
   integer p1st
   real, parameter :: efact1 = 1.0
   real :: aem_so4, aem_no3, aem_cl, aem_msa, aem_co3, aem_nh4, &
           aem_na, aem_ca, aem_oin, aem_oc, aem_bc, aem_num
   real dum, fact
   real, save :: fr8b_aem_sorgam_i(8) = &
                 (/ 0.965, 0.035, 0.000, 0.000, &
                    0.000, 0.000, 0.000, 0.000 /)
   real, save :: fr8b_aem_sorgam_j(8) = &
                 (/ 0.026, 0.147, 0.350, 0.332, &
                    0.125, 0.019, 0.001, 0.000/)
   real, save :: fr8b_aem_sorgam_c(8) = &
                 (/ 0.000, 0.000, 0.000, 0.002, &
                    0.021, 0.110, 0.275, 0.592 /)
   real, save :: fr8b_aem_mosaic_f(8) = &
       (/ 0.060, 0.045, 0.245, 0.400, 0.100, 0.150, 0., 0./)
   real, save :: fr8b_aem_mosaic_c(8) = &
       (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.300, 0.700 /)
   real, save :: fr8b_tno_bc1(8) = &
       (/ 0.0494, 0.3795, 0.4714, 0.0967, 0.003, 0.0, 0.0, 0.0 /)
   real, save :: fr8b_tno_ec25(8) = &
       (/ 0.0, 0.0, 0.0, 0.0, 0.40, 0.60, 0.0, 0.0 /)
   real, save :: fr8b_tno_oc_dom(8) = &
       (/ 0.0358, 0.1325, 0.2704, 0.3502, 0.1904, 0.0657, 0.0, 0.0 /)
   real, save :: fr8b_tno_oc_tra(8) = &
       (/ 0.0063, 0.0877, 0.3496, 0.4054, 0.1376, 0.0134, 0.0, 0.0 /)
   real, save :: fr8b_tno_mosaic_f(8) = &
       (/ 0.060, 0.045, 0.245, 0.400, 0.100, 0.150, 0.0, 0.0/)
   real, save :: fr8b_tno_mosaic_c(8) = &
       (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.300, 0.700 /)
   real :: fr_aem_sorgam_i(8)
   real :: fr_aem_sorgam_j(8)
   real :: fr_aem_sorgam_c(8)
   real :: fr_aem_mosaic_f(8)
   real :: fr_aem_mosaic_c(8)
   real :: fr_tno_bc1(8)
   real :: fr_tno_ec25(8)
   real :: fr_tno_oc_dom(8)
   real :: fr_tno_oc_tra(8)
   real :: fr_tno_mosaic_f(8)
   real :: fr_tno_mosaic_c(8)
   double precision :: chem_sum(num_chem)
   character*80 msg
 itype = 1
 iphase = ai_phase
  if (num_ebu.le.0 ) then
     print*,'no biomass burning species',num_ebu
     stop
  endif
 if ((nsize_aer(itype) .ne. 4) .and. (nsize_aer(itype) .ne. 8)) then
     write(msg,'(a,i5)') &
  'subr mosaic_addemiss - nsize_aer(itype) must be ' //   &
  '4 or 8 but = ', &
   nsize_aer(itype)
     call wrf_error_fatal3("<stdin>",245,&
msg )
 end if
 fr_aem_sorgam_i(:) = 0.0
 fr_aem_sorgam_j(:) = 0.0
 fr_aem_sorgam_c(:) = 0.0
 fr_aem_mosaic_f(:) = 0.0
 fr_aem_mosaic_c(:) = 0.0
 fr_tno_bc1(:) = 0.0
 fr_tno_ec25(:) = 0.0
 fr_tno_oc_dom(:) = 0.0
 fr_tno_oc_tra(:) = 0.0
 fr_tno_mosaic_f(:) = 0.0
 fr_tno_mosaic_c(:) = 0.0
 emiss_inpt_select_1: SELECT CASE( config_flags%emiss_inpt_opt )
   CASE( emiss_inpt_default, emiss_inpt_pnnl_rs )
     if (nsize_aer(itype) .eq. 8) then
  fr_aem_sorgam_i(:) = fr8b_aem_sorgam_i(:)
  fr_aem_sorgam_j(:) = fr8b_aem_sorgam_j(:)
  fr_aem_sorgam_c(:) = fr8b_aem_sorgam_c(:)
     else if (nsize_aer(itype) .eq. 4) then
  do n = 1, nsize_aer(itype)
      fr_aem_sorgam_i(n) = fr8b_aem_sorgam_i(2*n-1) &
                         + fr8b_aem_sorgam_i(2*n)
      fr_aem_sorgam_j(n) = fr8b_aem_sorgam_j(2*n-1) &
                         + fr8b_aem_sorgam_j(2*n)
      fr_aem_sorgam_c(n) = fr8b_aem_sorgam_c(2*n-1) &
                         + fr8b_aem_sorgam_c(2*n)
  end do
     end if
   CASE( emiss_inpt_pnnl_cm )
     if (nsize_aer(itype) .eq. 8) then
  fr_aem_mosaic_f(:) = fr8b_aem_mosaic_f(:)
  fr_aem_mosaic_c(:) = fr8b_aem_mosaic_c(:)
     else if (nsize_aer(itype) .eq. 4) then
  do n = 1, nsize_aer(itype)
      fr_aem_mosaic_f(n) = fr8b_aem_mosaic_f(2*n-1) &
                         + fr8b_aem_mosaic_f(2*n)
      fr_aem_mosaic_c(n) = fr8b_aem_mosaic_c(2*n-1) &
                         + fr8b_aem_mosaic_c(2*n)
  end do
     end if
   CASE( emiss_inpt_tno )
     if (nsize_aer(itype) .eq. 8) then
  fr_tno_bc1(:) = fr8b_tno_bc1(:)
  fr_tno_ec25(:) = fr8b_tno_ec25(:)
  fr_tno_oc_dom(:) = fr8b_tno_oc_dom(:)
  fr_tno_oc_tra(:) = fr8b_tno_oc_tra(:)
        fr_tno_mosaic_c(:) = fr8b_tno_mosaic_c(:)
        fr_tno_mosaic_f(:) = fr8b_tno_mosaic_f(:)
     else if (nsize_aer(itype) .eq. 4) then
  do n = 1, nsize_aer(itype)
      fr_tno_bc1(n) = fr8b_tno_bc1(2*n-1) &
                    + fr8b_tno_bc1(2*n)
      fr_tno_ec25(n) = fr8b_tno_ec25(2*n-1) &
                     + fr8b_tno_ec25(2*n)
      fr_tno_oc_dom(n) = fr8b_tno_oc_dom(2*n-1) &
                       + fr8b_tno_oc_dom(2*n)
      fr_tno_oc_tra(n) = fr8b_tno_oc_tra(2*n-1) &
                       + fr8b_tno_oc_tra(2*n)
      fr_tno_mosaic_c(n) = fr8b_tno_mosaic_c(2*n-1) &
                         + fr8b_tno_mosaic_c(2*n)
      fr_tno_mosaic_f(n) = fr8b_tno_mosaic_f(2*n-1) &
                         + fr8b_tno_mosaic_f(2*n)
  end do
     end if
   CASE DEFAULT
     return
 END SELECT emiss_inpt_select_1
 if (mosaic_addemiss_active <= 0.and.biom_active.le.0) then
     fr_aem_sorgam_i(:) = 0.0
     fr_aem_sorgam_j(:) = 0.0
     fr_aem_sorgam_c(:) = 0.0
     fr_aem_mosaic_f(:) = 0.0
     fr_aem_mosaic_c(:) = 0.0
     fr_tno_bc1(:) = 0.0
     fr_tno_ec25(:) = 0.0
     fr_tno_oc_dom(:) = 0.0
     fr_tno_oc_tra(:) = 0.0
     fr_tno_mosaic_f(:) = 0.0
     fr_tno_mosaic_c(:) = 0.0
 end if
 if (mosaic_addemiss_masscheck > 0) call addemiss_masscheck( &
               id, config_flags, 1, 'mosaic_ademiss', &
               dtstep, efact1, dz8w, chem, chem_sum, &
               ids,ide, jds,jde, kds,kde, &
               ims,ime, jms,jme, kms,kme, &
               its,ite, jts,jte, kts,kte, &
               14, &
               emis_ant(ims, 1,jms,p_e_pm_10),emis_ant(ims, 1,jms,p_e_pm_25), &
               emis_ant(ims, 1,jms,p_e_pm25i),emis_ant(ims, 1,jms,p_e_pm25j), &
               emis_ant(ims, 1,jms,p_e_eci),emis_ant(ims, 1,jms,p_e_ecj), &
               emis_ant(ims, 1,jms,p_e_orgi),emis_ant(ims, 1,jms,p_e_orgj), &
               emis_ant(ims, 1,jms,p_e_so4j),emis_ant(ims, 1,jms,p_e_so4c), &
               emis_ant(ims, 1,jms,p_e_no3j),emis_ant(ims, 1,jms,p_e_no3c), &
               emis_ant(ims, 1,jms,p_e_orgc),emis_ant(ims, 1,jms,p_e_ecc), &
               emis_ant(ims, 1,jms,p_e_ecc),emis_ant(ims, 1,jms,p_e_ecc), &
               emis_ant(ims, 1,jms,p_e_ecc),emis_ant(ims, 1,jms,p_e_ecc), &
               emis_ant(ims, 1,jms,p_e_ecc),emis_ant(ims, 1,jms,p_e_ecc), &
               emis_ant(ims, 1,jms,p_e_ecc))
 p1st = param_first_scalar
 do 1900 n = 1, nsize_aer(itype)
 do 1830 j = jts, jte
 do 1820 k = 1, min(config_flags%kemit,kte)
 do 1810 i = its, ite
 aem_so4 = fr_aem_mosaic_f(n)*(emis_ant(i,k,j,p_e_so4j)+ebu(i,k,j,p_ebu_sulf)) &
         + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_so4c) &
         + fr_aem_sorgam_i(n)*(emis_ant(i,k,j,p_e_so4i)+0.25*ebu(i,k,j,p_ebu_sulf)) &
         + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_so4j)+0.75*ebu(i,k,j,p_ebu_sulf))
 aem_no3 = fr_aem_mosaic_f(n)*emis_ant(i,k,j,p_e_no3j) &
         + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_no3c) &
         + fr_aem_sorgam_i(n)*emis_ant(i,k,j,p_e_no3i) &
         + fr_aem_sorgam_j(n)*emis_ant(i,k,j,p_e_no3j)
 aem_oc = fr_aem_mosaic_f(n)*(emis_ant(i,k,j,p_e_orgj)+ebu(i,k,j,p_ebu_oc)) &
         + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_orgc) &
         + fr_aem_sorgam_i(n)*(emis_ant(i,k,j,p_e_orgi)+0.25*ebu(i,k,j,p_ebu_oc)) &
         + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_orgj)+0.75*ebu(i,k,j,p_ebu_oc)) &
         + fr_tno_oc_dom(n)*emis_ant(i,k,j,p_e_oc_dom) &
         + fr_tno_oc_tra(n)*emis_ant(i,k,j,p_e_oc_tra) &
         + fr_tno_mosaic_c(n)*emis_ant(i,k,j,p_e_oc_25_10)
 aem_bc = fr_aem_mosaic_f(n)*(emis_ant(i,k,j,p_e_ecj)+ebu(i,k,j,p_ebu_bc)) &
         + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_ecc) &
         + fr_aem_sorgam_i(n)*(emis_ant(i,k,j,p_e_eci)+0.25*ebu(i,k,j,p_ebu_bc)) &
         + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_ecj)+0.75*ebu(i,k,j,p_ebu_bc)) &
         + fr_tno_bc1(n)*emis_ant(i,k,j,p_e_bc_1) &
         + fr_tno_ec25(n)*emis_ant(i,k,j,p_e_ec_1_25) &
         + fr_tno_mosaic_c(n)*emis_ant(i,k,j,p_e_ec_25_10)
  aem_oin = fr_aem_mosaic_f(n)*(emis_ant(i,k,j,p_e_pm25j)+ebu(i,k,j,p_ebu_pm25)) &
         + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_pm_10) &
         + fr_aem_sorgam_i(n)*(emis_ant(i,k,j,p_e_pm25i)+0.25*ebu(i,k,j,p_ebu_pm25)) &
         + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_pm25j)+0.75*ebu(i,k,j,p_ebu_pm25)) &
                + fr_aem_sorgam_i(n)*emis_ant(i,k,j,p_e_cai) &
                + fr_aem_sorgam_j(n)*emis_ant(i,k,j,p_e_caj) &
         + fr_tno_mosaic_f(n)*emis_ant(i,k,j,p_e_oin_25) &
               + fr_tno_mosaic_c(n)*emis_ant(i,k,j,p_e_oin_10)
 aem_nh4 = 0.0
 aem_na = 0.0
 aem_cl = 0.0
 aem_ca = 0.0
 aem_co3 = 0.0
 aem_msa = 0.0
        aem_nh4 = fr_aem_sorgam_i(n)*emis_ant(i,k,j,p_e_nh4i) &
                + fr_aem_sorgam_j(n)*emis_ant(i,k,j,p_e_nh4j)
        aem_na = fr_aem_sorgam_i(n)*emis_ant(i,k,j,p_e_nai) &
                + fr_aem_sorgam_j(n)*emis_ant(i,k,j,p_e_naj)
        aem_cl = fr_aem_sorgam_i(n)*emis_ant(i,k,j,p_e_cli) &
                + fr_aem_sorgam_j(n)*emis_ant(i,k,j,p_e_clj)
 aem_num = &
 (aem_so4/dens_so4_aer) + (aem_no3/dens_no3_aer) + &
 (aem_cl /dens_cl_aer ) + (aem_msa/dens_msa_aer) + &
 (aem_co3/dens_co3_aer) + (aem_nh4/dens_nh4_aer) + &
 (aem_na /dens_na_aer ) + (aem_ca /dens_ca_aer ) + &
 (aem_oin/dens_oin_aer) + (aem_oc /dens_oc_aer ) + &
 (aem_bc /dens_bc_aer )
 aem_num = aem_num*1.0e-6/volumcen_sect(n,itype)
 fact = (dtstep/dz8w(i,k,j))*alt(i,k,j)
 l = lptr_so4_aer(n,itype,iphase)
 if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_so4*fact
 l = lptr_no3_aer(n,itype,iphase)
 if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_no3*fact
 l = lptr_cl_aer(n,itype,iphase)
 if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_cl*fact
 l = lptr_msa_aer(n,itype,iphase)
 if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_msa*fact
 l = lptr_co3_aer(n,itype,iphase)
 if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_co3*fact
 l = lptr_nh4_aer(n,itype,iphase)
 if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_nh4*fact
 l = lptr_na_aer(n,itype,iphase)
 if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_na*fact
 l = lptr_ca_aer(n,itype,iphase)
 if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_ca*fact
 l = lptr_oin_aer(n,itype,iphase)
 if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_oin*fact
 l = lptr_oc_aer(n,itype,iphase)
 if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_oc*fact
 l = lptr_bc_aer(n,itype,iphase)
 if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_bc*fact
 l = numptr_aer(n,itype,iphase)
 if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_num*fact
1810 continue
1820 continue
1830 continue
1900 continue
 if (mosaic_addemiss_masscheck > 0) call addemiss_masscheck( &
               id, config_flags, 2, 'mosaic_ademiss', &
               dtstep, efact1, dz8w, chem, chem_sum, &
               ids,ide, jds,jde, kds,kde, &
               ims,ime, jms,jme, kms,kme, &
               its,ite, jts,jte, kts,kte, &
               14, &
               emis_ant(ims, 1,jms,p_e_pm_10),emis_ant(ims, 1,jms,p_e_pm_25), &
               emis_ant(ims, 1,jms,p_e_pm25i),emis_ant(ims, 1,jms,p_e_pm25j), &
               emis_ant(ims, 1,jms,p_e_eci),emis_ant(ims, 1,jms,p_e_ecj), &
               emis_ant(ims, 1,jms,p_e_orgi),emis_ant(ims, 1,jms,p_e_orgj), &
               emis_ant(ims, 1,jms,p_e_so4j),emis_ant(ims, 1,jms,p_e_so4c), &
               emis_ant(ims, 1,jms,p_e_no3j),emis_ant(ims, 1,jms,p_e_no3c), &
               emis_ant(ims, 1,jms,p_e_orgc),emis_ant(ims, 1,jms,p_e_ecc), &
               emis_ant(ims, 1,jms,p_e_ecc),emis_ant(ims, 1,jms,p_e_ecc), &
               emis_ant(ims, 1,jms,p_e_ecc),emis_ant(ims, 1,jms,p_e_ecc), &
               emis_ant(ims, 1,jms,p_e_ecc),emis_ant(ims, 1,jms,p_e_ecc), &
               emis_ant(ims, 1,jms,p_e_ecc))
 if (seasalt_emiss_active > 0) &
     call mosaic_seasalt_emiss( &
               id, dtstep, u10, v10, alt, dz8w, xland, config_flags, chem, &
               ids,ide, jds,jde, kds,kde, &
               ims,ime, jms,jme, kms,kme, &
               its,ite, jts,jte, kts,kte, seasalt_emiss_active )
        if (dust_opt == 2) then
            call mosaic_dust_emiss( slai, ust, smois, ivgtyp, isltyp, &
               id, dtstep, u10, v10, alt, dz8w, xland, config_flags, chem, &
               ids,ide, jds,jde, kds,kde, &
               ims,ime, jms,jme, kms,kme, &
               its,ite, jts,jte, kts,kte )
        endif
        if (dust_opt == 3) then
         call mosaic_dust_gocartemis (ktau,dtstep,config_flags%num_soil_layers,alt,u_phy, &
         v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, &
         ivgtyp,isltyp,xland,dx,g, &
         ids,ide, jds,jde, kds,kde, &
         ims,ime, jms,jme, kms,kme, &
         its,ite, jts,jte, kts,kte )
        endif
 return
   END subroutine mosaic_addemiss
   subroutine mosaic_seasalt_emiss( &
               id, dtstep, u10, v10, alt, dz8w, xland, config_flags, chem, &
               ids,ide, jds,jde, kds,kde, &
               ims,ime, jms,jme, kms,kme, &
               its,ite, jts,jte, kts,kte, seasalt_emiss_active )
   USE module_configure, only: grid_config_rec_type
   USE module_state_description, only: num_chem, param_first_scalar
   USE module_data_mosaic_asect
   IMPLICIT NONE
   TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
   INTEGER, INTENT(IN ) :: id, &
                                  ids,ide, jds,jde, kds,kde, &
                                  ims,ime, jms,jme, kms,kme, &
                                  its,ite, jts,jte, kts,kte
   REAL, INTENT(IN ) :: dtstep
   INTEGER, INTENT(IN) :: seasalt_emiss_active
   REAL, DIMENSION( ims:ime , jms:jme ), &
          INTENT(IN ) :: u10, v10, xland
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
         INTENT(INOUT ) :: chem
   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
          INTENT(IN ) :: alt, dz8w
 integer i, j, k, l, l_na, l_cl, n, l_oc
 integer iphase, itype
 integer p1st
 real dum, dumdlo, dumdhi, dumoceanfrac, dumspd10
 real factaa, factbb, fracna, fraccl, fracorg
 real :: ssemfact_numb( maxd_asize, maxd_atype )
 real :: ssemfact_mass( maxd_asize, maxd_atype )
    real, save :: alpha_f1(4) = &
                 (/ 12.328, 38.077, 102.31, 281.65 /)
    real, save :: alpha_f2(4) = &
                 (/ 2.2958, 8.0935, 25.251, 46.80 /)
    real, save :: alpha_f3(4) = &
                 (/ 0.00452, 0.00705, 0.00080, 0.000761 /)
    real, save :: beta_f1(4) = &
                 (/ 0.0311, -0.031633, 0.013154, -0.0017762 /)
    real, save :: beta_f2(4) = &
                 (/ -13.916, 35.73, -9.7651, 1.1665 /)
    real, save :: beta_f3(4) = &
                 (/ 4747.8, 12920.0, 7313.4, 6610.0 /)
 real :: nti(4), dp0gi(4)
 real, save :: oc02um(2) = (/ 0.0, 280.0 /)
 real, save :: org_frac_low_activity(8) = &
       (/ 0.05, 0.05, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 /)
 real, save :: org_frac_high_activity(8) = &
       (/ 0.2, 0.2, 0.1, 0.01, 0.01, 0.01, 0.01, 0.01 /)
    p1st = PARAM_FIRST_SCALAR
 itype = 1
 iphase = ai_phase
 if(seasalt_emiss_active .eq. 3 .or. seasalt_emiss_active .eq. 4)then
  do i=1,4
   nti(i) = beta_f1(i) * oc02um(seasalt_emiss_active-2)**2.0 + beta_f2(i) &
       * oc02um(seasalt_emiss_active-2) + beta_f3(i)
   dp0gi(i) = alpha_f1(i) + alpha_f2(i) &
       * exp(-alpha_f3(i)*oc02um(seasalt_emiss_active-2))
  end do
 end if
 do n = 1, nsize_aer(itype)
     if(seasalt_emiss_active == 1)then
      dumdlo = max( dlo_sect(n,itype), 0.02e-4 )
      dumdhi = max( dhi_sect(n,itype), 0.02e-4 )
      call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, &
   ssemfact_numb(n,itype), dum, ssemfact_mass(n,itype) )
  elseif(seasalt_emiss_active .eq. 3 .or. seasalt_emiss_active .eq. 4)then
      call seasalt_emit_feuntes_1bin( dlo_sect(n,itype), dhi_sect(n,itype), &
          ssemfact_numb(n,itype), dum, ssemfact_mass(n,itype), nti, dp0gi, oc02um(seasalt_emiss_active-2) )
  endif
     ssemfact_mass(n,itype) = ssemfact_mass(n,itype)*1.0e6
 end do
 k = kts
 do j = jts, jte
 do i = its, ite
  if( xland(i,j) < 1.5 ) cycle
  dumoceanfrac = 1.
  dumspd10 = dumoceanfrac* &
    ( (u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5*3.41) )
  factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j)
  factbb = factaa * dumspd10
  if(seasalt_emiss_active == 1)then
   fracna = mw_na_aer / (mw_na_aer + mw_cl_aer)
   fraccl = 1.0 - fracna
   do n = 1, nsize_aer(itype)
    l_na = lptr_na_aer(n,itype,iphase)
    l_cl = lptr_cl_aer(n,itype,iphase)
    if ((l_na >= p1st) .and. (l_cl >= p1st)) then
     chem(i,k,j,l_na) = chem(i,k,j,l_na) + &
      factbb * ssemfact_mass(n,itype) * fracna
     chem(i,k,j,l_cl) = chem(i,k,j,l_cl) + &
      factbb * ssemfact_mass(n,itype) * fraccl
     l = numptr_aer(n,itype,iphase)
     if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + &
          factbb * ssemfact_numb(n,itype)
    end if
   end do
  elseif(seasalt_emiss_active.eq.3 .or. seasalt_emiss_active.eq.4)then
   do n = 1, nsize_aer(itype)
    if(seasalt_emiss_active.eq.3)then
     fracorg = org_frac_low_activity(n)
    elseif(seasalt_emiss_active.eq.4)then
     fracorg = org_frac_high_activity(n)
    endif
    fracna = mw_na_aer / (mw_na_aer + mw_cl_aer)
    fraccl = 1.0 - fracna
    fracna = (1.0-fracorg)*fracna
    fraccl = (1.0-fracorg)*fraccl
    l_na = lptr_na_aer(n,itype,iphase)
    l_cl = lptr_cl_aer(n,itype,iphase)
    l_oc = lptr_oc_aer(n,itype,iphase)
    if ((l_na >= p1st) .and. (l_cl >= p1st) .and. (l_oc >= p1st)) then
     chem(i,k,j,l_na) = chem(i,k,j,l_na) + &
      factbb * ssemfact_mass(n,itype) * fracna
     chem(i,k,j,l_cl) = chem(i,k,j,l_cl) + &
      factbb * ssemfact_mass(n,itype) * fraccl
     chem(i,k,j,l_oc) = chem(i,k,j,l_oc) + &
      factbb * ssemfact_mass(n,itype) * fracorg
     l = numptr_aer(n,itype,iphase)
     if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + &
          factbb * ssemfact_numb(n,itype)
    end if
   end do
  endif
 end do
 end do
 return
   END subroutine mosaic_seasalt_emiss
 subroutine seasalt_emitfactors_1bin( ireduce_smallr_emit, &
        dpdrylo_cm, dpdryhi_cm, &
                emitfact_numb, emitfact_surf, emitfact_mass )
 implicit none
 integer ireduce_smallr_emit
 real dpdrylo_cm, dpdryhi_cm, &
                emitfact_numb, emitfact_surf, emitfact_mass
 integer isub_bin, nsub_bin
 real alnrdrylo
 real drydens, drydens_43pi_em12, x_4pi_em8
 real dum, dumadjust, dumb, dumexpb
 real dumsum_na, dumsum_ma, dumsum_sa
 real drwet, dlnrdry
 real df0drwet, df0dlnrdry, df0dlnrdry_star
 real relhum
 real rdry, rdrylo, rdryhi, rdryaa, rdrybb
 real rdrylowermost, rdryuppermost, rdry_star
 real rwet, rwetaa, rwetbb
 real rdry_cm, rwet_cm
 real sigmag_star
 real xmdry, xsdry
 real pi
 parameter (pi = 3.1415936536)
 real c1, c2, c3, c4, onethird
 parameter (c1 = 0.7674)
 parameter (c2 = 3.079)
 parameter (c3 = 2.573e-11)
 parameter (c4 = -1.424)
 parameter (onethird = 1.0/3.0)
 drydens = 2.165
 drydens_43pi_em12 = drydens*(4.0/3.0)*pi*1.0e-12
 x_4pi_em8 = 4.0*pi*1.0e-8
 relhum = 0.80
 rdry_star = 0.1
 if (ireduce_smallr_emit .le. 0) rdry_star = -1.0e20
 sigmag_star = 1.9
 dumsum_na = 0.0
 dumsum_sa = 0.0
 dumsum_ma = 0.0
        rdrylowermost = dpdrylo_cm*0.5e4
        rdryuppermost = dpdryhi_cm*0.5e4
 if (rdryuppermost .le. rdry_star) goto 2000
        rdrylo = max( rdrylowermost, rdry_star )
        rdryhi = rdryuppermost
 nsub_bin = 1000
 alnrdrylo = log( rdrylo )
 dlnrdry = (log( rdryhi ) - alnrdrylo)/nsub_bin
 rdrybb = exp( alnrdrylo )
 rdry_cm = rdrybb*1.0e-4
 rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ &
        ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird
 rwetbb = rwet_cm*1.0e4
 do 1900 isub_bin = 1, nsub_bin
 rdryaa = rdrybb
 rwetaa = rwetbb
 dum = alnrdrylo + isub_bin*dlnrdry
 rdrybb = exp( dum )
 rdry_cm = rdrybb*1.0e-4
 rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ &
        ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird
 rwetbb = rwet_cm*1.0e4
 rdry = sqrt(rdryaa * rdrybb)
 rwet = sqrt(rwetaa * rwetbb)
 drwet = rwetbb - rwetaa
 xmdry = drydens_43pi_em12 * (rdry**3.0)
 xsdry = x_4pi_em8 * (rdry**2.0)
 dumb = ( 0.380 - log10(rwet) ) / 0.650
 dumexpb = exp( -dumb*dumb)
 df0drwet = 1.373 * (rwet**(-3.0)) * &
        (1.0 + 0.057*(rwet**1.05)) * &
        (10.0**(1.19*dumexpb))
 dumsum_na = dumsum_na + drwet*df0drwet
 dumsum_ma = dumsum_ma + drwet*df0drwet*xmdry
 dumsum_sa = dumsum_sa + drwet*df0drwet*xsdry
1900 continue
2000 if (rdrylowermost .ge. rdry_star) goto 3000
 rdryaa = 0.99*rdry_star
 rdry_cm = rdryaa*1.0e-4
 rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ &
        ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird
 rwetaa = rwet_cm*1.0e4
 rdrybb = 1.01*rdry_star
 rdry_cm = rdrybb*1.0e-4
 rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ &
        ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird
 rwetbb = rwet_cm*1.0e4
 rwet = 0.5*(rwetaa + rwetbb)
 dumb = ( 0.380 - log10(rwet) ) / 0.650
 dumexpb = exp( -dumb*dumb)
 df0drwet = 1.373 * (rwet**(-3.0)) * &
        (1.0 + 0.057*(rwet**1.05)) * &
        (10.0**(1.19*dumexpb))
 drwet = rwetbb - rwetaa
 dlnrdry = log( rdrybb/rdryaa )
 df0dlnrdry_star = df0drwet * (drwet/dlnrdry)
        rdrylo = rdrylowermost
        rdryhi = min( rdryuppermost, rdry_star )
 nsub_bin = 1000
 alnrdrylo = log( rdrylo )
 dlnrdry = (log( rdryhi ) - alnrdrylo)/nsub_bin
 do 2900 isub_bin = 1, nsub_bin
 dum = alnrdrylo + (isub_bin-0.5)*dlnrdry
 rdry = exp( dum )
 xmdry = drydens_43pi_em12 * (rdry**3.0)
 xsdry = x_4pi_em8 * (rdry**2.0)
 dum = log( rdry/rdry_star ) / log( sigmag_star )
 dumadjust = exp( -0.5*dum*dum )
 df0dlnrdry = df0dlnrdry_star * dumadjust
 dumsum_na = dumsum_na + dlnrdry*df0dlnrdry
 dumsum_ma = dumsum_ma + dlnrdry*df0dlnrdry*xmdry
 dumsum_sa = dumsum_sa + dlnrdry*df0dlnrdry*xsdry
2900 continue
3000 emitfact_numb = dumsum_na
 emitfact_mass = dumsum_ma
 emitfact_surf = dumsum_sa
 return
 end subroutine seasalt_emitfactors_1bin
 subroutine seasalt_emit_feuntes_1bin( &
        dpdrylo_cm, dpdryhi_cm, &
                emitfact_numb, emitfact_surf, emitfact_mass, nti, dp0gi, oc02um )
 implicit none
 real dpdrylo_cm, dpdryhi_cm, &
                emitfact_numb, emitfact_surf, emitfact_mass
    real, intent(in) :: nti(4), dp0gi(4), oc02um
 integer isub_bin, nsub_bin, jd, nsub_lower_bin, nsub_upper_bin
 real alnrdrylo
 real drydens, drydens_43pi_em12, x_4pi_em8, drydens_16pi_em12, x_pi_em8
 real dum, dumadjust, dumb, dumexpb
 real dumsum_na, dumsum_ma, dumsum_sa
 real drwet, dlnrdry, ddwet, ddry, dwet
 real df0drwet, df0dlnrdry, df0dlnrdry_star
 real relhum
 real rdry, rdrylo, rdryhi, rdryaa, rdrybb
 real rdrylowermost, rdryuppermost, rdry_star
 real rwet, rwetaa, rwetbb
 real rdry_cm, rwet_cm
 real sigmag_star
 real xmdry, xsdry
 real ddrylo, ddryhi, alogddrylo
 real ddrybb, ddry_cm, dwet_cm, dwetbb
 real ddryaa, dwetaa, dlogddry, df0dlogddry
 real pi
 parameter (pi = 3.1415936536)
 real c1, c2, c3, c4, onethird
 parameter (c1 = 0.7674)
 parameter (c2 = 3.079)
 parameter (c3 = 2.573e-11)
 parameter (c4 = -1.424)
 parameter (onethird = 1.0/3.0)
 real, save :: width_ssinorg_f(4) = &
     (/ 1.55, 1.7, 1.5, 1.7 /)
 real, save :: width_ssorg_f(4) = &
     (/ 1.55, 1.9, 1.5, 1.7 /)
 real :: width_ss_f(4), frac
 real, parameter :: scale_factor = 58.3/(0.0146)*3.84e-6
 if(oc02um.gt.0e0)then
  width_ss_f = width_ssorg_f
 else
  width_ss_f = width_ssinorg_f
 end if
 drydens = 2.165
 drydens_43pi_em12 = drydens*(4.0/3.0)*pi*1.0e-12
 drydens_16pi_em12 = drydens*(1.0/6.0)*pi*1.0e-12
 x_4pi_em8 = 4.0*pi*1.0e-8
 x_pi_em8 = pi*1.0e-8
 relhum = 0.80
 rdry_star = 0.45 / 2.0
 sigmag_star = 1.9
 dumsum_na = 0.0
 dumsum_sa = 0.0
 dumsum_ma = 0.0
    rdrylowermost = dpdrylo_cm*0.5e4
    rdryuppermost = dpdryhi_cm*0.5e4
 if (rdrylowermost .ge. rdry_star) then
        rdrylo = rdrylowermost
        rdryhi = rdryuppermost
  nsub_bin = 1000
  alnrdrylo = log( rdrylo )
  dlnrdry = (log( rdryhi ) - alnrdrylo)/nsub_bin
  rdrybb = exp( alnrdrylo )
  rdry_cm = rdrybb*1.0e-4
  rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ &
         ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird
  rwetbb = rwet_cm*1.0e4
  do isub_bin = 1, nsub_bin
   rdryaa = rdrybb
   rwetaa = rwetbb
   dum = alnrdrylo + isub_bin*dlnrdry
   rdrybb = exp( dum )
   rdry_cm = rdrybb*1.0e-4
   rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ &
          ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird
   rwetbb = rwet_cm*1.0e4
   rdry = sqrt(rdryaa * rdrybb)
   rwet = sqrt(rwetaa * rwetbb)
   drwet = rwetbb - rwetaa
   xmdry = drydens_43pi_em12 * (rdry**3.0)
   xsdry = x_4pi_em8 * (rdry**2.0)
   dumb = ( 0.380 - log10(rwet) ) / 0.650
   dumexpb = exp( -dumb*dumb)
   df0drwet = 1.373 * (rwet**(-3.0)) * &
          (1.0 + 0.057*(rwet**1.05)) * &
          (10.0**(1.19*dumexpb))
   dumsum_na = dumsum_na + drwet*df0drwet
   dumsum_ma = dumsum_ma + drwet*df0drwet*xmdry
   dumsum_sa = dumsum_sa + drwet*df0drwet*xsdry
  end do
 elseif (rdryuppermost .gt. rdry_star) then
  frac = (log(rdry_star)-log(rdrylowermost)) / (log(rdryuppermost)-log(rdrylowermost))
  nsub_lower_bin = floor(frac*1000.0)
  nsub_upper_bin = 1000-nsub_lower_bin
        ddrylo = rdrylowermost*2.0
        ddryhi = rdry_star*2.0
  nsub_bin = nsub_lower_bin
  alogddrylo = log10( ddrylo )
  dlogddry = (log10( ddryhi ) - alogddrylo)/nsub_bin
  ddrybb = 10.0**( alogddrylo )
  ddry_cm = ddrybb*1.0e-4
  dwet_cm = ( ddry_cm**3 + (c1*(ddry_cm**c2))/ &
         ( (c3*(ddry_cm**c4)) - log10(relhum) ) )**onethird
  dwetbb = dwet_cm*1.0e4
  do isub_bin = 1, nsub_bin
   ddryaa = ddrybb
   dum = alogddrylo + isub_bin*dlogddry
   ddrybb = 10.0**( dum )
   ddry_cm = ddrybb*1.0e-4
   ddry = sqrt(ddryaa * ddrybb)
   xmdry = drydens_16pi_em12 * (ddry**3.0)
   xsdry = x_pi_em8 * (ddry**2.0)
   df0dlogddry = 0.0
   do jd = 1, 4
    df0dlogddry = df0dlogddry + nti(jd)/( (2.0*pi)**0.5 * log10(width_ss_f(jd)) ) &
       * exp(-1.0/2.0 * (log10(ddry*1e3/dp0gi(jd))/log10(width_ss_f(jd)))**2.0 )
   end do
   dumsum_na = dumsum_na + dlogddry*df0dlogddry*scale_factor
   dumsum_ma = dumsum_ma + dlogddry*df0dlogddry*scale_factor*xmdry
   dumsum_sa = dumsum_sa + dlogddry*df0dlogddry*scale_factor*xsdry
  end do
        rdrylo = rdry_star
        rdryhi = rdryuppermost
  nsub_bin = nsub_upper_bin
  alnrdrylo = log( rdrylo )
  dlnrdry = (log( rdryhi ) - alnrdrylo)/nsub_bin
  rdrybb = exp( alnrdrylo )
  rdry_cm = rdrybb*1.0e-4
  rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ &
         ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird
  rwetbb = rwet_cm*1.0e4
  do isub_bin = 1, nsub_bin
   rdryaa = rdrybb
   rwetaa = rwetbb
   dum = alnrdrylo + isub_bin*dlnrdry
   rdrybb = exp( dum )
   rdry_cm = rdrybb*1.0e-4
   rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ &
          ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird
   rwetbb = rwet_cm*1.0e4
   rdry = sqrt(rdryaa * rdrybb)
   rwet = sqrt(rwetaa * rwetbb)
   drwet = rwetbb - rwetaa
   xmdry = drydens_43pi_em12 * (rdry**3.0)
   xsdry = x_4pi_em8 * (rdry**2.0)
   dumb = ( 0.380 - log10(rwet) ) / 0.650
   dumexpb = exp( -dumb*dumb)
   df0drwet = 1.373 * (rwet**(-3.0)) * &
          (1.0 + 0.057*(rwet**1.05)) * &
          (10.0**(1.19*dumexpb))
   dumsum_na = dumsum_na + drwet*df0drwet
   dumsum_ma = dumsum_ma + drwet*df0drwet*xmdry
   dumsum_sa = dumsum_sa + drwet*df0drwet*xsdry
  end do
 else
        ddrylo = rdrylowermost*2.0
        ddryhi = rdryuppermost*2.0
  nsub_bin = 1000
  alogddrylo = log10( ddrylo )
  dlogddry = (log10( ddryhi ) - alogddrylo)/nsub_bin
  ddrybb = 10.0**( alogddrylo )
  ddry_cm = ddrybb*1.0e-4
  dwet_cm = ( ddry_cm**3 + (c1*(ddry_cm**c2))/ &
         ( (c3*(ddry_cm**c4)) - log10(relhum) ) )**onethird
  dwetbb = dwet_cm*1.0e4
  do isub_bin = 1, nsub_bin
   ddryaa = ddrybb
   dum = alogddrylo + isub_bin*dlogddry
   ddrybb = 10.0**( dum )
   ddry_cm = ddrybb*1.0e-4
   ddry = sqrt(ddryaa * ddrybb)
   xmdry = drydens_16pi_em12 * (ddry**3.0)
   xsdry = x_pi_em8 * (ddry**2.0)
   df0dlogddry = 0.0
   do jd = 1, 4
    df0dlogddry = df0dlogddry + nti(jd)/( (2.0*pi)**0.5 * log10(width_ss_f(jd)) ) &
       * exp(-1.0/2.0 * (log10(ddry*1e3/dp0gi(jd))/log10(width_ss_f(jd)))**2.0 )
   end do
   dumsum_na = dumsum_na + dlogddry*df0dlogddry*scale_factor
   dumsum_ma = dumsum_ma + dlogddry*df0dlogddry*scale_factor*xmdry
   dumsum_sa = dumsum_sa + dlogddry*df0dlogddry*scale_factor*xsdry
  end do
 end if
 emitfact_numb = dumsum_na
 emitfact_mass = dumsum_ma
 emitfact_surf = dumsum_sa
 return
 end subroutine seasalt_emit_feuntes_1bin
END MODULE module_mosaic_addemiss
   subroutine mosaic_dust_emiss( slai,ust, smois, ivgtyp, isltyp, &
               id, dtstep, u10, v10, alt, dz8w, xland, config_flags, chem, &
               ids,ide, jds,jde, kds,kde, &
               ims,ime, jms,jme, kms,kme, &
               its,ite, jts,jte, kts,kte )
   USE module_configure, only: grid_config_rec_type
   USE module_state_description, only: num_chem, param_first_scalar
   USE module_data_mosaic_asect
   IMPLICIT NONE
   TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
   INTEGER, INTENT(IN ) :: id, &
                                  ids,ide, jds,jde, kds,kde, &
                                  ims,ime, jms,jme, kms,kme, &
                                  its,ite, jts,jte, kts,kte
   REAL, INTENT(IN ) :: dtstep
   REAL, DIMENSION( ims:ime , jms:jme ), &
          INTENT(IN ) :: u10, v10, xland, slai, ust
   INTEGER, DIMENSION( ims:ime , jms:jme ), &
          INTENT(IN ) :: ivgtyp, isltyp
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
         INTENT(INOUT ) :: chem
   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
          INTENT(IN ) :: alt, dz8w
   REAL, DIMENSION( ims:ime, config_flags%num_soil_layers, jms:jme ) , &
          INTENT(INOUT) :: smois
        integer i, j, k, l, l_oin, l_ca, l_co3, n, ii
        integer iphase, itype, izob
        integer p1st
        real dum, dumdlo, dumdhi, dumlandfrac, dumspd10
        real factaa, factbb, fracoin, fracca, fracco3, fractot
        real ustart, ustar1, ustart0
        real alphamask, f8, f50, f51, f52, wetfactor, sumdelta, ftot
        real smois_grav, wp, pclay
        real :: beta(4,7)
        real :: gamma(4), delta(4)
        real :: sz(8)
        real :: dustflux, densdust, mass1part
        real :: c_const
        p1st = param_first_scalar
        beta(1,1)=0.12
        beta(2,1)=0.04
        beta(3,1)=0.04
        beta(4,1)=0.80
        beta(1,2)=0.34
        beta(2,2)=0.28
        beta(3,2)=0.28
        beta(4,2)=0.10
        beta(1,3)=0.45
        beta(2,3)=0.15
        beta(3,3)=0.15
        beta(4,3)=0.25
        beta(1,4)=0.12
        beta(2,4)=0.09
        beta(3,4)=0.09
        beta(4,4)=0.70
        beta(1,5)=0.40
        beta(2,5)=0.05
        beta(3,5)=0.05
        beta(4,5)=0.50
        beta(1,6)=0.34
        beta(2,6)=0.18
        beta(3,6)=0.18
        beta(4,6)=0.30
        beta(1,7)=0.22
        beta(2,7)=0.09
        beta(3,7)=0.09
        beta(4,7)=0.60
        gamma(1)=0.08
        gamma(2)=1.00
        gamma(3)=1.00
        gamma(4)=0.12
        itype=1
 if (nsize_aer(itype) .eq. 8) then
          sz(1)=0
          sz(2)=1.78751e-06
          sz(3)=0.000273786
          sz(4)=0.00847978
          sz(5)=0.056055
          sz(6)=0.0951896
          sz(7)=0.17
          sz(8)=0.67
 else if (nsize_aer(itype) .eq. 4) then
          sz(1)=1.78751e-06
          sz(2)=0.00875357
          sz(3)=0.1512446
          sz(4)=0.84
          sz(5)=0.0
          sz(6)=0.0
          sz(7)=0.0
          sz(8)=0.0
        endif
        itype = 1
        iphase = ai_phase
        k = kts
        do 1830 j = jts, jte
        do 1820 i = its, ite
    if( xland(i,j) > 1.5 ) cycle
        dumlandfrac = 1.
        dumspd10=(u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5)
        if(dumspd10 >= 5.0) then
           dumspd10 = dumlandfrac* &
         ( dumspd10*dumspd10*(dumspd10-5.0))
         else
            dumspd10=0.
         endif
         alphamask=0.001
         if (ivgtyp(i,j) .eq. 7) then
           f8=0.005
           f50=0.00
           f51=0.10
           f51=0.066
           f52=0.00
           alphamask=(f8+f50)*1.0+(f51+f52)*0.5
         endif
         if (ivgtyp(i,j) .eq. 8) then
           f8=0.010
           f50=0.00
           f51=0.00
           f52=0.15
           f52=0.10
           alphamask=(f8+f50)*1.0+(f51+f52)*0.5
         endif
         if (ivgtyp(i,j) .eq. 10) then
           f8=0.00
           f50=0.00
           f51=0.01
           f52=0.00
           alphamask=(f8+f50)*1.0+(f51+f52)*0.5
         endif
         izob=0
         if(isltyp(i,j).eq.1) izob=1
         if(isltyp(i,j).eq.2) izob=1
         if(isltyp(i,j).eq.3) izob=4
         if(isltyp(i,j).eq.4) izob=2
         if(isltyp(i,j).eq.5) izob=2
         if(isltyp(i,j).eq.6) izob=2
         if(isltyp(i,j).eq.7) izob=7
         if(isltyp(i,j).eq.8) izob=2
         if(isltyp(i,j).eq.9) izob=6
         if(isltyp(i,j).eq.10) izob=5
         if(isltyp(i,j).eq.11) izob=2
         if(isltyp(i,j).eq.12) izob=3
         if(isltyp(i,j).ge.13) izob=0
         if(izob.eq.0) goto 1840
         do ii=1,4
           delta(ii)=0.0
         enddo
         sumdelta=0.0
         do ii=1,4
           delta(ii)=beta(ii,izob)*gamma(ii)
           if(ii.lt.4) then
             sumdelta=sumdelta+delta(ii)
           endif
         enddo
         do ii=1,4
           delta(ii)=delta(ii)/sumdelta
         enddo
         pclay=beta(1,izob)*100.
         wp=0.0014*pclay*pclay+0.17*pclay
         smois_grav=(smois(i,1,j)/2.6)*100.
         if(smois_grav.gt.wp) then
           wetfactor=sqrt(1.0+1.21*(smois_grav-wp)**0.68)
         else
           wetfactor=1.0
         endif
         c_const=1.e-14
         ustar1=ust(i,j)*100.0
         if(ustar1.gt.100.0) ustar1=100.0
         ustart0=20.0
         ustart=ustart0*wetfactor
         if(ustar1.le.ustart) then
           dustflux=0.0
         else
           dustflux=c_const*(ustar1**4)*(1.0-(ustart/ustar1))
         endif
         dustflux=dustflux*10.0
         ftot=0.0
         do ii=1,2
           ftot=ftot+dustflux*alphamask*delta(ii)
         enddo
         ftot=ftot*1.0e+09
         factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j)
         factbb = factaa * ftot
         fracoin = 0.97
         fracca = 0.03*0.4
         fracco3 = 0.03*0.6
         fractot = fracoin + fracca + fracco3
         do 1810 n = 1, nsize_aer(itype)
            l_oin = lptr_oin_aer(n,itype,iphase)
            l_ca = lptr_ca_aer(n,itype,iphase)
            l_co3 = lptr_co3_aer(n,itype,iphase)
            if (l_oin >= p1st) then
               chem(i,k,j,l_oin) = chem(i,k,j,l_oin) + &
               factbb * sz(n) * fracoin
               if (l_ca >= p1st) &
                  chem(i,k,j,l_ca) = chem(i,k,j,l_ca) + &
                  factbb * sz(n) * fracca
               if (l_co3 >= p1st) &
                  chem(i,k,j,l_co3) = chem(i,k,j,l_co3) + &
                  factbb * sz(n) * fracco3
               densdust=2.5
               mass1part=0.523598*(dcen_sect(n,itype)**3)*densdust*1.0e06
               l = numptr_aer(n,itype,iphase)
               if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + &
                        factbb * sz(n) * fractot / mass1part
            end if
1810 continue
1840 continue
1820 continue
1830 continue
        return
   END subroutine mosaic_dust_emiss
  subroutine mosaic_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, &
         v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, &
         ivgtyp,isltyp,xland,dx,g, &
         ids,ide, jds,jde, kds,kde, &
         ims,ime, jms,jme, kms,kme, &
         its,ite, jts,jte, kts,kte )
  USE module_data_gocart_dust
  USE module_configure
  USE module_state_description
  USE module_model_constants, ONLY: mwdry
  USE module_data_mosaic_asect
  IMPLICIT NONE
   INTEGER, INTENT(IN ) :: ktau, num_soil_layers, &
                                  ids,ide, jds,jde, kds,kde, &
                                  ims,ime, jms,jme, kms,kme, &
                                  its,ite, jts,jte, kts,kte
   INTEGER,DIMENSION( ims:ime , jms:jme ) , &
          INTENT(IN ) :: &
                                                     ivgtyp, &
                                                     isltyp
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
         INTENT(INOUT ) :: chem
   REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , &
      INTENT(INOUT) :: smois
   REAL, DIMENSION( ims:ime , jms:jme, 3 ) , &
          INTENT(IN ) :: erod
   REAL, DIMENSION( ims:ime , jms:jme ) , &
          INTENT(IN ) :: &
                                                     u10, &
                                                     v10, &
                                                     xland
   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
          INTENT(IN ) :: &
                                                        alt, &
                                                     dz8w,p8w, &
                                              u_phy,v_phy,rho_phy
  REAL, INTENT(IN ) :: dt,dx,g
  integer :: nmx,i,j,k,ndt,imx,jmx,lmx
  integer ilwi, start_month
  real*8, DIMENSION (3) :: erodin
  real*8, DIMENSION (5) :: bems
  real*8 w10m,gwet,airden,airmas
  real*8 cdustemis,jdustemis,cdustcon,jdustcon
  real*8 cdustdens,jdustdens,mass1part,jdustdiam,cdustdiam,dp_meanvol_tmp
  real factaa, factbb, fracoin, fracca, fracco3, fractot
  real*8 dxy
  real*8 conver,converi
  real dttt
  real soilfacj,rhosoilj,rhosoilc
  integer p1st,l_oin,l,n
  real :: densdust
  real sz(8),ftot,frac_10um
  real totalemis,accfrac,corfrac,rscale
  integer iphase, itype
  rscale=1.01
  accfrac=0.07
  corfrac=0.93
  accfrac=accfrac*rscale
  corfrac=corfrac*rscale
  p1st = param_first_scalar
        sz(1)=1.0e-8
        sz(2)=1.0e-6
        sz(3)=3.0e-4
        sz(4)=3.5e-3
        sz(5)=0.018
        sz(6)=0.070
        sz(7)=0.2595
        sz(8)=0.42
        itype = 1
        iphase = ai_phase
  conver=1.e-9
  converi=1.e9
  nmx=5
  k=kts
  do j=jts,jte
  do i=its,ite
     if(xland(i,j).lt.1.5)then
     ilwi=1
     start_month = 3
     w10m=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
     airmas=-(p8w(i,kts+1,j)-p8w(i,kts,j))*dx*dx/g
     if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j))
     erodin(1)=erod(i,j,1)
     erodin(2)=erod(i,j,2)
     erodin(3)=erod(i,j,3)
     gwet=smois(i,1,j)/porosity(isltyp(i,j))
     ndt=ifix(dt)
     airden=rho_phy(i,kts,j)
     dxy=dx*dx
       if (i==40.and.j==50) then
        print*,'check moisture ',gwet
       endif
    call mosaic_source_du( nmx, dt, &
                     erodin, ilwi, dxy, w10m, gwet, airden, airmas, &
                     bems,start_month,g)
    totalemis=(sum(bems(1:5))/dt)*converi/dxy
    jdustemis = totalemis*accfrac
    cdustemis = totalemis*corfrac
    ftot=jdustemis+cdustemis
         factaa = (dt/dz8w(i,k,j))*alt(i,k,j)
         factbb = factaa * ftot
         fracoin = 0.97
         fracca = 0.03*0.4
         fracco3 = 0.03*0.6
         fractot = fracoin
         do 1810 n = 1, nsize_aer(itype)
            l_oin = lptr_oin_aer(n,itype,iphase)
            if (l_oin >= p1st) then
               chem(i,k,j,l_oin) = chem(i,k,j,l_oin) + &
               factbb * sz(n) * fracoin
               if (n <= 5) densdust=2.5
               if (n > 5 ) densdust=2.65
               mass1part=0.523598*(dcen_sect(n,itype)**3)*densdust*1.0e06
               l = numptr_aer(n,itype,iphase)
               if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + &
                        factbb * sz(n) * fractot / mass1part
            end if
1810 continue
     endif
  enddo
  enddo
end subroutine mosaic_dust_gocartemis
  SUBROUTINE mosaic_source_du( nmx, dt1, &
                     erod, ilwi, dxy, w10m, gwet, airden, airmas, &
                     bems,month,g0)
 USE module_data_gocart_dust
  INTEGER, INTENT(IN) :: nmx
  REAL*8, INTENT(IN) :: erod(ndcls)
  INTEGER, INTENT(IN) :: ilwi,month
  REAL*8, INTENT(IN) :: w10m, gwet
  REAL*8, INTENT(IN) :: dxy
  REAL*8, INTENT(IN) :: airden, airmas
  REAL*8, INTENT(OUT) :: bems(nmx)
  REAL*8 :: den(nmx), diam(nmx)
  REAL*8 :: tsrc, u_ts0, cw, u_ts, dsrc, srce
  REAL, intent(in) :: g0
  REAL :: rhoa, g,dt1
  INTEGER :: i, j, n, m, k
   ch_dust(:,:)=1.0D-9
  DO n = 1, nmx
     den(n) = den_dust(n)*1.0D-3
     diam(n) = 2.0*reff_dust(n)*1.0D2
     g = g0*1.0E2
     m = ipoint(n)
     tsrc = 0.0
              rhoa = airden*1.0D-3
              u_ts0 = 0.13*1.0D-2*SQRT(den(n)*g*diam(n)/rhoa)* &
                   SQRT(1.0+0.006/den(n)/g/(diam(n))**2.5)/ &
                   SQRT(1.928*(1331.0*(diam(n))**1.56+0.38)**0.092-1.0)
             IF (gwet < 0.5) THEN
                 u_ts = MAX(0.0D+0,u_ts0*(1.2D+0+2.0D-1*LOG10(MAX(1.0D-3, gwet))))
              ELSE
                 u_ts = 100.0
              END IF
              srce = frac_s(n)*erod(m)*dxy
              IF (ilwi == 1 ) THEN
                 dsrc = ch_dust(n,month)*srce*w10m**2 &
                      * (w10m - u_ts)*dt1
              ELSE
                 dsrc = 0.0
              END IF
              IF (dsrc < 0.0) dsrc = 0.0
              bems(n) = dsrc
  ENDDO
END SUBROUTINE mosaic_source_du
   subroutine addemiss_masscheck( id, config_flags, iflagaa, fromwhere, &
               dtstep, efact1, dz8w, chem, chem_sum, &
               ids,ide, jds,jde, kds,kde, &
               ims,ime, jms,jme, kms,kme, &
               its,ite, jts,jte, kts,kte, &
               nemit, &
               e01, e02, e03, e04, e05, e06, e07, e08, e09, e10, &
               e11, e12, e13, e14, e15, e16, e17, e18, e19, e20, e21 )
   USE module_configure, only: grid_config_rec_type
   USE module_state_description, only: num_chem
   IMPLICIT NONE
   TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
   INTEGER, INTENT(IN ) :: id, iflagaa, &
                                  ids,ide, jds,jde, kds,kde, &
                                  ims,ime, jms,jme, kms,kme, &
                                  its,ite, jts,jte, kts,kte, &
                                  nemit
   REAL, INTENT(IN ) :: dtstep, efact1
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
         INTENT(IN ) :: chem
   DOUBLE PRECISION, DIMENSION( num_chem ), &
         INTENT(INOUT ) :: chem_sum
   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
          INTENT(IN ) :: dz8w
  REAL, DIMENSION( ims:ime , kms:config_flags%kemit , jms:jme ), &
          INTENT(IN ) :: &
               e01, e02, e03, e04, e05, e06, e07, e08, e09, e10, &
               e11, e12, e13, e14, e15, e16, e17, e18, e19, e20, e21
   character(len=*), intent(in) :: fromwhere
   integer, parameter :: nemit_maxd = 21
   integer :: i, j, k, l
   double precision :: chem_sum_prev
   real :: fact
   real :: emit_sum(nemit_maxd)
 do 1900 l = 1, num_chem
 chem_sum_prev = chem_sum(l)
 chem_sum(l) = 0.0
 do j = jts, jte
 do k = kts, kte
 do i = its, ite
     chem_sum(l) = chem_sum(l) + dble( chem(i,k,j,l)*dz8w(i,k,j) )
 end do
 end do
 end do
 if (iflagaa == 2) chem_sum(l) = (chem_sum(l) - chem_sum_prev)
1900 continue
 if (iflagaa /= 2) return
 emit_sum(:) = 0.0
 do 2900 l = 1, min(nemit,nemit_maxd)
 do j = jts, jte
 do k = kts, min(config_flags%kemit,kte)
 do i = its, ite
     if (l== 1) emit_sum(l) = emit_sum(l) + e01(i,k,j)
     if (l== 2) emit_sum(l) = emit_sum(l) + e02(i,k,j)
     if (l== 3) emit_sum(l) = emit_sum(l) + e03(i,k,j)
     if (l== 4) emit_sum(l) = emit_sum(l) + e04(i,k,j)
     if (l== 5) emit_sum(l) = emit_sum(l) + e05(i,k,j)
     if (l== 6) emit_sum(l) = emit_sum(l) + e06(i,k,j)
     if (l== 7) emit_sum(l) = emit_sum(l) + e07(i,k,j)
     if (l== 8) emit_sum(l) = emit_sum(l) + e08(i,k,j)
     if (l== 9) emit_sum(l) = emit_sum(l) + e09(i,k,j)
     if (l==10) emit_sum(l) = emit_sum(l) + e10(i,k,j)
     if (l==11) emit_sum(l) = emit_sum(l) + e11(i,k,j)
     if (l==12) emit_sum(l) = emit_sum(l) + e12(i,k,j)
     if (l==13) emit_sum(l) = emit_sum(l) + e13(i,k,j)
     if (l==14) emit_sum(l) = emit_sum(l) + e14(i,k,j)
     if (l==15) emit_sum(l) = emit_sum(l) + e15(i,k,j)
     if (l==16) emit_sum(l) = emit_sum(l) + e16(i,k,j)
     if (l==17) emit_sum(l) = emit_sum(l) + e17(i,k,j)
     if (l==18) emit_sum(l) = emit_sum(l) + e18(i,k,j)
     if (l==19) emit_sum(l) = emit_sum(l) + e19(i,k,j)
     if (l==20) emit_sum(l) = emit_sum(l) + e20(i,k,j)
     if (l==21) emit_sum(l) = emit_sum(l) + e21(i,k,j)
 end do
 end do
 end do
2900 continue
 print 9110, fromwhere, its, ite, jts, jte
 print 9100, 'chem_sum'
 fact = 1.0/(dtstep*efact1)
 print 9120, (l, fact*chem_sum(l), l=1,num_chem)
 print 9100, 'emit_sum'
 print 9120, (l, emit_sum(l), l=1,min(nemit,nemit_maxd))
9100 format( a )
9110 format( / 'addemiss_masscheck output, fromwhere = ', a / &
 'its, ite, jts, jte =', 4i5 )
9120 format( 5( i5, 1pe11.3 ) )
 return
   END subroutine addemiss_masscheck


!
!     -------------------------------------------------------------
!      N O N R E L A T 4
!     -------------------------------------------------------------
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF MATRIX ELEMENTS        *
!     OF TWO PARTICLE OPERATOR IN CASE :      N'1 = N1 +- 1        *
!                                             N'2 = N2 +- 1        *
!                                             N'3 = N3 -+ 2        *
!     Written by G. Gaigalas,                                      *
!     Vanderbilt University,  Nashville            February 1994   *
!                                                                  *
      SUBROUTINE NONRELAT4(IA, IB, IC, ID)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE OPERAT_C
      USE MEDEFN_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  11:17:07  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ittk_I
      USE nonrelat41_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: IA
      INTEGER  :: IB
      INTEGER  :: IC
      INTEGER  :: ID
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
!-----------------------------------------------
      IF (IHSH <= 2) RETURN
      IF (IA == IB) THEN
         IF (ISOTOP == 1) THEN
            IF (ITTK(LJ(IC),LJ(IA),1) == 0) RETURN
            IF (ITTK(LJ(ID),LJ(IA),1) == 0) RETURN
         ENDIF
         CALL NONRELAT41 (IC, ID, IA, 1, IA, IB, IC, ID)
      ELSE IF (IC == ID) THEN
         IF (ISOTOP == 1) THEN
            IF (ITTK(LJ(IA),LJ(IC),1) == 0) RETURN
            IF (ITTK(LJ(IB),LJ(IC),1) == 0) RETURN
         ENDIF
         CALL NONRELAT41 (IA, IB, IC, 2, IA, IB, IC, ID)
      ELSE
         WRITE (6, '(A)') ' KLAIDA NONRELAT4  '
         STOP
      ENDIF
      RETURN
      END SUBROUTINE NONRELAT4


      subroutine FK2TEX(ibuf,buf,lbuf,iscr,lscr, scr, istop1, nready)
!-------------------------------------------------------------------------------
!    FK2TEX is the execution module of SIOSEIS for performing the inverse
!  FK transformation.  i.e. FK2TEX transforms the FK domain back into the tx
!  domain.
!
!     I blast the AP simulator common array after the last trace is input to
!  FK2TEX. The assumption is that any process that may be saving something
!  in the simulated memory will not be called again and any post FK2TX process
!  has not been called yet!  The simulator memory is used for transposing the
!  complex matrix, which might be very very large.  (1000 traces in a seismic
!  line is a short line!  Marine shots are typically 1500 samples long. There-
!  fore,  The seismic line or matrix, contains 1024*2048 (2,095,152) samples
!  (8,388,608 bytes!).  I also ran into a virtual addressing problem with
!  large arrays in SIOSEIS because SIOSEIS is not a small program!.
!
!  Inputs:
!   ibuf/buf/lbuf - Equivalenced array holding
!   iscr/scr      - Scratch Array
!
!   istop  - the stop signal.
!          = STOPNOTR (-1), The last call to fk2tex & buf does not have a trace.
!          = NOSTOP   ( 0), This is not the last call. a trace is in buf.
!          = STOPTR   ( 1), This is the last call & buf has a trace.
!
!  Outputs:
!
!   nready - The number of traces ready for the next processes. Since FK2TX
!            needs all the traces before it can process any, nready is 0
!            until ISTOP<>0, and then nready becomes the number of traces
!            output by FK2TX after 2-D transformation.
!
!  Call From:
!      CONTRO:FK2TEX
!
!  Externals:
!    GETFIL, FREFIL, PODISC, WRDISC, RDDISC : Disk I/O routines
!    EXIT, INAP, RLSEAP
!  Non-AP version:
!    FFTFWD. gnrfft
!    RECTC
!  AP version:
!    APINIT, APRLSE
!    RECT
!    VMOV, CFFT, CVNEG
!
!  Known Limitations:
!     The AP versio has not been tested & doesn't work because of the absence
!   of a Real FFT call
!
!  Modifications
!     10/11/88 ajh.   ( Added DSKSTRT to jstarti/jstarto)
!     12/20/88 ajh    ( Shift POLAR data in AP prior to conversion)
!   3/14/89 ajh Changed external names to 6 characters. Add space as first
!               character of PRINT statements
!               Passed binary Header values through READT
!  Apr 96 - Change txprestk from logical to integer counter
!         - Add unsorting of prestk data
! 27 May 96 - Pre stack with pads didn't work.
! 22 Nov 96 - Prestk didn't work when user gave the header file name
! 21 Dec 99 - Increase character*6 ctemp to character*20 ctemp
! 24 Jul 01 - Change SZAPMEM to 5000000
! 13 Jul 02 - Prevent negative disk address on first time after all traces have been read.
! 5 Feb 03 - ajh - add an additional stage and scratch file during
!            transformation but ensures that all writes to disk are
!             contiguous and sequential.
! 19 May 05 - Allow 32768 samples
! 31 Aug 05 - Add parameter KILL.  Zero dead traces when KILL YES.  Reset the
!             seismic trace identifier (word 15 - the dea trace flag) when KILL NO.
! 5 Jul 07 - Unsort the data only if prestk > 1 (match tx2fk)
! 15 Aug 07 - g95 doesn't do internal write to get ihdrpath
! 2 Oct 07 - That mod was botched.  rddisc needs istat!
! 2 Aug 08 - call getfil for a temp file didn't have space for the return name
! 22 Sep 08 - prestk of 1 no longer worked (Apr 96 change ?)
!           - change SZAPMEM to 10MW
! 26 Sep 08 - Use common numdat rather than segy header for nsamps
! 8 Apr 09 - Above wasn't done in all cases.
! 3 June 09 - Still not right.  Make the output nsamps the same as the original tx.
!-------------------------------------------------------------------------------
!
! INCLUDE FILES
! INCLUDE contro.inc
!.. Include file defining constants of use globally throughout SIOSEIS
!
! Last Modified 11/11/88
!    added DATINAP
! Define the sizes of some Large common blocks

      integer SZAPMEM, SZTRANP
      parameter (SZAPMEM = 10000000)                                     ! Size of /APMEM/ : AP memory
      parameter (SZTRANP = 262144)                                      ! Size of /TRANP/: Transpose array at 512x512
! parameter definitions for the stop signal istop
      integer STOPNOTR, STOPTR, NOSTOP
      parameter (STOPNOTR  = -1)                                        ! last call but no trace passed
      parameter (STOPTR    =  1)                                        ! last call and a trace passed
      parameter (NOSTOP    =  0)                                        ! normal call to the routine
!
! parameter for AP
      integer CLEARAP, USEAP, NOAP
      integer DATINAP
      parameter (USEAP    = 1)                                          ! There is an AP available
      parameter (NOAP     = 0)                                          ! No AP available
      parameter (CLEARAP  = 0)                                          ! Get data out of AP simulator
      parameter (DATINAP   = 1)                                         ! Data is in the AP
!
! Parameters for coord type
      integer CDRECT, CDPOLAR, CDPOLARU
      parameter ( CDRECT   = 1)
      parameter ( CDPOLAR  = 2)
      parameter ( CDPOLARU = 3)
!
! parameters for Windows
      integer BoxCar
      parameter (BoxCar = 5)
!
      logical txinit, fkinit, txed, fked, tmptxhdr
      integer ltxunt1, ltxunt2, lfkunt1, lfkunt2, txunit, ohdrtxfk,
     &        txprestk
      common /TXFKE/ txinit, fkinit, txed, fked, txunit, ltxunt1,
     &               ltxunt2, lfkunt1, lfkunt2, ohdrtxfk, tmptxhdr,
     &               txprestk, ntx2fk, nfk2tx, range
      integer     CRAYEBC, NORMEBC
      parameter ( CRAYEBC  = 400)
      parameter ( NORMEBC  = 2*CRAYEBC)
!
! BINARY HEADER
      integer     CRAYBIN, NORMBIN
      parameter ( CRAYBIN  =  50)                                       ! length of external disk image
      parameter ( NORMBIN  = 2*CRAYBIN)
!
!  The position of objects in the Binary header
      integer    NTRCPTR,IFMTPTR, IDTYPPTR, INKPTR, ITSIPTR
      integer    ITDELPTR, IVERSPTR
      parameter (NTRCPTR  =  7)                                         ! No of traces / gather
      parameter (IFMTPTR  = 13)                                         ! The SEGY Format of the data
      parameter (IDTYPPTR = 31)                                         ! The Domain/ID of the data e.q. T-X data
      parameter (INKPTR   = 32)                                         ! The No. of wavenumbers in an f-k dataset
      parameter (ITSIPTR  = 33)                                         ! Record of tx sample interval in us
      parameter (ITDELPTR = 34)                                         ! Record of tx time delay in ms.
      parameter (IVERSPTR = 35)                                         ! The SIOSEIS version number
!
!..Constants for SEGY Format (IFMTPTR)
      integer IBMFP, INT16, INT32, HOSTFP
      parameter (IBMFP  = 1)                                            ! IBM floating point
      parameter (INT32  = 2)
      parameter (INT16  = 3)
      parameter (HOSTFP = 5)                                            ! Host FP. In actuality Host FP >= 5
!
!.. Data Domains/Types (IDTYPPTR)
      integer    IDTX, IDFKRCT, IDFKPLR, IDFKPLRU
      parameter (IDTX     = 1)
      parameter (IDFKRCT  = 2)
      parameter (IDFKPLR  = 3)
      parameter (IDFKPLRU = 8)
!
!.. Version Number
      integer  CURVERS
      parameter( CURVERS = 210)
!
! TRACE HEADER
!.. Declare header length on external disk files. Internal length is given by
! Numhdr in common block READT.
      integer  CRAYTHDR, NORMTHDR
      parameter ( CRAYTHDR =  30)                                       ! Length of external disk image
      parameter ( NORMTHDR = 2*CRAYTHDR)
!
!    The positions of elements of the trace header are defined by elements of
! the common block SEGYPTR. This block is initialized in routine SETPTR. The
! position of elements differs on the CRAY since it does not allow mixing of
! Integer*16 & Integer*32 words but only has Integer*64.
!
      integer LLSEQPTR                                                  ! Trace Sequence No. within line
      integer LRSEQPTR                                                  ! Trace Sequence No. within reel
      integer LSHOTPTR                                                  ! Shot number or Stacked Number
      integer LSHTRPTR                                                  ! Trace number within Shot
      integer LRPNPTR                                                   ! RP or CDP number
      integer LRPTRPTR                                                  ! Trace No. within CDP
      integer ITRIDPTR                                                  ! Trace ID Live(1)/Dead(2)
      integer LDISTPTR                                                  ! Source to Receiver Distance
      integer LWBDPTR                                                   ! Water Bottom depth at source
      integer LSXCOPTR                                                  ! Source X co-ordinate
      integer LRXCOPTR                                                  ! Receiver X co-ordingate
      integer IDELMPTR                                                  ! Deep water delay in ms.
      integer ISTMPTR                                                   ! Start Mute time in ms.
      integer IENDMPTR                                                  !   End Mute time in ms
      integer ISAMPPTR                                                  ! Number of data samples in trace
      integer ISIPTR                                                    ! Sample interval of trace in us
      integer IYRPTR                                                    ! Year data was recorded
      integer IDAYPTR                                                   ! Day of year
      integer IHRPTR                                                    ! Hour of day
      integer IMINPTR                                                   ! Minute of hour
      integer ISECPTR                                                   ! Second of Minute
      integer IGMTPTR                                                   ! Time zone of header Local(1)/GMT(2)
      integer LDELSPTR                                                  ! Deep water delay in secs.
      integer LSMUSPTR                                                  ! Start of mute in seconds
      integer LEMUSPTR                                                  ! End of mute in seconds
      integer LSISPTR                                                   ! Sample interval in seconds
      integer LWBTSPTR                                                  ! Water bottom time in seconds
      integer LGATPTR                                                   ! No. of traces in stacked data(>0) or End of Gather(<0)
      integer LSSMSPTR                                                  ! Start of surgical mute in secs.
      integer LESMSPTR                                                  ! End of surgical mute in secs
      integer LSBPTR                                                    ! SeaBeam slant range
!
      common /SEGYPTR/ LLSEQPTR, LRSEQPTR, LSHOTPTR, LSHTRPTR, LRPNPTR,
     *                 LRPTRPTR, ITRIDPTR, LDISTPTR, LWBDPTR,  LSXCOPTR,
     *                 LRXCOPTR, IDELMPTR, ISTMPTR,  IENDMPTR, ISAMPPTR,
     *                 ISIPTR,   IYRPTR,   IDAYPTR,  IHRPTR,   IMINPTR,
     *                 ISECPTR,  IGMTPTR,  LDELSPTR, LSMUSPTR, LEMUSPTR,
     *                 LSISPTR,  LWBTSPTR, LGATPTR,  LSSMSPTR, LESMSPTR,
     *                 LSBPTR
!
!.. Define Constants for Trace Header
!
!.. Constants for Trace ID (ITRIDPTR)
      integer    LIVETR, DEADTR                                         ! Parameters for trace Type
      parameter (LIVETR  = 1)
      parameter (DEADTR  = 2)
!
!.. Define constants for use with the DISKIO subroutines getfil, frefil,
! podisc
! GETFIL constants
      integer    CREATTMP, CREATNEW, OPENOLD
      parameter (CREATTMP   = 1)                                        ! Create a temporary file
      parameter (CREATNEW   = 3)                                        ! Create a new named file
      parameter (OPENOLD    = 4)                                        ! Open an existing file
! FREFIL constants
      integer    RLDLCLS, RLCLS
      parameter (RLCLS   = 2)                                           ! Release and Close the file
      parameter (RLDLCLS = 3)                                           ! Release, delete and close
! PODISC constants
      integer    POSABS, POSREL, DSKSTRT
      parameter (POSABS     = 1)
      parameter (POSREL     = 2)
      parameter (DSKSTRT    = 0)                                        ! The starting position on the disk
! PROGRAM
!
      dimension buf(111),scr(111)
      integer*2 ibuf(111), iscr(111)
      integer   lbuf(111), lscr(111)
      integer   istop, nready
!
      parameter (MAXMEM = SZTRANP)                                      ! The transpose buffer size
      logical    NONORM, INVERSE
      parameter (INVERSE = .false., NONORM = .false.)
      integer    YES, NO
      parameter ( YES = 1, NO = 0)
      real   TXNORM
      parameter (TXNORM = 2.0)                                          ! Additional factor in tx normalization. This is
!                                                                       ! 2.0 for supplied routines
!
      integer parmunit, nwrds
      common /FK2TXC/ parmunit, nwrds                                   ! Pass parameters to execution phase.
!
      common /TRANSP/t(SZTRANP)
      INTEGER lt(1)
      EQUIVALENCE (t(1),lt(1))
      common /SIOAP/ iasgnd,irelse,in,iout,nextad,lapsiz,ifree,iuseap
      common /APMEM/ ap(SZAPMEM)
!
      integer origntr
      common /READT/ ilun,numhdr,numdat,iunhdr,ireelm,intrcs,ifmt,nskip,
     *               secs,lrenum,isrcf,idtype,
     *               nfskip, jform, itxsi, itxdel, nfktrc, origntr
      common /WRITET/ idum(5),ntrcs
!
      character*200 ctemp
      character*200 ihdrpath
      integer*2   txsius, msdelay
      integer     tpow, xpow, pow2
      integer     opad, lprint, kill
      integer     dskhdr1, dskhdr2, nspace1, nspace2
      integer     noutput
      logical     first, byrpnum
!
      save
!
      data first /.true./
      data lfor/1/, itrcno/1/
!
      istop = istop1
      nready = 0
      nfk2tx = nfk2tx + 1
!
!***********************                                ***********************
!                           Initialize the routine
!***********************                                ***********************
!
      if (first) then                                                   ! Initialize the routine
        first = .false.
!
        if ( fked) then
          call podisc(parmunit, POSABS, DSKSTRT)                        ! Read parameters from disk
          CALL rddisc( parmunit, ihdrpath, 25, istat )
          call rddisc(parmunit, lscr(26), nwrds-25, istat)
!          write(ihdrpath, '(25A4)') (lscr(i),i = 1, 25)
          opad   = lscr(26)
          lprint = lscr(27)
          kill = lscr(28)
        else
          ihdrpath = ' '
          opad     = NO
          lprint   = 0
          kill = 0
        endif
!
        if ( IAND(lprint,1).ne.0 ) then
          PRINT '(/A)',' FK2TEX Initialization Info'
          PRINT *, ' File Streams txunit: ', txunit,
     $              ' lfkunt1: ', lfkunt1,' lfkunt2: ',lfkunt2
          PRINT *,' ihdrpath = ',ihdrpath,' opad=',opad
        endif
        fkinit = .true.
!
!..                      Open 1st scratch file to accumulate input traces
        if (txinit) then
          ifunit = txunit                                               ! Use current scratch file if tx2fex was called
        else
          if ( (lfkunt1.ne.0).and.fked) then
            ifunit = lfkunt1
          else
            call getfil(CREATTMP,ifunit,ctemp,istat)                    ! Or get a new file
            if (istat.ne.0) then
              PRINT *,' *** FK2TX ERROR ***',
     $                     ' Could not open 1st Scratch file'
              STOP
            endif
          endif
        endif
!
!..                      Open 2nd scratch file to output traces after 2D FFT
        if ( fked.and.(lfkunt2.ne.0) ) then
          ixunit = lfkunt2
        else
          call getfil(CREATTMP, ixunit, ctemp, istat)                   ! File to hold the output
          if (istat.ne.0) then
            PRINT *,' *** FK2TX ERROR *** ',
     $                     ' Could not open 2nd Scratch file'
            STOP
          endif
        endif
!****
!****  If the user gave the header file name use it.
!****  If the user didn't give it in fk2tx but gave it in tx2fk, use
!****     the one from tx2fk.
!****  If the user didn't give it either place, use the one tx2fk used.
!****
        if (ihdrpath(1:10) .ne. ' ') then                               ! User gave header filename
           if  (ohdrtxfk.ne.0) then
               if (tmptxhdr) then
                  call frefil(RLDLCLS, ohdrtxfk, istat)
               else
                  call frefil(RLCLS, ohdrtxfk, istat)                   ! To avoid conflict
               endif
               ohdrtxfk = 0                                             ! close TX header file
           endif
           call getfil(OPENOLD, ihdrfktx, ihdrpath, istat)
           if (istat .ne. 0) then
              PRINT *,' *** FK2TX *** Could not open header file ',
     $           ihdrpath
              STOP
           endif
           tmptxhdr = .FALSE.
        else if (ohdrtxfk.ne.0) then                                    ! Use header file created by TXFK
           ihdrfktx = ohdrtxfk
        else
           byrpnum  = ( lbuf(LRPTRPTR) .ne. 0 )                          ! Form of trace indexing
           ihdrfktx = 0
        endif
!
!        inlen = ibuf(ISAMPPTR)                                          ! Length of the input trace
!        IF( inlen .LT. 0 ) inlen = lbuf(29)
        inlen = numdat
        nt    = inlen/2                                                 ! Length of the complex time series
        tpow  = pow2(nt)
        dskhdr1 = 0                                                     ! length of headers on 1st scratch
        dskhdr2 = 0                                                     ! length of headers on 2nd scratch
        nspace1 = dskhdr1 + inlen                                       ! Total trace length on disk
        nspace2 = dskhdr2 + nt
!
        if (inlen.ne.2**(tpow+1)) then
          PRINT 2000,' The length of the input FK data must be 2**N + 1'
          PRINT *, ' Input data length is ',inlen
          STOP
        endif
!
        if ((idtype.ne. IDFKRCT).AND.(idtype.ne.IDFKPLR)
     *                          .AND.(idtype.ne.IDFKPLRU) ) then
          PRINT 2000,' The input data must be in the FK domain.'
          PRINT *,   ' ID type of data is ',idtype
          STOP
        endif
      endif                                                             ! of fk2tex initialization
      IF( nfk2tx .EQ. 1 ) THEN
!          call podisc(ifunit, POSABS, DSKSTRT)
!****     the next use of ifunit is relative position -nspace1, which is a negative address!
          call podisc(ifunit, POSABS, nspace1 )
          call podisc(ixunit,POSABS,DSKSTRT)
          call podisc(ihdrfktx, POSABS, DSKSTRT)
      ENDIF
!
      if( istop.eq.STOPNOTR ) go to 500                                 ! Start doing 2-D transformation
!
!***********************                                ***********************
!*            Accumulate Traces & transform them from f to t
!***********************                                ***********************
!
!      nsamps = ibuf(ISAMPPTR)
!      IF( nsamps .EQ. -32768 ) nsamps = 32768
      nsamps = numdat
      if ( inlen.ne.nsamps ) then
          PRINT 2000
          PRINT *, ' Input number of samples for trace ', nfk2tx,' is ',
     *              inlen,' not the expected ',nsamps
          STOP
      endif
      call inap(buf(numhdr+1),nsamps)                                   ! Put everything in the ap
!
!.. If the FK domain is in polar coordinates, convert to rectangular coords
!.. On the forward FFT every other complex sample was negated to get
!.. -nyq -> 0 -> nyq ordering in frequency. Must undo it here
!
      if ( iuseap.eq. NOAP) then
          if( (idtype.eq.IDFKPLR).OR.(idtype.eq.IDFKPLRU) ) then
            do i = 1, nt+nt                                         ! Shift data prior to conversion
  190          ap(nextad+i-1) = ap(in-1+i)
            enddo
!            PRINT *,'RECTC in, nextad, nt',in, nextad, nt
!            PRINT *, 'ap(in): ', ap(in), 'ap(in+nt):',ap(in+nt)
!            PRINT *,'ap(nextad) (mod):',ap(nextad)
!            PRINT *,'ap(nextad+nt) (phase):',ap(nextad+nt)
            call rectc(nt,ap(in),ap(nextad),ap(nextad+nt))
          endif
!          call fftinv(ap(in),tpow)
          call fftfwd(ap(in),tpow)                                      ! FFT to time
          do 200 i = 1,nsamps,4
              ap(in+i-1) = -ap(in+i-1)
              ap(in+i)   = -ap(in+i)
  200     continue
      else
          if ( (idtype.eq.IDFKPLR).OR.(idtype.eq.IDFKPLRU) ) then
              call vmov(in,1,nextad,2,ncomps)
              call vmov(in+nsamps/2,1,nextad+1,2,ncomps)
              call rect(nextad,2,in,2,ncomps)
          endif
          call cfft(in, ncomps, -1)
          call cvneg(1,4,1,4,nsamps/4)
      endif
!
      iout = 0                                                          ! Force rlseap to get the data out of the ap
      call rlseap(buf(numhdr+1), nsamps)
!
      if(txinit)                                                        ! Write over untransformed trace if it exists
     $  call podisc(ifunit, POSREL, -nspace1 )
      call wrdisc(ifunit, buf(numhdr-dskhdr1+1), nspace1)
      IF( ntx2fk .EQ. 0 .AND. txprestk .GE. 1 ) istop = 1
!****  NOSTOP is 0
      if ( istop .eq. NOSTOP) RETURN
!
!***********************                                ***********************
!*      The data on disk has been transform from f to t, now do k to x.
!***********************                                ***********************
!
!.. There should be 2** nxo2 + 1 traces in the input dataset. spanning
!.. from 0 -> k (nyq). On output there will be nx = 2*nxo2 ranges
!
  500 continue
!
      nxo2 = nfk2tx -1
      xpow = pow2(nxo2)
      nx   = 2 * nxo2
      if (nxo2.ne.2**xpow) then
        PRINT 2000,' The entire set of FK traces must be input.'
        PRINT *,' Expecting ',2**xpow+1,' Traces.',
     *                     ' Instead received ', nxo2+1
        STOP
      endif
!
!.. Must pack the zero and nyquist traces into the zero wavenumber trace
      call podisc(ifunit, POSABS, DSKSTRT)                              ! Read zero wavenumber data
      call rddisc(ifunit, scr, nspace1, istat)
      istart = dskhdr1 + DSKSTRT + nxo2 * nspace1
      call podisc(ifunit, POSABS, istart)                               ! Read in nyquist data
      call rddisc(ifunit, t, nsamps, istat)
      do i = 1, nsamps, 2
  510    scr(dskhdr1+i+1) = t(i)
      enddo
      call podisc(ifunit, POSABS, DSKSTRT)
      call wrdisc(ifunit, scr, nspace1)

!..                           Create temporary file to hold partial time traces
!      call getfil( CREATTMP, igunit, name, istat)
      call getfil( CREATTMP, igunit, ctemp, istat)
      if (istat.ne.0) then
        PRINT 2000, ' Could not open temp file'
        STOP
      endif

      nsizec   = MAXMEM / nxo2                                           ! Find the no. of k traces that fit in t()
      if ( nsizec .gt. nsamps ) nsizec = nsamps
      ntimes  = nsamps / nsizec                                          ! This is the number of buffers per trace
      if (nsizec*ntimes.ne.nsamps) then
        PRINT 2000, ' Non zero remainder in k->x transform'
        STOP
      endif

      jstarti = dskhdr1 + DSKSTRT
      nsize   = nsizec
      nsizeo  = nsizec / 2

      do 1100 i = 1, ntimes
          istart = jstarti

          do 700 j = 1, nxo2
              call podisc(ifunit,POSABS,istart)                         ! Read part of the trace
              call rddisc(ifunit,scr,nsize,istat)
              indx = j*2 - 1
              do 600 k = 1, nsize, 2
                  t(indx)   = scr(k)
                  t(indx+1) = scr(k+1)
                  indx = indx + nx
  600         continue
              istart = istart + nspace1
  700     continue

          if (iuseap .eq. NOAP ) then
            indx = 1

            do 800 j = 1, nsizeo
              call gnrfft(t(indx), nx, inverse, nonorm)
              indx = indx + nx
  800       continue
          else
            PRINT 2000, ' AP FFT not installed'
            STOP
          endif

!..                             Gather the data back into partial time traces
          do 1000 j = 1, nx
              indx = j
              do 900 k = 1, nsizeo
                  scr(k) = t(indx)
                  indx   = indx + nx
  900         continue
              call wrdisc(igunit,scr,nsizeo)
 1000     continue

          jstarti = jstarti + nsize
 1100 continue

!...                            Assemble the partial trace into full traces
       nsizei  = nsizec/2
       nslice  = nsizei*nx
       jstarti = DSKSTRT - nsizei

       call podisc(ixunit,POSABS,DSKSTRT)

       do 1103 i = 1, nspace2
         scr(i) = 0.
 1103  continue
       do 1102 j = 1, nx
         indx   = dskhdr2 + 1
         nsizei = nsizec/2
         jstarti= jstarti + nsizei

         istart = jstarti

         do 1101 i = 1, ntimes
           call podisc(igunit,POSABS,istart)
           call rddisc(igunit,scr(indx),nsizei,istat)
           indx   = indx   + nsizei
           istart = istart + nslice
 1101    continue

         call wrdisc(ixunit,scr,nspace2)
 1102  continue

       call frefil(RLDLCLS, igunit,istat)                                ! & release the first scratch file

!
!..              Pass back the number of output traces
      if (opad .eq. YES ) then                                          ! Retain the padding traces and times
        nready = nx
      else
        nready = origntr
      endif
      noutput = nready
      nfk2tx   = 0
      call podisc(ixunit,POSABS,DSKSTRT)                                ! Rewind the tx file
!
!.. Recover & Reset variables in SEGY binary header through \READT\ common block
      txsius       = itxsi                                              ! Recover t-x sample interval in us
      msdelay      = itxdel                                             ! & the start time delay in ms
      delay        = msdelay/ 1000.
      si           = txsius/ 1000000.
      norig        = origntr
!
      itxsi        = 0                                                  ! Reset the parameters in /READT/
      itxdel       = 0
      idtype       = IDTX
      nfktrc       = 0
      origntr      = 0
!
!****
!****    If the data was prestack, get the original trace order which
!****  tx2fk appended to the header file.  Resort it and save it in
!****  the t array (transform) and hope that nobody blows it away.
!****

      IF( txprestk .GT. 1 ) THEN
          CALL podisc( ihdrfktx, POSABS, norig*numhdr )
          CALL rddisc( ihdrfktx, lscr, norig, istat )
          IF( istat .NE. norig ) THEN
              PRINT *,' ***  HELP  ***   fk2tx missing prestk sort.',
     &               norig,istat
              STOP
          ENDIF
          DO i = 1, norig
             scr(i) = lscr(i)
          ENDDO
          CALL indexx( norig, scr, lt )
          CALL podisc( ihdrfktx, POSABS, DSKSTRT )
      ENDIF
!
      RETURN
!
!************************                               ************************
!*         Get the complex data from disk and convert to real data.
!************************                               ************************
!
      ENTRY GETNXX(buf,lbuf,ibuf)
      nfk2tx  = nfk2tx + 1
      IF( txprestk .GT. 1 ) THEN
          CALL podisc( ixunit, POSABS, (lt(nfk2tx)-1)*nspace2 )
      ENDIF
      call rddisc(ixunit, buf(numhdr-dskhdr2+1), nspace2, istat)
      in     = 0                                                        ! Force inap to put the data in the "ap"
      scalar = TXNORM / ( nx * nt )
      do 1200 i = 1, nt                                                 ! Normalize the output trace
        buf(numhdr+i) = buf(numhdr+i) * scalar
 1200 continue
!
!..
      if ( ihdrfktx .ne. 0) then
        if (nfk2tx.gt.norig)
     $    call podisc(ihdrfktx, POSREL, -numhdr)
        call rddisc(ihdrfktx, buf, numhdr, istat)                       ! Read in stored trace header
!
      else                                                              ! Manufacture a trace header
         if ( byrpnum) then
           lbuf(LRPNPTR)  = lfor
           lbuf(LRPTRPTR) = itrcno
         else
           lbuf(LSHOTPTR) = lfor
           lbuf(LSHTRPTR) = itrcno
         endif
!
         if ( intrcs.eq.1 ) then                                        ! One trace per "gather"
            lfor   = lfor + 1
         else
            itrcno = itrcno + 1                                         ! Or index by trace no.
         endif
      endif
!
!
!.. No padding adjust times of data
!***  the output tx trace should be the same length as the input tx trace,
!***  so use nsamps from the trace header rather than common (which tx2fk changed)
      if ( (ihdrfktx .ne. 0) .and. (OPAD.eq.NO) ) then
           nshift = nint( buf(LDELSPTR) - delay) / si
!
!           long_nsamps = ibuf(ISAMPPTR)
!           IF( long_nsamps .EQ. -32768 ) long_nsamps = 32768
           CALL ushort2long( ibuf(ISAMPPTR), long_nsamps )
           if( nshift .gt. 0 ) then                                     ! Orignal start > delay
              ibuf(ISAMPPTR) = min ( nt - nshift, long_nsamps )
              numdat = min ( nt - nshift, long_nsamps )
              do 1250 i = numhdr + 1, numhdr + long_nsamps
                 buf(i) = buf(nshift + i)
 1250         continue
          else                                                          ! Increase start time to delay
              buf(LDELSPTR) = delay
              ibuf(IDELMPTR) = msdelay
              ibuf(ISAMPPTR) = min ( long_nsamps + nshift, nt)
              numdat = min ( long_nsamps + nshift, nt)
          endif
      else
          ibuf(IDELMPTR) = msdelay                                      ! Record start delay in ms
          buf(LDELSPTR) = delay                                         ! & in Secs
          ibuf(  ISIPTR) = txsius                                       ! Record sample interval in us
          buf( LSISPTR) = si                                            ! & in secs
          ibuf(ISAMPPTR) = nt                                           ! length of output in 4 byte words
          numdat = nt
      endif
!
      idtype = IDTX                                                     ! Set the idtype in /READT/
!
!**** dead traces get energy from adjacent traces.  FK filtered data probably
!**** should be rezeroed and the dead traces honored.  FK migrated dead traces
!**** are no longer dead.
!****
      IF( ibuf(ITRIDPTR) .EQ. 2 .AND. kill .EQ. 1 ) THEN
          DO i = 0, numdat-1
             buf(numdat+i) = 0.
          ENDDO
      ELSE
          ibuf(ITRIDPTR) = LIVETR
      ENDIF
      ibuf(ISTMPTR)  = 0                                                ! Zero all mute information
      ibuf(IENDMPTR) = 0
!      buf(LSMUSPTR) = 0.
!      buf(LEMUSPTR) = 0.
!      buf(LSSMSPTR) = 0.
!      buf(LESMSPTR) = 0.
!      if (nfk2tx .eq. noutput) then
!        call frefil(RLDLCLS, ixunit, istat)
!        if (tmptxhdr) then
!          call frefil(RLDLCLS, ihdrfktx, istat)
!        else
!          call frefil(RLCLS, ihdrfktx, istat)
!        endif
!      endif
      if (lprint.ne.0) PRINT *,' Exiting GETNXX nfk2tx =', nfk2tx
      RETURN
 2000 format (' ***  FK2TEX error  ***',(A))
      end