program main
  implicit none
  integer :: int, val

  print*, 'Enter an integer '
  read*,int

  call simple_function(int, val)
  print*, 'the result is ', val
contains
! here we define an internal subroutine i.e.
! contained in your program unit
subroutine simple_function(s,res)
  implicit none
  integer, intent(in) :: s   ! s is an input parameter
                             ! it cannot be modified
  integer,intent(out) :: res ! res is an output parameter

  res = 10*s
end subroutine simple_function
end program main


      subroutine virtual

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine summarizes data for subbasins with multiple HRUs and
!!    prints the daily output.hru file

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name          |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bactrolp      |# cfu/m^2     |less persistent bacteria transported to main
!!                                 |channel with surface runoff
!!    bactrop       |# cfu/m^2     |persistent bacteria transported to main
!!                                 |channel with surface runoff
!!    bactsedlp     |# cfu/m^2     |less persistent bacteria transported with
!!                                 |sediment in surface runoff
!!    bactsedp      |# cfu/m^2     |persistent bacteria transported with
!!                                 |sediment in surface runoff
!!    cbodu(:)      |mg/L          |carbonaceous biological oxygen demand of
!!                                 |surface runoff on current day in HRU
!!    chl_a(:)      |microgram/L   |chlorophyll-a concentration in runoff
!!                                 |on current day in HRU
!!    cklsp(:)      |
!!    curyr         |none          |current year of simulation
!!    da_ha         |ha            |area of watershed in hectares
!!    doxq(:)        |mg/L          |dissolved oxygen concentration in the
!!                                 |surface runoff on current day in HRU
!!    etday         |mm H2O        |actual amount of evapotranspiration that
!!                                 |occurs on day in HRU
!!    gw_q(:)       |mm H2O        |groundwater contribution to streamflow from
!!                                 |HRU on current day
!!    hhqday(:)     |mm H2O        |surface runoff for the hour in HRU
!!    hru_fr(:)     |none          |fraction of watershed area in HRU
!!    hru_fr(:)     |none          |fraction of subbasin area in HRU
!!    hru_ha(:)     |ha            |area of HRU in hectares
!!    ievent      |none          |rainfall/runoff code
!!                               |0 daily rainfall/curve number technique
!!                               |1 sub-daily rainfall/Green&Ampt/hourly
!!                               |  routing
!!                               |3 sub-daily rainfall/Green&Ampt/hourly routing
!!    ihout         |none          |hydrograph storage location number for
!!                                 |subbasin
!!    ihru          |none          |HRU number
!!    inum1         |none          |subbasin number
!!    iprint        |none          |print code:
!!                                 |0 monthly
!!                                 |1 daily
!!                                 |2 annually
!!    irtpest       |none          |the sequence number of the pesticide type
!!                                 |in NPNO(:) which is to be routed through
!!                                 |the watershed
!!    latno3(:)     |kg N/ha       |amount of NO3-N in lateral flow in HRU for
!!                                 |the day
!!    minpgw(:)     |kg P/ha       |soluble P loading to reach in groundwater
!!    mp            |none          |maximum number of pesticides used in
!!                                 |watershed
!!    mvaro         |none          |max number of variables routed through the
!!                                 |reach
!!    no3gw(:)      |kg N/ha       |nitrate loading to reach in groundwater
!!    nyskip        |none          |number of years to skip output summarization
!!                                 |and printing
!!    peakr         |m^3/s         |peak runoff rate
!!    pet_day       |mm H2O        |potential evapotranspiration for day in HRU
!!    precipday     |mm H2O        |amount of water reaching soil surface
!!    qday          |mm H2O        |surface runoff loading to main channel for
!!                                 |day in HRU
!!    qdfr          |none          |fraction of water yield that is surface
!!                                 |runoff
!!    qdr(:)        |mm H2O        |total amount of water entering main channel
!!                                 |from HRU for the day
!!    hrupstd(:,1,:)|mg pst        |amount of pesticide type in surface runoff
!!                                 |contribution to stream from HRU on day
!!                                 |(in solution)
!!    hrupstd(:,2,:)|mg pst        |amount of pesticide type in surface runoff
!!                                 |contribution to stream from HRU on day
!!                                 |(sorbed to sediment)
!!    sedminpa(:)   |kg P/ha       |amount of active mineral phosphorus sorbed to
!!                                 |sediment in surface runoff in HRU for day
!!    sedminps(:)   |kg P/ha       |amount of stable mineral phosphorus sorbed to
!!                                 |sediment in surface runoff in HRU for day
!!    sedorgn(:)    |kg N/ha       |amount of organic nitrogen in surface runoff
!!                                 |in HRU for the day
!!    sedorgp(:)    |kg P/ha       |amount of organic phosphorus in surface
!!                                 |runoff in HRU for the day
!!    sedyld(:)     |metric tons   |daily soil loss caused by water erosion
!!    sepbtm(:)     |mm H2O        |seepage leaving the bottom of the soil
!!                                 |profile on day in HRU
!!    snomlt        |mm H2O        |amount of water in snow melt for the day in
!!                                 |HRU
!!    sol_actp(:,:) |kg P/ha       |amount of phosphorus stored in the
!!                                 |active mineral phosphorus pool
!!    sol_aorgn(1,:)|kg N/ha       |amount of nitrogen stored in the active
!!                                 |organic (humic) nitrogen pool in first soil
!!                                 |layer of HRU
!!    sol_bd(1,:)   |Mg/m^3        |bulk density of top soil layer in HRU
!!    sol_fon(1,:)  |kg N/ha       |amount of nitrogen stored in the fresh
!!                                 |organic (residue) pool in first soil layer
!!                                 |of HRU
!!    sol_fop(1,:)  |kg P/ha       |amount of phosphorus stored in the fresh
!!                                 |organic (residue) pool in first soil layer
!!                                 |of HRU
!!    sol_orgn(1,:) |kg N/ha       |amount of nitrogen stored in the stable
!!                                 |organic N pool in first soil layer of HRU
!!    sol_orgp(1,:) |kg P/ha       |amount of phosphorus stored in the organic
!!                                 |P pool in first soil layer of HRU
!!    sol_pst(:,:,1)|kg/ha         |amount of pesticide in first soil layer in
!!                                 |HRU
!!    sol_stap(1,:) |kg P/ha       |amount of phosphorus in the soil layer
!!                                 |stored in the stable mineral phosphorus pool
!!    sol_sw(:)     |mm H2O        |amount of water in soil profile in HRU
!!    soxy          |mg/L          |saturation dissolved oxygen concentration
!!    sub_fr(:)     |none          |fraction of watershed area in subbasin
!!    subp(:)       |mm H2O        |precipitation for the day in HRU
!!    surfq(:)      |mm H2O        |amount of water in surface runoff generated
!!                                 |on day in HRU
!!    surqno3(:)    |kg N/ha       |amount of NO3-N in surface runoff in HRU for
!!                                 |the day
!!    surqsolp(:)   |kg P/ha       |amount of soluble phosphorus in surface
!!                                 |runoff in HRU for the day
!!    tloss         |mm H2O        |amount of water removed from surface runoff
!!                                 |via transmission losses on day in HRU
!!    tmpav(:)      |deg C         |average air temperature on current day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    aird(:)     |mm H2O        |amount of water applied to HRU on current
!!                               |day
!!    deepirr(:)  |mm H2O        |amount of water removed from deep aquifer
!!                               |for irrigation
!!    ovrlnd(:)   |mm H2O        |amount of overland flow onto HRU on day
!!    potflwi(:)  |m^3 H2O       |water entering pothole on day
!!    potsedi(:)  |metric tons   |sediment entering pothole on day
!!    shallirr(:) |mm H2O        |amount of water removed from shallow aquifer
!!                               |for irrigation
!!    shyd(1,:)   |m^3 H2O       |water
!!    shyd(2,:)   |metric tons   |sediment or suspended solid load
!!    shyd(3,:)   |kg N          |organic nitrogen
!!    shyd(4,:)   |kg P          |organic phosphorus
!!    shyd(5,:)   |kg N          |nitrate
!!    shyd(6,:)   |kg P          |soluble phosphorus
!!    shyd(7,:)   |kg P          |soluble pesticides
!!    shyd(8,:)   |kg P          |sorbed pesticides
!!    sub_bd(:)   |Mg/m^3        |average bulk density for top 10 mm of soil
!!                               |in subbasin
!!    sub_gwno3(:)|kg N/ha       |nitrate loading in groundwater from subbasin
!!    sub_gwminp(:)|kg N/ha      |soluble P loading in groundwater from subbasin
!!    sub_minp(:) |kg P/ha       |amount of phosphorus stored in all mineral
!!                               |pools sorbed to sediment
!!    submono(1,:)|mm H2O        |precipitation in subbasin for month
!!    submono(2,:)|mm H2O        |snow melt in subbasin for month
!!    submono(3,:)|mm H2O        |surface runoff loading in subbasin for month
!!    submono(4,:)|mm H2O        |water yield from subbasin for month
!!    submono(5,:)|mm H2O        |potential evapotranspiration in subbasin for
!!                               |month
!!    submono(6,:)|mm H2O        |actual evapotranspiration in subbasin for
!!                               |month
!!    submono(7,:)|metric tons/ha|sediment yield from subbasin for month
!!    submono(8,:)|kg N/ha       |organic N loading from subbasin for month
!!    submono(9,:)|kg P/ha       |organic P loading from subbasin for month
!!    submono(10,:)|kg N/ha       |NO3 loading from surface runoff in subbasin
!!                               |for month
!!    submono(11,:)|kg P/ha       |soluble P loading from subbasin for month
!!    submono(12,:)|mm H2O        |groundwater loading from subbasin for month
!!    submono(13,:)|mm H2O        |percolation out of soil profile in subbasin
!!                               |for month
!!    submono(14,:)|kg P/ha       |loading to reach of mineral P attached to
!!                               |sediment from subbasin for month
!!    sub_bactlp(:)|# cfu/m^2     |less persistent bacteria in surface runoff
!!                               |for day in subbasin
!!    sub_bactp(:)|# cfu/m^2     |persistent bacteria in surface runoff for
!!                               |day in subbasin
!!    sub_cbod(:) |kg O2         |carbonaceous biological oxygen demand on day
!!                               |for subbasin
!!    sub_chl(:)  |kg chl-a      |chlorophyll-a in water yield on day in
!!                               |subbasin
!!    sub_dox(:)  |kg O2         |dissolved oxygen loading on day for subbasin
!!    sub_etday(:)|mm H2O        |actual evapotranspiration on day in subbasin
!!    sub_gwq(:)  |mm H2O        |groundwater flow on day in subbasin
!!    sub_hhsedy(:,:) |metric tons |sediment yield for the time step in subbasin
!!    sub_hhwtmp(:,:) |deg C     |water temperature for the time step in subbasin
!!    sub_latno3(:)|kg N/ha       |NO3-N in lateral flow on day in subbasin
!!    sub_no3(:)  |kg N/ha       |NO3-N in surface runoff on day in subbasin
!!    sub_orgn(:) |kg N/ha       |total organic N in first soil layer of
!!                               |subbasin
!!    sub_orgp(:) |kg P/ha       |total organic P in first soil layer of
!!                               |subbasin
!!    sub_pet(:)  |mm H2O        |potential evapotranspiration for day in
!!                               |subbasin
!!    sub_precip(:)|mm H2O        |effective precipitation for the day in
!!                               |subbasin
!!    sub_pst(:,:)|kg pst/ha     |amount of pesticide type in forest soil layer
!!                               |in subbasin
!!    sub_qd(:)   |mm H2O        |surface runoff loading to main channel on
!!                               |day in subbasin
!!    sub_sedpa(:)|kg P/ha       |amount of active mineral P attached to sediment
!!                               |removed in surface runoff on day in subbasin
!!    sub_sedps(:)|kg P/ha       |amount of stable mineral P attached to sediment
!!                               |removed in surface runoff on day in subbasin
!!    sub_sedy(:) |metric tons   |sediment yield for the day in subbasin
!!    sub_sep(:)  |mm H2O        |seepage from bottom of soil profile on day
!!                               |in subbasin
!!    sub_snom(:) |mm H2O        |snow melt on day in subbasin
!!    sub_solp(:) |kg P/ha       |soluble P in surface runoff on day in subbasin
!!    sub_solpst(:)|mg pst        |pesticide in solution in surface runoff on day
!!                               |in subbasin
!!    sub_sorpst(:)|mg pst        |pesticide sorbed to sediment in surface
!!                               |runoff on day in subbasin
!!    sub_subp(:) |mm H2O        |precipitation for day in subbasin
!!    sub_sumfc(:)|mm H2O        |amount of water in soil at field capacity in
!!                               |subbasin
!!    sub_surfq(:)|mm H2O        |surface runoff generated on day in subbasin
!!    sub_sw(:)   |mm H2O        |amount of water in soil in subbasin
!!    sub_tran(:) |mm H2O        |transmission losses for day in subbasin
!!    sub_ubnrunoff(:,:)|mm H2O  |surface runoff from urban impervious cover in subbasin
!!    sub_ubntss(:,:)|metric tons  |TSS loading from urban impervious cover in subbasin
!!    sub_wyld(:) |mm H2O        |water yield on day in subbasin
!!    sub_yorgn(:)|kg N/ha       |organic N in surface runoff on day in subbasin
!!    sub_yorgp(:)|kg P/ha       |organic P in surface runoff on day in subbasin
!!    ubnrunoff(:) |mm H2O      |surface runoff from urban impervious cover
!!    ubntss(:)    |metric tons    |TSS loading from urban impervious cover
!!    varoute(1,:) |deg C        |temperature
!!    varoute(2,:) |m^3 H2O      |water
!!    varoute(3,:) |metric tons  |sediment or suspended solid load
!!    varoute(4,:) |kg N         |organic nitrogen
!!    varoute(5,:) |kg P         |organic phosphorus
!!    varoute(6,:) |kg N         |nitrate
!!    varoute(7,:) |kg P         |mineral phosphorus
!!    varoute(11,:)|mg pst       |pesticide in solution
!!    varoute(12,:)|mg pst       |pesticide sorbed to sediment
!!    varoute(13,:)|kg           |chlorophyll-a
!!    varoute(16,:)|kg           |carbonaceous biological oxygen demand
!!    varoute(17,:)|kg           |dissolved oxygen
!!    varoute(18,:)|# cfu/100ml  |persistent bacteria
!!    varoute(19,:)|# cfu/100ml  |less persistent bacteria
!!    wcklsp(:)   |
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    cnv         |none          |conversion factor (mm/ha => m^3)
!!    baseflw     |mm H2O        |difference in total loading and surface runoff
!!                               |loading
!!    ii          |none          |counter
!!    j           |none          |HRU number
!!    kk          |none          |counter
!!    sb          |none          |subbasin number
!!    sub_ha      |ha            |area of subbasin in hectares
!!    sub_hwyld(:)|mm H2O        |water yield from subbasin during hour
!!    wtmp        |deg C         |temperature of water
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    SWAT: hruday, impndday, subday
!!    SWAT: alph, pkq, ysed, enrsb, pesty, orgn, psed
!!    SWAT: Tair

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j, sb, kk, ii
      real*8 :: cnv, sub_ha, wtmp, baseflw, bf_fr,hr
      real*8 :: sub_hwyld(nstep), hqd(4*nstep), hsd(4*nstep),hqdtst(nstep)   ! hqd, hsd locally defined. J.Jeong 4/26/2009

      j = ihru
      sb = inum1
      cnv = hru_ha(j) * 10.

!! write daily HRU output
      if ((iprint==1.or.iprint==3) .and. curyr > nyskip) call hruday
      if ((iprint==1.or.iprint==3) .and. curyr > nyskip) call impndday

!! sum HRU results for subbasin
      if (sb > 0) then
      !! subbasin averages: water
        sub_subp(sb) = sub_subp(sb) + subp(j) * hru_fr(j)
        sub_snom(sb) = sub_snom(sb) + snomlt * hru_fr(j)
        sub_pet(sb) = sub_pet(sb) + pet_day * hru_fr(j)
        sub_etday(sb) = sub_etday(sb) + etday * hru_fr(j)
        sub_sumfc(sb) = sub_sumfc(sb) + sol_sumfc(j) * hru_fr(j)
        sub_sw(sb) = sub_sw(sb) + sol_sw(j) * hru_fr(j)
        sub_sep(sb) = sub_sep(sb) + sepbtm(j) * hru_fr(j)
        sub_qd(sb) = sub_qd(sb) + qday * hru_fr(j)
        sub_gwq(sb) = sub_gwq(sb) + gw_q(j) * hru_fr(j)
        sub_gwq_d(sb) = sub_gwq_d(sb) + gw_qdeep(j) * hru_fr(j)
        sub_wyld(sb) = sub_wyld(sb) + qdr(j) * hru_fr(j)
        sub_latq(sb) = sub_latq(sb) + latq(j) * hru_fr(j)
        sub_subp_dt(sb,:) = sub_subp_dt(sb,:) + rainsub(j,:) * hru_fr(j) !!urban modeling by J.Jeong

      !! subbasin averages: sub-daily water for URBAN MODELING
        if (ievent>0) then
        do ii = 1, nstep  !! step Oct. 18, 2007

          if (bmpdrain(j)==1) then
           !Urban HRUs where runoff drains to bmps
            sub_ubnrunoff(sb,ii) = sub_ubnrunoff(sb,ii)
     &         + (hhqday(ii) + ubnrunoff(ii)) * hru_fr(j) !J.Jeong
		    if (sub_ubnrunoff(sb,ii) < 1.e-20) sub_ubnrunoff(sb,ii) = 0.
            sub_ubntss(sb,ii) = sub_ubntss(sb,ii)
     &         + (hhsedy(j,ii) + ubntss(ii)) * hru_fr(j) !J.Jeong
		    if (sub_ubntss(sb,ii) < 1.e-20) sub_ubntss(sb,ii) = 0.
          else
            !Urban/non-urban HRUs that do not make runoff to BMPs
            sub_hhqd(sb,ii) = sub_hhqd(sb,ii)
     &         + (hhqday(ii) + ubnrunoff(ii)) * hru_fr(j)
 		      if (sub_hhqd(sb,ii) < 1.e-20) sub_hhqd(sb,ii) = 0.
            sub_hhsedy(sb,ii) = sub_hhsedy(sb,ii)
     &          + (hhsedy(j,ii) + ubntss(ii)) * hru_fr(j)
   	      if (sub_hhsedy(sb,ii) < 1.e-20) sub_hhsedy(sb,ii) = 0.
          end if
          !air temperature
          hr = ii * idt / 60.
          sub_atmp(sb,ii) = sub_atmp(sb,ii) + Tair(hr,j) * hru_fr(j)
        end do
        end if

      !! subbasin averages: sediment
        sub_sedy(sb) = sub_sedy(sb) + sedyld(j)
        sub_dsan(sb) = sub_dsan(sb) + sanyld(j)
        sub_dsil(sb) = sub_dsil(sb) + silyld(j)
        sub_dcla(sb) = sub_dcla(sb) + clayld(j)
        sub_dsag(sb) = sub_dsag(sb) + sagyld(j)
        sub_dlag(sb) = sub_dlag(sb) + lagyld(j)

        surqno3(j) = dmax1(1.e-12,surqno3(j))
        latno3(j) = dmax1(1.e-12,latno3(j))
        no3gw(j) = dmax1(1.e-12,no3gw(j))
        surqsolp(j) = dmax1(1.e-12,surqsolp(j))
        minpgw(j) = dmax1(1.e-12,minpgw(j))
        sedorgn(j) = dmax1(1.e-12,sedorgn(j))
        sedorgp(j) = dmax1(1.e-12,sedorgp(j))
        sedminpa(j) = dmax1(1.e-12,sedminpa(j))
        sedminps(j) = dmax1(1.e-12,sedminps(j))

      !! subbasin averages: nutrients
        if (latno3(j) < 1.e-6) latno3(j) = 0.0
        sub_no3(sb) = sub_no3(sb) + surqno3(j) * hru_fr(j)
        sub_latno3(sb) = sub_latno3(sb) + latno3(j) * hru_fr(j)
        sub_tileno3(sb) = sub_tileno3(sb) + tileno3(j) * hru_fr(j)
 !       sub_tileq(sb) = sub_tileq(sb) + tileq(j) * hru_fr(j)      !! jane f
        sub_tileq(sb) = sub_tileq(sb) + qtile * hru_fr(j)          !! jane f
        sub_vaptile(sb) = sub_vaptile(sb) + vap_tile * hru_fr(j)   !! jane f
        sub_gwno3(sb) = sub_gwno3(sb) + no3gw(j) * hru_fr(j)
        sub_solp(sb) = sub_solp(sb) + surqsolp(j) * hru_fr(j)
        sub_gwsolp(sb) = sub_gwsolp(sb) + minpgw(j) * hru_fr(j)
        sub_yorgn(sb) = sub_yorgn(sb) + sedorgn(j) * hru_fr(j)
        sub_yorgp(sb) = sub_yorgp(sb) + sedorgp(j) * hru_fr(j)
        sub_sedpa(sb) = sub_sedpa(sb) + sedminpa(j) * hru_fr(j)
        sub_sedps(sb) = sub_sedps(sb) + sedminps(j) * hru_fr(j)

      !! subbasin averages: pesticides
        if (irtpest > 0) then
          sub_solpst(sb) = sub_solpst(sb) + hrupstd(irtpest,1,j) +
     &                                              hrupstd(irtpest,4,j)
          sub_sorpst(sb) = sub_sorpst(sb) + hrupstd(irtpest,2,j)
        end if

      !! subbasin averages: bacteria
        sub_bactp(sb) = sub_bactp(sb) + (bactrop + bactsedp)
     &                                                     * hru_fr(j)
        sub_bactlp(sb) = sub_bactlp(sb) + (bactrolp + bactsedlp)
     &                                                     * hru_fr(j)

      !! subbasin averages: water quality indicators
        sub_chl(sb) = sub_chl(sb) + chl_a(j) * (qday * qdfr * cnv)
     &                                                           * 1.e-6

        sub_cbod(sb) = sub_cbod(sb) + cbodu(j) * (qdr(j) * qdfr * cnv)
     &                                                           * 1.e-3
        sub_dox(sb) = sub_dox(sb) + (doxq(j) * (qdr(j) * qdfr * cnv) +
     &               soxy * (qdr(j) * (1. - qdfr) * cnv)) * 1.e-3
      !! subbasin averages: water temperature
      !! Stefan and Preudhomme. 1993.  Stream temperature estimation
      !! from air temperature.  Water Res. Bull. p. 27-45
        wtmp = 0.
        wtmp = 5.0 + 0.75 * tmpav(j)
        sub_wtmp(sb) = sub_wtmp(sb) + wtmp * qdr(j) * hru_fr(j)

      !! subbasin averages used in subbasin sediment calculations
        wcklsp(sb) = wcklsp(sb) + cklsp(j) * hru_fr(j)
        sub_precip(sb) = sub_precip(sb) + precipday * hru_fr(j)
        sub_surfq(sb) = sub_surfq(sb) + surfq(j) * hru_fr(j)
        sub_tran(sb) = sub_tran(sb) + tloss * hru_fr(j)
        sub_bd(sb) = sub_bd(sb) + sol_bd(1,j) * hru_fr(j)
	  if (cswat == 0) then
        sub_orgn(sb) = sub_orgn(sb) + (sol_orgn(1,j) +
     &                      sol_aorgn(1,j) + sol_fon(1,j)) * hru_fr(j)
	  end if
	  if (cswat == 1) then
	  sub_orgn(sb) = sub_orgn(sb) + (sol_n(1,j) + sol_fon(1,j) +
     &					sol_mn(1,j)) * hru_fr(j)
	  end if
	  !!add by zhang
	  !!======================
	  if (cswat == 2) then
	  sub_orgn(sb) = sub_orgn(sb) + (sol_LMN(1,j) + sol_LSN(1,j) +
     &					sol_HPN(1,j)+sol_HSN(1,j)+sol_BMN(1,j)) * hru_dafr(j)
	  end if
	  !!add by zhang
	  !!======================
       ! do kk = 1, mp
       ! sub_pst(kk,sb) = sub_pst(kk,sb) + sol_pst(k,j,1) * hru_fr(j)
       ! end do
      end if
!! end subbasin summarization calculations

!! perform subbasin level operations after processing last HRU in subbasin
      if (iihru == hrutot(sb)) then
        sub_ha = 0.
        sub_ha = da_ha * sub_fr(sb)

        !! calculate subbasin average values for weighted parameters
        if (subfr_nowtr(sb) > 1.e-6) then
            sub_snom(sb) = sub_snom(sb) / subfr_nowtr(sb)
            sub_sumfc(sb) = sub_sumfc(sb) / subfr_nowtr(sb)
            sub_sw(sb) = sub_sw(sb) / subfr_nowtr(sb)
            sub_sep(sb) = sub_sep(sb) / subfr_nowtr(sb)
            sub_qd(sb) = sub_qd(sb) / subfr_nowtr(sb)
            sub_gwq(sb) = sub_gwq(sb) / subfr_nowtr(sb)
            sub_gwq_d(sb) = sub_gwq_d(sb) / subfr_nowtr(sb)
            sub_wyld(sb) = sub_wyld(sb) / subfr_nowtr(sb)
            sub_latq(sb) = sub_latq(sb) / subfr_nowtr(sb)
            sub_tileq(sb) = sub_tileq(sb) / subfr_nowtr(sb)
        else
            sub_snom(sb) = 0.0
            sub_sumfc(sb) = 0.0
            sub_sw(sb) = 0.0
            sub_sep(sb) = 0.0
            sub_qd(sb) = 0.0
            sub_gwq(sb) = 0.0
            sub_wyld(sb) = 0.0
            sub_latq(sb) = 0.0
            sub_tileq(sb) = 0.0
        end if

!        sub_subp(sb) = sub_subp(sb) / sub_fr(sb)
!        sub_pet(sb) = sub_pet(sb) / sub_fr(sb)
!        sub_etday(sb) = sub_etday(sb) / sub_fr(sb)
!
        if (ievent > 0) then
!
         ! subdaily surface runoff, upland sediment for the subbasin
!         sub_ubnrunoff(sb,1:nstep) = sub_ubnrunoff(sb,1:nstep)
!     &        / sub_fr(sb)
!         sub_ubntss(sb,1:nstep) = sub_ubntss(sb,1:nstep) / sub_fr(sb)
!
!         sub_hhqd(sb,1:nstep) = sub_hhqd(sb,1:nstep) / sub_fr(sb)
!         sub_hhsedy(sb,1:nstep) = sub_hhsedy(sb,1:nstep)
!     &        / sub_fr(sb)
!         sub_atmp(sb,1:nstep) = sub_atmp(sb,1:nstep) / sub_fr(sb)

        !----------------------------------------------------
        ! Simulate distributed urban BMPs in the subbasin
         call distributed_bmps
        !----------------------------------------------------

        !add urban runoff and non-urban runoff
         sub_hhqd(sb,1:nstep) = sub_hhqd(sb,1:nstep)
     &         + sub_ubnrunoff(sb,1:nstep)
         sub_hhsedy(sb,1:nstep) = sub_hhsedy(sb,1:nstep)
     &         + sub_ubntss(sb,1:nstep)

          !route surface runoff in the subbasin
         hqd = 0.; hsd = 0.      !! added on Oct. 22, 2007
         do ii = 1, nstep
            do ib = 1, itb(sb)
              hqd(ib+ii-1) = hqd(ib+ii-1) + sub_hhqd(sb,ii) * uh(sb,ib)
              hsd(ib+ii-1) = hsd(ib+ii-1) + sub_hhsedy(sb,ii) *
     &           uh(sb,ib)
            end do
         end do

         do ii = 1, itb(sb)
            hqd(ii) = hqd(ii) + hqdsave(sb,ii)
            hsd(ii) = hsd(ii) + hsdsave(sb,ii)
         end do

	   sub_hhqd(sb,1:nstep) = max(0.,hqd(1:nstep))
	   sub_hhsedy(sb,1:nstep) = max(0.,hsd(1:nstep))

         do ii = 1, itb(sb)
            hqdsave(sb,ii) = hqd(ii+nstep)  ! save flow after midnight for next day J.Jeong 4/17/2009
            hsdsave(sb,ii) = hsd(ii+nstep)  ! sediment. J.Jeong 4/22/2009
         end do
        end if

!        sub_no3(sb) = sub_no3(sb) / sub_fr(sb)
!       sub_latno3(sb) = sub_latno3(sb) / sub_fr(sb)
!        sub_tileno3(sb) = sub_tileno3(sb) / sub_fr(sb)
!        sub_gwno3(sb) = sub_gwno3(sb) / sub_fr(sb)
!        sub_solp(sb) = sub_solp(sb) / sub_fr(sb)
!        sub_gwsolp(sb) = sub_gwsolp(sb) / sub_fr(sb)
!        sub_yorgn(sb) = sub_yorgn(sb) / sub_fr(sb)
!        sub_yorgp(sb) = sub_yorgp(sb) / sub_fr(sb)
!        sub_sedpa(sb) = sub_sedpa(sb) / sub_fr(sb)
!        sub_sedps(sb) = sub_sedps(sb) / sub_fr(sb)

!        sub_bactp(sb) = sub_bactp(sb) / sub_fr(sb)
!        sub_bactlp(sb) = sub_bactlp(sb) / sub_fr(sb)

        if (sub_wyld(sb) > 0.1) then
          sub_wtmp(sb) = sub_wtmp(sb) / sub_wyld(sb)
        else
          sub_wtmp(sb) = 0.0
        end if

!        wcklsp(sb) = wcklsp(sb) / sub_fr(sb)
!        sub_precip(sb) = sub_precip(sb) / sub_fr(sb)
!        sub_surfq(sb) = sub_surfq(sb) / sub_fr(sb)
!        sub_tran(sb) = sub_tran(sb) / sub_fr(sb)
!        sub_bd(sb) = sub_bd(sb) / sub_fr(sb)
!        sub_orgn(sb) = sub_orgn(sb) / sub_fr(sb)
!        sub_orgp(sb) = sub_orgp(sb) / sub_fr(sb)
!        sub_minp(sb) = sub_minp(sb) / sub_fr(sb)
!        sub_minpa(sb) = sub_minpa(sb) / sub_fr(sb)
!        sub_minps(sb) = sub_minps(sb) / sub_fr(sb)

        !! assign reach loadings for subbasin
         !! zero out hydrograph storage locations
         do ii = 1, mvaro
           varoute(ii,ihout) = 0.
         end do

         !! set values for different routing variables
         !! storage locations set to zero are not currently used
         varoute(1,ihout) = sub_wtmp(sb)                 !!wtmp
         varoute(2,ihout) = sub_wyld(sb) * sub_ha * 10.  !!qdr m3/d
         varoute(3,ihout) = sub_sedy(sb)                 !!sedyld
         varoute(4,ihout) = sub_yorgn(sb) * sub_ha       !!sedorgn
         varoute(5,ihout) = (sub_yorgp(sb) + sub_sedps(sb) +
     &                  sub_sedpa(sb)) * sub_ha          !!sedorgp & sedminps
                                                  !!sedorgp & sedminps
         varoute(6,ihout) = (sub_no3(sb) + sub_latno3(sb) +
     &      sub_tileno3(sb) + sub_gwno3(sb)) * sub_ha          !!surqno3 & latno3 & no3gw
         varoute(7,ihout) = (sub_solp(sb) + sub_gwsolp(sb)) * sub_ha   !!surqsolp & minpgw & sedminpa
         varoute(8,ihout) = 0.
         varoute(9,ihout) = 0.
         varoute(10,ihout) = 0.
         varoute(11,ihout) = sub_solpst(sb)              !!sol pst
         varoute(12,ihout) = sub_sorpst(sb)              !!sorb pst
         varoute(13,ihout) = sub_chl(sb)                 !!chl_a
         varoute(14,ihout) = 0.                          !! NH3
         varoute(15,ihout) = 0.                          !! NO2
         varoute(16,ihout) = sub_cbod(sb)                !!cbodu
         varoute(17,ihout) = sub_dox(sb)                 !!doxq & soxy
         if (varoute(2,ihout) > .1) then
          varoute(18,ihout) = sub_bactp(sb) * sub_ha / varoute(2,ihout) !cfu/100ml
          varoute(19,ihout) = sub_bactlp(sb) * sub_ha / varoute(2,ihout)
         end if
         varoute(20,ihout) = 0.                            !! cmetal #1
         varoute(21,ihout) = 0.                            !! cmetal #2
         varoute(22,ihout) = 0.                            !! cmetal #3
         varoute(23,ihout) = sub_dsan(sb)                  !! detached sand
         varoute(24,ihout) = sub_dsil(sb)                  !! detached silt
         varoute(25,ihout) = sub_dcla(sb)                  !! detached clay
         varoute(26,ihout) = sub_dsag(sb)                  !! detached sml ag
         varoute(27,ihout) = sub_dlag(sb)                  !! detached lrg ag
         varoute(29,ihout) = sub_qd(sb) * sub_ha * 10.     !! surface runoff
         varoute(30,ihout) = sub_latq(sb) * sub_ha * 10.   !! lateral flow
         varoute(31,ihout) = sub_tileq(sb) * sub_ha * 10.  !! tile flow
         varoute(32,ihout) = sub_gwq(sb) * sub_ha * 10.    !! groundwater flow
         !! varoute array has space for 33 different routing components

         !! sum variables for hyd.out
         do ii = 1, 6
           shyd(ii,ihout) = shyd(ii,ihout) + varoute(ii+1,ihout)
         end do
         shyd(7,ihout) = shyd(7,ihout) + varoute(11,ihout)
         shyd(8,ihout) = shyd(8,ihout) + varoute(12,ihout)

        !! sub-daily calculations
        if (ievent > 0) then
          !! determine the daily total base flow
          baseflw = sub_gwq(sb) + sub_latq(sb) + sub_tileq(sb)
          if (baseflw < 0.) baseflw = 0.

         ! Urban modeling by J.Jeong 4/23/2008
         ! Daily water yield is unevenly distributed over time
         ! based on fractional rainfall of the day
          sub_hwyld = 0.
          do ii = 1, nstep
            if(baseflw>0.1 .and. sum(precipdt)>0.1) then
              bf_fr = bf_flg * precipdt(ii+1) / sum(precipdt) +
     &         (1. - bf_flg) * 1. / nstep
              sub_hwyld(ii) = sub_hhqd(sb,ii) + baseflw * bf_fr
            else
              sub_hwyld(ii) = sub_hhqd(sb,ii) + baseflw / nstep
            endif

            !! water temperature, equation 2.3.13 in SWAT manual
            sub_hhwtmp(sb,ii) = 5.0 + 0.75 * sub_atmp(sb,ii)

          end do
          !! assign reach loadings for subbasin
          !! zero out hydrograph storage locations
          do ii = 1, mvaro
            do kk = 1, nstep
              hhvaroute(ii,ihout,kk) = 0.
            end do
          end do

          !! set values for different routing variables
          !! storage locations set to zero are not currently used
          do ii = 1, nstep
            ratio = 0.
            if (sub_wyld(sb) > 1.e-3)
     &                              ratio = sub_hwyld(ii) / sub_wyld(sb)
            if (sub_hwyld(ii) > 0.) then
              hhvaroute(1,ihout,ii) = sub_hhwtmp(sb,ii)            !!wtmp
              hhvaroute(2,ihout,ii) = sub_hwyld(ii) * sub_ha * 10. !!water
              hhvaroute(3,ihout,ii) = sub_hhsedy(sb,ii)            !!sedyld
              hhvaroute(4,ihout,ii) = varoute(4,ihout) * ratio     !!sedorgn
              hhvaroute(5,ihout,ii) = varoute(5,ihout) * ratio     !!sedorgp
              hhvaroute(6,ihout,ii) = varoute(6,ihout) * ratio     !!no3
              hhvaroute(7,ihout,ii) = varoute(7,ihout) * ratio     !!minp
              hhvaroute(8,ihout,ii) = 0.
              hhvaroute(9,ihout,ii) = 0.
              hhvaroute(10,ihout,ii) = 0.
              hhvaroute(11,ihout,ii) = varoute(11,ihout) * ratio   !!sol pst
              hhvaroute(12,ihout,ii) = varoute(12,ihout) * ratio   !!sorb pst
              hhvaroute(13,ihout,ii) = varoute(13,ihout) * ratio   !!chl_a
              hhvaroute(14,ihout,ii) = 0.                          !! NH3
              hhvaroute(15,ihout,ii) = 0.                          !! NO2
              hhvaroute(16,ihout,ii) = varoute(16,ihout) * ratio   !!cbodu
              hhvaroute(17,ihout,ii) = varoute(17,ihout) * ratio   !!doxq & soxy
              hhvaroute(18,ihout,ii) = varoute(18,ihout)    !!bactp
              hhvaroute(19,ihout,ii) = varoute(19,ihout)    !!bactlp
              hhvaroute(20,ihout,ii) = 0.                          !!cmetal#1
              hhvaroute(21,ihout,ii) = 0.                          !!cmetal#2
              hhvaroute(22,ihout,ii) = 0.                          !!cmetal#3
            end if
            QHY(ii,ihout,IHX(1))=hhvaroute(2,ihout,ii)/(dthy * 3600.) !m3 -> m3/s Jaehak flood routing 2017
		  end do
        end if

        !! summary calculations
        if (curyr > nyskip) then
         submono(1,sb) = submono(1,sb) + sub_subp(sb)
         submono(2,sb) = submono(2,sb) + sub_snom(sb)
         submono(3,sb) = submono(3,sb) + sub_qd(sb)
         submono(4,sb) = submono(4,sb) + sub_wyld(sb)
         submono(5,sb) = submono(5,sb) + sub_pet(sb)
         submono(6,sb) = submono(6,sb) + sub_etday(sb)
         submono(7,sb) = submono(7,sb) + sub_sedy(sb) / sub_ha
         submono(8,sb) = submono(8,sb) + sub_yorgn(sb)
         submono(9,sb) = submono(9,sb) + sub_yorgp(sb)
         submono(10,sb) = submono(10,sb) + sub_no3(sb)
         submono(11,sb) = submono(11,sb) + sub_solp(sb)
         submono(12,sb) = submono(12,sb) + sub_gwq(sb)
         submono(13,sb) = submono(13,sb) + sub_sep(sb)
         submono(14,sb) = submono(14,sb) + sub_sedpa(sb) + sub_sedps(sb)
         submono(15,sb) = submono(15,sb) + sub_latq(sb)
         submono(16,sb) = submono(16,sb) + sub_latno3(sb)
         submono(17,sb) = submono(17,sb) + sub_gwno3(sb)
         submono(18,sb) = submono(18,sb) + sub_tileq(sb)    !! jane f.
         submono(19,sb) = submono(19,sb) + sub_tileno3(sb)
         submono(20,sb) = submono(20,sb) + sub_vaptile(sb)  !! jane f.

          if (iprint == 1) call subday
        end if
      endif

!! initialize irrigation/overland flow variables
!! these variable must be initialized here because irrigation/overland
!! flow is performed in different command loops and the water used in
!! irrigation will not be reported in output files if the
!! variables are initialized in the regular place

!! if rch or res sources reset aird here

!!!! Srin's irrigation source by each application changes
!!      irrsc(j) = irr_sc(nro(j),nirr(j),j)
!!!! Srin's irrigation source by each application changes

!!	if (irrsc(j) <= 2)  aird(j) = 0.

      shallirr(j) = 0.
      deepirr(j) = 0.
      ovrlnd(j) = 0.
      potflwi(j) = 0.
      potsedi(j) = 0.
      potsani(j) = 0.
      potsili(j) = 0.
      potclai(j) = 0.
      potsagi(j) = 0.
      potlagi(j) = 0.
!! end of day calculations
      tmpavp(j) = 0.
      tmpavp(j) = tmpav(j)

      return
      end


c 15.01.2009 Simplified Main program and random number generator for epos

c-----------------------------------------------------------------------
      program aamain
c-----------------------------------------------------------------------

c HEP common as defined in epos.inc
      parameter (nmxhep=9990)       !max nr of particles in hep ptl list
      double precision phep,vhep
      common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
     &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)

      common/cevt/phievt,nevt,bimevt,kolevt,koievt,pmxevt,egyevt,npjevt
     *,ntgevt,npnevt,nppevt,ntnevt,ntpevt,jpnevt,jppevt,jtnevt,jtpevt
     *,xbjevt,qsqevt,nglevt,zppevt,zptevt,minfra,maxfra
     *,typevt

c Set parameters to default value
      call aaset(0)

c Update some parameters value to run correctly for LHC
      call IniEpos(nevent,ish)

c The parameters can be changed optionnaly by reading a file (example.param) using the following subroutine
      ! call EposInput(nevent,ish)  !(it can be commented)
c if you put what is in input.optns in example.param, you can even run exactly the same way (coded parameters are overwritten). Don't forget the command :
c "EndEposInput"
c at the end of example.param, otherwise it will not run.

c initialization for the given energy
      call ainit

      do  n=1,nevent
c Calculate an inelastic event
        call aepos(-1)
c Fix final particles and some event parameters
        call afinal
c Fill HEP common
        call hepmcstore   !complete filling of hepevt arrays compatible with hepmc library
c        call ustore !user defined in epos-bas-*.f
c Print out (same as the one defined in input.optns)
        if(nhep.gt.nmxhep)then
          print *,'Warning : produced number of particles is too high'
          print *,'          increase nmxhep : ',nhep,' > ',nmxhep
          stop
        endif
        write(*,*)nevhep,nhep,typevt !typevt is type of collision : 1=Non Diffractive, 2=Double Diffractive, 3=Single Diffractive
        do i=1,nhep
          write(*,'(i5,3x,i2,2x,2i5,2x,2i5)')i,isthep(i)
     *               ,jmohep(1,i),jmohep(2,i),jdahep(1,i),jdahep(2,i)
          write(*,'(i10,1x,4(e12.6,1x))')idhep(i),(phep(k,i),k=1,4)
        enddo
      enddo
c optional Statistic information (only with debug level ish=1)
      call astati
      if(ish.ge.1)call bfinal

      end

c-----------------------------------------------------------------------
      subroutine IniEpos(nevto,isho)
c-----------------------------------------------------------------------
c Update some parameters and define path to tab files
c here can be set what particle is stable or not
c transfer number of event and debug level to main program (to avoid
c epos.inc in main)
c-----------------------------------------------------------------------
      include "epos.inc"

      seedi=1.d0   !seed for random number generator: at start program
      seedj=1.d0   !seed for random number generator: for first event

c Initialize decay of particles
      nrnody=0       !number of particle types without decay (if 0 (default) : all unstable particles decay (at the end only (anti)nucleons, (anti)electrons and muons)
c Particle code is given as
c     id=+/-ijkl
c
c          mesons--
c          i=0, j<=k, +/- is sign for j
c          id=110 for pi0, id=220 for eta, etc.
c
c          baryons--
c          i<=j<=k in general
c          j<i<k for second state antisymmetric in (i,j), eg. l = 2130
c
c          other--
c          id=1,...,6 for quarks
c          id=9 for gluon
c          id=10 for photon
c          id=11,...,16 for leptons
c          i=17 for deuteron
c          i=18 for triton
c          i=19 for alpha
c          id=20 for ks, id=-20 for kl
c
c          i=21...26 for scalar quarks
c          i=29 for gluino
c
c          i=30 for h-dibaryon
c
c          i=31...36 for scalar leptons
c          i=39 for wino
c          i=40 for zino
c
c          id=80 for w+
c          id=81,...,83 for higgs mesons (h0, H0, A0, H+)
c          id=84,...,87 for excited bosons (Z'0, Z''0, W'+)
c          id=90 for z0
c
c          diquarks--
c          id=+/-ij00, i<j for diquark composed of i,j.
c
c Examples : 2130 = lambda, 1330=xi0, 2330=xi-, 3331=omega
c
c Conversion from epos to  pdg code can be done using
c      id_pdg=idtrafo('nxs','pdg',id_epos)

      nrnody=nrnody+1
      nody(nrnody)=1220    !neutron
      nrnody=nrnody+1
      nody(nrnody)=-1220   !aneutron
      nrnody=nrnody+1
      nody(nrnody)=120     !pi+
      nrnody=nrnody+1
      nody(nrnody)=-120    !pi-
      nrnody=nrnody+1
      nody(nrnody)=130     !K+
      nrnody=nrnody+1
      nody(nrnody)=-130    !K-
      nrnody=nrnody+1
      nody(nrnody)=-20     !Kl
      nrnody=nrnody+1
      nody(nrnody)=-14     !mu+
      nrnody=nrnody+1
      nody(nrnody)=14      !mu-
c      nrnody=nrnody+1
c      nody(nrnody)=idtrafo('pdg','nxs',3122)    !lambda using pdg code

c      ctaumin=1.           !or min decay lenght c*tau can be defined here in cm
                           !(all particles with c*tau>ctaumin are stable)

      call LHCparameters        !LHC tune for EPOS
      isigma=1                  !use analytic cross section for nuclear xs
      ionudi=1

c      isigma=0              !do not print out the cross section on screen
c      ionudi=3              !count diffraction without excitation as elastic

      iframe=11                 !nucleon-nucleon frame (12=target)
      iecho=0                     !"silent" reading mode

      nfnnx=2
      fnnx="./"                    ! path to main epos subdirectory
      nfnii=10                     ! epos tab file name lenght
      fnii="epos.initl"            ! epos tab file name
      nfnid=10
      fnid="epos.inidi"
      nfnie=10
      fnie="epos.iniev"
      nfnrj=10
      fnrj="epos.inirj"       !'.lhc' is added a the end of the file name in ainit if LHCparameters is called
      nfncs=10
      fncs="epos.inics"       !'.lhc' is added a the end of the file name in ainit if LHCparameters is called

c Debug
      ish=0       !debug level
      ifch=6      !debug output (screen)
c      ifch=31    !debug output (file)
c      fnch="epos.debug"
c      nfnch=index(fnch,' ')-1
c      open(ifch,file=fnch(1:nfnch),status='unknown')

      nevent = 1000  !number of events
      modsho = 1  !printout every modsho events

      ecms=7000  !center of mass energy in GeV/c2

      idproj = 1120   !proton
      laproj = 1      !proj Z
      maproj = 1      !proj A
      idtarg = 1120   !proton
      latarg = 1      !targ Z
      matarg = 1      !targ A

      istmax = 0      !only final particles (istmax=1 includes mother particles)

c for main program
      nevto  = nevent
      isho   = ish

      end

c-----------------------------------------------------------------------
      subroutine EposInput(nevto,isho)
c-----------------------------------------------------------------------
c Read informations (new options or parameter change) in the file
c "epos.param". The unit "ifop" is used in aread. If not used, it will
c use the default value of all parameters.
c-----------------------------------------------------------------------
      include "epos.inc"
      nopen=0
      ifop=35
      open(unit=ifop,file='example.param',status='old')
      call aread
      close(ifop)
c for main program
      nevto  = nevent
      isho   = ish
      end

c-----------------------------------------------------------------------
      subroutine xsection(xsigtot,xsigine,xsigela,xsigdd,xsigsd
     &                          ,xsloela,xsigtotaa,xsigineaa,xsigelaaa)
c-----------------------------------------------------------------------
c     cross section function
c-----------------------------------------------------------------------
      implicit none
      include 'epos.inc'
      double precision xsigtot,xsigine,xsigela,xsigdd,xsigsd
     &                ,xsloela,xsigtotaa,xsigineaa,xsigelaaa

      xsigtot   = dble( sigtot   )
      xsigine   = dble( sigine   )
      xsigela   = dble( sigela   )
      xsigdd    = dble( sigdd    )
      xsigsd    = dble( sigsd    )
      xsloela   = dble( sloela   )
c Nuclear cross section only if needed
      xsigtotaa = 0d0
      xsigineaa = 0d0
      xsigelaaa = 0d0
      if(maproj.gt.1.or.matarg.gt.1)then
        if(model.eq.1)then
          call crseaaEpos(sigtotaa,sigineaa,sigcutaa,sigelaaa)
        else
          call crseaaModel(sigtotaa,sigineaa,sigcutaa,sigelaaa)
        endif
        xsigtotaa = dble( sigtotaa )
        xsigineaa = dble( sigineaa )
        xsigelaaa = dble( sigelaaa )
      endif

      return
      end


! $UWHPSC/codes/fortran/loops1.f90

program loops1

   implicit none
   integer :: i

   do i=1,3           ! prints 1,2,3
      print *, i
      enddo

   do i=5,11,2        ! prints 5,7,9,11
      print *, i
      enddo

   do i=6,2,-1        ! prints 6,5,4,3,2
      print *, i
      enddo

   i = 0
   do while (i < 5)   ! prints 0,1,2,3,4
      print *, i
      i = i+1
      enddo

end program loops1


      subroutine takemolec(kk,infoonly,molinquire,indexanswer)
*
* to add new molecules, just fill in with name as in Tsuji molecular file
* starting with the first '        ' at th ened of data block molinpresmo.
*    BPz 10/10-95
*
* this routine is to be used after a call to jon,
*  -if eqmol has been called also-, in order to get the pressures
* one needs placed in the common 'fullequilibrium'.
* This is the routine to change if one wants more or/and other
* molecular pressure to be kept.
* The values in the common fullequilibrium can then be used for
* computation of opacities, printing, etc.
* kk is the depth point to be adressed.
* 020890 BPlez
*
      include 'spectrum.inc'
      include 'tsuji.par'
      integer maxim
      parameter (maxim=1000)
      logical tsuswitch,tsuji,first
      character*20 molinpresmo(maxmol),nametryck(maxmol)
      doubleprecision parptsuji,xmettryck,xiontryck,partryck
      doubleprecision presneutral,presion,presion2,presion3
      common /tsuji/ tsuji,tsuswitch,nattsuji,nmotsuji,
     &             parptsuji(maxim+400)
      common /fullequilibrium/ partryck(ndp,maxmol),
     &  xmettryck(ndp,maxmet),xiontryck(ndp,maxmet),nametryck
      common /orderedpress/ presneutral(ndp,100),presion(ndp,100),
     &       presion2(ndp,100),presion3(ndp,100)
      COMMON/CARC3/F1P,F3P,F4P,F5P,HNIC,PRESMO(30)
      common/ci1/fl2(5),parco(45),parq(180),shxij(5),tparf(4),
     &           xiong(16,5),eev,enamn,sumh,xkbol,nj(16),iel(16),
     &           nel,summ
* common from eqmol
      logical switer,infoonly
      character*20 mol(maxim),molinquire
      integer nelem(5,maxim),natom(5,maxim),mmax(maxim),nelemx(100),
     &          nmol,
     &        nmetal,nimax,marcsnelemx(20),marcsnelemj,j,atindex(20),
     &        molindex(maxmol),index,indexanswer
      real exponent(maxim),g0(100),g1(100),g2(100),g3(100),sumpress
      doubleprecision IP(100),KP(100),uiidui(100),eps,fp(100),
     &       ppmol(maxim),apm(maxim),c(maxim,5),p(100),ccomp(100),
     &       ipp(100),ippp(100),d00(maxim),qmol(maxim),
     &       reducedmass15(maxim)
      character*20 molcode(maxim)
      COMMON/COMFH1/C,NELEM,NATOM,MMAX,PPMOL,d00,qmol,APM,MOL,IP,
     &              ipp,ippp,g0,g1,g2,g3,CCOMP,exponent,reducedmass15,
     &              UIIDUI,P,FP,KP,eps,NELEMX,NIMAX,NMETAL,NMOL,switer,
     &              molcode
      real abund(16),anjon(16,5),h(5),part(16,5),dxi,f1,f2,f3,
     &           f4,f5,xkhm,xmh,xmy
      common/ci5/abund,anjon,h,part,dxi,f1,f2,f3,f4,f5,xkhm,xmh,xmy

      save atindex,molindex,first

      data molinpresmo/'H -                 ','H H                 ',
     &                 'H H +               ','H O H               ',
     &                 'O H                 ','C H                 ',
     &                 'C O                 ','C N                 ',
     &                 'C C                 ','N N                 ',
     &                 'O O                 ','N O                 ',
     &                 'N H                 ','C C H H             ',
     &                 'H C N               ','C C H               ',
     &                 '                    ','H S                 ',
     &                 'SiH                 ','C C C H             ',
     &                 'C C C               ','C S                 ',
     &                 'SiC                 ','SiC C               ',
     &                 'N S                 ','SiN                 ',
     &                 'SiO                 ','S O                 ',
     &                 'S S                 ','SiS                 ',
     &                 'TiO                 ','V O                 ',
     &                 'ZrO                 ','MgH                 ',
     &                 'CaH                 ','H F                 ',
     &                 'SiO                 ','H Cl                ',
     &                 'FeH                 ','SiH                 ',
     &                 'N O                 ','C H H H H           ',
     &                 'AlH                 ','CrH                 ',
     &                 'LaO                 ','TiH                 ',
     &                 'Y O                 ','NaH                 ',
     &                 '                    ','                    ',
     &                 '                    ','                    ',
     &                 '                    ','                    ',
     &                 '                    ','                    ',
     &                 '                    ','                    ',
     &                 '                    ','                    '/
      data first/.true./
      data marcsnelemx/ 1, 2, 6, 7, 8, 10, 11, 12, 13, 14, 16, 19,
     &                 20, 24, 26, 28, 21, 22, 23, 25/
      data molindex/maxmol*0/

* store the metals and ions
* The 16 first are indexed like in jon:
* H, He, C, N, O, Ne, Na, Mg, Al, Si, S, K, Ca, Cr, Fe, Ni
* 1   2  3  4  5   6   7   8   9  10 11 12  13  14  15  16
* and then:
* Sc, Ti, V, Mn
* 17  18 19  20
*
cc      if(nattsuji.gt.maxmet) stop 'takemolec: maxmet too small'

      if (infoonly) then
* get index for molecular pressure in partryck for molecule molinquire
*
        indexanswer=0
        do j=1,maxmol
          if (molinquire.eq.molinpresmo(j)) then
            indexanswer=j
          endif
        enddo
        if (indexanswer.eq.0) then
          print*,'takemolec infoonly: molec. not implemented',molinquire
          print*,' See and complete data block molinpresmo!'
cccc          print*,' complete also atomdata table with ID and IP'
          stop
        endif
        return
      endif

      if (first) then
        do i=1,100
          do j=1,ndp
            presneutral(j,i)=-1.0
            presion(j,i)=-1.0
            presion2(j,i)=-1.0
            presion3(j,i)=-1.0
          enddo
        enddo
* find index for atomic and molecular pressures
        do i=1,nmetal
          nelemi=nelemx(i)
          do j=1,20
            marcsnelemj=marcsnelemx(j)
            if (nelemi.eq.marcsnelemj) then
              atindex(j)=i
            endif
          enddo
        enddo
* the indexes from 1 to 30 for partryck correspond to
* the ones in presmo (common carc3). See data block molinpresmo.
* 31 is TiO, 32 is VO, 33 is ZrO, 34 is MgH., 35 is CaH , 36 is HF
*  ( compatible with new bsyn !!!)
*********************************************************************
        do i=1,maxmol
          if (molinpresmo(i).ne.'                    ') then
            j=1
            do while (molinpresmo(i).ne.mol(j).and.j.lt.nmol)
              j=j+1
            enddo
            if (molinpresmo(i).eq.mol(j)) then
              molindex(i)=4*nmetal+j
            else
* this is when we reach the last molecule in Tsuji's list
* without finding the right molecule. we flag with negative pressure.
              molindex(i)=4*nmetal+nmol+2
            endif
          else
* partial pressure=0.0
            molindex(i)=4*nmetal+nmol+1
          endif
        enddo
        if (4*nmetal+nmol+2.gt.maxim+400) stop
     &          'takemolec; maxim dim. too small! ERROR!'
        if (nmol+2.gt.maxim) stop
     &          'takemolec; maxim dim. too small! ERROR!'
        parptsuji(4*nmetal+nmol+1) = 1.e-31
        parptsuji(4*nmetal+nmol+2) = -1.0
        mol(nmol+1)='zero pressure'
        mol(nmol+2)='not existing'
      endif
*
      do j=1,20
        xmettryck(kk,j)=parptsuji(atindex(j))
        xiontryck(kk,j)=parptsuji(atindex(j)+nmetal)
      enddo
* Set partition functions and ionisation fractions to the values used
* in eqmol_pe/die_pe. Part(16,5) and anjon(16,5) are used in detabs for
* the computation of continuous opacities.

cc      print*,'takemolec old part, new part for atoms for depth',kk

      do j=1,16
        if (first) then
          if ((nj(j).eq.4.and.g3(marcsnelemx(j)).eq.0.).or.
     &        (nj(j).gt.4) ) print*,
     &    'WARNING, takemolec: number of ionisation stages considered',
     &     ' for',marcsnelemx(j),
     &     ' lower than requested in input file jonabs.dat!'
        endif
        index=atindex(j)
        nelemi=nelemx(index)
cc        print*,nelemi,marcsnelemx(j),' =?'
        marcsnelemj=marcsnelemx(j)

cc        print*,part(j,1),part(j,2),part(j,3),part(j,4)
cc        print*,g0(marcsnelemj),g1(marcsnelemj),g2(marcsnelemj),
cc     &         g3(marcsnelemj)

        part(j,1)=g0(marcsnelemj)
        part(j,2)=g1(marcsnelemj)
        part(j,3)=g2(marcsnelemj)
        part(j,4)=g3(marcsnelemj)
        sumpress=parptsuji(index)+
     &           parptsuji(index+nmetal)+
     &           parptsuji(index+2*nmetal)+
     &           parptsuji(index+3*nmetal)
        anjon(j,1)=parptsuji(index)/sumpress
        anjon(j,2)=parptsuji(index+nmetal)/sumpress
        anjon(j,3)=parptsuji(index+2*nmetal)/sumpress
        anjon(j,4)=parptsuji(index+3*nmetal)/sumpress
      enddo
*
* now, the pressures indexed with the atomic number
* The arrays are initially set to -1.0 to allow selection later in bsyn of the
* elements not treated in eqmol. NOTE: does not work for
* presion3 not treated in eqmol, and which is 0.0 after next loop.
      do i=1,nmetal
        nelemi=nelemx(i)
        presneutral(kk,nelemi)=parptsuji(i)
        presion(kk,nelemi)=parptsuji(i+nmetal)
        presion2(kk,nelemi)=parptsuji(i+2*nmetal)
        presion3(kk,nelemi)=parptsuji(i+3*nmetal)
      enddo
* and the molecules
      do i=1,maxmol
        partryck(kk,i)=parptsuji(molindex(i))
        if (first) then
          nametryck(i)=mol(molindex(i)-4*nmetal)
        endif
      enddo
      first=.false.
***************************** debug*******************
ccc      if (kk.eq.1) print*,'same?',(partryck(kk,i),i=1,35)
***************************** debug*******************
      return
      end


PROGRAM simple_loop
  IMPLICIT NONE
  INTEGER :: loop

  loop = 0
  DO WHILE(loop <= 9)
    PRINT *, "Hello from loop ", loop
    loop = loop + 1
  END DO
END PROGRAM simple_loop


MODULE traadv_fct
  USE oce
  USE dom_oce
  USE trc_oce
  USE trd_oce
  USE trdtra
  USE diaptr
  USE diaar5
  USE phycst, ONLY: rau0_rcp
  USE in_out_manager
  USE iom
  USE lib_mpp
  USE lbclnk
  USE lib_fortran
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: tra_adv_fct
  PUBLIC :: interp_4th_cpt
  LOGICAL :: l_trd
  LOGICAL :: l_ptr
  LOGICAL :: l_hst
  REAL(KIND = wp) :: r1_6 = 1._wp / 6._wp
  INTEGER, PARAMETER :: np_NH = 0
  INTEGER, PARAMETER :: np_CEN2 = 1
  CONTAINS
  SUBROUTINE tra_adv_fct(kt, kit000, cdtype, p2dt, pun, pvn, pwn, ptb, ptn, pta, kjpt, kn_fct_h, kn_fct_v)
    INTEGER, INTENT(IN   ) :: kt
    INTEGER, INTENT(IN   ) :: kit000
    CHARACTER(LEN = 3), INTENT(IN   ) :: cdtype
    INTEGER, INTENT(IN   ) :: kjpt
    INTEGER, INTENT(IN   ) :: kn_fct_h
    INTEGER, INTENT(IN   ) :: kn_fct_v
    REAL(KIND = wp), INTENT(IN   ) :: p2dt
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pun, pvn, pwn
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(IN   ) :: ptb, ptn
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(INOUT) :: pta
    INTEGER :: ji, jj, jk, jn
    REAL(KIND = wp) :: ztra
    REAL(KIND = wp) :: zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u
    REAL(KIND = wp) :: zfm_ui, zfm_vj, zfm_wk, zC2t_v, zC4t_v
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw
    REAL(KIND = wp), DIMENSION(:, :, :), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry
    IF (kt == kit000) THEN
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) 'tra_adv_fct : FCT advection scheme on ', cdtype
      IF (lwp) WRITE(numout, FMT = *) '~~~~~~~~~~~'
    END IF
    l_trd = .FALSE.
    l_hst = .FALSE.
    l_ptr = .FALSE.
    IF ((cdtype == 'TRA' .AND. l_trdtra) .OR. (cdtype == 'TRC' .AND. l_trdtrc)) l_trd = .TRUE.
    IF (cdtype == 'TRA' .AND. ln_diaptr) l_ptr = .TRUE.
    IF (cdtype == 'TRA' .AND. (iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. iom_use("uadv_salttr") .OR. iom_use("vadv_salttr"))) l_hst = .TRUE.
    IF (l_trd .OR. l_hst) THEN
      ALLOCATE(ztrdx(jpi, jpj, jpk), ztrdy(jpi, jpj, jpk), ztrdz(jpi, jpj, jpk))
      !$ACC KERNELS
      ztrdx(:, :, :) = 0._wp
      ztrdy(:, :, :) = 0._wp
      ztrdz(:, :, :) = 0._wp
      !$ACC END KERNELS
    END IF
    IF (l_ptr) THEN
      ALLOCATE(zptry(jpi, jpj, jpk))
      !$ACC KERNELS
      zptry(:, :, :) = 0._wp
      !$ACC END KERNELS
    END IF
    !$ACC KERNELS
    zwz(:, :, 1) = 0._wp
    zwx(:, :, jpk) = 0._wp
    zwy(:, :, jpk) = 0._wp
    zwz(:, :, jpk) = 0._wp
    zwi(:, :, :) = 0._wp
    !$ACC END KERNELS
    DO jn = 1, kjpt
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 1, jpjm1
          DO ji = 1, jpim1
            zfp_ui = pun(ji, jj, jk) + ABS(pun(ji, jj, jk))
            zfm_ui = pun(ji, jj, jk) - ABS(pun(ji, jj, jk))
            zfp_vj = pvn(ji, jj, jk) + ABS(pvn(ji, jj, jk))
            zfm_vj = pvn(ji, jj, jk) - ABS(pvn(ji, jj, jk))
            zwx(ji, jj, jk) = 0.5 * (zfp_ui * ptb(ji, jj, jk, jn) + zfm_ui * ptb(ji + 1, jj, jk, jn))
            zwy(ji, jj, jk) = 0.5 * (zfp_vj * ptb(ji, jj, jk, jn) + zfm_vj * ptb(ji, jj + 1, jk, jn))
          END DO
        END DO
      END DO
      DO jk = 2, jpkm1
        DO jj = 1, jpj
          DO ji = 1, jpi
            zfp_wk = pwn(ji, jj, jk) + ABS(pwn(ji, jj, jk))
            zfm_wk = pwn(ji, jj, jk) - ABS(pwn(ji, jj, jk))
            zwz(ji, jj, jk) = 0.5 * (zfp_wk * ptb(ji, jj, jk, jn) + zfm_wk * ptb(ji, jj, jk - 1, jn)) * wmask(ji, jj, jk)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF (ln_linssh) THEN
        IF (ln_isfcav) THEN
          !$ACC KERNELS
          DO jj = 1, jpj
            DO ji = 1, jpi
              zwz(ji, jj, mikt(ji, jj)) = pwn(ji, jj, mikt(ji, jj)) * ptb(ji, jj, mikt(ji, jj), jn)
            END DO
          END DO
          !$ACC END KERNELS
        ELSE
          !$ACC KERNELS
          zwz(:, :, 1) = pwn(:, :, 1) * ptb(:, :, 1, jn)
          !$ACC END KERNELS
        END IF
      END IF
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            ztra = - (zwx(ji, jj, jk) - zwx(ji - 1, jj, jk) + zwy(ji, jj, jk) - zwy(ji, jj - 1, jk) + zwz(ji, jj, jk) - zwz(ji, jj, jk + 1)) * r1_e1e2t(ji, jj)
            pta(ji, jj, jk, jn) = pta(ji, jj, jk, jn) + ztra / e3t_n(ji, jj, jk) * tmask(ji, jj, jk)
            zwi(ji, jj, jk) = (e3t_b(ji, jj, jk) * ptb(ji, jj, jk, jn) + p2dt * ztra) / e3t_a(ji, jj, jk) * tmask(ji, jj, jk)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk(zwi, 'T', 1.)
      IF (l_trd .OR. l_hst) THEN
        !$ACC KERNELS
        ztrdx(:, :, :) = zwx(:, :, :)
        ztrdy(:, :, :) = zwy(:, :, :)
        ztrdz(:, :, :) = zwz(:, :, :)
        !$ACC END KERNELS
      END IF
      IF (l_ptr) zptry(:, :, :) = zwy(:, :, :)
      SELECT CASE (kn_fct_h)
      CASE (2)
        !$ACC KERNELS
        DO jk = 1, jpkm1
          DO jj = 1, jpjm1
            DO ji = 1, jpim1
              zwx(ji, jj, jk) = 0.5_wp * pun(ji, jj, jk) * (ptn(ji, jj, jk, jn) + ptn(ji + 1, jj, jk, jn)) - zwx(ji, jj, jk)
              zwy(ji, jj, jk) = 0.5_wp * pvn(ji, jj, jk) * (ptn(ji, jj, jk, jn) + ptn(ji, jj + 1, jk, jn)) - zwy(ji, jj, jk)
            END DO
          END DO
        END DO
        !$ACC END KERNELS
      CASE (4)
        !$ACC KERNELS
        zltu(:, :, jpk) = 0._wp
        zltv(:, :, jpk) = 0._wp
        DO jk = 1, jpkm1
          DO jj = 1, jpjm1
            DO ji = 1, jpim1
              ztu(ji, jj, jk) = (ptn(ji + 1, jj, jk, jn) - ptn(ji, jj, jk, jn)) * umask(ji, jj, jk)
              ztv(ji, jj, jk) = (ptn(ji, jj + 1, jk, jn) - ptn(ji, jj, jk, jn)) * vmask(ji, jj, jk)
            END DO
          END DO
          DO jj = 2, jpjm1
            DO ji = 2, jpim1
              zltu(ji, jj, jk) = (ztu(ji, jj, jk) + ztu(ji - 1, jj, jk)) * r1_6
              zltv(ji, jj, jk) = (ztv(ji, jj, jk) + ztv(ji, jj - 1, jk)) * r1_6
            END DO
          END DO
        END DO
        !$ACC END KERNELS
        CALL lbc_lnk_multi(zltu, 'T', 1., zltv, 'T', 1.)
        !$ACC KERNELS
        DO jk = 1, jpkm1
          DO jj = 1, jpjm1
            DO ji = 1, jpim1
              zC2t_u = ptn(ji, jj, jk, jn) + ptn(ji + 1, jj, jk, jn)
              zC2t_v = ptn(ji, jj, jk, jn) + ptn(ji, jj + 1, jk, jn)
              zwx(ji, jj, jk) = 0.5_wp * pun(ji, jj, jk) * (zC2t_u + zltu(ji, jj, jk) - zltu(ji + 1, jj, jk)) - zwx(ji, jj, jk)
              zwy(ji, jj, jk) = 0.5_wp * pvn(ji, jj, jk) * (zC2t_v + zltv(ji, jj, jk) - zltv(ji, jj + 1, jk)) - zwy(ji, jj, jk)
            END DO
          END DO
        END DO
        !$ACC END KERNELS
      CASE (41)
        !$ACC KERNELS
        ztu(:, :, jpk) = 0._wp
        ztv(:, :, jpk) = 0._wp
        DO jk = 1, jpkm1
          DO jj = 1, jpjm1
            DO ji = 1, jpim1
              ztu(ji, jj, jk) = (ptn(ji + 1, jj, jk, jn) - ptn(ji, jj, jk, jn)) * umask(ji, jj, jk)
              ztv(ji, jj, jk) = (ptn(ji, jj + 1, jk, jn) - ptn(ji, jj, jk, jn)) * vmask(ji, jj, jk)
            END DO
          END DO
        END DO
        !$ACC END KERNELS
        CALL lbc_lnk_multi(ztu, 'U', - 1., ztv, 'V', - 1.)
        !$ACC KERNELS
        DO jk = 1, jpkm1
          DO jj = 2, jpjm1
            DO ji = 2, jpim1
              zC2t_u = ptn(ji, jj, jk, jn) + ptn(ji + 1, jj, jk, jn)
              zC2t_v = ptn(ji, jj, jk, jn) + ptn(ji, jj + 1, jk, jn)
              zC4t_u = zC2t_u + r1_6 * (ztu(ji - 1, jj, jk) - ztu(ji + 1, jj, jk))
              zC4t_v = zC2t_v + r1_6 * (ztv(ji, jj - 1, jk) - ztv(ji, jj + 1, jk))
              zwx(ji, jj, jk) = 0.5_wp * pun(ji, jj, jk) * zC4t_u - zwx(ji, jj, jk)
              zwy(ji, jj, jk) = 0.5_wp * pvn(ji, jj, jk) * zC4t_v - zwy(ji, jj, jk)
            END DO
          END DO
        END DO
        !$ACC END KERNELS
      END SELECT
      SELECT CASE (kn_fct_v)
      CASE (2)
        !$ACC KERNELS
        DO jk = 2, jpkm1
          DO jj = 2, jpjm1
            DO ji = 2, jpim1
              zwz(ji, jj, jk) = (pwn(ji, jj, jk) * 0.5_wp * (ptn(ji, jj, jk, jn) + ptn(ji, jj, jk - 1, jn)) - zwz(ji, jj, jk)) * wmask(ji, jj, jk)
            END DO
          END DO
        END DO
        !$ACC END KERNELS
      CASE (4)
        CALL interp_4th_cpt(ptn(:, :, :, jn), ztw)
        !$ACC KERNELS
        DO jk = 2, jpkm1
          DO jj = 2, jpjm1
            DO ji = 2, jpim1
              zwz(ji, jj, jk) = (pwn(ji, jj, jk) * ztw(ji, jj, jk) - zwz(ji, jj, jk)) * wmask(ji, jj, jk)
            END DO
          END DO
        END DO
        !$ACC END KERNELS
      END SELECT
      IF (ln_linssh) THEN
        !$ACC KERNELS
        zwz(:, :, 1) = 0._wp
        !$ACC END KERNELS
      END IF
      CALL lbc_lnk_multi(zwx, 'U', - 1., zwy, 'V', - 1., zwz, 'W', 1.)
      CALL nonosc(ptb(:, :, :, jn), zwx, zwy, zwz, zwi, p2dt)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            pta(ji, jj, jk, jn) = pta(ji, jj, jk, jn) - (zwx(ji, jj, jk) - zwx(ji - 1, jj, jk) + zwy(ji, jj, jk) - zwy(ji, jj - 1, jk) + zwz(ji, jj, jk) - zwz(ji, jj, jk + 1)) * r1_e1e2t(ji, jj) / e3t_n(ji, jj, jk)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF (l_trd .OR. l_hst) THEN
        !$ACC KERNELS
        ztrdx(:, :, :) = ztrdx(:, :, :) + zwx(:, :, :)
        ztrdy(:, :, :) = ztrdy(:, :, :) + zwy(:, :, :)
        ztrdz(:, :, :) = ztrdz(:, :, :) + zwz(:, :, :)
        !$ACC END KERNELS
        IF (l_trd) THEN
          CALL trd_tra(kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:, :, :, jn))
          CALL trd_tra(kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:, :, :, jn))
          CALL trd_tra(kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:, :, :, jn))
        END IF
        IF (l_hst) CALL dia_ar5_hst(jn, 'adv', ztrdx(:, :, :), ztrdy(:, :, :))
      END IF
      IF (l_ptr) THEN
        !$ACC KERNELS
        zptry(:, :, :) = zptry(:, :, :) + zwy(:, :, :)
        !$ACC END KERNELS
        CALL dia_ptr_hst(jn, 'adv', zptry(:, :, :))
      END IF
    END DO
    IF (l_trd .OR. l_hst) THEN
      DEALLOCATE(ztrdx, ztrdy, ztrdz)
    END IF
    IF (l_ptr) THEN
      DEALLOCATE(zptry)
    END IF
  END SUBROUTINE tra_adv_fct
  SUBROUTINE nonosc(pbef, paa, pbb, pcc, paft, p2dt)
    REAL(KIND = wp), INTENT(IN   ) :: p2dt
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pbef, paft
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(INOUT) :: paa, pbb, pcc
    INTEGER :: ji, jj, jk
    INTEGER :: ikm1
    REAL(KIND = wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn
    REAL(KIND = wp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zbetup, zbetdo, zbup, zbdo
    !$ACC KERNELS
    zbig = 1.E+40_wp
    zrtrn = 1.E-15_wp
    zbetup(:, :, :) = 0._wp
    zbetdo(:, :, :) = 0._wp
    zbup = MAX(pbef * tmask - zbig * (1._wp - tmask), paft * tmask - zbig * (1._wp - tmask))
    zbdo = MIN(pbef * tmask + zbig * (1._wp - tmask), paft * tmask + zbig * (1._wp - tmask))
    DO jk = 1, jpkm1
      ikm1 = MAX(jk - 1, 1)
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zup = MAX(zbup(ji, jj, jk), zbup(ji - 1, jj, jk), zbup(ji + 1, jj, jk), zbup(ji, jj - 1, jk), zbup(ji, jj + 1, jk), zbup(ji, jj, ikm1), zbup(ji, jj, jk + 1))
          zdo = MIN(zbdo(ji, jj, jk), zbdo(ji - 1, jj, jk), zbdo(ji + 1, jj, jk), zbdo(ji, jj - 1, jk), zbdo(ji, jj + 1, jk), zbdo(ji, jj, ikm1), zbdo(ji, jj, jk + 1))
          zpos = MAX(0., paa(ji - 1, jj, jk)) - MIN(0., paa(ji, jj, jk)) + MAX(0., pbb(ji, jj - 1, jk)) - MIN(0., pbb(ji, jj, jk)) + MAX(0., pcc(ji, jj, jk + 1)) - MIN(0., pcc(ji, jj, jk))
          zneg = MAX(0., paa(ji, jj, jk)) - MIN(0., paa(ji - 1, jj, jk)) + MAX(0., pbb(ji, jj, jk)) - MIN(0., pbb(ji, jj - 1, jk)) + MAX(0., pcc(ji, jj, jk)) - MIN(0., pcc(ji, jj, jk + 1))
          zbt = e1e2t(ji, jj) * e3t_n(ji, jj, jk) / p2dt
          zbetup(ji, jj, jk) = (zup - paft(ji, jj, jk)) / (zpos + zrtrn) * zbt
          zbetdo(ji, jj, jk) = (paft(ji, jj, jk) - zdo) / (zneg + zrtrn) * zbt
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    CALL lbc_lnk_multi(zbetup, 'T', 1., zbetdo, 'T', 1.)
    !$ACC KERNELS
    DO jk = 1, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zau = MIN(1._wp, zbetdo(ji, jj, jk), zbetup(ji + 1, jj, jk))
          zbu = MIN(1._wp, zbetup(ji, jj, jk), zbetdo(ji + 1, jj, jk))
          zcu = (0.5 + SIGN(0.5, paa(ji, jj, jk)))
          paa(ji, jj, jk) = paa(ji, jj, jk) * (zcu * zau + (1._wp - zcu) * zbu)
          zav = MIN(1._wp, zbetdo(ji, jj, jk), zbetup(ji, jj + 1, jk))
          zbv = MIN(1._wp, zbetup(ji, jj, jk), zbetdo(ji, jj + 1, jk))
          zcv = (0.5 + SIGN(0.5, pbb(ji, jj, jk)))
          pbb(ji, jj, jk) = pbb(ji, jj, jk) * (zcv * zav + (1._wp - zcv) * zbv)
          za = MIN(1., zbetdo(ji, jj, jk + 1), zbetup(ji, jj, jk))
          zb = MIN(1., zbetup(ji, jj, jk + 1), zbetdo(ji, jj, jk))
          zc = (0.5 + SIGN(0.5, pcc(ji, jj, jk + 1)))
          pcc(ji, jj, jk + 1) = pcc(ji, jj, jk + 1) * (zc * za + (1._wp - zc) * zb)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    CALL lbc_lnk_multi(paa, 'U', - 1., pbb, 'V', - 1.)
  END SUBROUTINE nonosc
  SUBROUTINE interp_4th_cpt_org(pt_in, pt_out)
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pt_in
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(  OUT) :: pt_out
    INTEGER :: ji, jj, jk
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zwd, zwi, zws, zwrm, zwt
    !$ACC KERNELS
    DO jk = 3, jpkm1
      DO jj = 1, jpj
        DO ji = 1, jpi
          zwd(ji, jj, jk) = 4._wp
          zwi(ji, jj, jk) = 1._wp
          zws(ji, jj, jk) = 1._wp
          zwrm(ji, jj, jk) = 3._wp * (pt_in(ji, jj, jk - 1) + pt_in(ji, jj, jk))
          IF (tmask(ji, jj, jk + 1) == 0._wp) THEN
            zwd(ji, jj, jk) = 1._wp
            zwi(ji, jj, jk) = 0._wp
            zws(ji, jj, jk) = 0._wp
            zwrm(ji, jj, jk) = 0.5 * (pt_in(ji, jj, jk - 1) + pt_in(ji, jj, jk))
          END IF
        END DO
      END DO
    END DO
    jk = 2
    DO jj = 1, jpj
      DO ji = 1, jpi
        zwd(ji, jj, jk) = 1._wp
        zwi(ji, jj, jk) = 0._wp
        zws(ji, jj, jk) = 0._wp
        zwrm(ji, jj, jk) = 0.5 * (pt_in(ji, jj, jk - 1) + pt_in(ji, jj, jk))
      END DO
    END DO
    DO jj = 1, jpj
      DO ji = 1, jpi
        zwt(ji, jj, 2) = zwd(ji, jj, 2)
      END DO
    END DO
    DO jk = 3, jpkm1
      DO jj = 1, jpj
        DO ji = 1, jpi
          zwt(ji, jj, jk) = zwd(ji, jj, jk) - zwi(ji, jj, jk) * zws(ji, jj, jk - 1) / zwt(ji, jj, jk - 1)
        END DO
      END DO
    END DO
    DO jj = 1, jpj
      DO ji = 1, jpi
        pt_out(ji, jj, 2) = zwrm(ji, jj, 2)
      END DO
    END DO
    DO jk = 3, jpkm1
      DO jj = 1, jpj
        DO ji = 1, jpi
          pt_out(ji, jj, jk) = zwrm(ji, jj, jk) - zwi(ji, jj, jk) / zwt(ji, jj, jk - 1) * pt_out(ji, jj, jk - 1)
        END DO
      END DO
    END DO
    DO jj = 1, jpj
      DO ji = 1, jpi
        pt_out(ji, jj, jpkm1) = pt_out(ji, jj, jpkm1) / zwt(ji, jj, jpkm1)
      END DO
    END DO
    DO jk = jpk - 2, 2, - 1
      DO jj = 1, jpj
        DO ji = 1, jpi
          pt_out(ji, jj, jk) = (pt_out(ji, jj, jk) - zws(ji, jj, jk) * pt_out(ji, jj, jk + 1)) / zwt(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
  END SUBROUTINE interp_4th_cpt_org
  SUBROUTINE interp_4th_cpt(pt_in, pt_out)
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pt_in
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(  OUT) :: pt_out
    INTEGER :: ji, jj, jk
    INTEGER :: ikt, ikb
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zwd, zwi, zws, zwrm, zwt
    !$ACC KERNELS
    DO jk = 3, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zwd(ji, jj, jk) = 3._wp * wmask(ji, jj, jk) + 1._wp
          zwi(ji, jj, jk) = wmask(ji, jj, jk)
          zws(ji, jj, jk) = wmask(ji, jj, jk)
          zwrm(ji, jj, jk) = 3._wp * wmask(ji, jj, jk) * (pt_in(ji, jj, jk) + pt_in(ji, jj, jk - 1))
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    IF (ln_isfcav) THEN
      !$ACC KERNELS
      zwd(:, :, 2) = 1._wp
      zwi(:, :, 2) = 0._wp
      zws(:, :, 2) = 0._wp
      zwrm(:, :, 2) = 0._wp
      !$ACC END KERNELS
    END IF
    !$ACC KERNELS
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        ikt = mikt(ji, jj) + 1
        ikb = mbkt(ji, jj)
        zwd(ji, jj, ikt) = 1._wp
        zwi(ji, jj, ikt) = 0._wp
        zws(ji, jj, ikt) = 0._wp
        zwrm(ji, jj, ikt) = 0.5_wp * (pt_in(ji, jj, ikt - 1) + pt_in(ji, jj, ikt))
        zwd(ji, jj, ikb) = 1._wp
        zwi(ji, jj, ikb) = 0._wp
        zws(ji, jj, ikb) = 0._wp
        zwrm(ji, jj, ikb) = 0.5_wp * (pt_in(ji, jj, ikb - 1) + pt_in(ji, jj, ikb))
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        zwt(ji, jj, 2) = zwd(ji, jj, 2)
      END DO
    END DO
    DO jk = 3, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zwt(ji, jj, jk) = zwd(ji, jj, jk) - zwi(ji, jj, jk) * zws(ji, jj, jk - 1) / zwt(ji, jj, jk - 1)
        END DO
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        pt_out(ji, jj, 2) = zwrm(ji, jj, 2)
      END DO
    END DO
    DO jk = 3, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          pt_out(ji, jj, jk) = zwrm(ji, jj, jk) - zwi(ji, jj, jk) / zwt(ji, jj, jk - 1) * pt_out(ji, jj, jk - 1)
        END DO
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        pt_out(ji, jj, jpkm1) = pt_out(ji, jj, jpkm1) / zwt(ji, jj, jpkm1)
      END DO
    END DO
    DO jk = jpk - 2, 2, - 1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          pt_out(ji, jj, jk) = (pt_out(ji, jj, jk) - zws(ji, jj, jk) * pt_out(ji, jj, jk + 1)) / zwt(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
  END SUBROUTINE interp_4th_cpt
  SUBROUTINE tridia_solver(pD, pU, pL, pRHS, pt_out, klev)
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(IN   ) :: pD, pU, PL
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(IN   ) :: pRHS
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(  OUT) :: pt_out
    INTEGER, INTENT(IN   ) :: klev
    INTEGER :: ji, jj, jk
    INTEGER :: kstart
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zwt
    !$ACC KERNELS
    kstart = 1 + klev
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        zwt(ji, jj, kstart) = pD(ji, jj, kstart)
      END DO
    END DO
    DO jk = kstart + 1, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zwt(ji, jj, jk) = pD(ji, jj, jk) - pL(ji, jj, jk) * pU(ji, jj, jk - 1) / zwt(ji, jj, jk - 1)
        END DO
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        pt_out(ji, jj, kstart) = pRHS(ji, jj, kstart)
      END DO
    END DO
    DO jk = kstart + 1, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          pt_out(ji, jj, jk) = pRHS(ji, jj, jk) - pL(ji, jj, jk) / zwt(ji, jj, jk - 1) * pt_out(ji, jj, jk - 1)
        END DO
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        pt_out(ji, jj, jpkm1) = pt_out(ji, jj, jpkm1) / zwt(ji, jj, jpkm1)
      END DO
    END DO
    DO jk = jpk - 2, kstart, - 1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          pt_out(ji, jj, jk) = (pt_out(ji, jj, jk) - pU(ji, jj, jk) * pt_out(ji, jj, jk + 1)) / zwt(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
  END SUBROUTINE tridia_solver
END MODULE traadv_fct


      SUBROUTINE MCMCSTEPGM(PAR,PROB,NPROB,IFAIL)

      IMPLICIT NONE

      INTEGER IFAIL,I,OMGFLAG,MAFLAG,MOFLAG,GMFLAG
      INTEGER NTOT,IDUM,TOTMIN,TOTMAX,NMAX,NPROB,JM,JL
      INTEGER MCFLAG,NSUSY,NGUT,NMES
      PARAMETER (NSUSY=14,NGUT=21,NMES=20)

      DOUBLE PRECISION PAR(*),PROB(*),P,RAN2,XDUM,PP
      DOUBLE PRECISION FTSUSY(NSUSY+2),FTGUT(NGUT+2),FTMES(NMES+2)
      DOUBLE PRECISION SMASS(3),PMASS(2),CMASS,SCOMP(3,3),PCOMP(2,2)
      DOUBLE PRECISION MGL,MCHA(2),U(2,2),V(2,2),MNEU(5),NEU(5,5)
      DOUBLE PRECISION MUR,MUL,MDR,MDL,MLR,MLL,MNL
      DOUBLE PRECISION MST1,MST2,MSB1,MSB2,MSL1,MSL2,MSNT
      DOUBLE PRECISION CST,CSB,CSL,MSMU1,MSMU2,MSNM,CSMU,Q2
      DOUBLE PRECISION RMST1,RMST2,S2T,RMSB1,RMSB2,S2B,XT,XB
      DOUBLE PRECISION MSUSYEFF,MMESS,N5
      DOUBLE PRECISION ALINP,XIFINP,XISINP,MSINP,MUPINP,MSPINP
      DOUBLE PRECISION MHmin,MHmax,chi2max,chi2gam,chi2bb,chi2zz
      DOUBLE PRECISION MSUSYEFFCEN,MSUSYEFFDEV,MMESSCEN,MMESSDEV
      DOUBLE PRECISION TBCEN,TBDEV,LCEN,LDEV,KCEN,KDEV,ALCEN,ALDEV
      DOUBLE PRECISION XIFCEN,XIFDEV,XISCEN,XISDEV,MUPCEN,MUPDEV
      DOUBLE PRECISION MSPCEN,MSPDEV,MSCEN,MSDEV,XIUCEN,XIUDEV
      DOUBLE PRECISION LPPCEN,LPPDEV,LTTCEN,LTTDEV,LUCEN,LUDEV
      DOUBLE PRECISION LDCEN,LDDEV, LTCEN,LTDEV,LBCEN,LBDEV
      DOUBLE PRECISION LLCEN,LLDEV,XCEN,XDEV,X
      DOUBLE PRECISION MSUSYEFFMIN,MMESSMIN,TBMIN,LMIN,KMIN,ALMIN
      DOUBLE PRECISION XIFMIN,XISMIN,MUPMIN,MSPMIN,MSMIN,XIUMIN
      DOUBLE PRECISION LPPMIN,LTTMIN,LUMIN,LDMIN,LTMIN,LBMIN,LLMIN
      DOUBLE PRECISION LPPMES,LTTMES,LUMES,LDMES,LTMES,LBMES,LLMES,XIU
      DOUBLE PRECISION MSM,MST,LM,LT,KM,KT,HTM,HTT,LPPM,LPPT,LTTM,LTTT
      DOUBLE PRECISION XIFMES,XISMES,MSMES,MUPMES,MSPMES,M3HMES
      DOUBLE PRECISION MSREF,D,DMIN,DELMB
      DOUBLE PRECISION Q2MEM,DELMEM,XIFMEM,XISMEM,MSMEM
      DOUBLE PRECISION LPPMEM,LTTMEM,PARMEM(25)
      DOUBLE PRECISION neuttot2(5),neuttot(5),neuttot3(5),neuttotrad(5)

      COMMON/INPPAR/ALINP,XIFINP,XISINP,MSINP,MUPINP,MSPINP
      COMMON/MESEXT/XIFMES,XISMES,MSMES,MUPMES,MSPMES,M3HMES
      COMMON/MESGUT/LPPMES,LTTMES,LUMES,LDMES,LTMES,LBMES,LLMES,XIU
      COMMON/MESCAL/MSUSYEFF,MMESS,N5
      COMMON/HIGGSPEC/SMASS,SCOMP,PMASS,PCOMP,CMASS
      COMMON/SUSYSPEC/MGL,MCHA,U,V,MNEU,NEU
      COMMON/SFSPEC/MUR,MUL,MDR,MDL,MLR,MLL,MNL,
     . MST1,MST2,MSB1,MSB2,MSL1,MSL2,MSNT,
     . CST,CSB,CSL,MSMU1,MSMU2,MSNM,CSMU
      COMMON/RADCOR/RMST1,RMST2,S2T,RMSB1,RMSB2,S2B,XT,XB
      COMMON/HIGGSFIT/MHmin,MHmax,chi2max,chi2gam,chi2bb,chi2zz
      COMMON/MCMCPAR/MSUSYEFFCEN,MSUSYEFFDEV,MMESSCEN,MMESSDEV,
     . TBCEN,TBDEV,LCEN,LDEV,KCEN,KDEV,ALCEN,ALDEV,XIFCEN,
     . XIFDEV,XISCEN,XISDEV,MUPCEN,MUPDEV,MSPCEN,MSPDEV,
     . MSCEN,MSDEV,XIUCEN,XIUDEV,LPPCEN,LPPDEV,LTTCEN,LTTDEV,
     . LUCEN,LUDEV,LDCEN,LDDEV, LTCEN,LTDEV,LBCEN,LBDEV,
     . LLCEN,LLDEV,XCEN,XDEV,X,
     . MSUSYEFFMIN,MMESSMIN,TBMIN,LMIN,KMIN,ALMIN,
     . XIFMIN,XISMIN,MUPMIN,MSPMIN,MSMIN,XIUMIN,
     . LPPMIN,LTTMIN,LUMIN,LDMIN,LTMIN,LBMIN,LLMIN
      COMMON/FINETUN/FTSUSY,FTGUT,FTMES
      COMMON/FLAGS/OMGFLAG,MAFLAG,MOFLAG
      COMMON/STEPS/NTOT,IDUM,TOTMIN,TOTMAX,NMAX
      COMMON/GMSCEN/MSREF,D,DMIN,GMFLAG
      COMMON/GMEM/Q2MEM,DELMEM,XIFMEM,XISMEM,MSMEM,
     . LPPMEM,LTTMEM,PARMEM
      COMMON/GMSAVE/MSM,MST,LM,LT,KM,KT,HTM,HTT,
     . LPPM,LPPT,LTTM,LTTT,JM,JL
      COMMON/RENSCALE/Q2
      COMMON/DELMB/DELMB
      COMMON/MCFLAG/MCFLAG
      COMMON/NEUTRALINO_WIDTH/neuttot2,neuttot,neuttot3,neuttotrad

      X=0d0

      IF(IFAIL.EQ.9.OR.(IFAIL.GE.11 .AND. IFAIL.LE.20))THEN
       X=1d40
      ENDIF

      IF(IFAIL.EQ.1.OR.IFAIL.EQ.3.OR.IFAIL.EQ.5.OR.IFAIL.EQ.7)THEN
       X=X+(2d0-SMASS(1))*1d20
      ENDIF
      IF(IFAIL.EQ.2.OR.IFAIL.EQ.3.OR.IFAIL.EQ.6.OR.IFAIL.EQ.7)THEN
       X=X+(2d0-PMASS(1))*1d20
      ENDIF
      IF(IFAIL.EQ.4.OR.IFAIL.EQ.5.OR.IFAIL.EQ.6.OR.IFAIL.EQ.7)THEN
       X=X+(2d0-CMASS)*1d20
      ENDIF

      IF(IFAIL.EQ.8)THEN
       X=MIN(X,RMST1)
       X=MIN(X,RMSB1)
       X=MIN(X,MST1)
       X=MIN(X,MST2)
       X=MIN(X,MSB1)
       X=MIN(X,MSB2)
       X=MIN(X,MUL)
       X=MIN(X,MUR)
       X=MIN(X,MDL)
       X=MIN(X,MDR)
       X=MIN(X,MSL1)
       X=MIN(X,MSNT)
       X=MIN(X,MSMU1)
       X=MIN(X,MSNM)
       X=MIN(X,MLR)
       X=MIN(X,MLL)
       X=MIN(X,MNL)
       X=(1d0-X)*1d20
      ENDIF

      IF(MOD(MCFLAG,3).EQ.0)THEN
       IF(IFAIL.EQ.10 .OR. IFAIL.EQ.22)THEN
        DO I=1,NPROB
         X=X+DABS(PROB(I))
        ENDDO
        IF(X.NE.0d0)X=(1d0+X)*1d10
       ENDIF
       IF(IFAIL.EQ.21 .OR. IFAIL.EQ.22)THEN
        X=X+(DABS(D)/DMIN)*1d10
       ENDIF
      ELSEIF(MOD(MCFLAG,3).EQ.1)THEN
       IF(IFAIL.EQ.10 .OR. IFAIL.EQ.22)THEN
        DO I=1,NPROB
         X=X+DABS(PROB(I))
        ENDDO
        IF(X.NE.0d0)X=(1d0+X)*1d15
       ENDIF
       IF(IFAIL.EQ.21 .OR. IFAIL.EQ.22)THEN
        X=X+(DABS(D)/DMIN)*1d10
       ENDIF
      ELSEIF(MOD(MCFLAG,3).EQ.2)THEN
       IF(IFAIL.EQ.10 .OR. IFAIL.EQ.22)THEN
        DO I=1,NPROB
         X=X+DABS(PROB(I))
        ENDDO
        IF(X.NE.0d0)X=(1d0+X)*1d10
       ENDIF
       IF(IFAIL.EQ.21 .OR. IFAIL.EQ.22)THEN
        X=X+(DABS(D)/DMIN)*1d15
       ENDIF
      ENDIF

      IF(MCFLAG/3.EQ.1)THEN
       X=X+MGL
      ELSEIF(MCFLAG/3.EQ.2)THEN
       X=X+1.98d-14/neuttot(1)
      ELSE
       X=X+1d0
      ENDIF

      PP=(X-XCEN)/(.28d0*XDEV*MIN(X,XCEN))
      PP=MAX(PP,-8d0*DLOG(10d0))
      PP=MIN(PP,8d0*DLOG(10d0))
      P=1d0/(1d0+DEXP(PP))
      XDUM=RAN2(IDUM)
!      WRITE(0,*)"X",XCEN,X
!      WRITE(0,*)"P",P,XDUM
      IF(P.GE.XDUM)THEN
!       WRITE(0,*)"OK",IFAIL
       XCEN=X
       MSUSYEFFCEN=MSUSYEFF
       MMESSCEN=MMESS
       TBCEN=PAR(3)
       LCEN=PAR(1)
       ALCEN=ALINP
       IF(MAFLAG.EQ.-1 .OR. MAFLAG.EQ.-2)THEN
        XIFCEN=XIFINP
       ELSE
        KCEN=PAR(2)
       ENDIF
       IF(MAFLAG.EQ.-1 .OR. MAFLAG.EQ.-3)THEN
        XISCEN=XISINP
       ELSE
        MSCEN=MSINP
       ENDIF
       MUPCEN=MUPINP
       MSPCEN=MSPINP
       XIUCEN=XIU
       LPPCEN=LPPMES
       LTTCEN=LTTMES
       LUCEN=LUMES
       LDCEN=LDMES
       LTCEN=LTMES
       LBCEN=LBMES
       LLCEN=LLMES
       Q2MEM=Q2
       DELMEM=DELMB
       XIFMEM=XIFMES
       XISMEM=XISMES
       MSMEM=MSM
       LPPMEM=LPPM
       LTTMEM=LTTM
       DO I=1,25
        PARMEM(I)=PAR(I)
       ENDDO
!       WRITE(0,*)"MSUSYEFFCEN=",MSUSYEFFCEN
!       WRITE(0,*)"MMESSCEN=",MMESSCEN
!       WRITE(0,*)"TBCEN=",TBCEN
!       WRITE(0,*)"LCEN=",LCEN
!       WRITE(0,*)"XIUCEN=",XIUCEN
!      ELSE
!       WRITE(0,*)"NO",IFAIL
      ENDIF
!      WRITE(0,*)""
!      WRITE(0,*)""

      END


program Variable_DataTypes
    implicit none
    !Variable Declaration
    INTEGER ::x
    REAL :: i
    INTEGER :: c = 100!Assigning plus Declaration

    !Assigning the value
    x = 500
    i = 4.98

    Print *, 'x', x
    Print *, 'i', i
    Print *, 'c', c

    ! Comment start with '!' in fortran

end program Variable_DataTypes