!> \file glacier_soilmodel.f90
!> Contains module glacier_soilmodel.

!>HYPE glacier soil model (glacier_model = 3)
MODULE GLACIER_SOILMODEL

  !Copyright 2012-2017 SMHI
  !
  !This file is part of HYPE.

  !HYPE is free software: you can redistribute it and/or modify it under
  !the terms of the Lesser GNU General Public License as published by
  !the Free Software Foundation, either version 3 of the License, or (at
  !your option) any later version. HYPE is distributed in the hope that
  !it will be useful, but WITHOUT ANY WARRANTY; without even the implied
  !warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See
  !the Lesser GNU General Public License for more details. You should
  !have received a copy of the Lesser GNU General Public License along
  !with HYPE. If not, see <http://www.gnu.org/licenses/>.

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

  USE STATETYPE_MODULE
  USE MODVAR,  ONLY : missing_value,pi,   &
                      currentdate, &
                      timesteps_per_day, &
                      genpar,landpar,soilpar,  &
                      load,basin,classbasin,path, &
                      glacier,glacierindex,nglaciers,  &
                      numsubstances,nsub,maxsoillayers, &
                      classdata,soilthick,soildepth, &
                      i_t1,i_t2,i_in,i_on,i_sp,i_pp,i_oc,&
                      modeloption,p_deepgroundwater, &
                      conductN,conductP,conductC,conductS, &
                      p_snowmelt,p_snowevap
  USE HYPEVARIABLES, ONLY : wpmm,fcmm,epmm,pwmm, &
                            m_ttmp,m_cmlt,m_srrcs, &
                            m_wetsp,m_drypp, m_ponatm,m_cfrost,m_sfrost,m_perc1,m_perc2,  &
                            m_sreroexp,m_filtpbuf,m_filtpinner,m_filtpother,m_macfilt, &
                            m_pprelexp,m_fertdays,m_minerfn,m_minerfp,m_degradhn, &
                            m_degradhp,m_denitrlu, &
                            m_dissolfN,m_dissolhN,m_dissolfP,m_dissolhP,m_littdays,  &
                            m_crate1,m_crate2,m_crate3,m_crate9,m_crate10,m_minc,m_ocsoim,m_ocsmslp,  &
                            m_freuc,m_freuexp,m_freurate, &
                            m_sswcorr,m_immdep,m_iwdfrac,m_wdpar,m_ttpi, &
                            m_glacvcoef,m_glacvexp,m_glacdens, &
                            m_glacvcoef1,m_glacvexp1,m_glac2arlim, &
                            soilmem,m_deepmem, &
                            glacier_model, &
                            epotdist, &
                            m_snalbmin, m_snalbmax, m_snalbkexp,m_cmrad, &
                            m_cmrefr, m_fsceff, m_fepotsnow, &
                            m_glacttmp,m_glaccmlt,m_glaccmrad,m_glacalb,m_glaccmrefr,m_fepotglac,m_glacannmb
  USE GENERAL_WATER_CONCENTRATION, ONLY : remove_water,           &
                                          error_remove_water
  USE ATMOSPHERIC_PROCESSES, ONLY :  calculate_rain_snow_from_precipitation
  USE SOIL_PROCESSES, ONLY : calculate_snow, &
                             calculate_potential_evaporation,          &
                             calculate_actual_soil_evapotranspiration, &
                             add_macropore_flow,    &
                             calculate_tile_drainage,  &
                             calculate_soil_runoff,    &
                             infiltration,   &
                             add_infiltration,   &
                             percolation, &
                             calculate_groundwater_table,  &
                             calculate_soiltemp,   &
                             calculate_frostdepth,  &
                             calculate_soil_moisture_deficit, &
                             snowalbedo_function
  USE NPC_SOIL_PROCESSES, ONLY : add_dry_deposition_to_landclass,  &
                                 calculate_plant,        &
                                 soil_np_processes,      &
                                 soil_carbon_processes,  &
                                 balance_spsoil,         &
                                 particle_processes_for_runoff, &
                                 local_diffuse_source
  USE TRACER_PROCESSES, ONLY : soil_tracer_processes
  USE REGIONAL_GROUNDWATER_MODULE, ONLY : add_regional_groundwater_flow_to_soil

  IMPLICIT NONE
  PRIVATE
  !Private subroutines
  !--------------------------------------------------------------------
  !get_glacier_parameters
  !calculate_glacier_area
  !--------------------------------------------------------------------
  PUBLIC :: soilmodel_3, &
            initiate_glacier, &
            initiate_glacier_state, &
            calculate_glacier_massbalance

  !Parameter declarations (private)
  CHARACTER(LEN=80) :: errstring(1)  !error message for location of remove_water call
  PARAMETER (errstring = (/'surface runoff, soillayer 1'/))

  !Variable declarations
  REAL :: glac_areavol_par(2,2)              !<variable holding paraemters for glacier area-volume relationship
  REAL :: glac_areavol_par2(2)              !<variable holding paraemters for glacier area-volume relationship
  REAL,ALLOCATABLE :: glac_areavol_par1(:)  !<variable holding paraemters for glacier area-volume relationship

!> \brief Type for glacier mass balance calculations
  TYPE glacierTimeseries
    REAL,ALLOCATABLE :: glac_vol(:)  !vector with glacier volume time series for mass balance calculations
    REAL,ALLOCATABLE :: glac_area(:) !vector with glacier area time series for mass balance calculations
  END TYPE glacierTimeseries

  TYPE(glacierTimeseries), ALLOCATABLE :: glacierTimeSeriesData(:)

  INTEGER, PARAMETER :: glacierTimeSeriesSteps = 731 !<two years (one leap year) maximum mass balance period

CONTAINS

  !--------------------------------------------------------------
  !>\brief Soilmodel for glacier land class
  !!Calculate glacier, snow and soil processes for a glacier land class.
  !!
  ! TODO: glac_melt goes to soil today? Maybe ignore soil calculation
  ! for glacier part and let glac_melt go directly to runoff instead?
  !>
  !> \b Reference ModelDescription Chapter Land routines (Glaciers)
  !--------------------------------------------------------------
  SUBROUTINE soilmodel_3(i,j,isoil,iluse,subid,dayno,classarea,prec,cprec,temp, &
       daylength,mintemp,maxtemp,sffrac,swrad,  &
       radext,netrad,actvap,satvap,wind,cevpcorr,rrcscorr,phoscorr,  &
       frozenstate,soilstate,miscstate,surfaceflow,csrunoff,crunoffd,    &
       cropuptakein,nitrif,denitrif,epot,gwat,frostdepth,smdef,  &
       evap,cevap,crunoff1,crunoff2,crunoff3,  &
       glac_part,nonglac_part,snowfall,rainfall,cropsources,ruralaload,rgrwload,atmdepload,infiltrationflows,glacierflows, &
       evapflows,runofflows,crunofflows,verticalflows,cverticalflows,horizontalflows,horizontalflows2,evapsnow,cruralflow)

    INTEGER, INTENT(IN) :: i        !<index for current subbasin
    INTEGER, INTENT(IN) :: j        !<index for current class
    INTEGER, INTENT(IN) :: isoil    !<index of soil type
    INTEGER, INTENT(IN) :: iluse    !<index of landuse
    INTEGER, INTENT(IN) :: subid    !<subbasin id
    INTEGER, INTENT(IN) :: dayno    !<pseudo dayno for use in soil model subroutines
    REAL, INTENT(IN) :: classarea   !<class area (km2)
    REAL, INTENT(IN) :: prec        !<precipitation (mm/timestep)
    REAL, INTENT(IN) :: cprec(numsubstances)        !<concentration of precipitation
    REAL, INTENT(IN) :: temp        !<temperature
    REAL, INTENT(IN) :: daylength   !<day length (hours)
    REAL, INTENT(IN) :: mintemp     !<current daily min temperature (C)
    REAL, INTENT(IN) :: maxtemp     !<current daily max temperature (C)
    REAL, INTENT(IN) :: sffrac      !<snowfall fraction of precipitation [-]
    REAL, INTENT(IN) :: swrad       !<downward shortwave radiation [MJ/m2/day]
    REAL, INTENT(IN) :: radext      !<extraterrestrial solar radiation [MJ/m2/day]
    REAL, INTENT(IN) :: netrad      !<net downward radiation [MJ/m2/day]
    REAL, INTENT(IN) :: actvap      !<actual vapor pressure [kPa]
    REAL, INTENT(IN) :: satvap      !<saturated vapour pressure [kPa]
    REAL, INTENT(IN) :: wind        !<wind speed [m/s]
    REAL, INTENT(IN) :: cevpcorr    !<correction of potential evaporation
    REAL, INTENT(IN) :: rrcscorr    !<correction of recession coefficients
    REAL, INTENT(IN) :: phoscorr    !<correction of phosphorus level
    TYPE(snowicestatetype),INTENT(INOUT)  :: frozenstate   !<Snow and ice states
    TYPE(soilstatetype),INTENT(INOUT)  :: soilstate   !<Soil states
    TYPE(miscstatetype),INTENT(INOUT)  :: miscstate   !<Misc states
    REAL, INTENT(OUT) :: surfaceflow(2)  !<saturated overflow and surface excess infilt
    REAL, INTENT(OUT) :: csrunoff(numsubstances)   !<concentration surface flow
    REAL, INTENT(OUT) :: crunoffd (numsubstances)  !<concentration tile runoff
    REAL, INTENT(OUT) :: cropuptakein  !<crop uptake of IN
    REAL, INTENT(OUT) :: nitrif     !<nitrification
    REAL, INTENT(OUT) :: denitrif(maxsoillayers)   !<denitrification
    REAL, INTENT(OUT) :: epot       !<potential evaporation (mm/timestep)
    REAL, INTENT(OUT) :: gwat       !<groundwater table (m)
    REAL, INTENT(OUT) :: frostdepth   !<soil frost depth
    REAL, INTENT(OUT) :: smdef        !<soil moisture deficit (mm)
    REAL, INTENT(OUT) :: evap       !<evapotranspiration
    REAL, INTENT(OUT) :: cevap(numsubstances)   !<concentration of evapotranspiration
    REAL, INTENT(OUT) :: crunoff1(numsubstances)   !<concentration of runoff from soil layer 1 (mg/L)
    REAL, INTENT(OUT) :: crunoff2(numsubstances)   !<concentration of runoff from soil layer 2 (mg/L)
    REAL, INTENT(OUT) :: crunoff3(numsubstances)   !<concentration of runoff from soil layer 3 (mg/L)
    REAL, INTENT(OUT) :: glac_part       !<fraction of glacier (-)
    REAL, INTENT(OUT) :: nonglac_part    !<old fraction of class is snow field (-)
    REAL, INTENT(OUT) :: snowfall     !<Precipitation as rain (mm)
    REAL, INTENT(OUT) :: rainfall     !<Precipitation as snow (mm)
    REAL, INTENT(INOUT):: cropsources(2,numsubstances)  !<Load from fertiliser and resudues (kg/timestep)
    REAL, INTENT(OUT) :: ruralaload(numsubstances)   !<Load from rural households (kg/timestep)
    REAL, INTENT(INOUT) :: rgrwload(numsubstances)     !<Load from regional groundwater flow to soil (kg/timestep)
    REAL, INTENT(INOUT) :: atmdepload(numsubstances) !<Load of atmospheric dry deposition (kg/timestep)
    REAL, INTENT(OUT) :: infiltrationflows(7)  !<several infiltration flows [mm]
    REAL, INTENT(OUT) :: glacierflows(2)   !<flow between snow plain snow and glacier when glacier grow, precipitation on glacier [m3]
    REAL, INTENT(OUT) :: evapflows(4)  !<evaporation from soillayers, snow and glacier [mm]
    REAL, INTENT(OUT) :: runofflows(7) !<different runoff flows:1-3=soil runoff sl 1-3,4-6=tile runoff sl 1-3,7=saturated surface runoff
    REAL, INTENT(OUT) :: crunofflows(numsubstances,6) !<concentration of different runoff flows:1-3=soil runoff sl 1-3,4-6=tile runoff sl 1-3
    REAL, INTENT(OUT) :: verticalflows(6) !<vertical flows:1-2=percolation,3-4=upwelling due to rural,5-6=upwelling due to reg. grw flows
    REAL, INTENT(OUT) :: cverticalflows(2,numsubstances) !<concentration of vertical flows:1-2=percolation
    REAL, INTENT(OUT) :: horizontalflows(3) !<horizontal flows:1-3=recieved rural load flow
    REAL, INTENT(INOUT) :: horizontalflows2(3,nsub) !<horizontal flows:1-3=division of regional groundwater flows to grwdown
    REAL, INTENT(OUT) :: evapsnow  !<evaporation from snow covered land (from snow and glacier)
    REAL, INTENT(OUT) :: cruralflow(numsubstances) !<conc of rural flow

    !Local variables
    !---------------
    INTEGER nc      !numsubstances
    INTEGER status  !error status of subroutine call
    !Short notation of parameter values
    REAL tt       !threshold temperature for melting (C)
    REAL cm       !coefficient for snow melt (mm/Cday)
    REAL sc       !coefficient for runoff recession surface runoff(no unit)
    !Variables for class values
    REAL ginfilt,infilt   !gross infiltration (rain+melt), actual infiltration (after removed surfaceflow and macroporeflow)
    REAL cginfilt(numsubstances),cinfilt(numsubstances)   !concentration of infiltration
    REAL totalsurfaceflow
    REAL satoverflow
    REAL excessinfilt   !infiltration excess runoff
    REAL macroflow
    REAL cmacroflow(numsubstances), cexcessinfilt(numsubstances)          !concentration in infiltration excess runoff and macropore flow
    REAL melt,cmelt(numsubstances)      !snow melt,concentration in snow melt water
    REAL snowmelt         !melt of snow (classarea based)
    REAL cevapsnow(numsubstances)  !conc in evaporation from snow covered land
    !More variables
    REAL sink(numsubstances), source(numsubstances)
    REAL oldsnow
    REAL helpmm
    REAL plantuptake(2,2)          !uptake of plant (what they want), kg NP/km2/timestep
    REAL soilrunoff(maxsoillayers)    !soil runoff
    REAL csoilrunoff(numsubstances,maxsoillayers)    !concentration of soil runoff
    REAL cweights(maxsoillayers) ! weigths to calculate T2 conc. in tile drainage
    REAL trunofftemp(maxsoillayers)
    REAL T1release !release of T1 from surface sources
    REAL runoffd      !tile drainage runoff

    !Local variables for glacier model
    REAL glac_classarea   !area of slc:glacier (m2)
    REAL glac_area        !glacier area (m2)
    REAL glac_melt        !melt of glacier
    REAL glacmelt         !melt of glacier (classarea based)
    REAL meltmax          !water of glacier (mm)
    REAL new_glac_area    !area of glacier (m2)
    REAL new_glac_part    !glacier part of classarea (-)
    REAL cmrad
    REAL snalbmin, snalbmax, snalbkexp, glacieralbedo
    REAL effsnowcov,effsnowcovplain       !effective snow cover with respect to evaporation evap = evap(snowfree)*(1-effsnowcov)+evapsnow
    REAL epotsnow,epotglac         !potential evaporation from snow
    REAL fepotglac,glac_evap,abla,abla0,glacevap

    !Output, default values
    infiltrationflows = 0.
    glacierflows = 0.
    runofflows = 0.
    crunofflows = 0.
    epotglac = 0.
    evapflows = 0.
    verticalflows=0.
    cverticalflows=0.

    !Short notation of parameter values to be used in this subroutine
    sc = landpar(m_srrcs,iluse)*rrcscorr      !Runoff coefficient for surface runoff
    IF(sc>1.) sc = 1.

    !Locally defined variables for indata to be used in this subroutine
    T1release = 0.
    nc = numsubstances

    !Atmospheric deposition, add to soil or precipitation
    CALL add_dry_deposition_to_landclass(i,j,iluse,conductN,conductP,classarea,atmdepload,classdata(j)%vegtype,load(i)%indrydep,     &
         landpar(m_drypp,iluse),frozenstate,soilstate)

    !Calculate plant growth (for uptake of nutrients)
    CALL calculate_plant(i,j,dayno,temp,daylength,plantuptake,miscstate)

    !Current glacier area (simple function of volume)
    glac_classarea = classarea*1.E6      !area of slc:glacier (m2)
    IF(frozenstate%glacvol(i)>0)THEN
      glac_area = calculate_glacier_area(i,frozenstate%glacvol(i))
      IF(glac_area > glac_classarea) glac_area = glac_classarea
    ELSE
      glac_area = 0.
    ENDIF
    glac_part = glac_area/glac_classarea
    nonglac_part = 1. - glac_part

    !Precipitation, rain/snow division only for snow plain (1-glac_part, DG's note)
    CALL calculate_rain_snow_from_precipitation(iluse,prec,temp,snowfall,rainfall,sffrac)

    !Potential evapotranspiration (before snow and glacier melt/evaporation calculations)
    CALL calculate_potential_evaporation(i,j,temp,epot,radext,swrad,netrad,actvap,satvap,wind,epotsnow)
    epot = epot * cevpcorr          !PET for snow free soil, regionally adjusted
    epotsnow = epotsnow * cevpcorr  !PET for snow covered soil, regionally adjusted

    !Snow calculations on snow plain (snowfall addition and melting)
    oldsnow = frozenstate%snow(j,i)   !for snowdepth calculation
    CALL calculate_snow(i,j,basin(i)%subid,iluse,snowfall,cprec,frozenstate%snow(j,i),frozenstate%csnow(:,j,i), &
                        temp,melt,cmelt,swrad,frozenstate%snowage(j,i), &
                        frozenstate%snowmax(j,i),frozenstate%snowdepth(j,i),frozenstate%snowcov(j,i), &
                        epotsnow,evapsnow,cevapsnow,effsnowcov)
    evapflows(3) = evapsnow
    snowmelt = melt * nonglac_part  !output variable rescaled to class-area

    !Melting of glacier ice (glac_melt) - using glacier parameters, separate from the snow parameters
    tt = genpar(m_glacttmp)         !Threshold temperature for glacier melt and evaporation
    cm = genpar(m_glaccmlt)          !Coefficient for glacier melt
    cmrad = genpar(m_glaccmrad)     !Coefficient for glacier melt
    fepotglac = genpar(m_fepotglac) !Coefficient for glacier sublimation

    meltmax = 0.
    IF(glac_area>0.) meltmax = frozenstate%glacvol(i)/glac_area*genpar(m_glacdens)*1000.
    SELECT CASE(modeloption(p_snowmelt))
    CASE(2) ! Temperature And Radiation Index model
      !Radiation component
      IF(frozenstate%glacvol(i)>0. .AND. swrad>0.)then
        !Set parameter values
        snalbmin  = landpar(m_snalbmin,iluse)
        snalbmax  = landpar(m_snalbmax,iluse)
        snalbkexp = landpar(m_snalbkexp,iluse)

        !Get glacier albedo weighted average between snow-albedo and glacier albedo,
        !  assuming similar snow cover area on glacier as on snow plain
        glacieralbedo = snowalbedo_function(frozenstate%snowage(j,i)*timesteps_per_day,snalbmin,snalbmax,snalbkexp) &
                         * frozenstate%snowcov(j,i) + genpar(m_glacalb) * (1.-frozenstate%snowcov(j,i))
        glac_melt = cmrad * swrad * (1.-glacieralbedo)
      ELSE
        glac_melt = 0.
      ENDIF

      !Add Temperature component
      IF(frozenstate%glacvol(i)>0. .AND. temp>=tt) THEN
        glac_melt = glac_melt + cm * (temp - tt)
      ENDIF

      !Remove refreezing component from melt
      IF(frozenstate%glacvol(i)>0. .AND. temp < tt .AND. glac_melt > 0) THEN
        glac_melt = MAX(0.,glac_melt - genpar(m_glaccmrefr) * cm * (tt - temp))
      ENDIF

    CASE DEFAULT ! Original Temperature Index Model
      IF(frozenstate%glacvol(i)>0. .AND. temp>=tt) THEN
        glac_melt = cm * (temp - tt)
      ELSE
        glac_melt = 0.
      ENDIF
    END SELECT

    !Glacier evaporation (sublimation)
    IF(modeloption(p_snowevap).GE.1)THEN
      IF(frozenstate%glacvol(i)>0)THEN
        epotglac  = epot * fepotglac
        glac_evap = epotglac
      ELSE
        glac_evap = 0.
      ENDIF
    ELSE
      glac_evap = 0.
    ENDIF

    !Glacier Melt + Sublimation
    abla0 = glac_melt + glac_evap            !potential ablation (melt+evap)
    abla = MIN(abla0, meltmax)              !minimize ablation to maximum allowed melt
    IF(abla0.GT.0.)THEN
      glac_melt = glac_melt * abla/abla0    !distribute ablation on melt and evap
      glac_evap = glac_evap * abla/abla0      !distribute ablation on melt and evap
    ELSE
      glac_melt = 0.
      glac_evap = 0.
    ENDIF
    evapflows(4) = glac_evap

    !Gross infiltration (rain+melt) on snow plain + melt of glacier
    glacmelt = glac_melt*glac_part
    ginfilt = (rainfall + melt)*nonglac_part+glacmelt
    IF(numsubstances>0)THEN
      IF(ginfilt>0.)THEN
        cginfilt(:) = (cmelt(:)*melt + cprec(:)*rainfall)*nonglac_part / ginfilt   !correcting the glac_part error, thus cglac_melt(i_T2)==0 /DG
      ELSE
        cginfilt(:) = 0.
      ENDIF
    ENDIF
    !Evaporation from snow plain and glacier (evapsnow+evapglac)
    glacevap = glac_evap * glac_part
    evapsnow = evapsnow * nonglac_part

    !Effective reduction in evapotranspiration from the non-glacier part, taking reduction from snow cover into account.
    effsnowcovplain   = glac_part + effsnowcov * nonglac_part

    !Update glacier volume, change in m3/timestep.
    !All precipitation on glacier become glacier ice. Atmdep in prec/dry on glacier assumed retained.
    !Increasing glacier incorporate snow on reduced snow field area
    !Receding glacier, snow redistributes on new snow field area.
    IF(glac_area>0.) frozenstate%glacvol(i) = frozenstate%glacvol(i) + (prec-glac_melt-glac_evap)/1000.*glac_area/genpar(m_glacdens)
    IF(frozenstate%glacvol(i)<0) frozenstate%glacvol(i)=0.
    IF(prec>0.) glacierflows(2) = prec*(1.E-3*glac_area)
    IF(frozenstate%glacvol(i)>0 .AND. glac_area<glac_classarea) THEN
      new_glac_area = calculate_glacier_area(i,frozenstate%glacvol(i))
      IF(new_glac_area > glac_classarea) new_glac_area = glac_classarea
      IF(new_glac_area < glac_area)THEN
        frozenstate%snow(j,i) = frozenstate%snow(j,i) * ((glac_classarea-glac_area)/(glac_classarea-new_glac_area))
        oldsnow = oldsnow * ((glac_classarea-glac_area)/(glac_classarea-new_glac_area))
      ELSEIF(new_glac_area > glac_area) THEN
        IF(frozenstate%snow(j,i)>0.)THEN
          glacierflows(1) = (new_glac_area-glac_area)*frozenstate%snow(j,i)*1.E-3 !snow plain snow -> glacier ice (m3 H2O)
          frozenstate%glacvol(i) = frozenstate%glacvol(i) + glacierflows(1)/genpar(m_glacdens)
        ENDIF
      ENDIF
      new_glac_part = new_glac_area/glac_classarea
      glac_area = new_glac_area   !for output
      glac_part = new_glac_part   !for output, evaporation
    ENDIF

    !Calculate and add infiltration to soil, including calculation of surface flow and macropore flow due to limited infiltration capacity
    CALL infiltration(i,j,isoil,wpmm(:,j),fcmm(:,j),epmm(:,j),ginfilt,cginfilt,temp,mintemp,maxtemp,  &
       infilt,cinfilt,excessinfilt,cexcessinfilt,macroflow,cmacroflow,frozenstate,soilstate)
    CALL add_infiltration(i,j,iluse,infilt,cinfilt,soilstate)
    IF(ginfilt>0.)THEN
      infiltrationflows(1) = snowmelt/ginfilt !fraction of ginfilt from snow melt
      infiltrationflows(7) = glacmelt/ginfilt !fraction of ginfilt from glacier melt
    ENDIF
    infiltrationflows(2) = infilt
    infiltrationflows(3) = excessinfilt

    !Percolation down through the soil layers, including DOC-reduction
    CALL percolation(i,j,isoil,subid,wpmm(:,j),fcmm(:,j),epmm(:,j),soilthick(:,j),verticalflows(1:2),cverticalflows,soilstate)

    !Calculate and remove evapotranspiration from the soil upper two layers of the snowplain
    CALL calculate_actual_soil_evapotranspiration(i,j,temp,epot,wpmm(:,j),fcmm(:,j),epotdist(:,j),soilstate,evap,evapflows(1:2),cevap,(1.-effsnowcovplain))

    !Combined evaporation from snow-free area, snowplain and glacier, and update concentrations cevap
    evap     = evap + evapsnow + glacevap
    IF(numsubstances.GT.0 .AND. evap.GT.0.) cevap(:) = (cevap(:)*(evap-evapsnow) + cevapsnow(:)*evapsnow)/evap
    epot = epot * (1.-effsnowcovplain) + epotsnow * effsnowcov * nonglac_part + epotglac * glac_part
    evapsnow = evapsnow + glacevap

    !Calculate and remove soil runoff
    CALL calculate_soil_runoff(i,j,subid,wpmm(:,j),fcmm(:,j),epmm(:,j),soildepth(:,j),soilthick(:,j),classdata(j)%streamdepth,soilstate,soilrunoff,csoilrunoff)
    runofflows(1:3) = soilrunoff(1:3)
    crunofflows(:,1:3) = csoilrunoff(:,1:3)
    crunoff1 = csoilrunoff(:,1)
    crunoff2 = csoilrunoff(:,2)
    crunoff3 = csoilrunoff(:,3)

    !Calculate and remove runoff by tile or drainage pipe
    CALL calculate_tile_drainage(i,j,isoil,subid,wpmm(:,j),fcmm(:,j),epmm(:,j), &
             soildepth(:,j),soilthick(:,j),classdata(j)%tiledepth,rrcscorr,soilstate,runoffd,&
             crunoffd,cweights)    !unnecessary for glacier?
    runofflows(4:6) = runoffd*cweights(1:3)
    crunofflows(:,4) = crunoffd*cweights(1)
    crunofflows(:,5) = crunoffd*cweights(2)
    crunofflows(:,6) = crunoffd*cweights(3)

    !Add regional lateral groundwater flow from other subbasins
    IF(modeloption(p_deepgroundwater)==1) CALL add_regional_groundwater_flow_to_soil(i,j,classarea,pwmm(:,j),soilstate,rgrwload,verticalflows(5:6),horizontalflows2)

    !Add load from local diffuse sources to the lowest soil layer
    CALL local_diffuse_source(i,j,pwmm(:,j),classarea,soilstate,ruralaload,verticalflows(3:4),horizontalflows(1:3),cruralflow)

    !Calculate soil temperature, snow age, snow depth and frost depth
    CALL calculate_soiltemp(maxsoillayers,temp,frozenstate%snowdepth(j,i),genpar(m_deepmem),soilmem(:,j),soilstate%deeptemp(j,i),soilstate%temp(:,j,i))
    helpmm = fcmm(1,j)+fcmm(2,j)+fcmm(3,j)+wpmm(1,j)+wpmm(2,j)+wpmm(3,j)
    IF(soilthick(3,j)>0)THEN
      CALL calculate_frostdepth(helpmm,landpar(m_cfrost,iluse),soilpar(m_sfrost,isoil),   &
            soilstate%water(1,j,i)+soilstate%water(2,j,i)+soilstate%water(3,j,i),frostdepth,soilstate%temp(1:2,j,i),soilthick(:,j))
    ELSEIF(soilthick(2,j)>0)THEN
      CALL calculate_frostdepth(helpmm,landpar(m_cfrost,iluse),soilpar(m_sfrost,isoil),   &
            soilstate%water(1,j,i)+soilstate%water(2,j,i),frostdepth,soilstate%temp(1:2,j,i),soilthick(:,j))
    ELSE
      CALL calculate_frostdepth(helpmm,landpar(m_cfrost,iluse),soilpar(m_sfrost,isoil),   &
            soilstate%water(1,j,i),frostdepth,soilstate%temp(1:1,j,i),soilthick(:,j))
    ENDIF

    !Surface runoff from saturated overland flow of uppermost soil layer
    satoverflow = MAX(sc * (soilstate%water(1,j,i)-pwmm(1,j)),0.)
    csrunoff = 0.
    IF(satoverflow > 0.) THEN
      CALL remove_water(soilstate%water(1,j,i),nc,soilstate%conc(:,1,j,i),satoverflow,soilstate%conc(:,1,j,i),status)
      IF(status.NE.0) CALL error_remove_water(errstring(1),subid,i,j)
    ENDIF
    runofflows(7) = satoverflow

    !Total surfaceflow (saturated overland flow and excess infiltration)
    totalsurfaceflow = satoverflow + excessinfilt
    surfaceflow(1) = satoverflow
    surfaceflow(2) = excessinfilt
    IF(totalsurfaceflow > 0. .AND. numsubstances>0) THEN
      csrunoff(:) = (soilstate%conc(:,1,j,i) * satoverflow + excessinfilt * cexcessinfilt(:)) / totalsurfaceflow     !used for satoverflow and excessinfilt
    ENDIF

    !Erosion of particles with fastflow (surface flow and macropore flow) including delay in temporary storage.
    IF(conductP.OR.conductS) CALL particle_processes_for_runoff(i,j,isoil,iluse,dayno,rainfall,totalsurfaceflow,   &
              macroflow,runoffd,runofflows(1)+runofflows(2)+runofflows(3)+runoffd+totalsurfaceflow,phoscorr,  &
              csrunoff,cmacroflow,crunoffd,crunoff1,  &
              crunoff2,crunoff3,frozenstate%snow(j,i),soilstate)

    !Add macropore water to soil layer with groundwater level (except the PP)
    CALL add_macropore_flow(i,j,macroflow,cmacroflow,wpmm(:,j),fcmm(:,j), &
            epmm(:,j),pwmm(:,j),soildepth(:,j),soilthick(:,j),infiltrationflows(4:6),soilstate)

    !Second percolation down through the soil layers, including DOC-reduction (limited to same maxperc)
    CALL percolation(i,j,isoil,subid,wpmm(:,j),fcmm(:,j),epmm(:,j),soilthick(:,j),verticalflows(1:2),cverticalflows,soilstate)

    !Groundwater level
    CALL calculate_groundwater_table(soilstate%water(:,j,i),wpmm(:,j),fcmm(:,j),epmm(:,j),pwmm(:,j),soildepth(:,j),soilthick(:,j),gwat)
    CALL calculate_soil_moisture_deficit(soilstate%water(:,j,i),wpmm(:,j),fcmm(:,j),soilthick(:,j),smdef)

    !Soil transformation processes for substances
    CALL soil_np_processes(i,j,iluse,conductN,conductP,conductC,dayno,classarea,wpmm(:,j),fcmm(:,j),epmm(:,j),plantuptake,soilthick(:,j),genpar(m_fertdays),genpar(m_littdays),  &
         source,sink,nitrif,denitrif,cropuptakein,cropsources,   &
         landpar(m_dissolfN,iluse),landpar(m_dissolfP,iluse),landpar(m_dissolhN,iluse),landpar(m_dissolhP,iluse),      &
         landpar(m_minerfn,iluse),landpar(m_minerfp,iluse),landpar(m_degradhn,iluse),      &
         landpar(m_denitrlu,iluse),landpar(m_degradhp,iluse),soilstate)
    IF(conductC) CALL soil_carbon_processes(i,j,wpmm(:,j),fcmm(:,j),epmm(:,j),pwmm(:,j),soilthick(:,j),    &
         genpar(m_crate1),genpar(m_crate2),genpar(m_crate3),genpar(m_crate9),genpar(m_crate10),genpar(m_minc),  &
         landpar(m_ocsoim,iluse),landpar(m_ocsmslp,iluse),soilstate)
    CALL balance_spsoil(i,j,conductP,soilthick(:,j), &
         soilpar(m_freuc,isoil),soilpar(m_freuexp,isoil),soilpar(m_freurate,isoil),soilstate)
    CALL soil_tracer_processes(i,j,currentdate%year,soilthick(:,j),soilstate,miscstate,ginfilt,T1release)

    !Add released T1 to surface runoff or top soil
    IF(i_t1>0)THEN
      IF(T1release>0.)THEN
        IF(totalsurfaceflow>0.)THEN
          csrunoff(i_t1) = csrunoff(i_t1) + (T1release * (totalsurfaceflow/(infilt+totalsurfaceflow))) / totalsurfaceflow
        ENDIF
        soilstate%partT1(1,j,i) = soilstate%partT1(1,j,i) + T1release * (infilt/(infilt+totalsurfaceflow))
      ENDIF
    ENDIF

    !Runoff temperature concentrations dependent on soiltemp calculation [DG/JS Temp.model, May-2013]
    IF(i_t2>0) THEN
      trunofftemp(1) = AMAX1(0.,soilstate%temp(1,j,i))
      trunofftemp(2) = AMAX1(0.,soilstate%temp(2,j,i))
      trunofftemp(3) = AMAX1(0.,soilstate%temp(3,j,i))

      !T2 conc. in soil layers
      soilstate%conc(i_t2,1,j,i) = trunofftemp(1)
      soilstate%conc(i_t2,2,j,i) = trunofftemp(2)
      soilstate%conc(i_t2,3,j,i) = trunofftemp(3)

      !T2 conc. in runoff from soil layers
      crunoff1(i_t2) = trunofftemp(1)
      crunoff2(i_t2) = trunofftemp(2)
      crunoff3(i_t2) = trunofftemp(3)

      !T2 conc. in surface runoff, mixture of excess infiltration and saturated topsoil
      IF(totalsurfaceflow>0)THEN
        csrunoff(i_t2) = (trunofftemp(1) * satoverflow + excessinfilt * cexcessinfilt(i_t2)) / totalsurfaceflow
      ELSE
        csrunoff(i_t2) = 0.0
      ENDIF
      !T2 conc. in tile drainage (weigthed average over tile drainage depth)
      crunoffd(i_t2) = cweights(1) * trunofftemp(1) + cweights(2) * trunofftemp(2) + &
                       cweights(3) * trunofftemp(3)
    ENDIF

    !Update GlacierTimeSeriesData with current glacier state
    IF(ALLOCATED(GlacierTimeSeriesData(i)%glac_vol))THEN
      GlacierTimeSeriesData(i)%glac_vol(1:GlacierTimeSeriesSteps-1)=GlacierTimeSeriesData(i)%glac_vol(2:GlacierTimeSeriesSteps)
      GlacierTimeSeriesData(i)%glac_vol(GlacierTimeSeriesSteps)=frozenstate%glacvol(i)
    ENDIF
    IF(ALLOCATED(GlacierTimeSeriesData(i)%glac_area))THEN
      GlacierTimeSeriesData(i)%glac_area(1:GlacierTimeSeriesSteps-1)=GlacierTimeSeriesData(i)%glac_area(2:GlacierTimeSeriesSteps)
      GlacierTimeSeriesData(i)%glac_area(GlacierTimeSeriesSteps)=glac_area
    ENDIF

  END SUBROUTINE soilmodel_3

  !>Initialize glacier parameters.
  !>
  !> \b Reference ModelDescription Chapter Land routines (Glaciers)
  !---------------------------------------------------------
  SUBROUTINE get_glacier_parameters(nc,arr)

    !Argument declarations
    INTEGER, INTENT(IN) :: nc         !<number of classes (nclass)
    INTEGER, INTENT(IN) :: arr(nc)    !<classmodels

    !Local variables
    INTEGER i,j
    REAL volcoeff,tot_glac_area
    LOGICAL nogd

    !Allocate variables needed
    nogd = .FALSE.
    IF(.NOT.ALLOCATED(glacier))THEN     !No GlacierData.txt!
      nglaciers = nsub
      ALLOCATE(glacier(nglaciers))
      glacier(1:nsub)%gtype = INT(missing_value)
      glacier(1:nsub)%volcorr = 0.
      glacier(1:nsub)%yeardiff = 0.
      glacier(1:nsub)%glacinimb = 0.
      IF(.NOT.ALLOCATED(glacierindex)) ALLOCATE(glacierindex(nsub))
      glacierindex=-9999
      nogd = .TRUE.
    ENDIF
    IF(.NOT.ALLOCATED(glac_areavol_par1)) ALLOCATE(glac_areavol_par1(nglaciers))

    !Default value glacier parameter
    IF(genpar(m_glacdens).LE.0.)   genpar(m_glacdens)   = 0.85   ![m3 water/m3 ice]
    IF(genpar(m_glacvcoef).LE.0.)  genpar(m_glacvcoef)  = 0.205  !Default values for glacier type 0 (Glacier and Small) (Radic&Hock(2010), glacier, trad.fit)
    IF(genpar(m_glacvexp).LE.0.)   genpar(m_glacvexp)   = 1.375  ! -"-
    IF(genpar(m_glacvcoef1).LE.0.) genpar(m_glacvcoef1) = 1.701  !Default values for type 1 (Ice caps or Large glaciers) (Radic&Hock(2010), ice cap, trad.fit)
    IF(genpar(m_glacvexp1).LE.0.)  genpar(m_glacvexp1)  = 1.25   ! -"-
    IF(glacier(1)%gtype==INT(missing_value))THEN
      glacier%gtype = 0
      IF(nogd)THEN
        DO i = 1,nsub
          glacierindex(i) = i
        ENDDO
        IF(genpar(m_glac2arlim)>0.)THEN
          DO j = 1,nc
            IF(arr(j)==glacier_model)THEN
              DO i = 1,nsub
                tot_glac_area = classbasin(i,j)%part*basin(i)%area      !area of slc:glacier (m2)
                IF(tot_glac_area>0.)THEN
                  IF(tot_glac_area >= genpar(m_glac2arlim))THEN
                    glacier(i)%gtype = 1
                  ENDIF
                ENDIF
              ENDDO
            ENDIF
          ENDDO
        ENDIF
      ENDIF
    ENDIF

    !Set help variable for glacier area calculation: area = (vol*glac_areavol_par(:,1)/volcorr)**glac_areavol_par(:,2)
    DO i = 1,nglaciers
      IF(glacier(i)%gtype==0)THEN
        volcoeff = genpar(m_glacvcoef)*EXP(glacier(i)%volcorr)
      ELSE
        volcoeff = genpar(m_glacvcoef1)*EXP(glacier(i)%volcorr)
      ENDIF
      glac_areavol_par1(i) = 1./volcoeff
    ENDDO
    glac_areavol_par2(1) = 1./genpar(m_glacvexp)
    glac_areavol_par2(2) = 1./genpar(m_glacvexp1)

  END SUBROUTINE get_glacier_parameters

  !>Initialize glacier parameters and variables.
  !>
  !> \b Reference ModelDescription Chapter Land routines (Glaciers)
  !---------------------------------------------------------
  SUBROUTINE initiate_glacier(nc,arr)

    !Argument declarations
    INTEGER, INTENT(IN) :: nc         !<number of classes (nclass)
    INTEGER, INTENT(IN) :: arr(nc)    !<classmodels

    !Local variables
    INTEGER i,j

    !Default value glacier parameter
    CALL get_glacier_parameters(nc,arr)

    !Allocate and initiate the glacier time series tables
    IF(.NOT.ALLOCATED(glacierTimeSeriesData))THEN
      ALLOCATE(glacierTimeSeriesData(nsub))
      DO j=1,nc
        IF(arr(j)==glacier_model)THEN
          DO i = 1,nsub
            IF(classbasin(i,j)%part>0.)THEN
              IF(.NOT.ALLOCATED(glacierTimeSeriesData(i)%glac_vol))ALLOCATE(glacierTimeSeriesData(i)%glac_vol(glacierTimeSeriesSteps))
              IF(.NOT.ALLOCATED(glacierTimeSeriesData(i)%glac_area))ALLOCATE(glacierTimeSeriesData(i)%glac_area(glacierTimeSeriesSteps))
            ENDIF
          ENDDO
        ENDIF
      ENDDO
    ENDIF
    DO j=1,nc
      IF(arr(j)==glacier_model)THEN
        DO i = 1,nsub
          IF(classbasin(i,j)%part>0.)THEN
            glacierTimeSeriesData(i)%glac_vol(:)  = missing_value
            glacierTimeSeriesData(i)%glac_area(:) = missing_value
          ENDIF
        ENDDO
      ENDIF
    ENDDO

  END SUBROUTINE initiate_glacier

  !>Initialize glacier volume.
  !>
  !> \b Reference ModelDescription Chapter Land routines (Glaciers)
  !---------------------------------------------------------
  SUBROUTINE initiate_glacier_state(nc,arr,frozenstate)

    !Argument declarations
    INTEGER, INTENT(IN) :: nc         !<number of classes (nclass)
    INTEGER, INTENT(IN) :: arr(nc)    !<classmodels
    TYPE(snowicestatetype),INTENT(INOUT) :: frozenstate !<Snow and ice states

    !Local variables
    INTEGER i,j
    REAL tot_glac_area  !area of slc - glacier

    !Default value glacier parameter
    CALL get_glacier_parameters(nc,arr)

    !Calculate initial glacier volume
    DO j = 1,nc
      IF(arr(j)==glacier_model)THEN
        DO i = 1,nsub
          IF(classbasin(i,j)%part>0.)THEN
            tot_glac_area = classbasin(i,j)%part*basin(i)%area      !area of slc:glacier (m2)
            IF(glacier(glacierindex(i))%gtype==0)THEN
              frozenstate%glacvol(i) = EXP(glacier(glacierindex(i))%volcorr)*genpar(m_glacvcoef)*(tot_glac_area**genpar(m_glacvexp))  !m3
            ELSE
              frozenstate%glacvol(i) = EXP(glacier(glacierindex(i))%volcorr)*genpar(m_glacvcoef1)*(tot_glac_area**genpar(m_glacvexp1))  !m3
            ENDIF
            !Set the initial glacier area in relation to simulation starting date
            IF(glacier(glacierindex(i))%yeardiff/=0 .AND. (genpar(m_glacannmb)/=0. .OR. glacier(glacierindex(i))%glacinimb/=0.))THEN
              !update volume by average_annual_massbalance * yearsdiff - priority to glacinimb in GlacierData.txt over par.txt
              IF(glacier(glacierindex(i))%glacinimb/=0.)THEN
                frozenstate%glacvol(i) = frozenstate%glacvol(i) + glacier(glacierindex(i))%yeardiff * glacier(glacierindex(i))%glacinimb/1000.*tot_glac_area/genpar(m_glacdens)
              ELSE
                frozenstate%glacvol(i) = frozenstate%glacvol(i) + glacier(glacierindex(i))%yeardiff * genpar(m_glacannmb)/1000.*tot_glac_area/genpar(m_glacdens)
              ENDIF
            ENDIF
          ENDIF
        ENDDO
      ENDIF
    ENDDO

  END SUBROUTINE initiate_glacier_state

  !>Glacier area-volume relationship
  !>
  !> \b Reference ModelDescription Chapter Land routines (Glaciers)
  !---------------------------------------------------------
  REAL FUNCTION calculate_glacier_area(i,vol)

    !Argument declarations
    INTEGER, INTENT(IN) :: i        !<index of current subbasin
    REAL, INTENT(IN)    :: vol      !<glacier volume of current subbasin (m3)

    !Local variables
    REAL area

    calculate_glacier_area = 0.
    IF(vol==0) RETURN

    area = (vol*glac_areavol_par1(glacierindex(i)))**glac_areavol_par2(glacier(glacierindex(i))%gtype+1)
    calculate_glacier_area = area

  END FUNCTION calculate_glacier_area

  !>Glacier mass for a requested obseration period.
  !>
  !> "observation operator" for comparison with WGMS mass balance data
  !-------------------------------------------------------------------
  SUBROUTINE calculate_glacier_massbalance(i,recMP,comMB,comMA)

    INTEGER, INTENT(IN) :: i      !<current subbasin
    REAL, INTENT(IN)    :: recMP  !<mass balance period
    REAL, INTENT(OUT)   :: comMB  !<computed glacier mass balance
    REAL, INTENT(OUT)   :: comMA  !<computed mass balance area

    INTEGER glacT0, glacT1

    !beginning and ending of evaluation period in the glacier time series
    glacT0 = glacierTimeSeriesSteps-INT(recMP)
    glacT1 = glacierTimeSeriesSteps

    !check if the beginning is within the saved time series
    IF(glacT0.GT.0)THEN
      !check if modelled values are available at the beginning date, if so, evaluate mass balance
      IF(glacierTimeSeriesData(i)%glac_vol(glacT0).GE.0.)THEN
        !Mass balance(mm) = dmass/dtime/darea = density * (vol(T1)-vol(T0))*2/(area(T1)+area(T0)
        !  check if glacier area > 0
        comMA = 0.5 * (glacierTimeSeriesData(i)%glac_area(glacT0)+glacierTimeSeriesData(i)%glac_area(glacT1))
        IF(comMA.GT.0.)THEN
          comMB = 1000. * genpar(m_glacdens) * (glacierTimeSeriesData(i)%glac_vol(glacT1) - glacierTimeSeriesData(i)%glac_vol(glacT0))/ comMA
        ELSE
          !if glacier area = 0 in both ends of mass balance period, then the mass balance = 0
          comMB = 0
        ENDIF
        comMA = comMA/1.E6 !transform m2 to km2 for printout
      ELSE
        comMA = -9999.
        comMB = -9999.
      ENDIF
    ELSE
      comMA = -9999.
      comMB = -9999.
    ENDIF

  END SUBROUTINE calculate_glacier_massbalance

END MODULE GLACIER_SOILMODEL


!> mpi-related gemini functionality; all procedures must be bind(C) to allow C/C++ main programs
module gemini3d_mpi

use, intrinsic :: iso_fortran_env, only : stderr=>error_unit
use, intrinsic :: iso_c_binding, only : c_ptr
use phys_consts, only: wp,debug
use mpimod, only: mpi_manualgrid, process_grid_auto, mpi_cfg, mpibreakdown, mpisetup
use meshobj, only: curvmesh
use config, only: gemini_cfg
use io, only: output_plasma,output_aur,find_milestone,input_plasma,create_outdir
use potential_comm, only: get_BGEfields,velocities
use grid, only: lx1,lx2,lx3
use grid_mpi, only: grid_drift, read_grid
use collisions, only: conductivities
use potentialBCs_mumps, only: init_Efieldinput
use potential_comm,only : pot2perpfield
use neutral_perturbations, only: init_neutralperturb,neutral_denstemp_update,neutral_wind_update,neutral_perturb
use temporal, only : dt_comm
use sanity_check, only : check_finite_pertub, check_finite_output
use potential_comm,only : electrodynamics
use advec_mpi, only: set_global_boundaries_allspec, halo_interface_vels_allspec
use multifluid_mpi, only: halo_allparams
use sources_mpi, only: RK2_prep_mpi_allspec
use ionization_mpi, only: get_gavg_Tinf
use neutral_perturbations, only: clear_dneu
use gemini3d, only: cfg,x,Phiall,ns,vs1,Ts,Phi,E1,E2,E3,vs2,vs3,nn,Tn,vn1,vn2,vn3,iver, &
                      B1,B2,B3,J1,J2,J3,rhovs1,rhoes,vs1i,vs2i,vs3i

implicit none (type, external)
private
public :: init_procgrid, outdir_fullgridvaralloc, read_grid_C, get_initial_state, &
            BGfield_Lagrangian, check_dryrun, check_fileoutput,  &
            get_initial_drifts, init_Efieldinput_C, pot2perpfield_C, init_neutralperturb_C, dt_select_C, &
            neutral_atmos_wind_update_C, neutral_perturb_C, electrodynamics_C, check_finite_output_C, &
            halo_interface_vels_allspec_C, set_global_boundaries_allspec_C, halo_allparams_C, &
            RK2_prep_mpi_allspec_C,get_gavg_Tinf_C, clear_dneu_C, mpisetup_C, mpiparms_C

real(wp), parameter :: dtscale=2    ! controls how rapidly the time step is allowed to change

contains
  !> call the mpi setup from our module
  subroutine mpisetup_C() bind(C, name="mpisetup_C")
    call mpisetup()
  end subroutine mpisetup_C

  subroutine mpiparms_C(myid,lid) bind(C, name="mpiparms_C")
    integer, intent(inout) :: myid,lid

    myid=mpi_cfg%myid
    lid=mpi_cfg%lid
  end subroutine mpiparms_C

  !> create output directory and allocate full grid potential storage
  subroutine outdir_fullgridvaralloc(lx1,lx2all,lx3all) bind(C)
    integer, intent(in) :: lx1,lx2all,lx3all

    !> create a place, if necessary, for output datafiles
    if (mpi_cfg%myid==0) then
      call create_outdir(cfg)
    end if

    !> fullgrid variable allocations only needed for the potential variable
    if (mpi_cfg%myid==0) then
      allocate(Phiall(-1:lx1+2,-1:lx2all+2,-1:lx3all+2))
    end if
  end subroutine outdir_fullgridvaralloc

  !> read in the grid and distribute to workers
  subroutine read_grid_C() bind(C, name="read_grid_C")
    call read_grid(cfg%indatsize,cfg%indatgrid,cfg%flagperiodic, x)
    !! read in a previously generated grid from filenames listed in input file
    print*, 'end read_grid_C:  ',x%lx1,x%lx2,x%lx3
  end subroutine read_grid_C

  !> load initial conditions
  subroutine get_initial_state(UTsec,ymd,tdur) bind(C)
    real(wp), intent(inout) :: UTsec
    integer, dimension(3), intent(inout) :: ymd
    real(wp), intent(inout) :: tdur

    integer, dimension(3) :: ymdtmp
    real(wp) :: UTsectmp,ttmp
    character(:), allocatable :: filetmp

    call find_milestone(cfg, ttmp, ymdtmp, UTsectmp, filetmp)
    if ( ttmp > 0 ) then
      !! restart scenario
      if (mpi_cfg%myid==0) then
        print*, '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
        print*, '! Restarting simulation from time:  ',ymdtmp,UTsectmp
        print*, '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
      end if

      !! Set start variables accordingly and read in the milestone
      UTsec=UTsectmp
      ymd=ymdtmp
      tdur=cfg%tdur-ttmp    ! subtract off time that has elapsed to milestone
      if (mpi_cfg%myid==0) then
        print*, 'Treating the following file as initial conditions:  ',filetmp
        print*, ' full duration:  ',cfg%tdur,'; remaining simulation time:  ',tdur
      end if

      if (tdur <= 1e-6_wp .and. mpi_cfg%myid==0) error stop 'Cannot restart simulation from the final time step!'

      cfg%tdur=tdur         ! just to insure consistency
      call input_plasma(cfg%outdir, x%x1,x%x2all,x%x3all,cfg%indatsize,filetmp,ns,vs1,Ts,Phi,Phiall)
    else !! start at the beginning
      UTsec = cfg%UTsec0
      ymd = cfg%ymd0
      tdur = cfg%tdur

      if (tdur <= 1e-6_wp .and. mpi_cfg%myid==0) error stop 'Simulation is of zero time duration'
      print*, 'Starting from beginning of simulation...'
      call input_plasma(cfg%outdir, x%x1,x%x2all,x%x3all,cfg%indatsize,cfg%indatfile,ns,vs1,Ts,Phi,Phiall)
    end if
  end subroutine get_initial_state

  !> check whether file output should be done and complete it
  subroutine check_fileoutput(t,tout,tglowout,tmilestone,flagoutput,ymd,UTsec) bind(C)
    real(wp), intent(in) :: t
    real(wp), intent(inout) :: tout,tglowout,tmilestone
    integer, intent(inout) :: flagoutput
    integer, dimension(3), intent(in) :: ymd
    real(wp), intent(in) :: UTsec
    real(wp) :: tstart,tfin

    if (abs(t-tout) < 1d-5) then
      tout = tout + cfg%dtout
      if (cfg%nooutput ) then
        if (mpi_cfg%myid==0) write(stderr,*) 'WARNING: skipping file output at sim time (sec)',t
        return
      endif
      !! close enough to warrant an output now...
      if (mpi_cfg%myid==0 .and. debug) call cpu_time(tstart)

      !! We may need to adjust flagoutput if we are hitting a milestone
      flagoutput=cfg%flagoutput
      if (cfg%mcadence>0 .and. abs(t-tmilestone) < 1d-5) then
        flagoutput=1    !force a full output at the milestone
        call output_plasma(cfg%outdir,flagoutput,ymd, &
          UTsec,vs2,vs3,ns,vs1,Ts,Phiall,J1,J2,J3, &
          cfg%out_format)
        tmilestone = t + cfg%dtout * cfg%mcadence
        if(mpi_cfg%myid==0) print*, 'Milestone output triggered.'
      else
        call output_plasma(cfg%outdir,flagoutput,ymd, &
          UTsec,vs2,vs3,ns,vs1,Ts,Phiall,J1,J2,J3, &
          cfg%out_format)
      end if
      if (mpi_cfg%myid==0 .and. debug) then
        call cpu_time(tfin)
        print *, 'Plasma output done for time step:  ',t,' in cpu_time of:  ',tfin-tstart
      endif
    end if

    !> GLOW file output
    if ((cfg%flagglow /= 0) .and. (abs(t-tglowout) < 1d-5)) then !same as plasma output
      call cpu_time(tstart)
      call output_aur(cfg%outdir, cfg%flagglow, ymd, UTsec, iver, cfg%out_format)
      if (mpi_cfg%myid==0) then
        call cpu_time(tfin)
        print *, 'Auroral output done for time step:  ',t,' in cpu_time of: ',tfin-tstart
      end if
      tglowout = tglowout + cfg%dtglowout
    end if
  end subroutine

  !> check whether a dryrun simulation was done
  subroutine check_dryrun() bind(C)
    character(8) :: date
    character(10) :: time
    integer :: ierr

    if (cfg%dryrun) then
      ierr = mpibreakdown()
      if (ierr /= 0) error stop 'Gemini dry run MPI shutdown failure'
      call date_and_time(date,time)
      print '(/,A)', 'DONE: ' // date(1:4) // '-' // date(5:6) // '-' // date(7:8) // 'T' &
        // time(1:2) // ':' // time(3:4) // ':' // time(5:)
      stop "OK: Gemini dry run"
    endif
  end subroutine check_dryrun

  !> prep simulation for use of Lagrangian grid, if needed
  subroutine BGfield_Lagrangian(v2grid,v3grid) bind(C, name="BGfield_Lagrangian")
    real(wp), intent(inout) :: v2grid,v3grid
    real(wp), dimension(:,:,:), allocatable :: E01,E02,E03

    allocate(E01(lx1,lx2,lx3),E02(lx1,lx2,lx3),E03(lx1,lx2,lx3))    ! allocate without ghost cells
    E01=0; E02=0; E03=0;
    if (cfg%flagE0file==1) then
      call get_BGEfields(x,E01,E02,E03)
    end if
    if (cfg%flaglagrangian) then    ! Lagrangian (moving) grid; compute from input background electric fields
      call grid_drift(x,E02,E03,v2grid,v3grid)
      if (mpi_cfg%myid==0) print*, mpi_cfg%myid,' using Lagrangian grid moving at:  ',v2grid,v3grid
    else                            ! stationary grid
      v2grid = 0
      v3grid = 0
      E1(1:lx1,1:lx2,1:lx3) = E1(1:lx1,1:lx2,1:lx3) + E01    ! FIXME: this is before dist fields are computed???
      E2(1:lx1,1:lx2,1:lx3) = E2(1:lx1,1:lx2,1:lx3) + E02
      E3(1:lx1,1:lx2,1:lx3) = E3(1:lx1,1:lx2,1:lx3) + E03
    end if
    deallocate(E01,E02,E03)

    if (mpi_cfg%myid==0) then
      print*, 'Recomputed initial fields including background (BGfieldLagrangian):'
      print*, '    ',minval(E1(1:lx1,1:lx2,1:lx3)),maxval(E1(1:lx1,1:lx2,1:lx3))
      print*, '    ',minval(E2(1:lx1,1:lx2,1:lx3)),maxval(E2(1:lx1,1:lx2,1:lx3))
      print*, '    ',minval(E3(1:lx1,1:lx2,1:lx3)),maxval(E3(1:lx1,1:lx2,1:lx3))
    end if
  end subroutine BGfield_Lagrangian

  !> initial drifts at the start of the simulation
  subroutine get_initial_drifts() bind(C)
    real(wp), dimension(:,:,:), allocatable :: sig0,sigP,sigH,sigPgrav,sigHgrav
    real(wp), dimension(:,:,:,:), allocatable :: muP,muH,nusn
    integer :: lx1,lx2,lx3,lsp

    lx1=x%lx1; lx2=x%lx2; lx3=x%lx3; lsp=size(ns,4);
    allocate(sig0(lx1,lx2,lx3),sigP(lx1,lx2,lx3),sigH(lx1,lx2,lx3),sigPgrav(lx1,lx2,lx3),sigHgrav(lx1,lx2,lx3))
    allocate(muP(lx1,lx2,lx3,lsp),muH(lx1,lx2,lx3,lsp),nusn(lx1,lx2,lx3,lsp))
    call conductivities(nn,Tn,ns,Ts,vs1,B1,sig0,sigP,sigH,muP,muH,nusn,sigPgrav,sigHgrav)
    call velocities(muP,muH,nusn,E2,E3,vn2,vn3,ns,Ts,x,cfg%flaggravdrift,cfg%flagdiamagnetic,vs2,vs3)
    deallocate(sig0,sigP,sigH,muP,muH,nusn,sigPgrav,sigHgrav)
    if(mpi_cfg%myid==0) then
      print*, 'Recomputed initial drifts:  '
      print*, '    ',minval(vs2(1:lx1,1:lx2,1:lx3,1:lsp)),maxval(vs2(1:lx1,1:lx2,1:lx3,1:lsp))
      print*, '    ',minval(vs3(1:lx1,1:lx2,1:lx3,1:lsp)),maxval(vs3(1:lx1,1:lx2,1:lx3,1:lsp))
    end if
  end subroutine get_initial_drifts

  !> initialize the process gridf for this simulation
  subroutine init_procgrid(lx2all,lx3all,lid2in,lid3in) bind(C)
    integer, intent(in) :: lx2all,lx3all,lid2in,lid3in

    if (lid2in==-1) then
      call process_grid_auto(lx2all, lx3all)
      !! grid_size defines lx2all and lx3all
    else
      call mpi_manualgrid(lx2all, lx3all, lid2in, lid3in)
    endif
    print '(A, I0, A1, I0)', 'process grid (Number MPI processes) x2, x3:  ',mpi_cfg%lid2, ' ', mpi_cfg%lid3
    print '(A, I0, A, I0, A1, I0)', 'Process:',mpi_cfg%myid,' at process grid location: ',mpi_cfg%myid2,' ',mpi_cfg%myid3
  end subroutine init_procgrid

  !> initialize electric field input data
  subroutine init_Efieldinput_C(dt,t,ymd,UTsec) bind(C, name="init_Efieldinput_C")
    real(wp), intent(in) :: dt,t
    integer, dimension(3), intent(in) :: ymd
    real(wp), intent(in) :: UTsec

    call init_Efieldinput(dt,t,cfg,ymd,UTsec,x)
  end subroutine init_Efieldinput_C

  !> convert potential to electric field by differentiating
  subroutine pot2perpfield_C() bind(C, name="pot2perpfield_C")
    E1 = 0
    call pot2perpfield(Phi,x,E2,E3)
    if(mpi_cfg%myid==0) then
      print '(A)', 'Recomputed initial dist. fields via pot2perpfield:'
      print*, '    gemini ',minval(E1(1:lx1,1:lx2,1:lx3)),maxval(E1(1:lx1,1:lx2,1:lx3))
      print*, '    gemini ',minval(E2(1:lx1,1:lx2,1:lx3)),maxval(E2(1:lx1,1:lx2,1:lx3))
      print*, '    gemini ',minval(E3(1:lx1,1:lx2,1:lx3)),maxval(E3(1:lx1,1:lx2,1:lx3))
      print*, '    gemini ',minval(Phi(1:lx1,1:lx2,1:lx3)),maxval(Phi(1:lx1,1:lx2,1:lx3))
    end if
  end subroutine pot2perpfield_C

  !> initialize neutral perturbations
  subroutine init_neutralperturb_C(dt,ymd,UTsec) bind(C, name="init_neutralperturb_C")
    real(wp), intent(in) :: dt
    integer, dimension(3), intent(in) :: ymd
    real(wp), intent(in) :: UTsec

    call init_neutralperturb(cfg,x,dt,ymd,UTsec)
  end subroutine init_neutralperturb_C

  !> select time step and throttle if changing too rapidly
  subroutine dt_select_C(it,t,tout,tglowout,dt) bind(C, name="dt_select_C")
    integer, intent(in) :: it
    real(wp), intent(in) :: t,tout,tglowout
    real(wp), intent(inout) :: dt
    real(wp) :: dtprev

    !> save prior time step
    dtprev = dt

    !> time step calculation, requires workers to report their most stringent local stability constraint
    call dt_comm(t,tout,tglowout,cfg,ns,Ts,vs1,vs2,vs3,B1,B2,B3,x,dt)

    !> do not allow the time step to change too rapidly
    if (it>1) then
      if(dt/dtprev > dtscale) then
        !! throttle how quickly we allow dt to increase
        dt=dtscale*dtprev
        if (mpi_cfg%myid == 0) then
          print '(A,EN14.3)', 'Throttling dt to:  ',dt
        end if
      end if
    end if
  end subroutine dt_select_C

  !> apply neutral perturbations/background and assign to main code variables
  subroutine neutral_atmos_wind_update_C(v2grid,v3grid) bind(C, name="neutral_atmos_wind_update_C")
    real(wp), intent(in) :: v2grid,v3grid

    call neutral_denstemp_update(nn,Tn)
    call neutral_wind_update(vn1,vn2,vn3,v2grid,v3grid)
  end subroutine neutral_atmos_wind_update_C

  !> compute neutral perturbations and apply to main code variables
  subroutine neutral_perturb_C(dt,t,ymd,UTsec,v2grid,v3grid) bind(C, name="neutral_perturb_C")
    real(wp), intent(in) :: dt,t
    integer, dimension(3), intent(in) :: ymd
    real(wp), intent(in) :: UTsec
    real(wp), intent(in) :: v2grid,v3grid

    call neutral_perturb(cfg,dt,cfg%dtneu,t,ymd,UTsec,x,v2grid,v3grid,nn,Tn,vn1,vn2,vn3)
    call check_finite_pertub(cfg%outdir, t, mpi_cfg%myid, nn, Tn, vn1, vn2, vn3)
  end subroutine neutral_perturb_C

  !> call electrodynamics solution
  subroutine electrodynamics_C(it,t,dt,ymd,UTsec) bind(C, name="electrodynamics_C")
    integer, intent(in) :: it
    real(wp), intent(in) :: t,dt
    integer, dimension(3), intent(in) :: ymd
    real(wp), intent(in) :: UTsec

    call electrodynamics(it,t,dt,nn,vn2,vn3,Tn,cfg,ns,Ts,vs1,B1,vs2,vs3,x,E1,E2,E3,J1,J2,J3,Phiall,ymd,UTsec)
  end subroutine electrodynamics_C

  !> check main state variables for finiteness
  subroutine check_finite_output_C(t) bind(C, name="check_finite_output_C")
    real(wp), intent(in) :: t

    call check_finite_output(cfg%outdir, t, mpi_cfg%myid, vs2,vs3,ns,vs1,Ts, Phi,J1,J2,J3)
  end subroutine check_finite_output_C

  !> haloing for computing cell interface velocities
  subroutine halo_interface_vels_allspec_C(lsp) bind(C, name="halo_interface_vels_allspec_C")
    integer, intent(in) :: lsp

    call halo_interface_vels_allspec(x%flagper,vs2,vs3,lsp)
  end subroutine halo_interface_vels_allspec_C

  !> enforce global boundary conditions
  subroutine set_global_boundaries_allspec_C(lsp) bind(C, name="set_global_boundaries_allspec_C")
    integer, intent(in) :: lsp

    call set_global_boundaries_allspec(x%flagper,ns,rhovs1,vs1,vs2,vs3,rhoes,vs1i,lsp)
  end subroutine set_global_boundaries_allspec_C

  !> halo all advected parameters
  subroutine halo_allparams_C() bind(C, name="halo_allparams_C")
    call halo_allparams(ns,rhovs1,rhoes,x%flagper)
  end subroutine halo_allparams_C

  !> prepare/halo data for compression substep
  subroutine RK2_prep_mpi_allspec_C() bind(C, name="RK2_prep_mpi_allspec_C")
    call RK2_prep_mpi_allspec(vs1,vs2,vs3,x%flagper)
  end subroutine RK2_prep_mpi_allspec_C

  !> agree on average value of gravity and exospheric temp
  subroutine get_gavg_Tinf_C(gavg,Tninf) bind(C, name="get_gavg_Tninf_C")
    real(wp), intent(inout) :: gavg,Tninf

    call get_gavg_Tinf(gavg,Tninf)
  end subroutine get_gavg_Tinf_C

  !> deallocate module storage for neutral perturbations
  subroutine clear_dneu_C() bind(C, name="clear_dneu_C")
    call clear_dneu()
  end subroutine clear_dneu_C
end module gemini3d_mpi


      subroutine interlumdb(cooling_time,
     &                      wd_mass,
     &                      Z,
     &                      luminosity,
     &                      c1,
     &                      c2,
     &                      c3,
     &                      c4,
     &                      c5,
     &                      c6,
     &                      effective_temperature,
     &                      log_surface_gravity,
     &                      table)
C     Interpolating luminosity of DB WDs using cooling tables by
C     Althaus et al. (2009) for metallicities 0.001, 0.01, 0.06
C         TODO: rename
C         c1,c2,c3,c4,c5: Johnson colors Johnson (UBVRI)
      use external_types
      implicit none

C     TODO: find out the meanings of variables and rename them
      integer, parameter :: NROWB = 400,
     &                      NROWB2 = 60
      integer :: numberOfSequencesInGroup_1,
     &           numberOfSequencesInGroup_2,
     &           numberOfSequencesInGroup_3,
     &           numberOfSequences,
     &           model,
     &           modlog
      real :: cooling_time,
     &        wd_mass,
     &        Z,
     &        luminosity,
     &        effective_temperature,
     &        log_surface_gravity,
     &        Z1,
     &        lum1,
     &        teff1,
     &        logg1,
     &        Z2,
     &        lum2,
     &        teff2,
     &        logg2,
     &        c1,
     &        c2,
     &        c3,
     &        c4,
     &        c5,
     &        c6,
     &        zet1,
     &        zet2,
     &        zet3
      integer ::  vectorOfPointsNumberOfSeq_1(7),
     &            vectorOfPointsNumberOfSeq_2(9),
     &            vectorOfPointsNumberOfSeq_3(9),
     &            numberOfPointsInSequence(7)
      real :: vectorOfMasses_1(7),
     &        vectorOfPreviousTimes_1(7),
     &        matrixOfCoolingTimes_1(7,NROWB),
     &        matrixOfLuminosities_1(7,NROWB),
     &        matrixOfEffectiveTemperatures_1(7,NROWB),
     &        matrixOfLog_g_1(7,NROWB),
     &        vectorOfMasses_2(9),
     &        vectorOfPreviousTimes_2(9),
     &        matrixOfCoolingTimes_2(9,NROWB),
     &        matrixOfLuminosities_2(9,NROWB),
     &        matrixOfEffectiveTemperatures_2(9,NROWB),
     &        matrixOfLog_g_2(9,NROWB),
     &        vectorOfMasses_3(9),
     &        vectorOfPreviousTimes_3(9),
     &        matrixOfCoolingTimes_3(9,NROWB),
     &        matrixOfLuminosities_3(9,NROWB),
     &        matrixOfEffectiveTemperatures_3(9,NROWB),
     &        matrixOfLog_g_3(9,NROWB),
     &        massSequence(7),
     &        luminosityDB(7,NROWB2),
     &        colorDB_U(7,NROWB2),
     &        colorDB_B(7,NROWB2),
     &        colorDB_V(7,NROWB2),
     &        colorDB_R(7,NROWB2),
     &        colorDB_I(7,NROWB2)

      TYPE(FileGroupInfo),DIMENSION(11) :: table

C     TODO: delete this
      common /dbnums/ numberOfSequences,
     &                numberOfSequencesInGroup_1,
     &                numberOfSequencesInGroup_2,
     &                numberOfSequencesInGroup_3
      common /dbnums2/ vectorOfPointsNumberOfSeq_1,
     &                 vectorOfPointsNumberOfSeq_2,
     &                 vectorOfPointsNumberOfSeq_3,
     &                 numberOfPointsInSequence
      common /massesdb/ massSequence,
     &                  vectorOfMasses_1,
     &                  vectorOfMasses_2,
     &                  vectorOfMasses_3
      common /dbtrks1/ matrixOfLuminosities_1,
     &                 matrixOfEffectiveTemperatures_1,
     &                 matrixOfLog_g_1,
     &                 matrixOfCoolingTimes_1
      common /dbtrks2/ matrixOfLuminosities_2,
     &                 matrixOfEffectiveTemperatures_2,
     &                 matrixOfLog_g_2,
     &                 matrixOfCoolingTimes_2
      common /dbtrks3/ matrixOfLuminosities_3,
     &                 matrixOfEffectiveTemperatures_3,
     &                 matrixOfLog_g_3,
     &                 matrixOfCoolingTimes_3
      common /dbtprewd/ vectorOfPreviousTimes_1,
     &                  vectorOfPreviousTimes_2,
     &                  vectorOfPreviousTimes_3
      common /dbcolors/ luminosityDB,
     &                  colorDB_U,
     &                  colorDB_B,
     &                  colorDB_V,
     &                  colorDB_R,
     &                  colorDB_I

      zet1 = 0.001
      zet2 = 0.01
      zet3 = 0.06

C     Determinating luminosities, magnitudes for every star
      model = 0
      modlog = 0

C     Checking between what values of metallicity is the Z of input
C     calculating luminosity, effective_temperature, log_surface_gravity
C     for those values Z1 and Z2 and then interpolating for Z
      if (Z >= zet1 .and. Z < zet2) then
          Z1 = zet1
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(5)%ncol,table(5)%ntrk,
     &         table(5)%coolingTime,table(5)%prevTime,
     &         table(5)%mass,table(5)%luminosity,lum1)
          modlog = 1
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(5)%ncol,table(5)%ntrk,
     &         table(5)%coolingTime,table(5)%prevTime,
     &         table(5)%mass,table(5)%effTemp,teff1)
          modlog = 0
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(5)%ncol,table(5)%ntrk,
     &         table(5)%coolingTime,table(5)%prevTime,
     &         table(5)%mass,table(5)%gravAcc,logg1)

          Z2 = zet2
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(6)%ncol,table(6)%ntrk,
     &         table(6)%coolingTime,table(6)%prevTime,
     &         table(6)%mass,table(6)%luminosity,lum2)
          modlog = 1
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(6)%ncol,table(6)%ntrk,
     &         table(6)%coolingTime,table(6)%prevTime,
     &         table(6)%mass,table(6)%effTemp,teff2)
          modlog = 0
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(6)%ncol,table(6)%ntrk,
     &         table(6)%coolingTime,table(6)%prevTime,
     &         table(6)%mass,table(6)%gravAcc,logg2)
      end if

      if (Z >= zet2 .and. Z < zet3) then
          Z1 = zet2
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(6)%ncol,table(6)%ntrk,
     &         table(6)%coolingTime,table(6)%prevTime,
     &         table(6)%mass,table(6)%luminosity,lum1)
          modlog = 1
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(6)%ncol,table(6)%ntrk,
     &         table(6)%coolingTime,table(6)%prevTime,
     &         table(6)%mass,table(6)%effTemp,teff1)
          modlog = 0
          call interp(model,modlog,cooling_time,wd_mass,
     &         table(6)%ncol,table(6)%ntrk,
     &         table(6)%coolingTime,table(6)%prevTime,
     &         table(6)%mass,table(6)%gravAcc,logg1)
          Z2 = zet3
          call interp(model,modlog,cooling_time,wd_mass,table(7)%ncol,
     &         table(7)%ntrk,table(7)%coolingTime,
     &         table(7)%prevTime,table(7)%mass,
     &         table(7)%luminosity,lum2)
          modlog = 1
          call interp(model,modlog,cooling_time,wd_mass,table(7)%ncol,
     &         table(7)%ntrk,table(7)%coolingTime,
     &         table(7)%prevTime,table(7)%mass,
     &         table(7)%effTemp,teff2)
          modlog = 0
          call interp(model,modlog,cooling_time,wd_mass,table(7)%ncol,
     &         table(7)%ntrk,table(7)%coolingTime,
     &         table(7)%prevTime,table(7)%mass,table(7)%gravAcc,
     &         logg2)
      end if

C     Interpolation 3D in function of Z
      luminosity = lum1 + (lum2 - lum1) * (Z - Z1) / (Z2 - Z1)
      effective_temperature = teff1 + (teff2 - teff1) * (Z - Z1)
     &                                / (Z2 - Z1)
      log_surface_gravity = logg1 + (logg2 - logg1) * (Z - Z1)
     &                              / (Z2 - Z1)

C     Colors interpolation, there is no metallicity here
      call intermag(wd_mass,luminosity,table(10)%ncol,
     &     table(10)%ntrk,table(10)%mass,table(10)%luminosity,
     &     table(10)%color_U,table(10)%color_B,table(10)%color_V,
     &     table(10)%color_R,table(10)%color_I,table(10)%color_J,
     &     c1,c2,c3,c4,c5,c6)
      end subroutine


Subroutine artout(nevnt)
  Parameter (maxstr=150001, maxr=1)
  Parameter (ymt1=-1.0, ymt2=1.0)
  Parameter (bmt=0.05, by=0.4)
  Common /run/num
  Common /arprc1/ityp1(maxstr, maxr), gx1(maxstr, maxr), gy1(maxstr, maxr), gz1(maxstr, maxr), ft1(maxstr, maxr), px1(maxstr, maxr), py1(maxstr, maxr), pz1(maxstr, maxr), ee1(maxstr, maxr), xm1(maxstr, maxr)
  Common /arana1/dy1ntb(50), dy1ntp(50), dy1hm(50), dy1kp(50), dy1km(50), dy1k0s(50), dy1la(50), dy1lb(50), dy1phi(50), dm1pip(50), dm1pim(50), dmt1pr(50), dmt1pb(50), dmt1kp(50), dm1km(50), dm1k0s(50), dmt1la(50), dmt1lb(50), dy1msn(50), dy1pip(50), dy1pim(50), dy1pi0(50), dy1pr(50), dy1pb(50), dy1neg(50), dy1ch(50), de1neg(50), de1ch(50)
  Common /arana2/dy2ntb(50), dy2ntp(50), dy2hm(50), dy2kp(50), dy2km(50), dy2k0s(50), dy2la(50), dy2lb(50), dy2phi(50), dm2pip(50), dm2pim(50), dmt2pr(50), dmt2pb(50), dmt2kp(50), dm2km(50), dm2k0s(50), dmt2la(50), dmt2lb(50), dy2msn(50), dy2pip(50), dy2pim(50), dy2pi0(50), dy2pr(50), dy2pb(50), dy2neg(50), dy2ch(50), de2neg(50), de2ch(50)
  Save
  Open (30, File='../data/dndy_netb.dat', Status='UNKNOWN')
  Open (31, File='../data/dndy_netp.dat', Status='UNKNOWN')
  Open (32, File='../data/dndy_nb.dat', Status='UNKNOWN')
  Open (33, File='../data/dndy_neg.dat', Status='UNKNOWN')
  Open (34, File='../data/dndy_ch.dat', Status='UNKNOWN')
  Open (35, File='../data/dnde_neg.dat', Status='UNKNOWN')
  Open (36, File='../data/dnde_ch.dat', Status='UNKNOWN')
  Open (37, File='../data/dndy_kp.dat', Status='UNKNOWN')
  Open (38, File='../data/dndy_km.dat', Status='UNKNOWN')
  Open (39, File='../data/dndy_k0l.dat', Status='UNKNOWN')
  Open (40, File='../data/dndy_la.dat', Status='UNKNOWN')
  Open (41, File='../data/dndy_lb.dat', Status='UNKNOWN')
  Open (42, File='../data/dndy_phi.dat', Status='UNKNOWN')
  Open (43, File='../data/dndy_meson.dat', Status='UNKNOWN')
  Open (44, File='../data/dndy_pip.dat', Status='UNKNOWN')
  Open (45, File='../data/dndy_pim.dat', Status='UNKNOWN')
  Open (46, File='../data/dndy_pi0.dat', Status='UNKNOWN')
  Open (47, File='../data/dndy_pr.dat', Status='UNKNOWN')
  Open (48, File='../data/dndy_pb.dat', Status='UNKNOWN')
  Open (50, File='../data/dndmtdy_pip.dat', Status='UNKNOWN')
  Open (51, File='../data/dndmtdy_0_1_pim.dat', Status='UNKNOWN')
  Open (52, File='../data/dndmtdy_pr.dat', Status='UNKNOWN')
  Open (53, File='../data/dndmtdy_pb.dat', Status='UNKNOWN')
  Open (54, File='../data/dndmtdy_kp.dat', Status='UNKNOWN')
  Open (55, File='../data/dndmtdy_0_5_km.dat', Status='UNKNOWN')
  Open (56, File='../data/dndmtdy_k0s.dat', Status='UNKNOWN')
  Open (57, File='../data/dndmtdy_la.dat', Status='UNKNOWN')
  Open (58, File='../data/dndmtdy_lb.dat', Status='UNKNOWN')
  scale1 = 1./real(nevnt*num)/by
  scale2 = 1./real(nevnt*num)/bmt/(ymt2-ymt1)
  Do i = 1, 50
    ymid = -10. + by*(i-0.5)
    Write (30, 333) ymid, scale1*dy1ntb(i)
    Write (31, 333) ymid, scale1*dy1ntp(i)
    Write (32, 333) ymid, scale1*dy1hm(i)
    Write (37, 333) ymid, scale1*dy1kp(i)
    Write (38, 333) ymid, scale1*dy1km(i)
    Write (39, 333) ymid, scale1*dy1k0s(i)
    Write (40, 333) ymid, scale1*dy1la(i)
    Write (41, 333) ymid, scale1*dy1lb(i)
    Write (42, 333) ymid, scale1*dy1phi(i)
    Write (33, 333) ymid, scale1*dy1neg(i)
    Write (34, 333) ymid, scale1*dy1ch(i)
    Write (35, 333) ymid, scale1*de1neg(i)
    Write (36, 333) ymid, scale1*de1ch(i)
    Write (43, 333) ymid, scale1*dy1msn(i)
    Write (44, 333) ymid, scale1*dy1pip(i)
    Write (45, 333) ymid, scale1*dy1pim(i)
    Write (46, 333) ymid, scale1*dy1pi0(i)
    Write (47, 333) ymid, scale1*dy1pr(i)
    Write (48, 333) ymid, scale1*dy1pb(i)
    If (dm1pip(i)/=0.0) Then
      Write (50, 333) bmt*(i-0.5), scale2*dm1pip(i)
    End If
    If (dm1pim(i)/=0.0) Then
      Write (51, 333) bmt*(i-0.5), scale2*0.1*dm1pim(i)
    End If
    If (dmt1pr(i)/=0.0) Then
      Write (52, 333) bmt*(i-0.5), scale2*dmt1pr(i)
    End If
    If (dmt1pb(i)/=0.0) Then
      Write (53, 333) bmt*(i-0.5), scale2*dmt1pb(i)
    End If
    If (dmt1kp(i)/=0.0) Then
      Write (54, 333) bmt*(i-0.5), scale2*dmt1kp(i)
    End If
    If (dm1km(i)/=0.0) Then
      Write (55, 333) bmt*(i-0.5), scale2*0.5*dm1km(i)
    End If
    If (dm1k0s(i)/=0.0) Then
      Write (56, 333) bmt*(i-0.5), scale2*dm1k0s(i)
    End If
    If (dmt1la(i)/=0.0) Then
      Write (57, 333) bmt*(i-0.5), scale2*dmt1la(i)
    End If
    If (dmt1lb(i)/=0.0) Then
      Write (58, 333) bmt*(i-0.5), scale2*dmt1lb(i)
    End If
  End Do
  Do i = 30, 48
    Write (i, *) 'after hadron evolution'
  End Do
  Do i = 50, 58
    Write (i, *) 'after hadron evolution'
  End Do
  Do i = 1, 50
    ymid = -10. + by*(i-0.5)
    Write (30, 333) ymid, scale1*dy2ntb(i)
    Write (31, 333) ymid, scale1*dy2ntp(i)
    Write (32, 333) ymid, scale1*dy2hm(i)
    Write (37, 333) ymid, scale1*dy2kp(i)
    Write (38, 333) ymid, scale1*dy2km(i)
    Write (39, 333) ymid, scale1*dy2k0s(i)
    Write (40, 333) ymid, scale1*dy2la(i)
    Write (41, 333) ymid, scale1*dy2lb(i)
    Write (42, 333) ymid, scale1*dy2phi(i)
    Write (33, 333) ymid, scale1*dy2neg(i)
    Write (34, 333) ymid, scale1*dy2ch(i)
    Write (35, 333) ymid, scale1*de2neg(i)
    Write (36, 333) ymid, scale1*de2ch(i)
    Write (43, 333) ymid, scale1*dy2msn(i)
    Write (44, 333) ymid, scale1*dy2pip(i)
    Write (45, 333) ymid, scale1*dy2pim(i)
    Write (46, 333) ymid, scale1*dy2pi0(i)
    Write (47, 333) ymid, scale1*dy2pr(i)
    Write (48, 333) ymid, scale1*dy2pb(i)
    If (dm2pip(i)/=0.0) Then
      Write (50, 333) bmt*(i-0.5), scale2*dm2pip(i)
    End If
    If (dm2pim(i)/=0.0) Then
      Write (51, 333) bmt*(i-0.5), scale2*0.1*dm2pim(i)
    End If
    If (dmt2pr(i)/=0.0) Then
      Write (52, 333) bmt*(i-0.5), scale2*dmt2pr(i)
    End If
    If (dmt2pb(i)/=0.0) Then
      Write (53, 333) bmt*(i-0.5), scale2*dmt2pb(i)
    End If
    If (dmt2kp(i)/=0.0) Then
      Write (54, 333) bmt*(i-0.5), scale2*dmt2kp(i)
    End If
    If (dm2km(i)/=0.0) Then
      Write (55, 333) bmt*(i-0.5), scale2*0.5*dm2km(i)
    End If
    If (dm2k0s(i)/=0.0) Then
      Write (56, 333) bmt*(i-0.5), scale2*dm2k0s(i)
    End If
    If (dmt2la(i)/=0.0) Then
      Write (57, 333) bmt*(i-0.5), scale2*dmt2la(i)
    End If
    If (dmt2lb(i)/=0.0) Then
      Write (58, 333) bmt*(i-0.5), scale2*dmt2lb(i)
    End If
  End Do
  Return
  333 Format (2(F12.5,1X))
End Subroutine artout


*----------------------------------------------------------------------*
      subroutine fact_cost2(possible,cost,iscale,
     &     iarc,njoined_res,nlevel,
     &     contr,occ_vtx,irestr_vtx,info_vtx,
     &     make_red,
     &     contr_red,occ_vtx_red,irestr_vtx_red,info_vtx_red,
     &     op_info,str_info,orb_info)
*----------------------------------------------------------------------*
*     calculate the computational cost of a given contraction
*     for each contraction step, the number of flops is summed up
*     and the maximum size of the occurring intermediates is evaluated
*     returned on cost(1:3): cost(1)<-flops,
*                            cost(2)<-memory(tot)
*                            cost(3)<-memory(block)
*     the maximum scaling of contraction and intermediates is returned
*     on iscale(ngastp,1:2): iscale(,1)<-contr, iscale(,2)<-mem
*----------------------------------------------------------------------*
      implicit none

      include 'opdim.h'
      include 'stdunit.h'
      include 'def_contraction.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'def_orbinf.h'
      include 'mdef_operator_info.h'
      include 'ifc_operators.h'
      include 'def_contraction_info.h'
      include 'def_reorder_info.h'
      include 'multd2h.h'

      integer, parameter ::
     &     ntest = 0
      logical, parameter ::
     &     formal = .false., exact = .false.

      logical, intent(in) ::
     &     make_red
      integer, intent(in) ::
     &     iarc, njoined_res, nlevel
      type(contraction), intent(in) ::
     &     contr
      type(contraction), intent(out) ::
     &     contr_red
      type(orbinf), intent(in), target ::
     &     orb_info
      integer, intent(in) ::
     &     occ_vtx(ngastp,2,contr%nvtx+njoined_res),
     &     irestr_vtx(2,orb_info%ngas,2,2,contr%nvtx+njoined_res),
     &     info_vtx(2,contr%nvtx+njoined_res)
      integer, intent(out) ::
     &     occ_vtx_red(ngastp,2,contr%nvtx+njoined_res),
     &     irestr_vtx_red(2,orb_info%ngas,2,2,contr%nvtx+njoined_res),
     &     info_vtx_red(2,contr%nvtx+njoined_res)
      type(operator_info), intent(in) ::
     &     op_info
      type(strinf), intent(in) ::
     &     str_info
      real(8), intent(out) ::
     &     cost(3)
      integer, intent(out) ::
     &     iscale(ngastp,2)
      logical, intent(out) ::
     &     possible

      integer ::
     &     nvtx, narc, ngas, nsym, idum,
     &     np_op1op2, nh_op1op2, nx_op1op2, np_cnt, nh_cnt, nx_cnt,
     &     nv_op1op2, nv_cnt
      integer ::
     &     iocc_cnt(ngastp,2,2*contr%nvtx),
     &     iocc_ex1(ngastp,2,contr%nvtx),
     &     iocc_ex2(ngastp,2,contr%nvtx),
     &     irst_res(2,orb_info%ngas,2,2,contr%nvtx),
     &     iocc_op1(ngastp,2,contr%nvtx),
     &     iocc_op2(ngastp,2,contr%nvtx),
     &     iocc_op1op2(ngastp,2,contr%nvtx),
     &     irst_op1op2(2,orb_info%ngas,2,2,contr%nvtx),
     &     igr_op1op2(ngastp,2,contr%nvtx),
     &     irst_op1(2,orb_info%ngas,2,2,contr%nvtx),
     &     irst_op2(2,orb_info%ngas,2,2,contr%nvtx),
     &     mst_op(2), mst_op1op2,
     &     igamt_op(2), igamt_op1op2,
     &     njoined_op(2), njoined_op1op2, njoined_cnt,
     &     idxop(2), idar2(2),
     &     merge_op1(2*contr%nvtx*contr%nvtx), ! a bit too large, I guess ...
     &     merge_op2(2*contr%nvtx*contr%nvtx),
     &     merge_op1op2(2*contr%nvtx*contr%nvtx),
     &     merge_op2op1(2*contr%nvtx*contr%nvtx),
     &     iscale_new(ngastp)
      integer ::
     &     itf_index_info

      integer, pointer ::
     &     ihpvgas(:,:)

      type(contraction) ::
     &     contr_dum
      type(reorder_info) ::
     &     reo_dum
      type(contraction_info) ::
     &     cnt_info

      logical ::
     &     tra_op1, tra_op2, tra_op1op2
      real(8) ::
     &     flops, xmemtot, xmemblk, bc_sign

      integer, external ::
     &     idxlist, int_expand, int_pack, maxxlvl_op
      logical, external ::
     &     check_grph4occ
      real(8), external ::
     &     scale_rank

      if (ntest.gt.0) then
        call write_title(lulog,wst_dbg_subr,'this is fact_cost')
c dbg
c        call prt_contr3(lulog,contr,-1)
c dbg
      end if

      nsym = orb_info%nsym
      ngas = orb_info%ngas
      ihpvgas => orb_info%ihpvgas

      nvtx = contr%nvtx
      narc = contr%narc

      ! preliminary version (valid for standard CC only):
      ! restriction on result:
      call set_restr_prel(irst_res,contr,op_info,ihpvgas,ngas)

      itf_index_info = -1

      call get_bc_info3(bc_sign,idum,possible,
     &     idxop,idar2,
     &     iocc_ex1,iocc_ex2,iocc_cnt,
     &     iocc_op1,iocc_op2,iocc_op1op2,
     &     irst_op1,irst_op2,irst_op1op2,
     &     tra_op1,tra_op2,tra_op1op2,
     &     mst_op,mst_op1op2,
     &     igamt_op,igamt_op1op2,
     &     njoined_op, njoined_op1op2, njoined_cnt,
     &     merge_op1,merge_op2,merge_op1op2,merge_op2op1,
     &     itf_index_info,
     &     contr,occ_vtx,irestr_vtx,info_vtx,
     &     make_red,
     &     contr_red,occ_vtx_red,irestr_vtx_red,info_vtx_red,
     &     .false.,reo_dum,reo_dum,
     &     iarc,.false.,-nlevel,
     &     irst_res,njoined_res,orb_info,op_info,0)
c dbg
      print *,'iocc_op1op2 fresh from get_bc_info3'
      call wrt_occ_n(6,iocc_op1op2,njoined_op1op2)
c dbg

      ! count particle, hole, (active) spaces involved:
      ! in intermediate
      nh_op1op2 = sum(iocc_ex1(ihole,1:2,1:njoined_op(1)))
     &          + sum(iocc_ex2(ihole,1:2,1:njoined_op(2)))
      np_op1op2 = sum(iocc_ex1(ipart,1:2,1:njoined_op(1)))
     &          + sum(iocc_ex2(ipart,1:2,1:njoined_op(2)))
      nx_op1op2 = sum(iocc_ex1(iextr,1:2,1:njoined_op(1)))
     &          + sum(iocc_ex2(iextr,1:2,1:njoined_op(2)))
      nv_op1op2 = sum(iocc_ex1(ivale,1:2,1:njoined_op(1)))
     &          + sum(iocc_ex2(ivale,1:2,1:njoined_op(2)))
      ! in contraction length
      nh_cnt = sum(iocc_cnt(ihole,1:2,1:njoined_cnt))
      np_cnt = sum(iocc_cnt(ipart,1:2,1:njoined_cnt))
      nx_cnt = sum(iocc_cnt(iextr,1:2,1:njoined_cnt))
      nv_cnt = sum(iocc_cnt(ivale,1:2,1:njoined_cnt))

      if (ntest.ge.100) then
        write(lulog,*) 'op 1:'
        call wrt_occ_n(lulog,iocc_op1,njoined_op(1))
        write(lulog,*) 'op 2:'
        call wrt_occ_n(lulog,iocc_op2,njoined_op(2))
        write(lulog,*) 'externals 1:'
        call wrt_occ_n(lulog,iocc_ex1,njoined_op(1))
        write(lulog,*) 'externals 2:'
        call wrt_occ_n(lulog,iocc_ex2,njoined_op(2))
        write(lulog,*) 'contraction:'
        call wrt_occ_n(lulog,iocc_cnt,njoined_cnt)
        write(lulog,*) 'intermediate/result:'
        call wrt_occ_n(lulog,iocc_op1op2,njoined_op1op2)
      end if

      if (ntest.ge.50) then
        write(lulog,'(x,a,i2,a,i2,a)')
     &         'Contraction scales as  H^{',nh_op1op2+nh_cnt,
     &                                   '}P^{',np_op1op2+np_cnt,'}'
        write(lulog,'(x,a,i2,a,i2,a)')
     &             'Intermediate scales as H^{',nh_op1op2,
     &                                   '}P^{',np_op1op2,'}'
      end if

      ! set iscale
      ! maximum is taken over total scaling, so H^2 .gt. P^1
      iscale_new = 0
      iscale_new(IHOLE) = nh_op1op2+nh_cnt
      iscale_new(IPART) = np_op1op2+np_cnt
      iscale_new(IEXTR) = nx_op1op2+nx_cnt
      iscale_new(IVALE) = nv_op1op2+nv_cnt

      if (scale_rank(iscale_new).gt.scale_rank(iscale(1,1)))
     &     iscale(1:ngastp,1) = iscale_new(1:ngastp)

      iscale_new = 0
      iscale_new(IHOLE) = nh_op1op2
      iscale_new(IPART) = np_op1op2
      iscale_new(IEXTR) = nx_op1op2
      iscale_new(IVALE) = nv_op1op2

      if (scale_rank(iscale_new).gt.scale_rank(iscale(1,2)))
     &     iscale(1:ngastp,2) = iscale_new(1:ngastp)

c      possible = .true.
      ! check whether intermediate can be addressed by
      ! the available graphs (preliminary fix)
      possible = possible.and.
     &     check_grph4occ(iocc_op1op2,irst_op1op2,njoined_op1op2,
     &     str_info,orb_info)
      possible = possible.and.
     &     check_grph4occ(iocc_op1,irst_op1,njoined_op(1),
     &     str_info,orb_info)
      if (njoined_op(2).gt.0) possible = possible.and.
     &     check_grph4occ(iocc_op2,irst_op2,njoined_op(2),
     &     str_info,orb_info)

      ! if not: do not allow this factorization
      if (.not.possible)
     &     cost(1:3) = huge(cost(1))

      if (possible) then
        if (.not.formal) then
          call init_cnt_info(cnt_info,
     &         iocc_op1,iocc_ex1,njoined_op(1),
     &            iocc_op2,iocc_ex2,njoined_op(2),
     &         iocc_cnt,njoined_cnt,
     &         iocc_op1op2,njoined_op1op2,iocc_op1op2,njoined_op1op2)

          call condense_bc_info(
     &         cnt_info,idxop(2).eq.0,
     &         iocc_op1, iocc_op2, iocc_op1op2, iocc_op1op2,
     &         iocc_ex1,iocc_ex2,iocc_cnt,
     &         irst_op1, irst_op2, irst_op1op2, irst_op1op2,
     &         idum,idum,idum,0,
     &         merge_op1, merge_op2, merge_op1op2, merge_op2op1,
     &         njoined_op(1), njoined_op(2),njoined_op1op2, njoined_cnt,
     &         str_info,orb_info)
          if (exact) then
            call dummy_contr2(flops,xmemtot,xmemblk,
     &         cnt_info,
     &         mst_op(1),mst_op(2),mst_op1op2,
     &         igamt_op(1),igamt_op(2),igamt_op1op2,
     &         str_info,ngas,nsym)
          else
            call fact_cost_estimate(flops,xmemtot,xmemblk,
     &           cnt_info,
     &           str_info,ngas,nsym)
          end if
          call dealloc_cnt_info(cnt_info)
          cost(1) = cost(1)+flops
          cost(2) = max(cost(2),xmemtot)
          cost(3) = max(cost(3),xmemblk)
        else
c          cost(1) = cost(1) + scale_rank(iscale(1,1))
          cost(1) = max(cost(1),scale_rank(iscale(1,1)))
          cost(2) = max(cost(2),scale_rank(iscale(1,2)))
          cost(3) = max(cost(3),scale_rank(iscale(1,2)))
        end if

        if (ntest.ge.10)
     &       write(lulog,'(x,a,3(g20.10,x))') '$$ cost: ',cost(1:3)
        if (ntest.ge.10)
     &       write(lulog,'(x,a,2(2i4,2x))') '$$ scal: ',iscale(1:2,1:2)
      end if

      return
      end