program sponge ccccccccccccccccccccccccccccccccccc c Program Configuration Defines ccccccccccccccccccccccccccccccccccc c#define Atlantic c#define Wedge c#define Gulf c#define Mackenzie #define Laptev #define MPI 4 c#define FakeMPI 4 #define NX_Base 10 c#define HiVRes c#define MedVRes c#define LoVRes c#define UltraLoVRes #define HiTop_LoVRes #define Create_HiTop 5 c#define QuadLoVRes c#define CreateQuadLoVRes c#define DoubleMedVRes c#define DoubleLoVRes c#define DoubleVRes C#define DoubleHRes #define Verbose_CDF 10 c#define Suppress_CDF c#define Initial_CDF c#define Paced_CDF 1000 c#define Read_Restart_CDF 000003000 #define Read_Restart_CDF 050000000 c#define Convert_Vol_File #define Convert_N_SL #define I_Shifts_Init 0 #define T_Scale 1.d0 #define T_Scale_Diff 1.d0 #define Adaptive_Time_Step #define FlowLimiterVThreshold 0.001d0 #define NT_Diffuse 1 #define NT_Sed_Transport 1 #define NT_Igneous 1 #define TAU_ISOSTACY 1.d-4 #define Chem_Reactions c#define TAU_ISOSTACY 1.d0 c#define SquishItNow #define Continental_Margin c#define Trench c#define East_Coast c#define Blake_Ridge c#define NonDimensional c#define FlatPile #ifdef FakeMPI #define NX (NX_Base*FakeMPI) #define NX_Global NX #else #ifdef MPI #define NX NX_Base #define NX_Global (NX*MPI) #else #define NX NX_Base #define NX_Global NX #endif #endif #ifdef DoubleHRes #define NX_Global_In NX_Global/2 #else #define NX_Global_In NX_Global #endif #ifdef HiVRes #ifdef FakeMPI #define DT 0.1d0 #else #define DT 0.25d0 #endif #define NZ_Top 30 #define NZ_Body 40 #define DZ_Top_Zone 50.d0 #endif #ifdef MedVRes #ifdef FakeMPI #define DT 0.5d0 #else #define DT 0.5d0 #endif #define NZ_Top 15 #define NZ_Body 20 #define DZ_Top_Zone 100.d0 #endif #ifdef DoubleMedVRes #ifdef FakeMPI #define DT 0.25d0 #else #define DT 0.25d0 #endif #define NZ_Top 30 #define NZ_Body 40 #define DZ_Top_Zone 40.d0 #endif #ifdef QuadLoVRes #ifdef FakeMPI #define DT 0.1d0 #else #define DT 0.25d0 #endif #define NZ_Top 20 #define NZ_Body 40 #define DZ_Top_Zone 50.d0 #endif #ifdef DoubleLoVRes #ifdef FakeMPI #define DT 0.5d0 #else #define DT 0.5d0 #endif #define NZ_Top 10 #define NZ_Body 20 #define DZ_Top_Zone 100.d0 #endif #ifdef LoVRes #define DT 1.d0 #define NZ_Top 5 #define NZ_Body 10 #define DZ_Top_Zone 200.d0 #endif #ifdef UltraLoVRes #ifdef FakeMPI #define DT 0.5d0 #else #define DT 0.5d0 #endif #define NZ_Top 2 #define NZ_Body 5 #define DZ_Top_Zone 500.d0 #endif #ifdef HiTop_LoVRes #ifdef FakeMPI #define DT 0.2d0 #else #define DT 0.2d0 #endif #define NZ_Top 25 #define NZ_Body 10 #define DZ_Top_Zone 40.d0 #endif #define Ocean_Depth_0 (-4000.d0) c#ifndef Read_Restart_CDF #define SquishItInit c#endif c#define Read_CDF_Stdout cccccccccccccccccccccccccccccccccc c Primary model configuration cccccccccccccccccccccccccccccccccc #ifdef Continental_Margin /* coastal sediment transport and depostion package */ #define Sediment_Transport #define NZ_Fin 0 c#define Simple_Sedimentation c#define Sediment_Homogenized c#define Sediment_Dump_First_Cell c#define Sediment_Floats_Forever c#define Sediment_Transport_Smoothed c#define Jimmy_Erosion #define Accum c#define FlowLimiterVertical c#define POCv_Imposed 1.d-2 c#define Ocean_Temp_Offset 6d0 #define Geothermal_Heat #define Cooling_Ocean_Crust #define Isostacy #define Isostacy_Smoothed #define Smooth_Coeff 1.e6 #define DoubleExpPor #define WC_Depth_Interp c#define Perm_Pore_Only #define P_atm 0.1d0 #define Perm_Maximum 1.d-13 #define Perm_Minimum 1.d-18 #define Ocean_Crust_H0 5.d3 #define Cont_Crust_H0 13d3 #define Mantle_T0 1320.d0 #define Ocean_Crust_Min_Age 1.d6 #define Ocean_Sal 35.d0 #define Ocean_SO4 28.d0 #endif #ifdef FlatPile #define NZ_Top 5 #define Accum #define Simple_Sedimentation c#define Cap #define SlopingPile c#define Channel c#define Chimney c#define SquishItNow #define DEPTH_OF_SEABOTTOM 1500.d0 #endif #ifdef NonDimensional #define LAMBDA 1.d-2 #define FlatPile #define NZ_Top 0 #define NZ_Body 10 #define NZ_Fin 0 #define Perm_Wang_Nondim #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Variations to model scenarios, there can be only one cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #ifdef Gulf #define DT_Scenario 1.4d8 #define N_CDF 140 #define Perm_Channels #define DX_Init 100.d3 #define DZ_Init 1.d0 #define Initial_Condition_Tweak #define Initial_Geotherm #define Crust_Transition_Width 200.d3 #define Cont_Crust_DX 200d3 #define Plate_Width 2000.d3 #define Plate_Velocity 1.d-2 c#define Aging_Ocean_Crust 1 booger? #define Sinking_Crust 4000 #define Sinking_Ocean_Crust_Only #define Coastal_Sediment_Flux 10.d0 /* 60 m3 solid/m coastline yr */ c 1e5 * 5e3 m2 / 1e8 yr = 5 #define Sediment_Transport_Velocity 0.2d0 c m3 / m coastline yr #define Pelagic_Sedimentation 8.d-5 /* m/yr=1d5 cm / kyr */ #define Seafloor_Erosion 1.d-5 #define Seafloor_Slope_Critical 0.06 /* 4 km / 200 km */ #define POC_Sliding #define Size_Fractionate_POC #define Geothermal_Heat_Flux 70d-3 #define Perm_Grain_Size #define Perm_Anisotrophy 100.d0 #define Geologic_Sea_Level_Cycles_Haq #define Air_Temp_Base 20.d0 #endif /* Gulf */ #ifdef Atlantic #define DT_Scenario 2.0d8 #define N_CDF 200 #define Perm_Channels #define DX_Init 25.d3 /* scaled to NX_Base=10, so 250 km domain */ #define DZ_Init 1.d0 #define Initial_Condition_Tweak #define Initial_Geotherm #define Crust_Transition_Width 60.d3 #define Cont_Crust_DX 40d3 #define Plate_Width 1400.d3 #define Plate_Velocity 1.d-2 #define Aging_Ocean_Crust 1 #define Sinking_Crust 2500 #define Sinking_Ocean_Crust_Only #define Coastal_Sediment_Flux 2.1d0 /* m3 solid/m coastline yr */ c 1e5 * 5e3 m2 / 1e8 yr = 5 #define Sediment_Transport_Velocity 0.1d0 c m3 / m coastline yr #define Pelagic_Sedimentation 5.6d-5 /* m/yr=1d5 cm / kyr */ #define Seafloor_Erosion 1.d-5 #define Seafloor_Slope_Critical 0.06 #define Turbidite_Redeposit_Slope 0.01 #define POC_Sliding #define Size_Fractionate_POC #define Geothermal_Heat_Flux 70d-3 #define Perm_Grain_Size #define Perm_Anisotrophy 100.d0 #define Geologic_Sea_Level_Cycles_Haq #define Air_Temp_Base 10.d0 #endif /* Atlantic */ #ifdef Wedge #define DT_Scenario 1.d7 #define N_CDF 100 #define Size_Fractionate_POC #define Perm_Channels #define DX_Init 50.d3 /* defined as if nx_base=10 and single cpu */ #define DZ_Init 1.d0 #define Accrete #define Sedcol_U_Out_Frac 0.1 c#define Wedge_No_Scrapeoff #define Wedge_Shift_Grid #define Plate_Velocity 40.d-3 /* 40.d-3 */ #define Plate_Width 400.d3 #define Plate_Max_Deform_Zone 200d3 #define Plate_Torque #define Plate_X0 125.d3 #define Plate_Xb 175.d3 #define Plate_Wb 100.d0 c#define Plate_Pulldown_Smoothed #define Sed_Youngs_Modulus 4.d-2 /* 4.d-2 */ c#define Sed_Pushback_Thickness 10.d3 #define Youngs_amplitude 0. ! 0.4 #define Youngs_wavelength 100.d3 #define Seafloor_Erosion 1.d-5 #define POC_Sliding c#define Sediment_Dump_First_Cell #define Seafloor_Slope_Critical 0.06 /* 0.06 */ #define Turbidite_Redeposit_Slope 0.01 /* 0.01 */ c#define Resuspended_Forever c#define Topo_High_Erosion c#define Test_Erosion c#define Land_Erosion #define Land_Erosion_Tau 1.d-6 c#define Winnowing #define Winnowing_Tau 1.d-5 #define Coastal_Sediment_Flux 40.d0 /* 40 */ #define Sediment_Transport_Velocity 0.1 /* 0.2 booger */ #define Pelagic_Sedimentation 10.d-5 /* 2d-5, 1 m/yr = 1d5 cm/kyr */ #define Pelagic_Sed_Init #define West_Coast_POC_Interp #define Init_POC 0.d-2 #define Geothermal_Heat_Flux 120d-3 c#define Geothermal_Heat_Coupled #define Perm_Grain_Size #define Perm_Anisotrophy 100.d0 c#define Perm_Hyndmann #define Tectonic_Bouncing_Sea_Level #define Air_Temp_Base 10.d0 #endif #ifdef Mackenzie c#define End_Game #ifdef End_Game #define Read_Restart_CDF 138000000 #define DT_Scenario 140.0d6 #define Quaternary_Sea_Level_Cycles 138.2d6 #define Paced_CDF 10.d4 /* years */ #define Global_Warming 139.5d6 #else #define DT_Scenario 1.4d8 #endif #define N_CDF 140 #define Perm_Channels #define DX_Init 25.d3 /* scaled to NX_Base=10, so 250 km domain */ #define DZ_Init 1.d0 #define Initial_Condition_Tweak #define Initial_Geotherm #define Crust_Transition_Width 60.d3 #define Cont_Crust_DX 40d3 #define Plate_Width 1400.d3 #define Plate_Velocity 1.d-2 #define Aging_Ocean_Crust 1 #define Sinking_Crust 2000 c#define Sinking_Ocean_Crust_Only #define Land_Deposition 1.d-6 /* m/yr * 1e5 yr ice age = 10 m */ #define Land_Deposition_POC 0.3 #define Coastal_Sediment_Flux 7.d0 /* m3 solid/m coastline yr */ c 1e5 * 5e3 m2 / 1e8 yr = 5 #define Sediment_Transport_Velocity 0.1d0 c m3 / m coastline yr #define Pelagic_Sedimentation 7.d-5 /* m/yr=1d5 cm / kyr */ #define Seafloor_Erosion 1.d-5 #define Seafloor_Slope_Critical 0.04 #define POC_Sliding #define Size_Fractionate_POC #define Geothermal_Heat_Flux 50d-3 #define Perm_Grain_Size #define Perm_Anisotrophy 100.d0 c#define Geologic_Sea_Level_Cycles_Haq #define Air_Temp_Base -16.d0 #define Perm_Inhibit_Bubble_Rising 1.d-17 #endif /* Mackenzie */ #ifdef Laptev c#define End_Game c#define Drained_Init #ifdef End_Game #define Read_Restart_CDF 062030000 #define Quaternary_Sea_Level_Cycles 62.0d6 c#define Ice_Sheet #define Step_Sea_Level_Change -120.d0 #define Step_Sea_Level_Change_Time 50.0d6 c#define Global_Warming 62.4d6 #define Paced_CDF 1.d4 /* years */ #define Paced_CDF_Begin Quaternary_Sea_Level_Cycles #endif #define DT_Scenario 65d6 #define N_CDF 65 c#define Perm_Channels #define Theres_Permafrost #define Land_Deposition 1.d-3 /* 1e-3 m/yr * 1e5 yr ice age = 100 m */ #define Land_Deposition_POC 0.3 #define Hydrology #define Hydrology_Recharge 0.1 /* meters / year */ #define Canyon_Lengthscale 100.d3 cc#define Hydrology_Head_Boundary 1000.d0 #define DX_Init 100.d3 /* scaled to NX_Base=10, so 1000 km domain */ #define DZ_Init 10.d0 c#define Initial_Condition_Tweak #define Initial_Geotherm #define Crust_Transition_Width 100.d3 #define Cont_Crust_DX 40d3 #define Plate_Width 1400.d3 #define Plate_Velocity 1.d-2 #define Aging_Ocean_Crust 1 #define Sinking_Crust 1000 c#define Sinking_Ocean_Crust_Only #define Coastal_Sediment_Flux 80.d0 /* m3 solid/m coastline yr */ c 1e5 * 5e3 m2 / 1e8 yr = 5 #define Sediment_Transport_Velocity 0.1d0 c m3 / m coastline yr #define Pelagic_Sedimentation 7.d-5 /* m/yr=1d5 cm / kyr */ #define Seafloor_Erosion 1.d-5 #define Seafloor_Slope_Critical 0.04 #define POC_Sliding #define Size_Fractionate_POC #define Geothermal_Heat_Flux 50d-3 #define Perm_Grain_Size #define Perm_Anisotrophy 100.d0 c#define Geologic_Sea_Level_Cycles_Haq c#define Air_Temp_Base -16.d0 #define Air_Temp_Base 0.d0 #define Ice_Age_Low_SL -120.d0 #define Ice_Age_High_SL 20.d0 #ifdef Theres_Permafrost #define Ice_Age_Ocean_Temp_Cyc 3.d0 #define Ice_Age_Atm_Temp_Cyc 16.d0 #else #define Ice_Age_Ocean_Temp_Cyc 0.d0 #define Ice_Age_Atm_Temp_Cyc 0.d0 #endif #define Perm_Inhibit_Bubble_Rising 1.d-17 #endif /* Laptev */ #ifdef Trench #define DX_Init 225.d3 #define Accrete #define Plate_Width 1000.d3 #define Plate_Velocity 1.d-2 c 1d6 m / 2d-2 m/y = 1e8 years c 4e5 m * 10 pts = 4e6 m / 2e-2 m/yr = 2e8 yr to swallow itself #define Cont_Crust_DX 135d3 #define Sed_Youngs_Modulus 1d-5 #define Crust_Transition_Width 50.d3 #define Plate_Torque #define Plate_X0 125.d3 #define Plate_Xb 175.d3 #define Plate_Wb 500.d0 #define Plate_Pulldown_Smoothed #define Trench_Max_Depth 5.d3 c all plate stuff in meters c#define Plate_X0_Water_Depth 1000 #define Pelagic_Sed_Init #define SquishItInit #define Coastal_Sediment_Flux 80.d0 /* m3 / m yr */ #define East_Coast_POC_Interp #endif /* Trench */ #ifdef East_Coast c#define East_Coast_POC_Interp #define Strong_OMZ_POC_Interp #endif #ifdef Blake_Ridge c#define Channel c#define BedrockInitial #endif ccccccccccccccccccccccccccccccc c Model Components on off ccccccccccccccccccccccccccccccc #define Sigma_Grid #define Growzinta_Sigma #define Uniform_DZ c#define Simple_Grain_Size c#define POC_Muds_Interp c#define POC_surface_area #define Reaction_Resp #define Resp_Scale_T #define Resp_Scale_Age #define Resp_Wallmann 35.d0 /* 200 simulates half-sat at 35 */ #define Bio_POC_Frac 0.5d0 #define Reaction_Thermogen #define Resp_DOC 1.d-6 #define Resp_Sloppy_Frac 0.1d0 #define Therm_DOC_Frac 0.1 #define Reaction_CO2_Reduction c#define Reaction_SO4_Reduction this seems to crash and aom works alone ok anyway c#define Reaction_SO4_Reduction_pH #define Reaction_AOM 0.1 #define Black_Gold 0.1 /* mobile fraction */ #define Rising_Black_Gold 1.d-3 /* rise rate, m / year */ #define Resp_Petro 1.d-6 #define Reaction_d_Org #define Reaction_d_CH4 #define Reaction_d_AOM #define Reaction_d_Therm #define d_Diffusion ccccc#define Boost_CH4_Production 10 c#define Reaction_Clays 1.d-2 #define Reaction_Ice_Freeze 0.1 /* 0.03 equil frac / timestep */ #define Ice_Sal_Feedback c#define Ice_Brine_Convective_Rejection #define Min_Unfrozen_Fluid_Frac 1.d-2 #define Reaction_Rocks #define Reaction_Igneous 1.d-4 /* max d/dt */ c#define Reaction_CaCO3 1.d-4 leave this off, my advice #define Reaction_CaCO3_Equil #define Reaction_Ceq_TDep #define Reaction_CaCO3eq_TDep #define Reaction_Urey_TDep -6.3d0 #define Decay_Time_I129 22.7d6 #define Vertical_Diffusion #define Heat_Sources #define Heat_Internal_Sources #define Reaction_CH4_Phases 1.d-3 /* yr-1 */ #define Hydrate_Split_Box c#define Hydrate_Gas_Phase_All_or_Nothing #define Hydrate_Reaction_Degassing #define Hydrate_Reaction_Redissolve #define Hydrate_Release_Fluid_Volume c#define Hydrate_Bubbles_Only c#define Hydrate_Hydrate_Only #define Hydrate_Porosity #define Ice_Porosity #define Ice_Release_Fluid_Volume c#define Reaction_CO2_Liquid 1.d-2 c#define Reaction_CO2_Phases #define Bubble_Crit_Vanish #define BB_Conc_Crit 0.1d0 c#define Bubble_Escape_Hard_Cutoff #define Bubble_Rediss_Scale 500.d0 c#define Bubble_Flow #define Scale_Gas_Visc #define Bubble_Flow_U #define Bubble_Flow_W #define Bubble_Buoy #define Bubble_Driven_by_P_Excess #define Bubble_Vel_Max 1.d0 #define Bubble_Flow_U_ifTrapped c check whether MIN_Pexcess_Fluid_Buoy is necessary #define Bubbles_Driven_by_P_Excess c#define Fluid_Buoy #define MIN_Pexcess_Fluid_Buoy #define MIN_STRESS_LITHO 0.02d0 #define VerticalFlow #define HorizontalFlow c#define No_Canyon c#define Clamp_p_excess c#define Fluid_Advection_Separate c#define FlowLimiterHoriz c#define FlowHomogenizerHoriz #define FlowLimiterHThreshold 1.d-4 #define FlowLimiterIterations 15 #define Bubble_Pressure c#define Thermal_Expansion_Porosity #ifdef MPI c#define MPI_Frag_CDF #define MPI_Collect_CDF c#define MPIStdOut #endif #define Master 0 #define Write_Restartable_CDF c#define Wrap_On_Update #define Wrap_On_Demand #define Wrap_Each_Timestep c#define Debug_PW_Conserved c gas (compressible) phases c keep the CH4 labels contiguous and CH4 as 1 #define i_CH4 1 #define i_C13H4 2 #define i_CDH3 3 #define i_CO2 4 #define N_Bubble_Types 4 #define N_CH4_Isotopes 3 c dissolved phases c 1-3 recycle the labels from bubbles #define i_DIC 4 #define i_DIC13 5 #define i_SO4 6 #define i_DOC 7 #define i_I129 8 #define i_ITot 9 #define i_Sal 10 #define i_Alk 11 #define i_Ca 12 #define N_PW 12 c#define i_Delta18O 11 c solid or incompressible phases #define i_Bio_POC 1 #define i_POC 2 #define i_POH 3 #define i_POO 4 #define N_POCs 4 #define i_Hydrate 5 #define i_Hydrate_13 6 #define i_Hydrate_d 7 #define i_Hydrate_CO2 8 #define i_Petro 9 #define i_Ice 10 #define i_CaCO3 11 #define i_Montmorillonite 12 #define i_Illite 13 #define i_Quartz 14 #define N_SL_Conc 14 #define i_Age 15 #define i_first_size_class 16 #define i_last_size_class 56 #define i_Aeolean 57 #define i_Pelagic 58 #define N_Size_Spectrum 41 #define N_Size_Classes 43 #define N_SL 58 c tags for rho(densities), continuing from solid phases #define i_Freshwater 15 #define i_Seawater 16 #define i_Sediment 17 #define i_Ocean_Crust 18 #define i_Continental_Crust 19 #define i_Mantle 20 #define N_Rho 20 cc rate constants in memory c#define irc_resp 1 c#define N_RC 1 c fractionation factors #define i_alpha_org 1 #define i_alpha_co2_redn 2 #define i_alpha_co2_redn_d 3 #define i_alpha_aom 4 #define i_alpha_aom_d 5 #define i_alpha_therm 6 #define i_alpha_therm_d 7 #define i_alpha_diffuse 8 #define N_Alpha 8 c ocean states for depth interpolation #define OcS_East_Coast 1 #define OcS_West_Coast 2 #define OcS_Strong_OMZ 3 #define OcS_Anoxic 4 #define N_OcS 4 #define Oc_POC_frac 1 #define Oc_POH_frac 2 #define Oc_POO_frac 3 #define N_Oc_Props 3 #define N_Oc_Z 4 c 2-D diagnostic arrays (not state variables) c first part rates in moles / timestep #define id2_CH4_src_resp 1 #define id2_CH4_src_therm 2 #define id2_DOC_src_therm 3 #define id2_DIC_src_therm 4 #define id2_POC_sink_therm 5 #define id2_POH_sink_therm 6 #define id2_POO_sink_therm 7 #define id2_CH4_sink_aom 8 #define id2_resp 9 #define id2_resp_DOC 10 #define id2_resp_petro 11 #define id2_therm_K 12 #define id2_therm_H 13 #define id2_therm_O 14 #define id2_petro_src 15 #define id2_CH4_src_petro 16 #define id2_caco3_pcp 17 #define id2_igneous_diss 18 #define id2_clay_dewater 19 #define id2_CH4_exsolve 20 #define id2_CO2_exsolve 21 #define id2_bubble_ch4_excess 22 #define id2_bubble_ch4_redissolve 23 #define id2_hydrate_freeze 24 #define id2_ice_freeze 25 #define id2_hydrate_CO2_freeze 26 #define Nd2_Vol_Rates 26 #define id2_CH4_bubble_flux 27 #define id2_CH4_diff_flux 28 #define id2_CH4_adv_flux 29 #define Nd2_Area_Rates 29 #define id2_fluid_vol_flux 30 /* per yr not per timestep, unlike the others */ c second part other miscellany 2-D diagnostic arrays #define id2_heat_src_hydrate 31 #define id2_heat_src_CO2_hydrate 32 #define id2_heat_src_ice 33 #define id2_w 34 #define id2_w_bur 35 #define id2_w_seafloor 36 #define id2_w_jitter 37 #define id2_w_unlimited 38 #define id2_w_d_press_potential 39 #define id2_w_hydro 40 #define id2_u 41 #define id2_u_limited 42 #define id2_v 43 #define id2_therm_diffusivity 44 #define id2_fluid_buoy 45 #define id2_bb_u 46 #define id2_bb_w 47 #define id2_bb_buoy 48 #define id2_T_Ice 49 #define id2_dT_Ice 50 #define id2_ice_frac 51 #define id2_ice_sheet_active 52 #define id2_heat_capacity 53 #define id2_heat_diff_flux 54 #define id2_heat_adv_flux 55 #define id2_resp_k 56 #define id2_resp_diss_k 57 #define id2_resp_h2c 58 #define id2_resp_o2c 59 #define id2_resp_alpha_so4 60 #define id2_resp_alpha_ch4 61 #define id2_pH 62 #define id2_hplus 63 #define id2_omega_CaCO3 64 #define id2_omega_igneous 65 #define id2_csat_igneous 66 #define id2_igneous_k 67 #define id2_rxn_igneous 68 #define id2_dT_CH4_hydrate 69 #define id2_T3P_CH4_hydrate 70 #define id2_CH4_eq_T3P 71 #define id2_dT_CO2_hydrate 72 #define id2_CH4_hydrate_frac 73 #define id2_CO2_hydrate_frac 74 #define id2_CO2_liq_drho 75 #define id2_CO2 76 #define id2_CO3 77 #define id2_HCO3 78 #define id2_K1 79 #define id2_K2 80 #define id2_Ksp_CaCO3 81 #define id2_CH4_eq 82 #define id2_CO2_eq 83 #define id2_por_melted 84 #define id2_por_liquid 85 #define id2_por_mobile 86 #define id2_por_drained 87 #define id2_por_dev 88 #define id2_sal_melted 89 #define id2_liquid_saturation 90 #define id2_dpsupp_dpor 91 #define id2_perm 92 #define id2_perm_lateral 93 #define id2_perm_goosefac 94 #define id2_perm_mdarcys 95 #define id2_P_excess 96 #define id2_P_supp 97 #define id2_P_hydro 98 #define id2_P_fluid 99 #define id2_P_gas 100 #define id2_fluid_delta_z 101 #define id2_z_water_table_equiv 102 #define id2_P_head 103 #define id2_fluid_delta_z_canyon 104 #define id2_z_water_table_equiv_canyon 105 #define id2_P_head_canyon 106 #define id2_stress_litho 107 #define id2_dyn_visc 108 #define id2_gas_visc 109 #define id2_grain_size 110 #define N_Diags_2d 110 c 1-D diagnostic arrays c#define Nd1_rates 0 c internally per timestep, then converted to per year in report #define id1_POC_rain_flux 1 #define id1_POC_bio_rain_flux 2 c moles #define id1_sed_accum_rate 3 c m #define id1_hydro_recharge 4 #define id1_hydro_runoff 5 c m3 c computed originally as per year c m3 / year #define id1_d_fluid_vol_dt 6 #define id1_d_solid_vol_dt 7 c not rates anymore, no time issue #define id1_surface_temp 8 c grade #define id1_seafloor_slope 9 #define id1_seafloor_slope_2nd 10 #define id1_tau_scour 11 #define id1_suspended_flux_tot 12 #define id1_resuspended_flux_tot 13 #define id1_deposit_flux_tot 14 #define id1_redeposit_flux_tot 15 #define id1_sed_redeposit_frac 16 #define id1_z_erosion_target 17 c watts/m2 #define id1_heat_geotherm_flux 18 #define id1_sedcol_youngs_mod 19 #define id1_sedcol_u 20 #define id1_d_sedcol_u_dx 21 #define id1_sedcol_thickening 22 #define id1_column_mass 23 #define id1_column_height 24 #define id1_sedcol_mass 25 #define id1_sedcol_height 26 #define id1_plate_pulldown 27 #define id1_plate_x_scale 28 #define id1_isostat_eq 29 #define id1_freeboard_eq 30 #define id1_sedcol_conv_dieqdt 31 #define id1_crust_therm_dieqdt 32 #define id1_isostat_dzdt 33 #define id1_z_water_table 34 #define id1_seafloor_slope_canyon 35 #define id1_dz_ice_sheet 36 #define id1_ice_sheet_u 37 #define id1_ice_sheet_vol_flow 38 #define id1_ice_sheet_accum 39 #define id1_ice_sheet_ablate 40 #define id1_z_ice_sheet_base 41 #define id1_ice_sheet_base_dt 42 #define id1_w_n_iters 43 #define N_Diags_1d 43 #define Report_Skip -99 #define Report_Start_Clock -1 #define Report_Stdout -2 #define HeatMethanogenesis #define LatentHeatIce #define LatentHeatHydrate #define NZ_Max NZ_Body+NZ_Top #define Min_Dz_Calc 0.5 c#define CHECK_BREACHING #define Multiphase_Thermal_Diffusion #define Hydrate_Thermal_Diffusion C#define Bubbles_Thermal_Diffusion #define SL_BOUNDS ccccccccccccccsccccccccccccc c Variable Declarations ccccccccccccccccccccccccccc implicit none #ifdef MPI include 'mpif.h' #endif integer ix,iz,i_pw,i_sl,nz, $ nt_diffuse,nt_sed_transport, $ nt, $ itag, ierr, iter, i_throttle_dt, i_shifts integer*8 i_timestep, i_timestep_init double precision t_now, t_init, $ dt, dt_run, dt_cdf, dt_out, $ por_0(0:2), $ beta(2), domain_x, domain_z, $ perm_0, gas_visc_0, $ dummy double precision, dimension(0:NX_Global+1) :: $ x_global, dx_global, $ z_seafloor_global, dz_seafloor_global, $ ocean_frac_global, sedcol_youngs_mod_global c grids #define ig_x 1 #define ig_dx 2 #define ig_z_top 3 #define ig_z_center 4 #define ig_dz 5 #define ig_z_top_last 6 #define ig_dz_top_dt 7 #define ig_z_canyon 8 #define N_Grids 8 double precision, dimension(0:NX+1,0:NZ_Max+1,N_Grids) :: $ grid double precision, dimension(0:NX+1) :: $ x, dx, z_canyon double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_top, z_center, dz, dz_top_dt, z_top_last equivalence(grid(0,0,ig_x),x(0)) equivalence(grid(0,0,ig_dx),dx(0)) equivalence(grid(0,0,ig_z_top),z_top(0,0)) equivalence(grid(0,0,ig_z_center),z_center(0,0)) equivalence(grid(0,0,ig_dz),dz(0,0)) equivalence(grid(0,0,ig_z_top_last),z_top_last(0,0)) equivalence(grid(0,0,ig_dz_top_dt),dz_top_dt(0,0)) equivalence(grid(0,0,ig_z_canyon),z_canyon(0)) c volumes #define ivol_fluid 1 #define ivol_solid 2 #define ivol_air 3 #define ivol_hydrate 4 #define ivol_bubble 5 #define ivol_ice 6 #define ivol_hydrate_CO2 7 #define ivol_petro 8 #define ivol_ice_sheet 9 #define ivol_tot 10 #define N_Vols 10 double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume, volume_flux double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ solid_vol, fluid_vol, air_vol, $ hydrate_vol, bubble_vol, ice_vol, $ hydrate_co2_vol, oil_vol, ice_sheet_vol, $ tot_vol equivalence(volume(0,0,ivol_fluid),fluid_vol(0,0)) equivalence(volume(0,0,ivol_solid),solid_vol(0,0)) equivalence(volume(0,0,ivol_air),air_vol(0,0)) equivalence(volume(0,0,ivol_hydrate),hydrate_vol(0,0)) equivalence(volume(0,0,ivol_bubble),bubble_vol(0,0)) equivalence(volume(0,0,ivol_ice),ice_vol(0,0)) equivalence(volume(0,0,ivol_ice_sheet),ice_sheet_vol(0,0)) equivalence(volume(0,0,ivol_hydrate_CO2), $ hydrate_co2_vol(0,0)) equivalence(volume(0,0,ivol_petro),oil_vol(0,0)) equivalence(volume(0,0,ivol_tot),tot_vol(0,0)) double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature #define degC 1 #define Kelvins 2 double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ temperature_canyon double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc, pw_inv, pw_diff, pw_adv, $ pw_canyon_conc, pw_canyon_inv double precision, dimension(N_PW) :: $ pw_tot, diff_tot double precision, dimension(0:NX+1,N_PW) :: $ surface_conc double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_conc, sl_frac, sl_inv double precision, dimension(0:NX_Global+1,N_SL) :: $ rain_frac double precision, dimension(N_SL) :: $ sl_tot c this array carries chemical info, age, and size fraction; probably too much c Units: inv conc frac c chem mol mol/m3 g/g c age yr m3 yr yr m3 / g c size g g/m3 g/g double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_Bubble_Types) :: $ bb_inv, bb_conc double precision, dimension(N_Bubble_Types) :: $ phase_tot double precision :: molwt(N_SL),rho(N_Rho), resp_rc, $ diffusivity(N_PW), alpha(N_Alpha) #ifdef Bubble_Buoy double precision rho_bb, rho_fluid #endif #ifdef Continental_Margin integer nt_tectonics #endif c Continental_Margin #define Mantle 1 #define MeanCrust 2 #define ContCrust 3 #define OceanCrust 4 #define N_Lith_Slabs 4 #define il_Density 1 #define il_Thickness 2 #define il_Mass_per_m 3 #define il_Ocean_Fraction 4 #define il_Age 5 #define N_Lith_Vars 5 double precision, dimension(0:NX+1,N_Lith_Slabs,N_Lith_Vars) :: $ lithosphere #ifdef Accum integer i_stripe double precision stripe_por_init #endif #ifdef Sediment_Transport double precision sedtrans_velocity #endif #ifdef Isostacy double precision :: tau_isostacy #endif #define NDimScales 4 #define SedRateScale 1 #define DepthScale 2 #define TimeScale 3 #define PressureScale 4 double precision dim_scale(NDimScales) integer n_time_scales integer myid, numprocs c 2-D diagnostic variables double precision, dimension(0:NX+1,0:NZ_Max+1,N_Diags_2d) :: $ field double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ CH4_src_resp, $ CH4_src_therm, $ DOC_src_therm, $ DIC_src_therm, $ POC_sink_therm, $ POH_sink_therm, $ POO_sink_therm, $ CH4_sink_aom, $ resp, $ resp_DOC, $ resp_petro, $ therm_K, $ therm_H, $ therm_O, $ petro_src, $ CH4_src_petro, $ caco3_pcp, $ igneous_diss, $ clay_dewater, $ CH4_exsolve, $ CO2_exsolve, $ bubble_ch4_excess, $ bubble_ch4_redissolve, $ hydrate_freeze, $ ice_freeze, $ hydrate_CO2_freeze, $ solid_vol_flux, $ solid_vol_flux_div, $ fluid_vol_flux, $ bubble_vol_flux, $ CH4_bubble_flux, $ CH4_diff_flux, $ CH4_adv_flux, $ heat_src_hydrate, $ heat_src_CO2_hydrate, $ heat_src_ice, $ w_darcy, $ w_bur, $ w_seafloor, $ w_jitter, $ w_unlimited, $ w_d_press_potential, $ w_hydro, $ u, v, $ u_limited, $ therm_diffusivity, $ fluid_buoy, $ bb_u, $ bb_w, $ bb_buoy, $ T_Ice, $ dT_Ice, $ ice_frac, $ ice_sheet_active, $ heat_capacity, $ heat_diff_flux, $ heat_adv_flux, $ resp_k, $ resp_diss_k, $ resp_h2c, $ resp_o2c, $ resp_alpha_so4, $ resp_alpha_ch4, $ pH, $ hplus, $ omega_CaCO3, $ omega_igneous, $ csat_igneous, $ igneous_k, $ rxn_igneous, $ dT_CH4_hydrate, $ T3P_CH4_hydrate, $ CH4_eq_T3P, $ dT_CO2_hydrate, $ CH4_hydrate_frac, $ CO2_hydrate_frac, $ CO2_liq_drho, $ CO2, $ CO3, $ HCO3, $ K1, $ K2, $ Ksp_CaCO3, $ CH4_eq, $ CO2_eq, $ por_melted, $ por_liquid, $ por_mobile, $ por_drained, $ por_dev, $ sal_melted, $ liquid_saturation, $ dpsupp_dpor, $ perm, $ perm_lateral, $ perm_goosefac, $ perm_mdarcys, $ P_excess, $ P_supp, $ P_hydro, $ P_fluid, $ P_gas, $ fluid_delta_z, $ z_water_table_equiv, $ p_head, $ fluid_delta_z_canyon, $ z_water_table_equiv_canyon, $ p_head_canyon, $ stress_litho, $ dyn_visc, $ gas_visc, $ grain_size equivalence( field(0,0,id2_CH4_src_resp), $ CH4_src_resp(0,0)) equivalence( field(0,0,id2_CH4_src_therm), $ CH4_src_therm(0,0)) equivalence( field(0,0,id2_DOC_src_therm), $ DOC_src_therm(0,0)) equivalence( field(0,0,id2_DIC_src_therm), $ DIC_src_therm(0,0)) equivalence( field(0,0,id2_POC_sink_therm), $ POC_sink_therm(0,0)) equivalence( field(0,0,id2_POH_sink_therm), $ POH_sink_therm(0,0)) equivalence( field(0,0,id2_POO_sink_therm), $ POO_sink_therm(0,0)) equivalence( field(0,0,id2_CH4_sink_aom), $ CH4_sink_aom(0,0)) equivalence( field(0,0,id2_resp), $ resp(0,0)) equivalence( field(0,0,id2_resp_DOC), $ resp_DOC(0,0)) equivalence( field(0,0,id2_resp_petro), $ resp_petro(0,0)) equivalence( field(0,0,id2_therm_K), $ therm_K(0,0)) equivalence( field(0,0,id2_therm_H), $ therm_H(0,0)) equivalence( field(0,0,id2_therm_O), $ therm_O(0,0)) equivalence( field(0,0,id2_petro_src), $ petro_src(0,0)) equivalence( field(0,0,id2_CH4_src_petro), $ CH4_src_petro(0,0)) equivalence( field(0,0,id2_caco3_pcp), $ caco3_pcp(0,0)) equivalence( field(0,0,id2_igneous_diss), $ igneous_diss(0,0)) equivalence( field(0,0,id2_clay_dewater), $ clay_dewater(0,0)) equivalence( field(0,0,id2_CH4_exsolve), $ CH4_exsolve(0,0)) equivalence( field(0,0,id2_CO2_exsolve), $ CO2_exsolve(0,0)) equivalence( field(0,0,id2_bubble_ch4_excess), $ bubble_ch4_excess(0,0)) equivalence( field(0,0,id2_bubble_ch4_redissolve), $ bubble_ch4_redissolve(0,0)) equivalence( field(0,0,id2_hydrate_freeze), $ hydrate_freeze(0,0)) equivalence( field(0,0,id2_ice_freeze), $ ice_freeze(0,0)) equivalence( field(0,0,id2_hydrate_CO2_freeze), $ hydrate_CO2_freeze(0,0)) equivalence( field(0,0,id2_fluid_vol_flux), $ fluid_vol_flux(0,0)) equivalence( field(0,0,id2_CH4_bubble_flux), $ CH4_bubble_flux(0,0)) equivalence( field(0,0,id2_CH4_diff_flux), $ CH4_diff_flux(0,0)) equivalence( field(0,0,id2_CH4_adv_flux), $ CH4_adv_flux(0,0)) equivalence( field(0,0,id2_heat_src_hydrate), $ heat_src_hydrate(0,0)) equivalence( field(0,0,id2_heat_src_CO2_hydrate), $ heat_src_CO2_hydrate(0,0)) equivalence( field(0,0,id2_heat_src_ice), $ heat_src_ice(0,0)) equivalence( field(0,0,id2_w), $ w_darcy(0,0)) equivalence( field(0,0,id2_w_bur), $ w_bur(0,0)) equivalence( field(0,0,id2_w_seafloor), $ w_seafloor(0,0)) equivalence( field(0,0,id2_w_jitter), $ w_jitter(0,0)) equivalence( field(0,0,id2_w_unlimited), $ w_unlimited(0,0)) equivalence( field(0,0,id2_w_d_press_potential), $ w_d_press_potential(0,0)) equivalence( field(0,0,id2_w_hydro), $ w_hydro(0,0)) equivalence( field(0,0,id2_u), $ u(0,0)) equivalence( field(0,0,id2_v), $ v(0,0)) equivalence( field(0,0,id2_u_limited), $ u_limited(0,0)) equivalence( field(0,0,id2_therm_diffusivity), $ therm_diffusivity(0,0)) equivalence( field(0,0,id2_fluid_buoy), $ fluid_buoy(0,0)) equivalence( field(0,0,id2_bb_u), $ bb_u(0,0)) equivalence( field(0,0,id2_bb_w), $ bb_w(0,0)) equivalence( field(0,0,id2_bb_buoy), $ bb_buoy(0,0)) equivalence( field(0,0,id2_T_Ice), $ T_Ice(0,0)) equivalence( field(0,0,id2_dT_Ice), $ dT_Ice(0,0)) equivalence( field(0,0,id2_ice_frac), $ ice_frac(0,0)) equivalence( field(0,0,id2_ice_sheet_active), $ ice_sheet_active(0,0)) equivalence( field(0,0,id2_heat_capacity), $ heat_capacity(0,0)) equivalence( field(0,0,id2_heat_diff_flux), $ heat_diff_flux(0,0)) equivalence( field(0,0,id2_heat_adv_flux), $ heat_adv_flux(0,0)) equivalence( field(0,0,id2_resp_k), $ resp_k(0,0)) equivalence( field(0,0,id2_resp_diss_k), $ resp_diss_k(0,0)) equivalence( field(0,0,id2_resp_h2c), $ resp_h2c(0,0)) equivalence( field(0,0,id2_resp_o2c), $ resp_o2c(0,0)) equivalence( field(0,0,id2_resp_alpha_so4), $ resp_alpha_so4(0,0)) equivalence( field(0,0,id2_resp_alpha_ch4), $ resp_alpha_ch4(0,0)) equivalence( field(0,0,id2_pH), $ pH(0,0)) equivalence( field(0,0,id2_hplus), $ hplus(0,0)) equivalence( field(0,0,id2_omega_CaCO3), $ omega_caco3(0,0)) equivalence( field(0,0,id2_omega_igneous), $ omega_igneous(0,0)) equivalence( field(0,0,id2_csat_igneous), $ csat_igneous(0,0)) equivalence( field(0,0,id2_igneous_k), $ igneous_k(0,0)) equivalence( field(0,0,id2_rxn_igneous), $ rxn_igneous(0,0)) equivalence( field(0,0,id2_dT_CH4_hydrate), $ dT_CH4_hydrate(0,0)) equivalence( field(0,0,id2_T3P_CH4_hydrate), $ T3P_CH4_hydrate(0,0)) equivalence( field(0,0,id2_CH4_eq_T3P), $ CH4_eq_T3P(0,0)) equivalence( field(0,0,id2_dT_CO2_hydrate), $ dt_CO2_hydrate(0,0)) equivalence( field(0,0,id2_CH4_hydrate_frac), $ CH4_hydrate_frac(0,0)) equivalence( field(0,0,id2_CO2_hydrate_frac), $ CO2_hydrate_frac(0,0)) equivalence( field(0,0,id2_CO2_liq_drho), $ CO2_liq_drho(0,0)) equivalence( field(0,0,id2_CO2), $ CO2(0,0)) equivalence( field(0,0,id2_CO3), $ CO3(0,0)) equivalence( field(0,0,id2_HCO3), $ HCO3(0,0)) equivalence( field(0,0,id2_K1), $ k1(0,0)) equivalence( field(0,0,id2_K2), $ k2(0,0)) equivalence( field(0,0,id2_Ksp_CaCO3), $ Ksp_CaCO3(0,0)) equivalence( field(0,0,id2_CH4_eq), $ CH4_eq(0,0)) equivalence( field(0,0,id2_CO2_eq), $ CO2_eq(0,0)) equivalence( field(0,0,id2_por_melted), $ por_melted(0,0)) equivalence( field(0,0,id2_por_liquid), $ por_liquid(0,0)) equivalence( field(0,0,id2_por_mobile), $ por_mobile(0,0)) equivalence( field(0,0,id2_por_drained), $ por_drained(0,0)) equivalence( field(0,0,id2_por_dev), $ por_dev(0,0)) equivalence( field(0,0,id2_sal_melted), $ sal_melted(0,0)) equivalence( field(0,0,id2_liquid_saturation), $ liquid_saturation(0,0)) equivalence( field(0,0,id2_dpsupp_dpor), $ dpsupp_dpor(0,0)) equivalence( field(0,0,id2_perm), $ perm(0,0)) equivalence( field(0,0,id2_perm_lateral), $ perm_lateral(0,0)) equivalence( field(0,0,id2_perm_goosefac), $ perm_goosefac(0,0)) equivalence( field(0,0,id2_perm_mdarcys), $ perm_mdarcys(0,0)) equivalence( field(0,0,id2_P_excess), $ P_excess(0,0)) equivalence( field(0,0,id2_P_supp), $ P_supp(0,0)) equivalence( field(0,0,id2_P_hydro), $ P_hydro(0,0)) equivalence( field(0,0,id2_P_fluid), $ P_fluid(0,0)) equivalence( field(0,0,id2_P_gas), $ P_gas(0,0)) equivalence( field(0,0,id2_fluid_delta_z), $ fluid_delta_z(0,0)) equivalence( field(0,0,id2_z_water_table_equiv), $ z_water_table_equiv(0,0)) equivalence( field(0,0,id2_P_head), $ p_head(0,0)) equivalence( field(0,0,id2_fluid_delta_z_canyon), $ fluid_delta_z_canyon(0,0)) equivalence( field(0,0,id2_z_water_table_equiv_canyon), $ z_water_table_equiv_canyon(0,0)) equivalence( field(0,0,id2_P_head_canyon), $ p_head_canyon(0,0)) equivalence( field(0,0,id2_stress_litho), $ stress_litho(0,0)) equivalence( field(0,0,id2_dyn_visc), $ dyn_visc(0,0)) equivalence( field(0,0,id2_gas_visc), $ gas_visc(0,0)) equivalence( field(0,0,id2_grain_size), $ grain_size(0,0)) c 1-D diagnostic variables double precision, dimension(0:NX+1,N_Diags_1d) :: $ diagnostic_1d double precision, dimension(0:NX+1) :: $ POC_rain_flux, $ POC_bio_rain_flux, $ sed_accum_rate, $ hydro_recharge, $ hydro_runoff, $ sed_surf_area_rain, $ surface_temp, $ seafloor_slope, $ seafloor_slope_2nd, $ tau_scour, $ suspended_flux_tot, $ resuspended_flux_tot, $ deposit_flux_tot, $ redeposit_flux_tot, $ sed_redeposit_frac, $ z_erosion_target, $ heat_geotherm_flux, $ d_fluid_vol_dt, $ d_solid_vol_dt, $ sedcol_youngs_mod, $ sedcol_u, $ d_sedcol_u_dx, $ sedcol_thickening, $ column_mass, $ column_height, $ sedcol_mass, $ sedcol_height, $ plate_pulldown, $ plate_x_scale, $ isostat_eq, $ freeboard_eq, $ sedcol_conv_dieqdt, $ crust_therm_dieqdt, $ isostat_dzdt, $ z_water_table, $ seafloor_slope_canyon, $ dz_ice_sheet, $ ice_sheet_u, $ ice_sheet_vol_flow, $ ice_sheet_accum, $ ice_sheet_ablate, $ z_ice_sheet_base, $ ice_sheet_base_dt, $ w_n_iters equivalence( diagnostic_1d(0,id1_POC_rain_flux), $ POC_rain_flux(0)) equivalence( diagnostic_1d(0,id1_POC_bio_rain_flux), $ POC_bio_rain_flux(0)) equivalence( diagnostic_1d(0,id1_sed_accum_rate), $ sed_accum_rate(0)) equivalence( diagnostic_1d(0,id1_hydro_recharge), $ hydro_recharge(0)) equivalence( diagnostic_1d(0,id1_hydro_runoff), $ hydro_runoff(0)) equivalence( diagnostic_1d(0,id1_surface_temp), $ surface_temp(0)) equivalence( diagnostic_1d(0,id1_seafloor_slope), $ seafloor_slope(0)) equivalence( diagnostic_1d(0,id1_seafloor_slope_2nd), $ seafloor_slope_2nd(0)) equivalence( diagnostic_1d(0,id1_tau_scour), $ tau_scour(0)) equivalence( diagnostic_1d(0,id1_suspended_flux_tot), $ suspended_flux_tot(0)) equivalence( diagnostic_1d(0,id1_resuspended_flux_tot), $ resuspended_flux_tot(0)) equivalence( diagnostic_1d(0,id1_deposit_flux_tot), $ deposit_flux_tot(0)) equivalence( diagnostic_1d(0,id1_redeposit_flux_tot), $ redeposit_flux_tot(0)) equivalence( diagnostic_1d(0,id1_sed_redeposit_frac), $ sed_redeposit_frac(0)) equivalence( diagnostic_1d(0,id1_z_erosion_target), $ z_erosion_target(0)) equivalence( diagnostic_1d(0,id1_heat_geotherm_flux), $ heat_geotherm_flux(0)) equivalence( diagnostic_1d(0,id1_d_fluid_vol_dt), $ d_fluid_vol_dt(0)) equivalence( diagnostic_1d(0,id1_d_solid_vol_dt), $ d_solid_vol_dt(0)) equivalence( diagnostic_1d(0,id1_sedcol_youngs_mod), $ sedcol_youngs_mod(0)) equivalence( diagnostic_1d(0,id1_sedcol_u), $ sedcol_u(0)) equivalence( diagnostic_1d(0,id1_d_sedcol_u_dx), $ d_sedcol_u_dx(0)) equivalence( diagnostic_1d(0,id1_sedcol_thickening), $ sedcol_thickening(0)) equivalence( diagnostic_1d(0,id1_column_mass), $ column_mass(0)) equivalence( diagnostic_1d(0,id1_column_height), $ column_height(0)) equivalence( diagnostic_1d(0,id1_sedcol_mass), $ sedcol_mass(0)) equivalence( diagnostic_1d(0,id1_sedcol_height), $ sedcol_height(0)) equivalence( diagnostic_1d(0,id1_plate_pulldown), $ plate_pulldown(0)) equivalence( diagnostic_1d(0,id1_plate_x_scale), $ plate_x_scale(0)) equivalence( diagnostic_1d(0,id1_isostat_eq), $ isostat_eq(0)) equivalence( diagnostic_1d(0,id1_freeboard_eq), $ freeboard_eq(0)) equivalence( diagnostic_1d(0,id1_sedcol_conv_dieqdt), $ sedcol_conv_dieqdt(0)) equivalence( diagnostic_1d(0,id1_crust_therm_dieqdt), $ crust_therm_dieqdt(0)) equivalence( diagnostic_1d(0,id1_isostat_dzdt), $ isostat_dzdt(0)) equivalence( diagnostic_1d(0,id1_z_water_table), $ z_water_table(0)) equivalence( diagnostic_1d(0,id1_seafloor_slope_canyon), $ seafloor_slope_canyon(0)) equivalence( diagnostic_1d(0,id1_dz_ice_sheet), $ dz_ice_sheet(0)) equivalence( diagnostic_1d(0,id1_ice_sheet_u), $ ice_sheet_u(0)) equivalence( diagnostic_1d(0,id1_ice_sheet_vol_flow), $ ice_sheet_vol_flow(0)) equivalence( diagnostic_1d(0,id1_ice_sheet_accum), $ ice_sheet_accum(0)) equivalence( diagnostic_1d(0,id1_ice_sheet_ablate), $ ice_sheet_ablate(0)) equivalence( diagnostic_1d(0,id1_z_ice_sheet_base), $ z_ice_sheet_base(0)) equivalence( diagnostic_1d(0,id1_ice_sheet_base_dt), $ ice_sheet_base_dt(0)) equivalence( diagnostic_1d(0,id1_w_n_iters), $ w_n_iters(0)) c diagnostics gridded by x and grain size #define ids1_particle_radius 1 #define ids1_sinking_rate 2 #define ids1_tau_critical 3 #define N_Diags_DS1 3 double precision, dimension(N_Size_Classes, $ N_Diags_DS1) :: $ diagnostic_ds1 double precision, dimension(N_Size_Classes) :: $ particle_radius, tau_critical, sinking_rate equivalence( diagnostic_ds1(1,ids1_particle_radius), $ particle_radius(1)) equivalence( diagnostic_ds1(1,ids1_sinking_rate), $ sinking_rate(1)) equivalence( diagnostic_ds1(1,ids1_tau_critical), $ tau_critical(1)) #define ids2_suspended 1 #define ids2_resuspended 2 #define ids2_depositing 3 #define ids2_redepositing 4 #define ids2_redeposit_org 5 #define ids2_resuspended_org 6 #define ids2_surf_sl 7 #define N_Diags_DS2 7 #define ids2_flux 1 #define ids2_frac 2 double precision, dimension(0:NX+1, $ N_SL, 2, $ N_Diags_DS2) :: $ diagnostic_ds2 double precision, dimension(0:NX+1, $ N_SL) :: $ suspended_flux, $ suspended_frac, $ resuspended_flux, $ resuspended_frac, $ deposit_flux, $ deposit_frac, $ redeposit_flux, $ redeposit_frac, $ resuspended_org_flux, $ resuspended_org_frac, $ redeposit_org_flux, $ redeposit_org_frac, $ surf_sl_frac equivalence( diagnostic_ds2(0,1,ids2_flux,ids2_suspended), $ suspended_flux(0,1)) equivalence( diagnostic_ds2(0,1,ids2_frac,ids2_suspended), $ suspended_frac(0,1)) equivalence( diagnostic_ds2(0,1,ids2_flux,ids2_resuspended), $ resuspended_flux(0,1)) equivalence( diagnostic_ds2(0,1,ids2_frac,ids2_resuspended), $ resuspended_frac(0,1)) equivalence( diagnostic_ds2(0,1,ids2_flux,ids2_depositing), $ deposit_flux(0,1)) equivalence( diagnostic_ds2(0,1,ids2_frac,ids2_depositing), $ deposit_frac(0,1)) equivalence( diagnostic_ds2(0,1,ids2_flux,ids2_redepositing), $ redeposit_flux(0,1)) equivalence( diagnostic_ds2(0,1,ids2_frac,ids2_redepositing), $ redeposit_frac(0,1)) equivalence( diagnostic_ds2(0,1,ids2_flux,ids2_redeposit_org), $ redeposit_org_flux(0,1)) equivalence( diagnostic_ds2(0,1,ids2_frac,ids2_redeposit_org), $ redeposit_org_frac(0,1)) equivalence( diagnostic_ds2(0,1,ids2_flux,ids2_resuspended_org), $ resuspended_org_flux(0,1)) equivalence( diagnostic_ds2(0,1,ids2_frac,ids2_resuspended_org), $ resuspended_org_frac(0,1)) equivalence( diagnostic_ds2(0,1,ids2_frac,ids2_surf_sl), $ surf_sl_frac(0,1)) double precision sea_level, ocean_oxic_state, $ ocean_temperature_offset, air_temp_sea_level, $ w_jitter_max, dt_inner integer, dimension(NX) :: iz_water_table integer :: i_step #ifdef MPI call MPI_INIT(ierr) call MPI_COMM_RANK(MPI_COMM_WORLD,myid,ierr) c call MPI_BUFFER_ATTACH(buffer,10000000,ierr) call MPI_COMM_SIZE(MPI_COMM_WORLD,numprocs,ierr) #ifdef MPIStdOut write(6,*) "I am", myid, " of", numprocs call flush(6) #endif #else myid = Master numprocs = 1 #endif if(NX * numprocs .NE. NX_Global) then write(6,*) "Horizontal grid mismatch", NX, numprocs, NX_Global #ifdef MPI call MPI_Finalize(MPI_COMM_WORLD, ierr) #endif stop endif cccccccccccccccccccccccccccccccccccccccc c Initialization of Global Variables cccccccccccccccccccccccccccccccccccccccc sea_level = 0.d0 dt = DT dt_run = DT_Scenario / T_Scale nt_diffuse = NT_Diffuse nt_sed_transport = NT_Sed_Transport c it seems stupid to #define them then make variables, but they c might get tweaked during a run dt_cdf = dt_run $ / N_CDF #ifdef Paced_CDF dt_cdf = Paced_CDF ! years #endif #ifdef Verbose_CDF dt_cdf = dt_cdf/Verbose_CDF #endif #ifdef Suppress_CDF dt_cdf = dt_run #endif dt_out = dt_cdf if(dt_run .GT. 2.d6) then dt_out = dt_out / 10 endif c#ifdef Read1_Restart_CDF c nt_out = 1 c#endif #ifdef DoubleExpPor por_0(1) = 0.38d0 ! 0.38d0 ! Flemings 2002 parameter ref porosity por_0(2) = 0.32d0 ! 0.32d0 ! turns off double exp if 0 beta(1) = 3.12d-2 ! bulk compressibility 1/MPa from Flemings 2002 beta(2) = 0.2d0 #else por_0(1) = 0.5 ! 0.38d0 ! Flemings 2002 parameter ref porosity por_0(2) = 0.0d0 ! 0.32d0 ! turns off double exp if 0 beta(1) = 3.12d-2 ! bulk compressibility 1/MPa from Flemings 2002 beta(2) = 0 #endif por_0(0) = por_0(1) + por_0(2) #ifdef Perm_Pore_Only perm_0 = 1.d-17 perm = perm_0 perm_lateral = perm_0 #endif #ifdef Geothermal_Heat_Flux heat_geotherm_flux = Geothermal_Heat_Flux ! W/m2 #else heat_geotherm_flux = 0.d0 #endif dyn_visc = 1.E-3 ! Pa s gas_visc_0 = 1.e-6 ! Pa s cccccccccccccccccccccccccccccccccccccccccccccccccccccc c Variable Initialization for Individual Scenarios cccccccccccccccccccccccccccccccccccccccccccccccccccccc call find_timedep_drivers(0, dt_run, $ sea_level, surface_conc, $ ocean_oxic_state, ocean_temperature_offset, $ air_temp_sea_level) #ifdef Continental_Margin nt_tectonics = 1 #endif c Continental_Margin #ifdef Cap #ifdef MPI if(2*myid+1 .GT. numprocs) then ! right hand side, cap them all perm(:,NZ_Max-2:NZ_Max) = 3.e-19 elseif(2*myid+1 .EQ. numprocs) then ! in the middle, cap half perm(NX/2:NX,NZ_Max-2:NZ_Max) = 3.d-19 endif #else perm(6:11,8:10) = 3.d-18 #endif #endif C Cap #ifdef Channel perm(:,15:20) = 1.d-17 #endif #ifdef Chimney perm(5:6,:) = 3.d-16 perm(9:10,:) = 3.d-16 perm(15:16,:) = 3.d-16 #endif c rate constants in stone #define H_to_C_Oxic 0.7 #define H_to_C_Anxic 1.3 #define O_to_C_Oxic 0.12 #define O_to_C_Anoxic 0.05 #define Therm_A 4.d21 /* yr-1 from Hunt 147 */ #define Therm_E 230.d3 /* Joules/mol */ #define Petro_A 1.d16 /* yr-1 outta my ass */ #define Petro_E 150.d3 /* Joules/mol */ #define Clay_Act_Energy 19600. /* Joules/mol */ resp_rc = 0.d0 #ifdef Resp_Scale_Age resp_rc = 3.d-1 #else resp_rc = 1.25d-8/T_Scale ! yr-1 #endif #ifdef Resp_Wallmann resp_rc = resp_rc * 3 ! booger * 10.d0 #endif #ifdef Boost_CH4_Production resp_rc = resp_rc * Boost_CH4_Production #endif c molecular weights of solids molwt = 1.d0 molwt(i_Bio_POC:i_Bio_POC-1+N_POCs) = 12.d0 molwt(i_Hydrate:i_Hydrate_d) = 160.d0 molwt(i_Hydrate_CO2) = 147.5d0 molwt(i_CaCO3) = 100.d0 molwt(i_Montmorillonite) = 549.1d0 molwt(i_Illite) = 389.3d0 molwt(i_Quartz) = 60.d0 molwt(i_Ice) = 18.d0 molwt(i_Freshwater) = 18.d0 ! sneaking a tag from the rho indices c densities, g / m3 rho(i_Bio_POC:i_Bio_POC-1+N_POCs) = 900.d3 rho(i_Hydrate:i_Hydrate_d) = 910.d3 ! Gupta et al 2006 rho(i_Hydrate_CO2) = 1100.d3 ! Aya, Yamane, Nariai 1997 (30MPa) rho(i_CaCO3) = 2710.d3 rho(i_Montmorillonite) = 2350.d3 rho(i_Illite) = 2750.d3 rho(i_Quartz) = 2650.d3 rho(i_Ice) = 900.d3 ! try rho(i_Freshwater) = 1000.d3 rho(i_Seawater) = 1030.d3 rho(i_Sediment) = 2500.d3 c $ rho(i_Montmorillonite) * rc(irc_mont_frac) c $ + rho(i_Illite) * rc(irc_illite_frac) c $ + rho(i_Quartz) * rc(irc_quartz_frac) c $ + rho(i_CaCO3) * rc(irc_CaCO3_frac) rho(i_Ocean_Crust) = 3000.d3 rho(i_Continental_Crust) = 2700.d3 rho(i_Mantle) = 3500.d3 c fractionation factors alpha = 0.d0 #ifdef Reaction_d_Org alpha(i_alpha_org) = -25.d-3 #endif #ifdef Reaction_d_CH4 alpha(i_alpha_co2_redn) = -90.d-3 ! Whiticar 1999, derives from DIC alpha(i_alpha_co2_redn_d) = -180.d-3 #endif #ifdef Reaction_d_AOM alpha(i_alpha_aom) = -9.d-3 alpha(i_alpha_aom_d) = -160.d-3 #endif #ifdef Reaction_d_Therm alpha(i_alpha_therm) = 0.d-3 ! derives from organic C, not DIC alpha(i_alpha_therm_d) = -180.d-3 #endif #ifdef d_Diffusion alpha(i_alpha_diffuse) = -10.d-3 #endif c diffusivities diffusivity = 5.d-6 ! cm2/sed $ * 3.14d3 ! m2/yr diffusivity(i_C13H4) = diffusivity(i_CH4) $ * ( 1. + alpha(i_alpha_diffuse) ) diffusivity(i_CDH3) = diffusivity(i_CH4) $ * ( 1. + alpha(i_alpha_diffuse) ) diffusivity(i_DIC13) = diffusivity(i_DIC) $ * ( 1. + alpha(i_alpha_diffuse) ) #ifdef Accum i_stripe = nz #ifdef Simple_Sedimentation sed_accum_rate = 1.d-3 ! m / year grain_size = 1.d-6 #endif #ifdef BlakeFake1D sed_accum_rate = 2.2d-4 !m/yr = 22 cm/kyr !from Davie & Buffett #endif #ifdef CascadiaFake1D sed_accum_rate = 2.5d-4 !m/yr = 25 cm/kyr !from Davie & Buffett #endif #endif c Accum c solute upper boundary condition surface_conc = 0.d0 surface_conc(:,i_DIC:i_DIC13) = 2.2d0 #ifdef i_Alk surface_conc(:,i_Alk) = 2.3d0 #endif #ifdef i_Ca surface_conc(:,i_Ca) = 10.d-3 #endif surface_conc(:,i_SO4) = Ocean_SO4 #ifdef i_Sal surface_conc(:,i_Sal) = Ocean_Sal #endif #ifdef i_Delta18O surface_conc(:,i_Delta18O) = 0.d0 #endif #ifdef Sediment_Transport sedtrans_velocity = Sediment_Transport_Velocity #endif #ifdef NonDimensional z_top(:,0) = -1000 write(6,*) "waiting for lambda" read(5,*) dim_scale(SedRateScale) c dim_scale(SedRateScale) = LAMBDA ! (no dims) n_time_scales = 5 sed_accum_rate = perm_0 ! m2 $ * ( rho(i_Sediment) - rho(i_Seawater) ) ! g / m3 $ / 1.d3 ! kg / m3 -> kg / m $ * 9.8d0 ! m / s2 -> kg / s2 $ / dyn_visc(1,1) ! kg / s2 / (N s / m2) -> m / s $ / dim_scale(SedRateScale) ! m/s $ * 3.14d7 ! m/yr dim_scale(DepthScale) = 1.d0 / ( beta(1) / 1.d6 ) ! Pa = N/m2 = kg / m / s2 $ / ( ( rho(i_Sediment) - rho(i_Seawater) ) ! g / m3 -> m2 / s2 $ / 1.d3 $ ) $ / 9.8d0 ! m dim_scale(TimeScale) = dim_scale(DepthScale) $ / sed_accum_rate(1) ! yr dim_scale(PressureScale) = $ ( rho(i_Sediment) - rho(i_Seawater) ) $ / 1.d3 $ * 9.8d0 ! kg/m3 * m/s2 = N/m3 = Pa/m $ / 1.d6 ! MPa/m $ * dim_scale(DepthScale) ! MPa dt_run = dim_scale(TimeScale) * n_time_scales nt = dt_run / dt dt_cdf = nt write(6,*) $ "lambda depth_scale time_scale accum_rate pr_scale dt_run" write(6,*) $ "(no dims) (m) (yr) (m/yr) (MPa) (yr) " write(6,"(6g12.4)") dim_scale(SedRateScale), $ dim_scale(DepthScale), dim_scale(TimeScale), $ sed_accum_rate(1), dim_scale(PressureScale), dt_run write(6,*) $ "dt n_time_scales nt" write(6,"(6g12.3)") dt, n_time_scales, $ nt #endif #ifdef Read_Restart_CDF call read_netcdf(Read_Restart_CDF, $ x, dx, z_top, sea_level,z_canyon, $ x_global, dx_global, $ z_seafloor_global, $ ocean_frac_global, $ volume, $ pw_conc, sl_frac, bb_conc, temperature, lithosphere, $ nz, myid, numprocs) c initialize iz_water_table after read_cdf do ix = 1, NX if( z_top(ix,nz) .LT. sea_level) then ! fully submerged iz_water_table(ix) = nz+1 else iz_water_table(ix) = nz do iz = nz, 1, -1 if(air_vol(ix,iz).GT. 0.d0) then iz_water_table(ix) = iz endif enddo ! chooses the deepest endif enddo #ifdef Create_HiTop call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) call compute_column_mh(lithosphere, $ volume, rho, dx, z_top, sea_level, z_water_table, $ nz, $ column_mass, column_height, $ sedcol_mass, sedcol_height) call hires_top_grid_z( $ pw_conc, sl_frac, bb_conc, $ temperature, volume, nz) call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) call compute_column_mh(lithosphere, $ volume, rho, dx, z_top, sea_level, z_water_table, $ nz, $ column_mass, column_height, $ sedcol_mass, sedcol_height) call hires_top_grid_interp( sl_frac(:,:,i_Age), $ z_center , nz ) #endif #ifdef DoubleVRes call double_grid_z( $ pw_conc, sl_frac, bb_conc, $ temperature, volume, nz) #endif #ifdef CreateQuadLoVRes call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) call compute_column_mh(lithosphere, $ volume, rho, dx, z_top, sea_level, z_water_table, $ nz, $ column_mass, column_height, $ sedcol_mass, sedcol_height) call double_grid_z( $ pw_conc, sl_frac, bb_conc, $ temperature, volume, nz) call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) call compute_column_mh(lithosphere, $ volume, rho, dx, z_top, sea_level, z_water_table, $ nz, $ column_mass, column_height, $ sedcol_mass, sedcol_height) call double_grid_z( $ pw_conc, sl_frac, bb_conc, $ temperature, volume, nz) call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) call compute_column_mh(lithosphere, $ volume, rho, dx, z_top, sea_level, z_water_table, $ nz, $ column_mass, column_height, $ sedcol_mass, sedcol_height) #endif #ifdef DoubleHRes call double_grid_x(grid, $ pw_conc, sl_frac, bb_conc, $ temperature, volume, lithosphere, $ x_global, dx_global, $ z_seafloor_global, ocean_frac_global) #endif call update_sl_inv(sl_frac,sl_inv,solid_vol, $ molwt,rho,nz) call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) #ifdef MPI call MPI_Gather(dz(1:NX,nz),NX,MPI_DOUBLE_PRECISION, $ dz_seafloor_global(1:NX_Global),NX,MPI_DOUBLE_PRECISION, $ Master, MPI_COMM_WORLD,ierr) call MPI_Bcast(dz_seafloor_global(1:NX_Global), NX_Global, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) #else dz_seafloor_global(1:NX) = dz(1:NX,nz) #endif lithosphere(:,OceanCrust,il_Mass_per_m) = $ Ocean_Crust_H0 * rho(i_Ocean_Crust) lithosphere(:,ContCrust,il_Mass_per_m) = $ Cont_Crust_H0 * rho(i_Continental_Crust) do ix = 1, N_Lith_Vars-2 lithosphere(:,MeanCrust,ix) = $ lithosphere(:,OceanCrust,ix) $ * lithosphere(:,OceanCrust,il_Ocean_Fraction) $ + lithosphere(:,ContCrust,ix) $ * (1.d0 - lithosphere(:,OceanCrust,il_Ocean_Fraction)) enddo call compute_column_mh(lithosphere, $ volume, rho, dx, z_top, sea_level, z_water_table, $ nz, $ column_mass, column_height, $ sedcol_mass, sedcol_height) call cooling_ocean_crust( $ rho, $ temperature, $ lithosphere, $ dt, crust_therm_dieqdt, heat_geotherm_flux) plate_pulldown = 0.d0 #ifdef Sinking_Crust call sinking_crust(t_now, dt_run, $ lithosphere(:,OceanCrust,il_Ocean_Fraction), $ plate_pulldown) #endif #ifdef Plate_Torque call plate_torque( $ x_global, ocean_frac_global, $ plate_pulldown, plate_x_scale, $ myid, numprocs) #endif #ifdef Sediment_Transport call find_POC_rain_fraction(ocean_oxic_state, $ z_seafloor_global, sea_level, $ rain_frac) call sediment_transport(sea_level, $ z_seafloor_global, dz_seafloor_global, $ x_global, dx_global, $ sedtrans_velocity, $ rain_frac, $ rho, por_0, $ particle_radius, tau_critical, sinking_rate, ! grid of size class $ diagnostic_ds2, $ sed_accum_rate, ! ix only $ tau_scour, $ seafloor_slope, seafloor_slope_2nd, $ sed_redeposit_frac, z_erosion_target, $ suspended_flux_tot, resuspended_flux_tot, $ deposit_flux_tot, redeposit_flux_tot, $ sl_frac, por_melted, $ nz, myid, numprocs) #endif #else /* Read_Restart_CDF */ c Set up initial conditions from scratch dx = DX_Init #ifdef MPI $ / numprocs #endif #ifdef FakeMPI $ / FakeMPI #endif $ / NX_Base * 10 dx_global = DX_Init #ifdef MPI $ / numprocs #endif #ifdef FakeMPI $ / FakeMPI #endif $ / NX_Base * 10 x_global(0) = - 2 * dx_global(1) do ix=1,NX_Global+1 x_global(ix) = x_global(ix-1) ! | | $ + dx_global(ix) ! dx(ix-1) x(ix-1) dx(ix) ix(ix) enddo #ifdef Cont_Crust_DX x_global = x_global - x_global(1) - Cont_Crust_DX c offsets to put zero at continental boundary #endif x(0:NX+1) = x_global(0+myid*NX:NX+1+myid*NX) #ifdef Continental_Margin #ifdef Crust_Transition_Width lithosphere(:,OceanCrust,il_Ocean_Fraction) = $ 0.5 $ - ATAN( - x(:) $ / Crust_Transition_Width ! meters $ ) / 3.14 #else lithosphere(:,OceanCrust,il_Ocean_Fraction) = $ 1.d0 #endif lithosphere(:,OceanCrust,il_Thickness) = Ocean_Crust_H0 #ifdef Cont_Crust_H0 lithosphere(:,ContCrust,il_Thickness) = Cont_Crust_H0 #endif lithosphere(:,OceanCrust,il_Mass_per_m) = $ Ocean_Crust_H0 * rho(i_Ocean_Crust) lithosphere(:,ContCrust,il_Mass_per_m) = $ Cont_Crust_H0 * rho(i_Continental_Crust) lithosphere(:,Mantle,il_Thickness) = 0.d0 lithosphere(:,Mantle,il_Mass_per_m) = 0.d0 lithosphere(:,OceanCrust,il_Age) = $ MAX( ( Plate_Width - x(:) ) $ / Plate_Velocity, $ Ocean_Crust_Min_Age $ ) #ifdef Mackenzie lithosphere(:,OceanCrust,il_Age) = $ Ocean_Crust_Min_Age #endif #ifdef Gulf lithosphere(:,OceanCrust,il_Age) = $ 60.d6 / T_Scale #endif #ifdef SedimentDam lithosphere(:,OceanCrust,il_Age) = $ 60.d6 / T_Scale #endif do ix = 1, N_Lith_Vars-2 lithosphere(:,MeanCrust,ix) = $ lithosphere(:,OceanCrust,ix) $ * lithosphere(:,OceanCrust,il_Ocean_Fraction) $ + lithosphere(:,ContCrust,ix) $ * (1.d0 - lithosphere(:,OceanCrust,il_Ocean_Fraction)) enddo #ifdef MPI call MPI_Gather(lithosphere(1:NX, $ OceanCrust, $ il_Ocean_Fraction), $ NX,MPI_DOUBLE_PRECISION, $ ocean_frac_global(1:NX_Global), $ NX,MPI_DOUBLE_PRECISION, $ Master,MPI_COMM_WORLD,ierr) call MPI_Bcast(ocean_frac_global, NX_Global+2, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) #else ocean_frac_global = lithosphere(:, $ OceanCrust, $ il_Ocean_Fraction) #endif temperature = 0.d0 call cooling_ocean_crust( $ rho, $ temperature, $ lithosphere, $ dt, crust_therm_dieqdt, heat_geotherm_flux) c sets lithosphere density #endif nz = NZ_Max do iz = 1, nz tot_vol(1:NX,iz) = dx(1:NX) * DZ_Init enddo #ifdef Pelagic_Sed_Init do iz = 1, nz tot_vol(:,iz) = MAX( $ tot_vol(:,iz), $ dx(:) $ * Pelagic_Sedimentation ! m / yr $ * lithosphere(:,OceanCrust,il_Age) ! yr, now m $ / nz $ ) enddo #endif solid_vol = tot_vol * ( 1. - por_0(0) ) fluid_vol = tot_vol * por_0(0) c initialize iz_water_table for scratch start case iz_water_table = nz+1 #ifdef Drained_Init call setup_drained_sediment_column( $ z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid,por_mobile, $ por_drained, por_dev, $ liquid_saturation, $ z_water_table, iz_water_table, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, $ nz, myid, numprocs) #endif do iz = 1, nz sl_frac(1:NX,iz,i_Age) = lithosphere(1:NX,OceanCrust,il_Age) ! yr $ * ( nz - iz + 1 ) / nz ! nz gets 1/nz, 1 gets the crust age $ / solid_vol(1:NX,iz) enddo #ifdef Isostacy sea_level = 0. z_top(:,0) = -5000.d0 call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) call compute_column_mh(lithosphere, $ volume, rho, dx, z_top, sea_level, z_water_table, $ nz, $ column_mass, column_height, $ sedcol_mass, sedcol_height) #ifdef Plate_Torque call plate_torque( $ x_global, z_seafloor_global, ocean_frac_global, $ plate_pulldown, plate_x_scale, $ myid, numprocs) #endif tau_isostacy = 1.d0 call isostacy(z_top, x, dx, $ x_global, $ lithosphere, volume, rho, $ dt, tau_isostacy, sea_level, $ plate_pulldown, plate_x_scale, $ isostat_eq, $ column_mass, column_height, freeboard_eq, $ isostat_dzdt, $ nz,myid,numprocs) call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid,por_mobile, $ por_drained, por_dev, $ liquid_saturation, $ z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) #else z_top(:,0) = -1000. ! basement depth, meters #endif c Isostacy #ifdef Wedge c set the right-hand wedge boundary condition if( myid .EQ. numprocs-1 ) then pw_conc(NX+1,:,:) = pw_conc(NX,:,:) sl_frac(NX+1,:,:) = sl_frac(NX,:,:) bb_conc(NX+1,:,:) = 0.d0 temperature(NX+1,:,:) = temperature(NX,:,:) endif #endif call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid,por_mobile, $ por_drained, por_dev, $ liquid_saturation, $ z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) #ifdef MPI call MPI_Gather(z_top(1:NX,nz),NX,MPI_DOUBLE_PRECISION, $ z_seafloor_global(1:NX_Global),NX,MPI_DOUBLE_PRECISION, $ Master, MPI_COMM_WORLD,ierr) call MPI_Bcast(z_seafloor_global(1:NX_Global), NX_Global, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) call MPI_Gather(dz(1:NX,nz),NX,MPI_DOUBLE_PRECISION, $ dz_seafloor_global(1:NX_Global),NX,MPI_DOUBLE_PRECISION, $ Master, MPI_COMM_WORLD,ierr) call MPI_Bcast(dz_seafloor_global(1:NX_Global), NX_Global, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) #else z_seafloor_global(1:NX) = z_top(1:NX,nz) dz_seafloor_global(1:NX) = dz(1:NX,nz) #endif c sl_frac sl_frac(:,:,i_Bio_POC:i_Bio_POC-1+N_POCs) = 0.0d0 #ifdef Init_POC sl_frac(:,:,i_Bio_POC) = Init_POC $ * Bio_POC_Frac sl_frac(:,:,i_POC) = Init_POC sl_frac(:,:,i_POH) = sl_frac(:,:,i_POC) $ * H_to_C_Oxic sl_frac(:,:,i_POO) = sl_frac(:,:,i_POC) $ * O_to_C_Oxic #endif #ifdef Init_POC_Profile do ix=1,NX do iz=1,nz sl_frac(ix,iz,i_Bio_POC) = 0.001d0 $ * exp( ( z_center(ix,iz) - z_top(ix,nz) ) ! say (-3000 - -2000) = -1000 $ / 200. $ ) sl_frac(ix,iz,i_POC) = 0.01 $ * exp( ( z_center(ix,iz) - z_top(ix,nz) ) $ / 2000. $ ) sl_frac(ix,iz,i_POH) = sl_frac(ix,iz,i_POC) $ * H_to_C_Oxic sl_frac(ix,iz,i_POO) = sl_frac(ix,iz,i_POC) $ * O_to_C_Oxic enddo enddo #endif sl_frac(:,:,i_CaCO3) = 0.1d0 c sl_frac(:,:,i_Bio_POC) = 1.d-2 sl_frac(:,:,i_Montmorillonite) = 1.d0 do i_sl = 1, N_SL_Conc if( i_sl .NE. i_Montmorillonite) then sl_frac(:,:,i_Montmorillonite) = $ sl_frac(:,:,i_Montmorillonite) $ - sl_frac(:,:,i_sl) ! should now sum to 1 endif enddo c initialize grain sizes in column #ifdef Sediment_Transport call find_POC_rain_fraction(ocean_oxic_state, $ z_seafloor_global, sea_level, $ rain_frac) call sediment_transport(sea_level, $ z_seafloor_global, dz_seafloor_global, $ x_global, dx_global, $ sedtrans_velocity, $ rain_frac, $ rho, por_0, $ particle_radius, tau_critical, sinking_rate, ! grid of size class $ diagnostic_ds2, $ sed_accum_rate, ! ix only $ tau_scour, $ seafloor_slope, seafloor_slope_2nd, $ sed_redeposit_frac, z_erosion_target, $ suspended_flux_tot, resuspended_flux_tot, $ deposit_flux_tot, redeposit_flux_tot, $ sl_frac, por_melted, $ nz, myid, numprocs) #endif do i_sl = i_first_size_class, i_Pelagic do ix = 1, NX sl_frac(ix,1:nz,i_sl) = #ifdef Test_Erosion $ 1.d0 / N_Size_Classes #else $ deposit_frac(1,i_sl) #endif enddo enddo #ifdef Sediment_Homogenized sl_frac(:,:,i_first_size_class:i_Pelagic) = 0.d0 sl_frac(:,:,i_last_size_class) = 1.d0 #endif c sl_frac(:,:,i_Age) = 1.d3 this was set above c pw_conc call find_surface_temp(z_top(:,nz), $ sea_level,ocean_temperature_offset, $ surface_temp, surface_conc, nz) do ix=1,NX pw_conc(ix,nz+1,1:N_PW) = surface_conc(ix,1:N_PW) temperature(ix,nz+1,degC) = surface_temp(ix) enddo c pw_conc(:,:,i_SO4) = 0.d0 do iz = 1, nz do i_pw = 1, N_PW pw_conc(:,iz,i_pw) = pw_conc(:,nz+1,i_pw) enddo #ifdef Initial_Geotherm temperature(:,iz,degC) = temperature(:,nz+1,degC) $ - ( z_center(:,iz) - z_top(:,nz) ) ! say -(-3000--2000) = +1000 $ / 1000. * 30. #endif enddo #ifdef Isostacy c need a truly steady-state initial condition, but there is feedback c from the temperature, and the temperature needs to know the sea floor c depth to get the sediment surface temperature. hence the iteration call cooling_ocean_crust( $ rho, $ temperature, $ lithosphere, $ dt, crust_therm_dieqdt, heat_geotherm_flux) call isostacy(z_top, x, dx, $ x_global, $ lithosphere, volume, rho, $ dt, tau_isostacy, sea_level, $ plate_pulldown, plate_x_scale, $ isostat_eq, $ column_mass, column_height, freeboard_eq, $ isostat_dzdt, $ nz,myid,numprocs) call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid,por_mobile, $ por_drained, por_dev, $ liquid_saturation, $ z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) #endif c Isostacy bb_conc = 0.d0 z_canyon(1:NX) = z_top(1:NX,nz) #endif /* Read_Restart_CDF */ c at this point these variables should be initialized: c z_top, dx, x_global, volumes, pw_conc, sl_frac, bb_conc, c temperature, lithosphere call update_pw_inv(pw_conc,pw_inv,fluid_vol,nz) call update_sl_inv(sl_frac,sl_inv,solid_vol, $ molwt,rho,nz) call update_sl_conc(sl_inv,sl_conc,sl_frac,solid_vol, $ molwt,rho,nz) do ix = 1, NX call find_p_excess( ix, ! updates only in column ix, for sub-looping $ p_excess, p_supp, p_hydro, p_fluid, p_gas, $ por_melted, fluid_buoy, stress_litho, $ por_0, beta, $ dpsupp_dpor, $ dz, temperature, $ nz ) enddo temperature(:,:,Kelvins) = temperature(:,:,degC) + 273.15d0 call update_bb_inv(bb_conc,bb_inv, $ p_gas,fluid_vol,temperature, $ rho,CO2_liq_drho,nz) z_top_last = z_top i_shifts = I_Shifts_Init i_timestep = -1 t_now = - dt #ifdef Read_Restart_CDF t_now = Read_Restart_CDF i_timestep = t_now / dt itag = t_now+2 c call write_netcdf(itag, c $ grid, volume, x_global, dx_global, dim_scale, c $ pw_conc, sl_frac, bb_conc, temperature, lithosphere, c $ field, diagnostic_1d, c $ diagnostic_ds1, diagnostic_ds2, c $ sea_level, rho, molwt, c $ dt, nz, myid, numprocs) #endif z_canyon(1:NX) = MIN(sea_level,z_top(1:NX,nz)) i_timestep_init = i_timestep w_n_iters = 1.d0 ccccccccccccccccccccccc c Beginning of Time Loop ccccccccccccccccccccccc 10 i_timestep = i_timestep + 1 c do i_timestep=1,nt t_now = t_now + dt c if( i_timestep .GT. i_timestep_init + 300 ) then c#ifdef MPI c call MPI_Finalize(MPI_COMM_WORLD, ierr) c#endif c stop c endif #ifdef ClusterFuck write(6,"(a6,i12, 7g14.6)") "poop", i_timestep, $ z_top(26:28,nz) if(z_top(1,nz) .GT. sea_level) then c $ volume(1,15,1:3), c $ volume(1,15,6), $ volume(1,15,9) endif c $ por_drained(1,15), por_melted(1,15) $ ice_vol(1,nz-1:nz), $ ice_vol(1,nz-1)/tot_vol(1,nz-1), $ ice_vol(1,nz)/tot_vol(1,nz) if(i_timestep .EQ. 5624432) then endif c if(t_now .GT. 100.d0) then c stop c endif c if(i_timestep .EQ. 59377) then c write(6,*) "stepping", i_timestep, fluid_vol(4,10) c endif c if(z_top(1,nz) .GT. sea_level) then c if(bubbles_c13h4(28,12 .GT. 1.d0) then $ c $ z_water_table(1:2), c $ p_excess(1:2,15) $ fluid_vol(2,15), pw_inv(2,15,i_Sal) c $ bb_conc(28,12,1), c $ bb_conc(28,12,2), c $ ( ( bb_conc(28,12,2) c $ / (bb_conc(28,12,1)+1.d-19) c $ ) - 1.d0 ) * 1000.d0 c $ z_top(1,15)-sea_level, c $ isostat_eq(1),! - z_top(1,nz)+z_top(1,0) c $ z_top(1,0) c $ column_height(1), column_mass(1) c $ sea_level-z_top(1,15),z_top(1,15), c $ z_top(1,0) c $ solid_vol(1,15), fluid_vol(1,15) c $ plate_pulldown(1) c $ sedcol_mass(1), sedcol_height(1) c $ lithosphere(1,OceanCrust,il_Mass_per_m), c $ lithosphere(1,OceanCrust,il_Thickness) c endif c write(6,"(i12, 3f12.3,3f12.5,g12.5)") c $ i_timestep,z_top(1,nz), c $ z_top(1,0), z_top(1,nz) - z_top(1,0) c $ fluid_vol(1,nz)/tot_vol(1,nz), c $ ice_vol(1,nz)/tot_vol(1,nz), c $ solid_vol(1,nz)/tot_vol(1,nz), c $ tot_vol(1,nz) c $ por_melted(1,nz), por_liquid(1,nz) c $ column_mass(1), column_height(1) c $ p_hydro(1,nz), c $ stress_litho(1,nz),por_drained(1,nz) c write(6,"(a5,f12.2, f8.3,f8.2)") "step",t_now,dt, w_jitter_max c if( i_timestep .EQ. 2102311066 ) then c if( iz_water_table(2) .LT. 14 ) then c endif c if(i_timestep .EQ. 11530587) then write(6,"(A2,15g12.2)") "V", fluid_vol(6:8,13) write(6,"(A2,15f12.5)") "W", w_jitter(6:8,13) write(6,"(A2,15f12.5)") "U",u(6:8,13) write(6,"(A2,15f12.5)") "P", p_excess(6:8,13) write(6,"(A2,15f12.5)") "Po",por_dev(6:8,13) write(6,"(A2,15f12.5)") "Z",z_top(6:8,13) write(6,*) write(6,"(A2,15g12.2)") "V", fluid_vol(6:8,14) write(6,"(A2,15f12.5)") "W", w_jitter(6:8,14) write(6,"(A2,15f12.5)") "U",u(6:8,14) write(6,"(A2,15f12.5)") "P", p_excess(6:8,14) write(6,"(A2,15f12.5)") "Po",por_dev(6:8,14) write(6,"(A2,15f12.5)") "Z",z_top(6:8,14) c endif write(6,*) i_timestep, pw_conc(2,9,1) endif c write(6,"(2f12.2,4f12.2)") t_now, z_water_table(1), c $ fluid_vol(1,35) c if(air_vol(1,10) .GT. 0) then c write(6,"(f9.1, 9f9.4)") fluid_vol(1,2), w_jitter(1,1:3), c $ p_excess(1,1:3) c endif c if(w_darcy(2,32) .LT. 0.d0) then c endif write(6,*) sea_level,fluid_vol(1,15)+ice_vol(1,15), $ por_melted(1,15) $ z_water_table(1), z_top(1,nz) write(6,*) i_timestep, t_now, z_top(5,15), $ fluid_vol(5,15), solid_vol(5,15) if(pw_conc(22,2,i_Sal) .GT. 40.) then write(6,*) "stop the press", i_timestep stop endif c if(myid .EQ. Master) then c write(6,"(a6,2i12,f12.2)") "tstep", i_timestep, c $ nt_cdf-mod(i_timestep,nt_cdf), t_now c endif #endif #ifdef Initial_CDF if(i_timestep .EQ. i_timestep_init + 100) then itag = Report_Stdout call report_stdout(fluid_vol, solid_vol, air_vol, grid, $ pw_conc, pw_inv, sl_inv, bb_inv, $ lithosphere, $ x_global, z_seafloor_global, $ sea_level, z_water_table, iz_water_table, $ ocean_oxic_state, ocean_temperature_offset, $ air_temp_sea_level, $ rho, molwt, $ temperature, $ field, diagnostic_1d, $ dt, t_now, nz, $ myid, numprocs, itag, i_shifts) itag = t_now call write_netcdf(itag, $ grid, volume, x_global, dx_global, dim_scale, $ pw_conc, sl_frac, bb_conc, temperature, lithosphere, $ field, diagnostic_1d, $ diagnostic_ds1, diagnostic_ds2, $ sea_level, rho, molwt, dt, nz, myid, numprocs) endif #endif #ifdef Initial_Condition_Tweak if(i_timestep .EQ. 2) then do iz = 1, nz do i_sl = i_first_size_class, i_Pelagic sl_frac(1:NX,iz,i_sl) = $ deposit_frac(1:NX,i_sl) enddo enddo c pw_conc(:,:,i_CH4) = ch4_eq(:,:) c#define Initial_Condition_Tweak_POC #ifdef Initial_Condition_Tweak_POC do iz = 1, nz sl_frac(1:NX,iz,i_Bio_POC) = $ rain_frac(1:NX,i_Bio_POC) $ * exp( ( z_top(ix,iz) - z_top(ix,nz) ) ! say -3000 - - 2000 = -1000 $ / 500.d0 $ ) sl_frac(1:NX,iz,i_POC) = $ rain_frac(1:NX,i_POC) $ * exp( ( z_top(ix,iz) - z_top(ix,nz) ) $ / 2000.d0 $ ) sl_frac(1:NX,iz,i_POH) = $ sl_frac(1:NX,iz,i_POC) $ * H_to_C_Oxic sl_frac(1:NX,iz,i_POO) = $ sl_frac(1:NX,iz,i_POC) $ * O_to_C_Oxic enddo #endif call update_pw_inv(pw_conc,pw_inv,fluid_vol,nz) call update_sl_inv(sl_frac,sl_inv,solid_vol, $ molwt,rho,nz) call update_sl_conc(sl_inv,sl_conc,sl_frac,solid_vol, $ molwt,rho,nz) c itag = 1 c call write_netcdf(itag, c $ grid, volume, x_global, dx_global, dim_scale, c $ pw_conc, sl_frac, bb_conc, temperature, lithosphere, c $ field, diagnostic_1d, c $ diagnostic_ds1, diagnostic_ds2, c $ sea_level, rho, molwt, dt, nz, myid, numprocs) endif #endif c write report to stdout itag = Report_Skip if(mod(t_now +dt , dt_cdf) .LT. dt) then ! itll cross boundary on next time step itag = t_now + dt / 2.d0 if( itag .GT. 9 ) then itag = 10 * ((itag+5)/10) endif c if( MOD( itag,10 ) .EQ. 9 ) then c itag = itag + 1 c endif c if( MOD( itag,10 ) .EQ. 1 ) then c itag = itag - 1 c endif else if(mod(t_now + dt, dt_out) .LT. dt) then itag = Report_Start_Clock endif if(mod(t_now, dt_out) .LT. dt) then itag = Report_Stdout endif endif c itag = Report_Stdout call report_stdout(fluid_vol, solid_vol, air_vol, grid, $ pw_conc, pw_inv, sl_inv, bb_inv, $ lithosphere, $ x_global, z_seafloor_global, $ sea_level, z_water_table, iz_water_table, $ ocean_oxic_state, ocean_temperature_offset, $ air_temp_sea_level, $ rho, molwt, $ temperature, $ field, diagnostic_1d, $ dt, t_now, nz, $ myid, numprocs, itag, i_shifts) c write to netcdf dump if(mod(t_now+dt, dt_cdf) .LT. dt) then ! itll cross boundary on next time step call write_netcdf(itag, $ grid, volume, x_global, dx_global, dim_scale, $ pw_conc, sl_frac, bb_conc, temperature, lithosphere, $ field, diagnostic_1d, $ diagnostic_ds1, diagnostic_ds2, $ sea_level, rho, molwt, dt, nz, myid, numprocs) endif call find_timedep_drivers(t_now, dt_run, $ sea_level, surface_conc, $ ocean_oxic_state, ocean_temperature_offset, $ air_temp_sea_level) c top boundary condition call find_surface_temp(z_top(:,nz), $ sea_level, ocean_temperature_offset, $ air_temp_sea_level, $ surface_temp, surface_conc, nz) do ix=0,NX pw_conc(ix,nz+1,1:N_PW) = surface_conc(ix,1:N_PW) temperature(ix,nz+1,degC) = surface_temp(ix) enddo ! ix call find_thermal_properties(z_center, dz, $ volume, $ heat_capacity, therm_diffusivity, $ sl_inv, bb_inv, $ diffusivity, molwt, rho, $ dt, nz) call find_freeze_temperatures(z_top, z_center, dz, $ pw_conc, temperature, $ p_fluid, p_gas, T_Ice, dT_Ice, $ dT_CH4_hydrate, T3P_CH4_hydrate, $ CH4_eq, CH4_eq_T3P, CH4_hydrate_frac, $ dT_CO2_hydrate, CO2_eq, CO2_hydrate_frac, $ CO2_liq_drho, $ myid, $ nz) #ifdef SquishItNow call drain_sediment_column(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid,por_mobile, $ por_drained, por_dev, $ liquid_saturation, $ z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, $ nz, myid, numprocs) call update_pw_inv(pw_conc,pw_inv,fluid_vol,nz) #endif #ifdef MPI call MPI_Gather(z_top(1:NX,nz),NX,MPI_DOUBLE_PRECISION, $ z_seafloor_global(1:NX_Global),NX,MPI_DOUBLE_PRECISION, $ Master, MPI_COMM_WORLD,ierr) call MPI_Bcast(z_seafloor_global(1:NX_Global), NX_Global, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) #else z_seafloor_global(1:NX) = z_top(1:NX,nz) #endif #ifdef Sediment_Transport call find_POC_rain_fraction(ocean_oxic_state, $ z_seafloor_global, sea_level, $ rain_frac) c if(myid .EQ. 0) then c write(6,*) "going into sediment transport", myid, t_now c endif call flush(6) call sediment_transport(sea_level, $ z_seafloor_global, dz_seafloor_global, $ x_global, dx_global, $ sedtrans_velocity, $ rain_frac, $ rho, por_0, $ particle_radius, tau_critical, sinking_rate, ! grid of size class $ diagnostic_ds2, $ sed_accum_rate, ! ix only $ tau_scour, $ seafloor_slope, seafloor_slope_2nd, $ sed_redeposit_frac, z_erosion_target, $ suspended_flux_tot, resuspended_flux_tot, $ deposit_flux_tot, redeposit_flux_tot, $ sl_frac, por_melted, $ nz, myid, numprocs) c calculates rates in per year to be scaled by dt to be determined in advect #endif cccccccccccccccccccccccccc c Flow in Time Loop cccccccccccccccccccccccccc z_canyon(1:NX) = MIN(sea_level,z_top(1:NX,nz)) call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) #ifdef Hydrology call evolve_canyon(dx, z_canyon, z_top, z_center, $ seafloor_slope, temperature, temperature_canyon, $ dt, nz) #endif dt_inner = dt / 10.d0 do i_step = 1, 10 call deposit_sediment(dx, dz, $ volume, volume_flux, fluid_vol_flux, $ por_0, por_melted, $ rho, molwt, particle_radius, $ sl_inv, sl_conc, $ pw_inv, pw_conc, bb_inv, bb_conc, $ CH4_hydrate_frac, $ grain_size, $ sed_accum_rate, iz_water_table, $ deposit_flux, redeposit_flux, $ poc_rain_flux, poc_bio_rain_flux, $ dt_inner, nz) #ifdef Booger #ifdef MPI if(myid .EQ. 2) then c if(sed_accum_rate(7) .LT. 0.d0) then write(6,*) "from deposit_sediment",t_now, $ sed_accum_rate(7), $ deposit_flux(7,i_Aeolean) c endif endif #else c if(sed_accum_rate(27) .LT. 0.d0) then write(6,*) "from deposit_sediment",t_now, $ sed_accum_rate(27), $ deposit_flux(27,i_Aeolean) c endif #endif #endif c updates fluid_vol for sediment deposition and movement of cell boundaries c including darcy flow for fluid_vol. solute burial done in next call vertical_flow_implicit( $ z_top, z_center, dz, dx, sea_level, i_shifts, $ nz, dt_inner, iz_water_table, $ sl_inv, sl_frac, $ pw_inv, pw_conc, pw_adv, $ bb_conc, $ volume, $ por_0, beta, rho, dyn_visc, molwt, $ por_liquid, por_mobile, por_melted, $ por_drained, por_dev, $ liquid_saturation, $ particle_radius, grain_size, perm_0, $ perm, perm_lateral, perm_goosefac, perm_mdarcys, $ p_excess, p_supp, p_hydro, p_fluid, p_gas, $ p_head_canyon, p_head, $ fluid_buoy, stress_litho, $ temperature, temperature_canyon, $ heat_adv_flux, $ w_darcy, w_hydro, w_bur, w_seafloor, v, $ hydro_runoff, hydro_recharge, $ fluid_vol_flux, w_d_press_potential, w_n_iters, $ fluid_delta_z, fluid_delta_z_canyon, $ z_canyon, $ z_water_table, $ z_water_table_equiv, $ z_water_table_equiv_canyon, $ z_ice_sheet_base, $ dpsupp_dpor $ ) call update_pw_conc(pw_conc,pw_inv,fluid_vol, $ nz,myid,numprocs) #ifdef HorizontalFlow call horizontal_fluid_flow( dt_inner, $ u, dx, dz, $ fluid_vol, tot_vol, por_liquid, $ pw_conc, pw_inv, temperature, $ p_head, p_excess, perm_lateral, dyn_visc, $ liquid_saturation, heat_capacity, $ myid, numprocs, nz ) #endif #ifdef Clusterfuck #ifdef MPI if( myid .EQ. 0 ) then write(6,'(i3, i5,6F12.4)') myid, i_step, $ dz(1:6,nz) call flush(6) endif #else write(6,'(i5,6F12.4)') i_step, dz(1:6,nz) call flush(6) #endif #endif call update_pw_conc(pw_conc,pw_inv,fluid_vol, $ nz,myid,numprocs) call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) c#define Flow_Iter_Stdout #ifdef Flow_Iter_Stdout c if( ice_vol(1,nz) .GT. 0.d0 ) then write(6,"(a6, i4,13g12.4)") "shit", $ i_step, $ volume(1,15,:) c $ sea_level, c $ z_water_table(1:3), c $ ice_frac(1:3,15) c $ fluid_delta_z(4,11), c $ pw_conc(4,11,i_Sal), c $ temperature(4,11,1), c $ p_excess(1:3,10), c $ p_head(1:3,10) c $ temperature(1,nz,1), c $ t_ice(1,nz), c $ dt_ice(1,nz), c $ pw_conc(1,nz,i_Sal), c $ ice_vol(1:2,nz) c $ u(1:3,1) c endif #endif enddo CH4_adv_flux(:,:) = pw_adv(:,:,i_CH4) #ifdef MPIStdOut write(6,*) "update_pw_conc 1840", myid call flush(6) #endif cccccccccccccccccccccccccccccccccccccccccccc c Individual Scenario Stuff in Time Loop cccccccccccccccccccccccccccccccccccccccccccc #ifdef Continental_Margin if(MOD(i_timestep,nt_tectonics) .EQ. 0) then c write(6,*) "I am", myid, t_now, i_timestep c if( i_timestep .EQ. 24986) then c write(6,*) "I am", myid, t_now, i_timestep c endif #ifdef Accrete c do ix = 1, 10 call sediment_smashup(lithosphere, rho, $ z_top, z_seafloor_global, $ ocean_frac_global, sedcol_youngs_mod_global, $ column_height, freeboard_eq, $ dt, nz, $ myid, numprocs, $ sedcol_youngs_mod, sedcol_u, $ d_sedcol_u_dx, sedcol_thickening, $ sedcol_conv_dieqdt, $ x, dx, x_global, dx_global) c enddo c returns an altered x grid and updates the lithosphere info: the c grid moves and carries with it the sediment, but it is changing c positions relative to the crust. #endif #ifdef Wedge_Squash do ix = 1, NX if( x(ix) .GT. Plate_Xb ) then do iz = 1, nz pw_conc(ix,iz,:) = pw_conc(ix,nz+1,:) enddo sl_frac(ix,:,i_Bio_POC:i_Ice) = 0.d0 endif enddo #endif #ifdef Wedge_Shift_Grid if(x_global(2) .LT. 0.d0 $ .OR. $ z_seafloor_global(2) .LT. 0.d0 $ ) then c if(myid .EQ. numprocs-1) then c write(6,*) "shifting grid" c $ solid_vol(NX-1:NX,nz) c endif i_shifts = i_shifts + 1 call left_shift_grid( $ grid, volume, $ pw_conc, sl_frac, bb_conc, temperature, lithosphere, $ field, diagnostic_1d, $ diagnostic_ds1, diagnostic_ds2, $ x_global, dx_global, $ z_seafloor_global, ocean_frac_global, $ sedcol_youngs_mod_global, $ nz, myid, numprocs) call update_pw_inv(pw_conc,pw_inv,fluid_vol,nz) call update_sl_inv(sl_frac,sl_inv,solid_vol, $ molwt,rho,nz) call update_sl_conc(sl_inv,sl_conc,sl_frac,solid_vol, $ molwt,rho,nz) call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid,por_mobile, $ por_drained, por_dev, $ liquid_saturation, $ z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) if( myid .EQ. numprocs-1 ) then fluid_vol(NX,:) = tot_vol(NX,:) $ * por_drained(NX,:) solid_vol(NX,:) = tot_vol(NX,:) $ * (1-por_drained(NX,:)) endif call find_p_excess(dz, fluid_vol, $ temperature, temperature_canyon, $ pw_conc, por_0, beta, $ p_excess, p_supp, p_hydro, p_fluid, p_gas, $ por_drained, dpsupp_dpor, $ fluid_buoy, stress_litho, por_melted, $ z_top, z_center, sea_level, z_water_table, z_canyon, $ fluid_delta_z, z_water_table_equiv, p_head, $ fluid_delta_z_canyon, z_water_table_equiv_canyon, $ p_head_canyon, $ rho, $ nz, myid, numprocs) call update_bb_inv(bb_conc,bb_inv, $ p_gas,fluid_vol,temperature, $ rho,CO2_liq_drho,nz) call compute_column_mh(lithosphere, $ volume, rho, dx, z_top, sea_level, z_water_table, $ nz, $ column_mass, column_height, $ sedcol_mass, sedcol_height) endif #endif #ifdef Cooling_Ocean_Crust #ifdef Aging_Ocean_Crust lithosphere(:,OceanCrust,il_Age) = $ lithosphere(:,OceanCrust,il_Age) $ + dt * T_Scale * Aging_Ocean_Crust #endif #ifdef Wedge lithosphere(:,OceanCrust,il_Age) = $ MAX( ( Plate_Width - x(:) ) $ / Plate_Velocity, $ Ocean_Crust_Min_Age $ ) #endif call cooling_ocean_crust( $ rho, $ temperature, $ lithosphere, $ dt, crust_therm_dieqdt, heat_geotherm_flux) #endif c Cooling_Ocean_Crust #ifdef Isostacy call compute_column_mh(lithosphere, $ volume, rho, dx, z_top, sea_level, z_water_table, $ nz, $ column_mass, column_height, $ sedcol_mass, sedcol_height) #ifdef Sinking_Crust call sinking_crust(t_now, dt_run, $ lithosphere(:,OceanCrust,il_Ocean_Fraction), $ plate_pulldown) #endif #ifdef Plate_Torque call plate_torque( $ x_global, z_seafloor_global, ocean_frac_global, $ plate_pulldown, plate_x_scale, $ myid, numprocs) #endif #ifdef Ice_Sheet call ice_sheet(ice_sheet_vol, tot_vol, $ dz_ice_sheet, ice_sheet_active, $ ice_sheet_u, ice_sheet_vol_flow, $ ice_sheet_accum, ice_sheet_ablate, $ z_ice_sheet_base, ice_sheet_base_dt, $ dx, dz, z_top, $ rho, molwt, dt_ice, $ sea_level, dt, myid, numprocs, nz) #endif< tau_isostacy = TAU_ISOSTACY * dt * nt_tectonics call isostacy(z_top, x, dx, $ x_global, $ lithosphere, volume, rho, $ dt, tau_isostacy, sea_level, $ plate_pulldown, plate_x_scale, $ isostat_eq, $ column_mass, column_height, freeboard_eq, $ isostat_dzdt, $ nz, myid,numprocs) #endif /* Isostacy */ endif ! MOD(i_timestep,nt_tectonics) = 0 #endif /* Continental_Margin */ #ifdef NonDimensional z_top(:,0) = -1000. #endif call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid,por_mobile, $ por_drained, por_dev, $ liquid_saturation, $ z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) #ifdef Blake_Ridge_Accum call blake_ridge_accum(z_top, dx, $ t_now, myid, $ sed_accum_rate) #endif #ifdef NonDimensional z_top(:,0) = - i_timestep * dt $ / dim_scale(TimeScale) $ * dim_scale(DepthScale) $ + 1000. #endif c if(myid .EQ. 1) then c write(6,*) "I am", myid, deposit_flux(:,1) c endif c do ix=1,NX c if(solid_vol(ix,nz) .LT. 0) then c write(6,*) "negative volume" c endif c enddo ccccccccccccccccccccccccccccccccccccccccccc c Tracer Sources and Sinks in Time Loop ccccccccccccccccccccccccccccccccccccccccccc #define Aging_Sediment #ifdef Aging_Sediment sl_inv(:,:,i_Age) = sl_inv(:,:,i_Age) ! units of year*gram $ + solid_vol(:,:) $ * rho(i_Sediment) $ * dt * T_Scale ! year m3 leaves units of years in sl_conc call update_sl_conc(sl_inv,sl_conc,sl_frac,solid_vol, $ molwt,rho,nz) #endif #ifdef Chem_Reactions #ifdef Debug_PW_Conserved call sum_diag_2d(pw_inv, pw_tot, N_PW, nz) write(6,*) "before org", pw_tot(i_DIC), $ pw_tot(i_DIC13) #endif c if(myid .EQ. 2) then c write(6,*) "starting", i_timestep, myid, c $ sl_inv(:,15,i_Petro) c endif #ifdef Reaction_Resp call organic_reactions(pw_conc, pw_inv, $ sl_inv, sl_conc, sl_frac, $ resp, resp_doc, resp_petro, $ resp_k, resp_diss_k, $ resp_h2c, resp_o2c, resp_alpha_so4,resp_alpha_ch4, $ therm_k, therm_h, therm_o, $ petro_src,CH4_src_petro, $ CH4_sink_aom, $ CH4_src_resp, CH4_src_therm, $ DOC_src_therm, DIC_src_therm, $ POC_sink_therm, POH_sink_therm, POO_sink_therm, $ temperature, ice_frac, x, $ resp_rc, molwt, alpha, $ dt, nz) call update_pw_conc(pw_conc,pw_inv,fluid_vol, $ nz,myid,numprocs) call update_sl_conc(sl_inv,sl_conc,sl_frac,solid_vol, $ molwt,rho,nz) #endif c if(myid .EQ. 2) then c write(6,*) "ending", i_timestep, myid, c $ sl_inv(:,15,i_Petro) c endif #ifdef MPIStdOut write(6,*) "organic_reactions 1840", myid call flush(6) #endif #ifdef Reaction_Clays call clay_reactions(sl_inv, fluid_vol, temperature, $ field, molwt, rho, dt, nz) #endif c if(i_timestep .GT. 21) then c write(6,*) "booger", i_timestep, pw_conc(9,15,4) c endif #ifdef Reaction_Rocks if(MOD(i_timestep,NT_Igneous) .EQ. 0) then call urey_reactions(fluid_vol, $ pw_conc, pw_inv, sl_conc, sl_inv, temperature, $ p_hydro, pH, hplus, CO3, CO2, HCO3, $ K1, K2, Ksp_CaCO3, $ igneous_k, rxn_igneous, $ omega_caco3, omega_igneous, csat_igneous, $ caco3_pcp, igneous_diss, $ dt*NT_Igneous, nz) call update_pw_conc(pw_conc,pw_inv,fluid_vol, $ nz,myid,numprocs) call update_sl_conc(sl_inv,sl_conc,sl_frac,solid_vol, $ molwt,rho,nz) endif #endif #ifdef Debug_PW_Conserved call sum_diag_2d(pw_inv, pw_tot, N_PW, nz) write(6,*) "after rxns", pw_tot(i_DIC), $ pw_tot(i_DIC13) #endif call find_freeze_temperatures(z_top, z_center, dz, $ pw_conc, temperature, $ p_fluid, p_gas, T_Ice, dT_Ice, $ dT_CH4_Hydrate, T3P_CH4_hydrate, $ CH4_eq, CH4_eq_T3P, CH4_hydrate_frac, $ dT_CO2_hydrate, CO2_eq, CO2_hydrate_frac, $ CO2_liq_drho, $ myid, $ nz) #ifdef Reaction_Ice_Freeze call ice_freeze_reaction(volume, $ sl_inv, pw_conc, pw_inv, temperature, heat_capacity, $ dT_Ice, ice_freeze, ice_frac, heat_src_ice, $ rho, molwt, $ dt, nz) #endif #ifdef Heat_Sources call heat_sources(dz, tot_vol, temperature, $ heat_src_hydrate, heat_src_ice, $ heat_capacity, $ heat_geotherm_flux, $ dt, nz) temperature(:,:,Kelvins) = temperature(:,:,degC) $ + 273.15d0 #endif #ifdef Reaction_CH4_Phases c do ix = 1, NX c do iz = 1, nz c if(sl_inv(ix,iz,i_Bio_POC) .LT. 0) then c write(6,*) "negative POC ", ix,iz c call flush(6) c stop c endif c enddo c enddo call three_phase_reactions(fluid_vol, $ sl_inv(:,:,i_Hydrate), $ pw_conc(:,:,i_CH4), $ pw_inv(:,:,i_CH4), $ bb_inv(:,:,i_CH4), $ dT_CH4_hydrate, CH4_hydrate_frac, $ heat_src_hydrate, CH4_exsolve, $ hydrate_freeze, CH4_eq, $ rho, molwt(i_CH4), molwt(i_Hydrate), $ 438.54d0, ! latent heat of fusion for hydrate $ N_CH4_Isotopes, $ dt, nz) call update_bb_conc(bb_conc,bb_inv, $ p_gas,fluid_vol,temperature, $ rho,CO2_liq_drho,nz) #ifdef Bubble_Crit_Vanish call bubble_crit_vanish(z_top,perm, $ bb_conc, bb_inv, pw_inv, pw_conc, ch4_eq, $ bubble_ch4_excess, bubble_ch4_redissolve, $ CH4_bubble_flux, $ dt,nz) #endif #ifdef Bubble_Flow call bubbles_flow(dx, dz, z_top, $ bb_conc, bb_inv, temperature, $ gas_visc, dyn_visc, perm, perm_lateral, $ p_excess, p_gas, $ bb_u, bb_w, bb_buoy, $ CH4_bubble_flux, $ nz, dt) #endif #endif /* Reaction_CH4_Phase */ #ifdef Rising_Black_Gold call black_gold_risin(sl_inv(:,:,i_Petro), $ dz, nz, dt) #endif #ifdef Reaction_CO2_Liquid do ix=1,NX do iz=1,nz if(CO2(ix,iz) .GT. CO2_eq(ix,iz)) then dummy = (CO2(ix,iz) - CO2_eq(ix,iz)) ! mol/m3 $ * Reaction_CO2_Liquid $ * fluid_vol(ix,iz) ! mol flux pw_inv(ix,iz,i_DIC) = pw_inv(ix,iz,i_DIC) $ - dummy bb_inv(ix,iz,i_CO2) = bb_inv(ix,iz,i_CO2) $ + dummy endif enddo enddo #endif #ifdef Reaction_CO2_Phases call three_phase_reactions(fluid_vol, $ sl_inv(:,:,i_Hydrate_CO2), $ field(:,:,id2_CO2), $ pw_inv(:,:,i_DIC), $ bb_inv(:,:,id2_CO2), $ dT_CO2_hyrate, heat_src_CO2_hydrate, CO2_exsolve, $ hydrate_CO2_freeze, CO2_eq, $ rho, molwt(i_CO2), molwt(i_Hydrate_CO2), $ 438.54d0, ! latent heat of fusion for hydrate $ 1, $ dt, nz) #endif call update_pw_conc(pw_conc,pw_inv,fluid_vol, $ nz,myid,numprocs) call update_sl_conc(sl_inv,sl_conc,sl_frac, solid_vol, $ molwt,rho,nz) call update_bb_conc(bb_conc,bb_inv, $ p_gas,fluid_vol,temperature, $ rho,CO2_liq_drho,nz) temperature(:,:,Kelvins) = temperature(:,:,degC) $ + 273.15d0 #endif /* Chem_Reactions */ #ifdef MPIStdOut write(6,*) "Chem_Reactions 1990", myid call flush(6) #endif #ifdef Debug_PW_Conserved call sum_diag_2d(pw_inv, pw_tot, N_PW, nz) write(6,*) "before diffusion", pw_tot(i_DIC), $ pw_tot(i_DIC13) #endif #ifdef Vertical_Diffusion if(mod(i_timestep,nt_diffuse) .EQ. 0) then call diffuse_vertical(dx, z_center, dz, $ fluid_vol, ice_vol, iz_water_table, $ por_liquid, therm_diffusivity, heat_capacity, $ diffusivity, $ pw_conc, temperature, $ pw_diff, heat_diff_flux, $ dt * nt_diffuse * T_Scale_Diff, $ nz) ch4_diff_flux(1:NX,1:nz) = pw_diff(1:NX,1:nz,i_CH4) $ / nt_diffuse ! now in moles per timestep, same as the others call update_pw_inv(pw_conc,pw_inv,fluid_vol,nz) endif #ifdef MPIStdOut write(6,*) "diffuse_vertical 2014", myid call flush(6) #endif #endif #ifdef Debug_PW_Conserved call sum_diag_2d(pw_inv, pw_tot, N_PW, nz) write(6,*) " after diffusion", pw_tot(i_DIC), $ pw_tot(i_DIC13) #endif #ifdef Wrap_Each_Timestep /* in main */ call wrap_ghosts(z_top,myid,numprocs,NZ_Max) c call wrap_ghosts(dz,myid,numprocs,NZ_Max) /* done in horizontal fluid flow */ c call boundary_wrap_ghosts(p_excess,myid,numprocs,NZ_Max) /* horizontal fluid flow */ c call wrap_ghosts(u,myid,numprocs,NZ_Max) c do i_pw=1,N_PW c call boundary_wrap_ghosts(pw_conc(:,:,i_pw), c $ myid,numprocs,NZ_Max) c enddo c call boundary_wrap_ghosts(sl_conc(:,:,i_Petro), c $ myid,numprocs,NZ_Max) call boundary_wrap_ghosts(temperature,myid,numprocs,NZ_Max) c call boundary_wrap_ghosts(perm_lateral,myid,numprocs,NZ_Max) call wrap_ghosts(por_melted,myid,numprocs,NZ_Max) call boundary_wrap_ghosts(heat_capacity,myid,numprocs,NZ_Max) #endif #ifdef MPIStdOut write(6,*) "end of time loop 2033", myid call flush(6) #endif #ifdef ClusterFuck c if( ice_vol(1,nz) .GT. 0.d0 ) then write(6,"(a6, i8,13g12.4)") "hor", $ i_timestep, $ sea_level, $ z_water_table(1), $ dt_ice(1,nz-1:nz), $ pw_conc(1,nz-1:nz,i_Sal), $ ice_frac(1,nz-1:nz) c $ p_excess(1:3,1), c $ p_head(1:3,1), c $ u(1:3,1) c endif #endif if( t_now .LT. dt_run) then goto 10 endif cccccccccccccccccccccc c End of Time Loop cccccccccccccccccccccc if(myid .EQ. Master) then write(6,*) "finishing normally" endif #ifdef MPI call MPI_Finalize(ierr) #endif end subroutine write_netcdf(itag, $ grid, volume, x_global, dx_global, dim_scale, $ pw_conc, sl_frac, bb_conc, temperature, lithosphere, $ field, diagnostic_1d, $ diagnostic_ds1, diagnostic_ds2, $ sea_level, rho, molwt, $ dt, nz, myid, numprocs) implicit none #ifdef MPI include 'mpif.h' #endif #include integer itag, ipos, idigit double precision, dimension(0:NX+1, $ 0:NZ_Max+1,N_Grids) :: $ grid double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume double precision, dimension(0:NX_Global+1) :: $ x_global, dx_global double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_frac double precision, dimension(0:NX+1,0:NZ_Max+1,N_Bubble_Types) :: $ bb_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,N_Lith_Slabs,N_Lith_Vars) :: $ lithosphere double precision, dimension(0:NX+1,0:NZ_Max+1, N_Diags_2d) :: $ field double precision, dimension(0:NX+1,N_Diags_1d) :: $ diagnostic_1d double precision, dimension(N_Size_Classes, $ N_Diags_DS1) :: $ diagnostic_ds1 double precision, dimension(0:NX+1, $ N_SL, 2, $ N_Diags_DS2) :: $ diagnostic_ds2 double precision :: molwt(N_SL),rho(N_Rho) integer myid, numprocs, ierr, nz double precision sea_level, dt c local variables real, dimension(NX,NZ_Max) :: dummy real, dimension(N_Size_Classes) :: dummy_ds1 real, dimension(NX,N_Size_Classes) :: dummy_ds2 integer, dimension(2) :: start, count, lith_count, $ dims, lith_dims character*25 filename integer i_pw, i_sl, i_bb, i_vol, i_d, i_b, ntmp, i_r, $ idfile, $ iddX, iddZ, iddr, iddc, iddl, $ idvx,idvdx,idvz_top,idvz_center,idvdz, idvsealev,rcode, idvr, $ idvpw(N_PW), idvsl(N_SL), idvbb(N_Bubble_Types), $ idvvol(N_Vols), $ idvtemp, $ idvlithh,idvlithrho, idvlithof, idvlithage, $ idvdic13,idvpohc,idvpooc, $ idvc13h4,idvcdh3,idvI129age,idvsedage,idvphi, idvdzdt, $ idvz_canyon, idvw0a, $ idvn2(N_Diags_2d), idvn1(N_Diags_1d), $ idvnds1(N_Diags_DS1), $ idvnds2(N_Diags_DS2), idvnds2c(N_Diags_DS2) integer ix, iz double precision dim_scale(NDimScales) real, dimension(NX_Global,NZ_Max) :: dummy_global integer i_allocated character*20 name_1d(N_Diags_1d), name_2d(N_Diags_2d), $ name_bb(N_Bubble_Types), name_ds1(N_Diags_DS1), $ name_ds2(N_Diags_DS2), name_ds2c(N_Diags_DS2), $ name_pw(N_PW), name_sl(N_SL), name_vol(N_Vols) save data i_allocated /0/ if(nz .EQ. 0) then return endif if(i_allocated .EQ. 0) then i_allocated = 1 name_vol = "" name_vol(ivol_fluid) = "fluid_vol" name_vol(ivol_solid) = "solid_vol" name_vol(ivol_air) = "air_vol" name_vol(ivol_hydrate) = "hydrate_vol" name_vol(ivol_bubble) = "bubble_vol" name_vol(ivol_ice) = "ice_vol" name_vol(ivol_hydrate_CO2) = "hydrate_co2_vol" name_vol(ivol_petro) = "oil_vol" name_vol(ivol_ice_sheet) = "ice_sheet_vol" name_vol(ivol_tot) = "tot_vol" name_bb = "" name_bb(i_CH4) = "bubbles" #ifdef Write_Restartable_CDF name_bb(i_C13H4) = "bubbles_C13H4" name_bb(i_CDH3) = "bubbles_CDH3" name_bb(i_CO2) = "bubbles_CO2" #endif name_pw = "" name_pw(i_CH4) = "CH4" #ifdef Write_Restartable_CDF name_pw(i_C13H4) = "C13H4" name_pw(i_CDH3) = "CDH3" #endif name_pw(i_DIC) = "DIC" #ifdef Write_Restartable_CDF name_pw(i_DIC13) = "DIC13" #endif name_pw(i_Alk) = "Alk" name_pw(i_SO4) = "SO4" name_pw(i_Sal) = "Sal" name_pw(i_Ca) = "Ca" name_pw(i_DOC) = "DOC" name_pw(i_I129) = "I129" name_pw(i_ITot) = "ITot" #ifdef i_Delta18O #ifdef Write_Restartable_CDF name_pw(i_Delta18O) = "Delta18O" #endif #endif name_sl = "" name_sl(i_Bio_POC) = "bio_POC" #ifdef Write_Restartable_CDF name_sl(i_POC) = "POC" #endif name_sl(i_POH) = "POH" name_sl(i_POO) = "POO" name_sl(i_Hydrate) = "hydrate" #ifdef Write_Restartable_CDF name_sl(i_Hydrate_13) = "hydrate_13" name_sl(i_Hydrate_d) = "hydrate_d" name_sl(i_Hydrate_CO2) = "hydrate_CO2" #endif name_sl(i_Petro) = "Petro" name_sl(i_CaCO3) = "CaCO3" name_sl(i_Montmorillonite) = "Montmorillonite" name_sl(i_Illite) = "Illite" name_sl(i_Quartz) = "Quartz" name_sl(i_Ice) = "Ice" name_sl(i_Age) = "Age" #ifdef Write_Restartable_CDF do i_sl = i_first_size_class, i_last_size_class filename = "Sizexx" ntmp = i_sl + 1 - i_first_size_class do ipos = 6, 5, -1 idigit = mod(ntmp,10) filename(ipos:ipos) = char(ichar('0') + idigit) ntmp = ntmp / 10 enddo name_sl(i_sl) = filename enddo name_sl(i_Pelagic) = "Pelagic" #endif c#ifndef Convert_N_SL name_sl(i_Aeolean) = "Aeolean" c#endif name_2d = "" name_2d(id2_CH4_src_resp) = "CH4_src_resp" name_2d(id2_CH4_src_therm) = "CH4_src_therm" name_2d(id2_DOC_src_therm) = "DOC_src_therm" name_2d(id2_DIC_src_therm) = "DIC_src_therm" name_2d(id2_POC_sink_therm) = "POC_sink_therm" name_2d(id2_POH_sink_therm) = "POH_sink_therm" name_2d(id2_POO_sink_therm) = "POO_sink_therm" name_2d(id2_CH4_sink_aom) = "CH4_sink_aom" name_2d(id2_resp) = "resp" name_2d(id2_resp_DOC) = "resp_DOC" name_2d(id2_resp_petro) = "resp_petro" name_2d(id2_therm_K) = "therm_K" name_2d(id2_therm_H) = "therm_H" name_2d(id2_therm_O) = "therm_O" name_2d(id2_petro_src) = "petro_src" name_2d(id2_CH4_src_petro) = "CH4_src_petro" name_2d(id2_caco3_pcp) = "caco3_pcp" name_2d(id2_igneous_diss) = "igneous_diss" name_2d(id2_clay_dewater) = "clay_dewater" name_2d(id2_CH4_exsolve) = "CH4_exsolve" name_2d(id2_bubble_ch4_excess) = "bubble_ch4_excess" name_2d(id2_bubble_ch4_redissolve) = "bubble_ch4_rediss" name_2d(id2_CH4_exsolve) = "CH4_exsolve" name_2d(id2_hydrate_freeze) = "hydrate_freeze" name_2d(id2_ice_freeze) = "ice_freeze" name_2d(id2_CH4_bubble_flux) = "CH4_bubble_flux" name_2d(id2_CH4_diff_flux) = "CH4_diff_flux" name_2d(id2_CH4_adv_flux) = "CH4_adv_flux" name_2d(id2_heat_src_hydrate) = "heat_src_hydrate" name_2d(id2_heat_src_ice) = "heat_src_ice" name_2d(id2_w) = "w_darcy" name_2d(id2_w_bur) = "w_bur" name_2d(id2_w_seafloor) = "w_seafloor" name_2d(id2_w_jitter) = "w_jitter" name_2d(id2_w_unlimited) = "w_unlimited" name_2d(id2_w_d_press_potential) = "w_d_press_potential" name_2d(id2_w_hydro) = "w_hydro" name_2d(id2_therm_diffusivity) = "therm_diffusivity" name_2d(id2_u) = "u" name_2d(id2_v) = "v" name_2d(id2_heat_diff_flux) = "heat_diff_flux" name_2d(id2_heat_adv_flux) = "heat_adv_flux" name_2d(id2_resp_k) = "resp_k" name_2d(id2_resp_diss_k) = "resp_diss_k" name_2d(id2_resp_h2c) = "resp_h2c" name_2d(id2_resp_o2c) = "resp_o2c" name_2d(id2_resp_alpha_so4) = "resp_alpha_so4" name_2d(id2_resp_alpha_ch4) = "resp_alpha_ch4" name_2d(id2_pH) = "pH" name_2d(id2_csat_igneous) = "csat_igneous" name_2d(id2_igneous_k) = "igneous_k" name_2d(id2_rxn_igneous) = "rxn_igneous" name_2d(id2_omega_CaCO3) = "omega_CaCO3" name_2d(id2_dT_CH4_hydrate) = "dT_CH4_Hydrate" name_2d(id2_T3P_CH4_hydrate) = "T3P_CH4_Hydrate" name_2d(id2_CH4_eq_T3P) = "CH4_eq_T3P" name_2d(id2_dT_CO2_hydrate) = "dT_CO2_Hydrate" name_2d(id2_CO2_liq_drho) = "CO2_liq_drho" name_2d(id2_CO2) = "CO2" name_2d(id2_CO3) = "CO3" name_2d(id2_HCO3) = "HCO3" name_2d(id2_K1) = "K1" name_2d(id2_K2) = "K2" name_2d(id2_Ksp_CaCO3) = "Ksp_CaCO3" name_2d(id2_CH4_eq) = "CH4_eq" name_2d(id2_CO2_eq) = "CO2_eq" name_2d(id2_por_melted) = "por_melted" name_2d(id2_por_liquid) = "por_liquid" name_2d(id2_por_mobile) = "por_mobile" name_2d(id2_por_drained) = "por_drained" name_2d(id2_por_dev) = "por_dev" name_2d(id2_sal_melted) = "sal_melted" name_2d(id2_liquid_saturation) = "liquid_saturation" name_2d(id2_stress_litho) = "stress_litho" name_2d(id2_P_hydro) = "p_hydro" name_2d(id2_perm) = "perm" name_2d(id2_perm_lateral) = "perm_lateral" name_2d(id2_perm_goosefac) = "perm_goosefac" name_2d(id2_perm_mdarcys) = "perm_mdarcys" name_2d(id2_P_excess) = "P_excess" name_2d(id2_P_supp) = "P_supp" name_2d(id2_fluid_delta_z) = "fluid_delta_z" name_2d(id2_z_water_table_equiv) = "z_water_table_equiv" name_2d(id2_P_head) = "p_head" name_2d(id2_fluid_delta_z_canyon) = "fluid_delta_z_canyon" name_2d(id2_z_water_table_equiv_canyon) = $ "z_water_table_equiv_canyon" name_2d(id2_P_head_canyon) = "p_head_canyon" name_2d(id2_grain_size) = "grain_size" name_2d(id2_fluid_vol_flux) = "fluid_vol_flux" name_2d(id2_CH4_hydrate_frac) = "hydrate_frac" name_2d(id2_T_Ice) = "T_Ice" name_2d(id2_dT_Ice) = "dT_Ice" name_2d(id2_ice_frac) = "ice_frac" name_2d(id2_ice_sheet_active) = "ice_sheet_active" name_1d = "" name_1d(id1_POC_rain_flux) = "POC_rain_flux" name_1d(id1_sed_accum_rate) = "sed_accum_rate" name_1d(id1_hydro_recharge) = "hydro_recharge" name_1d(id1_hydro_runoff) = "hydro_runoff" name_1d(id1_surface_temp) = "surface_temp" name_1d(id1_seafloor_slope) = "seafloor_slope" name_1d(id1_seafloor_slope_2nd) = "seafloor_slope_2nd" name_1d(id1_tau_scour) = "tau_scour" name_1d(id1_sed_redeposit_frac) = "sed_redeposit_frac" name_1d(id1_suspended_flux_tot) = "suspended_flux_tot" name_1d(id1_resuspended_flux_tot) = "resuspended_flux_tot" name_1d(id1_deposit_flux_tot) = "deposit_flux_tot" name_1d(id1_redeposit_flux_tot) = "redeposit_flux_tot" name_1d(id1_z_erosion_target) = "z_erosion_target" name_1d(id1_heat_geotherm_flux) = "heat_geotherm_flux" name_1d(id1_d_fluid_vol_dt) = "d_fluid_vol_dt" name_1d(id1_sedcol_youngs_mod) = "sedcol_youngs_mod" name_1d(id1_sedcol_u) = "sedcol_u" name_1d(id1_d_sedcol_u_dx) = "d_sedcol_u_dx" name_1d(id1_sedcol_thickening) = "sedcol_thickening" name_1d(id1_column_mass) = "column_mass" name_1d(id1_column_height) = "column_height" name_1d(id1_sedcol_mass) = "sedcol_mass" name_1d(id1_sedcol_height) = "sedcol_height" name_1d(id1_plate_pulldown) = "plate_pulldown" name_1d(id1_plate_x_scale) = "plate_x_scale" name_1d(id1_isostat_eq) = "isostat_eq" name_1d(id1_freeboard_eq) = "freeboard_eq" name_1d(id1_sedcol_conv_dieqdt) = "sedcol_conv_dieqdt" name_1d(id1_crust_therm_dieqdt) = "crust_therm_dieqdt" name_1d(id1_isostat_dzdt) = "isostat_dzdt" name_1d(id1_z_water_table) = "z_water_table" name_1d(id1_seafloor_slope_canyon) = "seafloor_slope_canyon" name_1d(id1_ice_sheet_u) = "ice_sheet_u" name_1d(id1_dz_ice_sheet) = "dz_ice_sheet" name_1d(id1_ice_sheet_vol_flow) = "ice_sheet_vol_flow" name_1d(id1_ice_sheet_accum) = "ice_sheet_accum" name_1d(id1_ice_sheet_ablate) = "ice_sheet_ablate" name_1d(id1_z_ice_sheet_base) = "z_ice_sheet_base" name_1d(id1_ice_sheet_base_dt) = "ice_sheet_base_dt" name_1d(id1_w_n_iters) = "w_n_iters" name_ds1 = "" name_ds1(ids1_tau_critical) = "tau_critical" name_ds1(ids1_sinking_rate) = "sinking_rate" name_ds2 = "" name_ds2(ids2_suspended) = "suspended_size" name_ds2(ids2_resuspended) = "resuspended_size" name_ds2(ids2_depositing) = "deposit_size" name_ds2(ids2_redepositing) = "redeposit_size" name_ds2(ids2_redeposit_org) = "redeposit_org_size" name_ds2(ids2_resuspended_org) = "resuspended_org_size" name_ds2c = "" name_ds2c(ids2_suspended) = "suspended_chem" name_ds2c(ids2_resuspended) = "resuspended_chem" name_ds2c(ids2_depositing) = "depositing_chem" name_ds2c(ids2_redepositing) = "redeposit_chem" endif #ifdef MPI c call MPI_Barrier(MPI_COMM_WORLD,ierr) #endif do ix = 1, NX do iz = 1, nz if( volume(ix,iz,ivol_fluid) .GT. 0.d0 ) then field(ix,iz,id2_sal_melted) = $ pw_conc(ix,iz,i_Sal) $ * volume(ix,iz,ivol_fluid) $ / ( volume(ix,iz,ivol_fluid) $ + volume(ix,iz,ivol_hydrate) ! m3 hydrate $ * rho(i_Hydrate) ! g hydrate $ / molwt(i_Hydrate) ! mol hydrate $ * ( molwt(i_Hydrate) - molwt(i_CH4) ) ! g water $ / rho(i_Seawater) ! vol seawater $ + volume(ix,iz,ivol_ice) ! m3 ice $ * rho(i_Ice) ! g ice $ / rho(i_Seawater) $ ) endif enddo enddo if(myid .EQ. Master) then filename = "year.000000000.cdf" ntmp = itag do ipos=14,6,-1 idigit = mod(ntmp,10) filename(ipos:ipos) = char(ichar('0') + idigit) ntmp = ntmp/10 enddo idfile = nccre(filename, NCCLOB, rcode) write(6,*) "writing ", filename iddX = ncddef(idFile,'X',NX_Global,rcode) iddZ = ncddef(idFile,'Y',nz,rcode) iddR = ncddef(idFile,'R',N_Size_Classes,rcode) iddC = ncddef(idFile,'C',N_SL_Conc,rcode) iddL = ncddef(idFile,'L',N_Lith_Slabs,rcode) dims(1) = 1 ! x dims(2) = 2 ! z idvx = ncvdef(idFile,'XC',NCFLOAT,1,dims,rcode) ! 1 idvdx = ncvdef(idFile,'DX',NCFLOAT,1,dims,rcode) ! 2 idvz_center = ncvdef(idFile,'ZC',NCFLOAT,2,dims,rcode) ! 3 idvz_top = ncvdef(idFile,'Z_top',NCFLOAT,2,dims,rcode) ! 4 idvdz = ncvdef(idFile,'dZ',NCFLOAT,2,dims,rcode) ! 5 idvz_canyon = ncvdef(idFile,'Z_canyon',NCFLOAT,1,dims,rcode) ! 6 idvsealev = ncvdef(idFile,'Sea_level',NCFLOAT,1,dims,rcode) ! 7 idvr = ncvdef(idFile,'R',NCFLOAT,1,3,rcode) ! 8 c#define Read_Old_File #ifdef Read_Old_File #define N_Netcdf_Grid_Vars 7 #else #define N_Netcdf_Grid_Vars 8 #endif c state variables do i_pw = 1, N_PW if(name_pw(i_pw) .NE. "") then idvpw(i_pw) = ncvdef(idFile,name_pw(i_pw), $ NCFLOAT,2,dims,rcode) ! idvpw(i_pw) = i_pw ! + N_Netcdf_Grid_Vars endif enddo do i_sl = 1, N_SL if(name_sl(i_sl) .NE. "") then idvsl(i_sl) = ncvdef(idFile,name_sl(i_sl), $ NCFLOAT,2,dims,rcode) ! idvsl(i_sl) = i_sl ! + N_PW ! + N_Netcdf_Grid_Vars endif enddo do i_b = 1, N_Bubble_Types if(name_bb(i_b) .NE. "") then idvbb(i_b) = ncvdef(idFile,name_bb(i_b), $ NCFLOAT,2,dims,rcode) ! idvsl(i_sl) = i_b ! + N_SL ! + N_PW ! + N_Netcdf_Grid_Vars endif enddo do i_vol = 1, N_Vols if(name_vol(i_vol) .NE. "") then idvvol(i_vol) = ncvdef(idFile,name_vol(i_vol), $ NCFLOAT,2,dims,rcode) ! idvsl(i_vol) = i_vol ! + N_Bubble_Types ! + N_SL ! + N_PW ! + N_Netcdf_Grid_Vars endif enddo idvtemp = ncvdef(idFile,'Temperature', NCFLOAT,2,dims,rcode) lith_dims(1) = 1 ! x lith_dims(2) = 5 ! lithosphere level idvlithrho = ncvdef(idFile,'Crust_rho',NCFLOAT,2, $ lith_dims,rcode) idvlithh = ncvdef(idFile,'Crust_h',NCFLOAT,2, $ lith_dims,rcode) idvlithof = ncvdef(idFile,'Crust_ocn',NCFLOAT,1, $ lith_dims,rcode) idvlithage = ncvdef(idFile,'Crust_age',NCFLOAT,1, $ lith_dims,rcode) c derived diagnostics on the fly c if(volume(1,nz,ivol_hydrate) .GT. 0.d0) then c write(6,*) "stopthepress" c endif idvpohc = ncvdef(idfile,'HtoC',NCFLOAT,2,dims,rcode) idvpooc = ncvdef(idfile,'OtoC',NCFLOAT,2,dims,rcode) idvc13h4 = ncvdef(idFile,'del13CH4',NCFLOAT,2,dims,rcode) idvcdh3 = ncvdef(idFile,'delDCH3',NCFLOAT,2,dims,rcode) idvdic13 = ncvdef(idFile,'del13DIC',NCFLOAT,2,dims,rcode) idvI129age = ncvdef(idFile,'I129_age',NCFLOAT,2,dims,rcode) idvsedage = ncvdef(idFile,'Sed_age',NCFLOAT,2,dims,rcode) idvphi = ncvdef(idFile,'Phi_grn_size',NCFLOAT,2,dims,rcode) idvdzdt = ncvdef(idFile,'dz_top_dt',NCFLOAT,2,dims,rcode) idvw0a = ncvdef(idFile,'w0_apparent',NCFLOAT,1,dims,rcode) c internal model variables and diagnostics do i_d = 1, N_Diags_2d if(name_2d(i_d) .NE. "") then idvn2(i_d) = ncvdef(idFile,name_2d(i_d), $ NCFLOAT,2,dims,rcode) endif enddo do i_d = 1, N_Diags_1d if(name_1d(i_d) .NE. "") then idvn1(i_d) = ncvdef(idFile,name_1d(i_d), $ NCFLOAT,1,dims,rcode) endif enddo dims(1) = 3 ! radius do i_d = 1, N_Diags_DS1 if(name_ds1(i_d) .NE. "") then idvnds1(i_d) = ncvdef(idFile,name_ds1(i_d), $ NCFLOAT,1,dims,rcode) endif enddo dims(1) = 1 ! x dims(2) = 3 ! radius do i_d = 1, N_Diags_DS2 if(name_ds2(i_d) .NE. "") then idvnds2(i_d) = ncvdef(idFile,name_ds2(i_d), $ NCFLOAT,2,dims,rcode) endif enddo dims(1) = 1 ! x dims(2) = 4 ! chemical component do i_d = 1, N_Diags_DS2 if(name_ds2c(i_d) .NE. "") then idvnds2c(i_d) = ncvdef(idFile,name_ds2c(i_d), $ NCFLOAT,2,dims,rcode) endif enddo call ncendf(idfile,rcode) c#define Write_CDF_Diagnostics #ifdef Write_CDF_Diagnostics write(6,*) "created file", filename #endif endif ! only creates netcdf if its master c c write data c c grid stuff header if( myid .EQ. Master) then dummy_global(1:NX_Global,1) = x_global(1:NX_Global) $ / 1000.d0 call ncvpt(idFile,idvx,1,NX_Global,dummy_global,rcode) endif if( myid .EQ. Master) then dummy_global(1:NX_Global,1) = dx_global(1:NX_Global) $ / 1000.d0 call ncvpt(idFile,idvdx,1,NX_Global,dummy_global,rcode) endif start = 1 count(1) = NX_Global count(2) = nz dummy = grid(1:NX,1:nz,ig_z_top) #ifdef NonDimensional $ / dim_scale(DepthScale) #endif call my_ncvpt(myid,numprocs, $ idFile,idvz_top,start,count, $ dummy,rcode) #ifdef NonDimensional do ix = 1, NX dummy(ix,1:nz) = $ ( grid(ix,1:nz,ig_z_center) $ - grid(ix,nz,ig_z_center) $ ) ! 0 at top $ / ( grid(ix,1,ig_z_center) $ - grid(ix,nz,ig_z_center) $ ) ! 0 to 1 dummy(ix,1:nz) = 1.d0 - dummy(ix,1:nz) enddo #else dummy = grid(1:NX,1:nz,ig_z_center) #endif call my_ncvpt(myid,numprocs, $ idFile,idvz_center,start,count, $ dummy,rcode) dummy = grid(1:NX,1:nz,ig_dz) #ifdef NonDimensional $ / dim_scale(DepthScale) #endif call my_ncvpt(myid,numprocs, $ idFile,idvdz,start,count, $ dummy,rcode) dummy(1:NX,1) = grid(1:NX,0,ig_z_canyon) call my_ncvpt(myid,numprocs, $ idFile,idvz_canyon,start,count, $ dummy,rcode) dummy(1:NX,1) = sea_level call my_ncvpt(myid,numprocs, $ idFile,idvsealev,start,count, $ dummy,rcode) if(myid .EQ. Master) then #ifdef Sediment_Transport dummy_ds1(1:N_Size_Classes) = $ diagnostic_ds1(1:N_Size_Classes,ids1_particle_radius) #else do ix=1,N_Size_Classes dummy_ds1(ix) = ix enddo #endif call ncvpt(idFile,idvr,1,N_Size_Classes, $ dummy_ds1,rcode) endif c state variables c call MPI_Barrier(MPI_COMM_WORLD, ierr) c write(6,*) "got here", myid, itag c call flush(6) #ifdef Write_CDF_Diagnostics if(myid .EQ. Master) then write(6,*) "wrote grids" endif #endif do i_pw = 1, N_PW if(name_pw(i_pw) .NE. "") then #ifdef Write_CDF_Diagnostics write(6,*) "yukkin it up", i_pw #endif dummy(1:NX,1:nz) = pw_conc(1:NX,1:nz,i_pw) call my_ncvpt(myid,numprocs, $ idFile,idvpw(i_pw),start,count, $ dummy,rcode) endif enddo do i_sl = 1, N_SL if(name_sl(i_sl) .NE. "") then #ifdef Write_CDF_Diagnostics write(6,*) "yukkin it up", i_sl #endif dummy(1:NX,1:nz) = sl_frac(1:NX,1:nz,i_sl) call my_ncvpt(myid,numprocs, $ idFile,idvsl(i_sl),start,count, $ dummy,rcode) endif enddo do i_bb = 1, N_Bubble_Types if(name_bb(i_bb) .NE. "") then dummy(1:NX,1:nz) = bb_conc(1:NX,1:nz,i_bb) call my_ncvpt(myid,numprocs, $ idFile,idvbb(i_bb),start,count, $ dummy,rcode) endif enddo do i_vol = 1, N_Vols if(name_vol(i_vol) .NE. "") then dummy = volume(1:NX,1:nz,i_vol) call my_ncvpt(myid,numprocs, $ idFile,idvvol(i_vol),start,count, $ dummy,rcode) endif enddo dummy = temperature(1:NX,1:nz,degC) call my_ncvpt(myid,numprocs,idFile, $ idvtemp,start,count, $ dummy,rcode) lith_count(1) = NX_Global lith_count(2) = N_Lith_Slabs dummy(1:NX,1:N_Lith_Slabs) = $ lithosphere(1:NX,1:N_Lith_Slabs,il_Density) call my_ncvpt(myid,numprocs, $ idFile,idvlithrho,start,lith_count, $ dummy,rcode) dummy(1:NX,1:N_Lith_Slabs) = $ lithosphere(1:NX,1:N_Lith_Slabs,il_Thickness) call my_ncvpt(myid,numprocs, $ idFile,idvlithh,start,lith_count, $ dummy,rcode) lith_count(2) = 1 dummy(1:NX,1) = lithosphere(1:NX,OceanCrust, $ il_Ocean_Fraction) call my_ncvpt(myid,numprocs, $ idFile,idvlithof,start,lith_count, $ dummy,rcode) dummy(1:NX,1) = lithosphere(1:NX,OceanCrust,il_Age) call my_ncvpt(myid,numprocs, $ idFile,idvlithage,start,lith_count, $ dummy,rcode) #ifdef Write_CDF_Diagnostics if(myid .EQ. Master) then write(6,*) "state variables" endif #endif c derived diagnostics on the fly c del13CH4 dummy = ( pw_conc(1:NX,1:nz,i_C13H4) $ / ( pw_conc(1:NX,1:nz,i_CH4) + 1.d-18 ) $ - 1.d0 $ ) * 1000. ! del 13 CH4 do ix=1,NX do iz=1,nz if(pw_conc(ix,iz,i_CH4) .LT. 0.1) then dummy(ix,iz) = 0. endif enddo enddo #ifdef NoDelNotation dummy = pw_conc(1:NX,1:nz,i_C13H4) #endif call my_ncvpt(myid,numprocs, $ idFile,idvc13h4,start,count, $ dummy,rcode) c H/C ratio in POC do ix=1,NX do iz=1,nz if(sl_frac(ix,iz,i_POC) .GT. 0.d0) then dummy(ix,iz) = sl_frac(ix,iz,i_POH) $ / sl_frac(ix,iz,i_POC) endif enddo enddo call my_ncvpt(myid,numprocs, $ idFile,idvpohc,start,count, $ dummy,rcode) c O/C ratio in POC do ix=1,NX do iz=1,nz if(sl_frac(ix,iz,i_POC) .GT. 0.d0) then dummy(ix,iz) = sl_frac(ix,iz,i_POO) $ / sl_frac(ix,iz,i_POC) endif enddo enddo call my_ncvpt(myid,numprocs, $ idFile,idvpooc,start,count, $ dummy,rcode) c delDCH4 dummy = ( pw_conc(1:NX,1:nz,i_CDH3) $ / ( pw_conc(1:NX,1:nz,i_CH4) + 1.d-18 ) $ - 1.d0 $ ) * 1000. do ix=1,NX do iz=1,nz if(pw_conc(ix,iz,i_CH4) .LT. 0.1) then dummy(ix,iz) = 0. endif enddo enddo #ifdef NoDelNotation dummy = pw_conc(1:NX,1:nz,i_CDH3) #endif call my_ncvpt(myid,numprocs, $ idFile,idvcdh3,start,count, $ dummy,rcode) c del13DIC dummy = ( pw_conc(1:NX,1:nz,i_DIC13) $ / ( pw_conc(1:NX,1:nz,i_DIC) + 1.d-18 ) $ - 1.d0 $ ) * 1000. call my_ncvpt(myid,numprocs, $ idFile,idvdic13,start,count, $ dummy,rcode) c Phi grain size diagnostic do ix=1,NX do iz=1,nz if(field(ix,iz,id2_grain_size) $ .GT. 0.d0) then dummy(ix,iz) = $ - log( field(ix,iz,id2_grain_size) ! meters $ * 1.d3 $ ) ! mm, phi $ / .6909 ! to get base 2 log scale else dummy(ix,iz) = 0.0d0 endif enddo enddo call my_ncvpt(myid,numprocs, $ idFile,idvphi,start,count,dummy,rcode) dummy(1:NX,1:nz) = grid(1:NX,1:nz,ig_dz_top_dt)/ dt call my_ncvpt(myid,numprocs, $ idFile,idvdzdt,start,count,dummy,rcode) c Iodine 129 age do ix=1,NX do iz=1,nz if(pw_conc(ix,iz,i_ITot) .GT. 1.d-18) then dummy(ix,iz) = - log( pw_conc(ix,iz,i_I129) $ / pw_conc(ix,iz,i_ITot) $ ) $ * Decay_Time_I129 ! the iodine age in years else dummy(ix,iz) = 0.d0 endif enddo enddo call my_ncvpt(myid,numprocs, $ idFile,idvI129age,start,count, $ dummy,rcode) c Sediment age do ix=1,NX do iz=1,nz dummy(ix,iz) = sl_frac(ix,iz,i_Age) $ * volume(ix,iz,ivol_solid) enddo enddo call my_ncvpt(myid,numprocs, $ idFile,idvsedage,start,count, $ dummy,rcode) c apparent fluid velocity from change in fluid volume count(2) = 1 dummy(1:NX,1) = - diagnostic_1d(1:NX,id1_d_fluid_vol_dt) $ / grid(1:NX,0,ig_dx) $ / field(1:NX,nz,id2_por_melted) call my_ncvpt(myid,numprocs, $ idFile,idvw0a,start,count, $ dummy,rcode) #ifdef Write_CDF_Diagnostics if(myid .EQ. Master) then write(6,*) "kibbles" endif #endif c internal model variables and diagnostics count(2) = nz do i_pw = 1, Nd2_Vol_Rates if(name_2d(i_pw) .NE. "") then dummy(1:NX,1:nz) = field(1:NX,1:nz,i_pw) ! mol / timestep $ / volume(1:NX,1:nz,ivol_tot) ! mol/m3 timestep $ / dt ! mol / m3 yr call my_ncvpt(myid,numprocs, $ idFile,idvn2(i_pw),start,count, $ dummy,rcode) endif enddo do i_pw = Nd2_Vol_Rates+1, Nd2_Area_Rates if(name_2d(i_pw) .NE. "") then do iz = 1, nz dummy(1:NX,iz) = field(1:NX,iz,i_pw) ! mol / timestep $ / grid(1:NX,0,ig_dx) ! mol / m timestep $ / dt ! mol / m2 yr enddo call my_ncvpt(myid,numprocs, $ idFile,idvn2(i_pw),start,count, $ dummy,rcode) endif enddo do i_pw = Nd2_Area_Rates+1, N_Diags_2d if(name_2d(i_pw) .NE. "") then dummy(1:NX,1:nz) = field(1:NX,1:nz,i_pw) call my_ncvpt(myid,numprocs, $ idFile,idvn2(i_pw),start,count, $ dummy,rcode) endif enddo #ifdef Write_CDF_Diagnostics if(myid .EQ. Master) then write(6,*) "fields" endif #endif count(2) = 1 do i_pw = 1, N_Diags_1d if(name_1d(i_pw) .NE. "") then dummy(1:NX,1) = diagnostic_1d(1:NX,i_pw) call my_ncvpt(myid,numprocs, $ idFile,idvn1(i_pw),start,count, $ dummy,rcode) endif enddo #ifdef Write_CDF_Diagnostics if(myid .EQ. Master) then write(6,*) "1d diags" endif #endif if(myid .EQ. Master) then count(1) = N_Size_Classes count(2) = 1 do i_pw = 2, N_Diags_DS1 ! already wrote 1 which was radius if(name_ds1(i_pw) .NE. "") then dummy_ds1(1:N_Size_Classes) = $ diagnostic_ds1(1:N_Size_Classes,i_pw) call ncvpt(idFile,idvnds1(i_pw),start,count, $ dummy_ds1,rcode) endif enddo endif #ifdef Write_CDF_Diagnostics if(myid .EQ. Master) then write(6,*) "1d sed diags" endif #endif ! the dimensions are x and radius ! do it one level (radius) at a time to avoid overfilling if ! N_Size_Classes > nz_max count(1) = NX_Global count(2) = 1 do i_pw = 1, N_Diags_DS2 if(name_ds2(i_pw) .NE. "") then do i_r = 1, N_Size_Classes dummy(1:NX, 1) = diagnostic_ds2(1:NX, $ i_r-1+i_first_size_class, $ ids2_frac, $ i_pw ) start(2) = i_r call my_ncvpt(myid,numprocs, $ idFile,idvnds2(i_pw),start,count, $ dummy,rcode) enddo endif enddo #ifdef Write_CDF_Diagnostics if(myid .EQ. Master) then write(6,*) "1d sed x size diags" endif #endif count(1) = NX_Global count(2) = 1 do i_pw = 1, N_Diags_DS2 if(name_ds2c(i_pw) .NE. "") then do i_r = 1, N_SL_Conc dummy(1:NX, 1) = diagnostic_ds2(1:NX, $ i_r, $ ids2_frac, $ i_pw ) start(2) = i_r call my_ncvpt(myid,numprocs, $ idFile,idvnds2c(i_pw),start,count, $ dummy,rcode) enddo endif enddo c done if(myid .EQ. Master) then c write(6,*) c write(6,*,advance='no') "written ", filename c call flush(6) call ncclos(idfile,rcode) endif return end subroutine double_grid_z( $ pw_conc, sl_frac, bb_conc, $ temperature, volume, nz) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1,N_Grids) :: $ grid double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_frac double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_Bubble_Types) :: $ bb_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume integer iz, nz do iz = nz, 1, -1 ! where nz fits with the incoming data pw_conc(:,2*iz,:) = pw_conc(:,iz,:) ! nz->2*nz, .. 1->2 sl_frac(:,2*iz,:) = sl_frac(:,iz,:) bb_conc(:,2*iz,:) = bb_conc(:,iz,:) temperature(:,2*iz,:) = temperature(:,iz,:) volume(:,2*iz,:) = volume(:,iz,:) / 2 pw_conc(:,2*iz-1,:) = pw_conc(:,iz,:) ! nz->2nz-1, .. 1->1 sl_frac(:,2*iz-1,:) = sl_frac(:,iz,:) bb_conc(:,2*iz-1,:) = bb_conc(:,iz,:) temperature(:,2*iz-1,:) = temperature(:,iz,:) volume(:,2*iz-1,:) = volume(:,iz,:) / 2 enddo nz = 2*nz return end #ifdef Create_HiTop subroutine hires_top_grid_z( $ pw_conc, sl_frac, bb_conc, $ temperature, volume, nz) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_frac double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_Bubble_Types) :: $ bb_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume integer iz, izz, iz_from, iz_to, nz c fill the lowest boxes in expanded scheme do iz = NZ_Top/Create_HiTop, 1, -1 ! index over input nz_top iz_from = NZ_Body + iz ! say iz=1,2,3 iz_to = NZ_Body + 1 + (iz-1)*Create_HiTop ! goes into 1,6,11 pw_conc(:,iz_to,:) = pw_conc(:,iz_from,:) sl_frac(:,iz_to,:) = sl_frac(:,iz_from,:) bb_conc(:,iz_to,:) = bb_conc(:,iz_from,:) temperature(:,iz_to,:) = temperature(:,iz_from,:) volume(:,iz_to,:) = volume(:,iz_from,:) / Create_HiTop c write(6,*) "writing from ", iz_from, "to ", iz_to enddo c fill each expanded set up from lowest do iz = 1, NZ_Top/Create_HiTop ! index over input nz_top iz_from = NZ_Body + 1 + (iz-1)*Create_HiTop ! say iz=1,2,3, from=1,6,11 do izz = 1, Create_HiTop-1 ! 1,4 iz_to = NZ_Body + 1 + (iz-1)*Create_HiTop + izz ! to=2,7,12 pw_conc(:,iz_to,:) = pw_conc(:,iz_from,:) sl_frac(:,iz_to,:) = sl_frac(:,iz_from,:) bb_conc(:,iz_to,:) = bb_conc(:,iz_from,:) temperature(:,iz_to,:) = temperature(:,iz_from,:) volume(:,iz_to,:) = volume(:,iz_from,:) enddo enddo nz = NZ_Body + NZ_Top return end subroutine hires_top_grid_interp( field_dummy, z_center , nz ) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ field_dummy, z_center double precision, dimension(0:NX+1) :: fract_lower integer iz, izz, iz_to, nz, $ iz_lower, iz_upper, iz_center do iz = 1, NZ_Top/Create_HiTop ! index over input nz_top iz_center = NZ_Body + 1 + (iz-1)*Create_HiTop $ + Create_HiTop / 2 ! =13,18,23 iz_lower = NZ_Body do izz = 1, Create_HiTop ! 1,5 iz_to = NZ_Body + izz + (iz-1)*Create_HiTop ! 11,12,13,14,15 if(iz_to .EQ. iz_center) then iz_lower = iz_center else if(iz_to .LT. iz_center) then iz_upper = iz_center else iz_upper = MIN( iz_center+Create_HiTop, nz) endif fract_lower(1:NX) = $ ( z_center(1:NX,iz_upper) $ - z_center(1:NX,iz_to) $ ) $ / ( z_center(1:NX,iz_upper) $ - z_center(1:NX,iz_lower) $ ) field_dummy(1:NX,iz_to) = $ fract_lower(1:NX) $ * field_dummy(1:NX,iz_lower) $ + ( 1.d0 - fract_lower(1:NX) ) $ * field_dummy(1:NX,iz_upper) endif enddo enddo return end #endif #ifndef MPI subroutine double_grid_x(grid, $ pw_conc, sl_frac, bb_conc, $ temperature, volume, lithosphere, $ x_global, dx_global, $ z_seafloor_global, ocean_frac_global) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1,N_Grids) :: $ grid double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_frac double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_Bubble_Types) :: $ bb_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume double precision, dimension(0:NX+1,N_Lith_Slabs,N_Lith_Vars) :: $ lithosphere double precision, dimension(0:NX_Global+1) :: $ z_seafloor_global, ocean_frac_global, $ x_global, dx_global integer ix #ifdef MPI write(6,*) "do this in single processor mode please" call MPI_Finalize(MPI_COMM_WORLD, ierr) stop #endif do ix = NX/2, 1, -1 ! 1 2 3 -> 1 1 2 2 3 3 grid(2*ix,:,:) = grid(ix,:,:) ! NX/2->NX, .. 1->2, evens filled pw_conc(2*ix,:,:) = pw_conc(ix,:,:) sl_frac(2*ix,:,:) = sl_frac(ix,:,:) bb_conc(2*ix,:,:) = bb_conc(ix,:,:) temperature(2*ix,:,:) = temperature(ix,:,:) volume(2*ix,:,:) = volume(ix,:,:) / 2 lithosphere(2*ix,:,:) = lithosphere(ix,:,:) grid(2*ix-1,:,:) = grid(ix,:,:) ! odds filled pw_conc(2*ix-1,:,:) = pw_conc(ix,:,:) sl_frac(2*ix-1,:,:) = sl_frac(ix,:,:) bb_conc(2*ix-1,:,:) = bb_conc(ix,:,:) temperature(2*ix-1,:,:) = temperature(ix,:,:) volume(2*ix-1,:,:) = volume(ix,:,:) / 2 lithosphere(2*ix-1,:,:) = lithosphere(ix,:,:) enddo grid(:,0,ig_dx) = grid(:,0,ig_dx) / 2 do ix = 1, NX/2 grid(2*ix-1,0,ig_x) = grid(2*ix-1,0,ig_x) $ - grid(2*ix-1,0,ig_dx) / 2 ! 1,3,5 shift to the left grid(2*ix,0,ig_x) = grid(2*ix,0,ig_x) $ + grid(2*ix,0,ig_dx) / 2 ! 2,4,6 shift to the right enddo x_global = grid(:,0,ig_x) dx_global = grid(:,0,ig_dx) z_seafloor_global = grid(:,NZ_Max,ig_z_top) ocean_frac_global = lithosphere(:,OceanCrust,il_Ocean_Fraction) return end #endif subroutine read_netcdf(itag, $ x, dx, z_top, sea_level,z_canyon, $ x_global, dx_global, $ z_seafloor_global, $ ocean_frac_global, $ volume, $ pw_conc, sl_frac, bb_conc, temperature, lithosphere, $ nz, myid, numprocs) implicit none #ifdef MPI include 'mpif.h' integer ierr #endif #include integer itag, nz, myid, numprocs double precision, dimension(0:NX+1) :: $ x, dx, z_canyon double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_top double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_frac double precision, dimension(0:NX+1,0:NZ_Max+1,N_Bubble_Types) :: $ bb_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,N_Lith_Slabs,N_Lith_Vars) :: $ lithosphere double precision :: sea_level integer rcode, ix, i_b, i_pw, i_sl, nx_in, idNC, $ ntmp, ipos, idigit, i_vol, n_vols_tmp, n_sl_tmp real, dimension(NX,NZ_Max) :: dummy real, dimension(NX_Global) :: dummy_global double precision, dimension(0:NX_Global+1) :: $ z_seafloor_global, $ ocean_frac_global, $ x_global, dx_global integer, dimension(2) :: start, count, count_lith, dims character*25 filename, dummyname integer allocated /0/ save data start /1,1/ data dims / 1,2/ #ifdef DoubleHRes count_lith(1) = NX_Global_In count(1) = NX_Global_In #else count_lith(1) = NX_Global_In count(1) = NX_Global_In #endif count(2) = NZ_Max count_lith(2) = 2 filename = "year.000000000.cdf" ntmp = itag do ipos=14,6,-1 idigit = mod(ntmp,10) filename(ipos:ipos) = char(ichar('0') + idigit) ntmp = ntmp/10 enddo if(myid .EQ. Master) then #ifdef Read_CDF_Stdout write(6,*) "Reading ",filename #endif idNC = ncopn(filename,NCNOWRIT,rcode) call ncdinq(idNC, 1, dummyname, nx_in, rcode) if(nx_in .NE. NX_Global_In) then write(6,*) "NX mismatch" call flush(6) stop endif call ncdinq(idNC, 2, dummyname, nz, rcode) if(nz .GT. NZ_Max) then write(6,*) "NZ too big" call flush(6) stop endif write(6,*)'NX,nz=',NX,nz endif #ifdef MPI call MPI_Bcast(nz,1,MPI_INTEGER,Master, $ MPI_COMM_WORLD,ierr) #endif count(2) = 1 dummy = 0.d0 if(myid .EQ. Master) then call ncvgt(idNC, 1, start, count, dummy_global, rcode) x_global(1:NX_Global) = $ dummy_global(1:NX_Global) * 1000. call ncvgt(idNC, 2, start, count, dummy_global, rcode) dx_global(1:NX_Global) = $ dummy_global(1:NX_Global) * 1000. endif dx_global(0) = dx_global(1) dx_global(NX_Global+1) = dx_global(NX_Global) x_global(0) = x_global(1) $ - dx_global(1) x_global(NX_Global+1) = x_global(NX_Global) $ + dx_global(NX_Global+1) #ifdef MPI call MPI_Bcast(x_global, NX_Global+2, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) call MPI_Bcast(dx_global, NX_Global+2, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) #endif x(0:NX+1) = x_global(0+myid*NX:NX+1+myid*NX) dx(0:NX+1) = dx_global(0+myid*NX:NX+1+myid*NX) count(2) = nz call my_ncvgt(idNC, 4, start, count, dummy, rcode) ! z_top z_top(1:NX,1:nz) = dummy(1:NX,1:nz) call my_ncvgt(idNC, 5, start, count, dummy, rcode) ! dz z_top(1:NX,0) = z_top(1:NX,1) - dummy(1:NX,1) #ifdef Read_Old_File count(2) = 1 call my_ncvgt(idNC, 6, start, count, dummy, rcode) ! sea_level to 7 sea_level = dummy(1,1) #else count(2) = 1 call my_ncvgt(idNC, 7, start, count, dummy, rcode) ! sea_level to 7 sea_level = dummy(1,1) call my_ncvgt(idNC, 6, start, count, dummy, rcode) ! z_canyon z_canyon(1:NX) = dummy(1:NX,1) #endif count(2) = nz do i_pw = 1, N_PW call my_ncvgt(idNC, i_pw+N_Netcdf_Grid_Vars, $ start, count, dummy, rcode) pw_conc(1:NX,1:nz,i_pw) = dummy(1:NX,1:nz) enddo #ifdef Read_CDF_Stdout if(myid .EQ. Master) then write(6,*) "looking for solids" endif #endif #ifdef Convert_N_SL n_sl_tmp = N_SL - 1 sl_frac(1:NX,1:nz,i_Aeolean) = 0.d0 do i_sl = 1, N_SL-1 #else n_sl_tmp = N_SL do i_sl = 1, N_SL #endif call my_ncvgt(idNC, i_sl+N_PW+N_Netcdf_Grid_Vars, $ start, count, dummy, rcode) sl_frac(1:NX,1:nz,i_sl) = dummy(1:NX,1:nz) enddo #ifdef Read_CDF_Stdout if(myid .EQ. Master) then write(6,*) "looking for bubbles" endif #endif do i_b = 1, N_Bubble_Types call my_ncvgt(idNC, $ i_b+n_sl_tmp+N_PW+N_Netcdf_Grid_Vars, $ start, count, dummy, rcode) bb_conc(1:NX,1:nz,i_b) = dummy(1:NX,1:nz) enddo #ifdef Read_CDF_Stdout if(myid .EQ. Master) then write(6,*) "looking for volume" endif #endif #ifdef Convert_Vol_File n_vols_tmp = N_Vols - 1 #else n_vols_tmp = N_Vols #endif do i_vol = 1, n_vols_tmp - 1 call my_ncvgt(idNC, $ i_vol+N_Bubble_Types+n_sl_tmp+N_PW $ + N_Netcdf_Grid_Vars, $ start, count, dummy, rcode) volume(1:NX,1:nz,i_vol) = dummy(1:NX,1:nz) c write(6,*) volume(1:3,1,i_vol) enddo #ifdef Convert_Vol_File volume(:,:,ivol_ice_sheet) = 0.d0 #endif #ifdef Read_CDF_Stdout if(myid .EQ. Master) then write(6,*) "looking for temperature" endif #endif call my_ncvgt(idNC, $ 1+n_vols_tmp+N_Bubble_Types+n_sl_tmp+N_PW $ + N_Netcdf_Grid_Vars, $ start, count, dummy, rcode) temperature(1:NX,1:nz,degC) = dummy(1:NX,1:nz) #ifdef Read_CDF_Stdout if(myid .EQ. Master) then write(6,*) "looking for crust density" endif #endif count(2) = N_Lith_Slabs call my_ncvgt(idNC, $ 2+n_vols_tmp+N_Bubble_Types+n_sl_tmp+N_PW $ + N_Netcdf_Grid_Vars, $ start, count, dummy, rcode) lithosphere(1:NX,1:N_Lith_Slabs,il_Density) = $ dummy(1:NX,1:N_Lith_Slabs) call my_ncvgt(idNC, $ 3+n_vols_tmp+N_Bubble_Types+n_sl_tmp+N_PW $ + N_Netcdf_Grid_Vars, $ start, count, dummy, rcode) lithosphere(1:NX,1:N_Lith_Slabs,il_Thickness) = $ dummy(1:NX,1:N_Lith_Slabs) count(2) = 1 call my_ncvgt(idNC, $ 4+n_vols_tmp+N_Bubble_Types+n_sl_tmp+N_PW $ + N_Netcdf_Grid_Vars, $ start, count, dummy, rcode) lithosphere(1:NX,OceanCrust,il_Ocean_Fraction) = $ dummy(1:NX,1) #ifdef Read_CDF_Stdout if(myid .EQ. Master) then write(6,*) "looking for crust age", myid endif #endif call my_ncvgt(idNC, $ 5+n_vols_tmp+N_Bubble_Types+n_sl_tmp+N_PW $ + N_Netcdf_Grid_Vars, $ start, count, dummy, rcode) lithosphere(1:NX,OceanCrust,il_Age) = dummy(1:NX,1) if(myid .EQ. Master) then call ncclos(idNC,rcode) endif #ifdef MPI call MPI_Gather(z_top(1:NX,nz),NX,MPI_DOUBLE_PRECISION, $ z_seafloor_global(1:NX_Global),NX,MPI_DOUBLE_PRECISION, $ Master, MPI_COMM_WORLD,ierr) call MPI_Bcast(z_seafloor_global(1:NX_Global), NX_Global, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) call MPI_Gather(lithosphere(1:NX, $ OceanCrust, $ il_Ocean_Fraction), $ NX,MPI_DOUBLE_PRECISION, $ ocean_frac_global(1:NX_Global), $ NX,MPI_DOUBLE_PRECISION, $ Master,MPI_COMM_WORLD,ierr) call MPI_Bcast(ocean_frac_global, NX_Global+2, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) #else ocean_frac_global = lithosphere(:, $ OceanCrust, $ il_Ocean_Fraction) z_seafloor_global(1:NX) = z_top(1:NX,nz) #endif call flush(6) return end subroutine my_ncvpt(myid,numprocs,idfile, idvar, $ start, count, array, rcode) implicit none #ifdef MPI include 'mpif.h' #endif integer rcode,myid,numprocs,ierr integer idfile, idvar, start(3), count(3) real, dimension(NX,NZ_Max) :: array real, dimension(NX_Global,NZ_Max) :: array_global integer i_allocated save array_global, i_allocated data i_allocated /0/ c#ifdef MPI c call MPI_COMM_RANK(MPI_COMM_WORLD,myid,ierr) c call MPI_COMM_SIZE(MPI_COMM_WORLD,numprocs,ierr) c#else c myid = 0 c numprocs = 1 c#endif count(1) = NX_Global call collect_global(array, array_global, $ myid, numprocs, NZ_Max) if(myid .EQ. Master) then call ncvpt(idfile, idvar, start, count, array_global, rcode) endif return end subroutine my_ncvgt(idfile, idvar, start, count, array, rcode) implicit none #ifdef MPI include 'mpif.h' #endif integer n_numbers,idim integer rcode,myid,numprocs,ierr integer idfile, idvar, start(3), count(3) real, dimension(NX,NZ_Max) :: array real, dimension(NX_Global,NZ_Max) :: array_global character*12 varname integer vartype,nvdims,dims(3),nvatts #ifdef MPI call MPI_COMM_RANK(MPI_COMM_WORLD,myid,ierr) numprocs = MPI #else myid = 0 numprocs = 1 #endif if(myid .EQ. Master) then call ncvinq(idfile,idvar,varname,vartype, $ nvdims,dims,nvatts,rcode) #ifdef Read_CDF_Stdout write(6,*) "reading ", varname, idvar ! count(1:2) #endif call ncvgt(idfile, idvar, start, count, $ array_global(1:NX_Global_In,:), rcode) n_numbers = 1 do idim=1,nvdims n_numbers = n_numbers * count(idim) enddo endif #ifdef MPI call MPI_Bcast(n_numbers,1,MPI_INTEGER,Master, $ MPI_COMM_WORLD,ierr) call MPI_Bcast(nvdims,1,MPI_INTEGER,Master, $ MPI_COMM_WORLD,ierr) call MPI_Bcast(array_global,n_numbers, $ MPI_REAL,Master,MPI_COMM_WORLD,ierr) #endif if(nvdims .EQ. 1) then array(1:NX,1) = $ array_global(1+myid*NX:NX+myid*NX,1) else array(1:NX,1:count(2)) = $ array_global(1+myid*NX:NX+myid*NX,1:count(2)) endif return end subroutine left_shift_grid( $ grid, volume, $ pw_conc, sl_frac, bb_conc, temperature, lithosphere, $ field, diagnostic_1d, $ diagnostic_ds1, diagnostic_ds2, $ x_global, dx_global, $ z_seafloor_global, ocean_frac_global, $ sedcol_youngs_mod_global, $ nz, myid, numprocs) implicit none #ifdef MPI include 'mpif.h' #endif #include double precision, dimension(0:NX+1, $ 0:NZ_Max+1,N_Grids) :: $ grid double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_frac double precision, dimension(0:NX+1,0:NZ_Max+1,N_Bubble_Types) :: $ bb_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,N_Lith_Slabs,N_Lith_Vars) :: $ lithosphere double precision, dimension(0:NX+1,0:NZ_Max+1, N_Diags_2d) :: $ field double precision, dimension(0:NX+1,N_Diags_1d) :: $ diagnostic_1d double precision, dimension(N_Size_Classes, $ N_Diags_DS1) :: $ diagnostic_ds1 double precision, dimension(0:NX+1, $ N_SL, 2, $ N_Diags_DS2) :: $ diagnostic_ds2 double precision, dimension(0:NX_Global+1) :: x_global, $ dx_global, z_seafloor_global, ocean_frac_global, $ sedcol_youngs_mod_global integer myid, numprocs, igrid, nz c first copy everything, leaving original value in position NX_Global, c also now in NX_Global-1 do igrid = 1, N_Grids call boundary_wrap_ghosts(grid(:,:,igrid), $ myid,numprocs,NZ_Max) grid(1:NX,:,igrid) = grid(2:NX+1,:,igrid) call wrap_ghosts(grid(:,:,igrid), $ myid,numprocs,NZ_Max) enddo do igrid = 1, N_Vols call boundary_wrap_ghosts(volume(:,:,igrid), $ myid,numprocs,NZ_Max) volume(1:NX,:,igrid) = volume(2:NX+1,:,igrid) call wrap_ghosts(volume(:,:,igrid), $ myid,numprocs,NZ_Max) enddo do igrid = 1, N_PW call boundary_wrap_ghosts(pw_conc(:,:,igrid), $ myid,numprocs,NZ_Max) pw_conc(1:NX,:,igrid) = pw_conc(2:NX+1,:,igrid) call wrap_ghosts(pw_conc(:,:,igrid), $ myid,numprocs,NZ_Max) enddo do igrid = 1, N_SL call boundary_wrap_ghosts(sl_frac(:,:,igrid), $ myid,numprocs,NZ_Max) sl_frac(1:NX,:,igrid) = sl_frac(2:NX+1,:,igrid) call wrap_ghosts(sl_frac(:,:,igrid), $ myid,numprocs,NZ_Max) enddo do igrid = 1, N_Bubble_Types call boundary_wrap_ghosts(bb_conc(:,:,igrid), $ myid,numprocs,NZ_Max) bb_conc(1:NX,:,igrid) = bb_conc(2:NX+1,:,igrid) call wrap_ghosts(bb_conc(:,:,igrid), $ myid,numprocs,NZ_Max) enddo do igrid = 1, 2 call boundary_wrap_ghosts(temperature(:,:,igrid), $ myid,numprocs,NZ_Max) temperature(1:NX,:,igrid) = temperature(2:NX+1,:,igrid) call wrap_ghosts(temperature(:,:,igrid), $ myid,numprocs,NZ_Max) enddo do igrid = 1, N_Lith_Vars call boundary_wrap_ghosts(lithosphere(:,:,igrid), $ myid,numprocs,N_Lith_Slabs) lithosphere(1:NX,:,igrid) = lithosphere(2:NX+1,:,igrid) call wrap_ghosts(lithosphere(:,:,igrid), $ myid,numprocs,N_Lith_Slabs) enddo do igrid = 1, N_Diags_2d call boundary_wrap_ghosts(field(:,:,igrid), $ myid,numprocs,NZ_Max) field(1:NX,:,igrid) = field(2:NX+1,:,igrid) call wrap_ghosts(field(:,:,igrid), $ myid,numprocs,NZ_Max) enddo call wrap_ghosts(diagnostic_1d(:,:), $ myid,numprocs,N_Diags_1d-2) ! the -2 is because no 0 and nz+1 ! vertical ghost points as assumed by wrap diagnostic_1d(1:NX,:) = diagnostic_1d(2:NX+1,:) call wrap_ghosts(diagnostic_1d(:,:), $ myid,numprocs,N_Diags_1d-2) #ifdef Shift_DS2 do igrid = 1, N_Diags_DS2 call wrap_ghosts(diagnostic_ds2(:,:,igrid), $ myid,numprocs,N_Size_Classes-2) diagnostic_ds2(1:NX,:,igrid) = $ diagnostic_ds2(2:NX+1,:,igrid) call wrap_ghosts(diagnostic_ds2(:,:,igrid), $ myid,numprocs,N_Size_Classes-2) enddo #endif c global variables x_global(0:NX_Global-1) = x_global(1:NX_Global) dx_global(0:NX_Global-1) = dx_global(1:NX_Global) dx_global(NX_Global:NX_Global+1) = DX_Init $ / numprocs #ifdef FakeMPI $ / FakeMPI #endif $ / NX_Base * 10 x_global(NX_Global) = x_global(NX_Global-1) $ + dx_global(NX_Global) x_global(NX_Global+1) = x_global(NX_Global) $ + dx_global(NX_Global+1) z_seafloor_global(0:NX_Global-1) = $ z_seafloor_global(1:NX_Global) ocean_frac_global(0:NX_Global-1) = $ ocean_frac_global(1:NX_Global) sedcol_youngs_mod_global(0:NX_Global-1) = $ sedcol_youngs_mod_global(1:NX_Global) ! NX_Global-1 = NX_Global c set right-hand boundary condition if( myid .EQ. numprocs-1 ) then ! local variables grid(NX,0,ig_dx) = DX_Init $ / numprocs #ifdef FakeMPI $ / FakeMPI #endif $ / NX_Base * 10 grid(NX,0,ig_x) = grid(NX-1,0,ig_x) $ + grid(NX,0,ig_dx) endif c needed the grid to get the age lithosphere(1:NX,OceanCrust,il_Age) = $ MAX( ( Plate_Width - grid(1:NX,0,ig_x) ) $ / Plate_Velocity, $ Ocean_Crust_Min_Age $ ) #ifdef Mackenzie lithosphere(1:NX,OceanCrust,il_Age) = $ Ocean_Crust_Min_Age #endif #ifdef Crust_Transition_Width lithosphere(NX,OceanCrust,il_Ocean_Fraction) = $ 0.5 $ - ATAN( - grid(NX,0,ig_x) $ / Crust_Transition_Width ! meters $ ) / 3.14 #endif c needed the age to get the sediment thickness in RH boundary if( myid .EQ. numprocs-1 ) then ! local variables volume(NX,1:nz,ivol_tot) = grid(NX,0,ig_dx) $ * DZ_Init #ifdef Pelagic_Sedimentation volume(NX,1:nz,ivol_tot) = MAX( $ volume(NX,1:nz,ivol_tot), $ grid(NX,0,ig_dx) $ * Pelagic_Sedimentation ! m / yr $ * lithosphere(NX,OceanCrust,il_Age) ! yr, now m $ / nz $ ) #endif volume(NX,:,ivol_solid) = volume(NX,:,ivol_tot) $ * ( 1. - field(NX,:,id2_por_melted) ) volume(NX,:,ivol_fluid) = volume(NX,:,ivol_tot) $ * field(NX,:,id2_por_melted) endif return end subroutine lateral_smoothing_global(dummy_global, $ x_global, niter) integer ix,i_allocated, niter double precision, dimension(0:NX_Global+1) :: $ dummy_global, x_global double precision, dimension(NX_Global) :: $ dzdx,d2zdx2 data i_allocated /0/ save do iter = 1, niter do ix = 2, NX_Global dzdx(ix) = ( dummy_global(ix) $ - dummy_global(ix-1) $ ) $ / ( x_global(ix) $ - x_global(ix-1) $ ) enddo do ix = 2, NX_Global-1 d2zdx2(ix) = ( dzdx(ix+1) $ - dzdx(ix) $ ) $ / ( x_global(ix+1) $ - x_global(ix) $ ) enddo do ix = 2, NX_Global-1 dummy_global(ix) = dummy_global(ix) $ + Smooth_Coeff $ * d2zdx2(ix) enddo enddo return end subroutine lateral_smoothing(dummy, $ x_global, $ niter, $ myid,numprocs) implicit none #ifdef MPI include 'mpif.h' #endif integer myid,numprocs,ix,i_allocated,niter,ierr double precision, dimension(0:NX+1) :: dummy double precision, dimension(0:NX_Global+1) :: x_global double precision, dimension(0:NX_Global+1) :: $ dummy_global #ifdef MPI call MPI_Gather(dummy(1:NX),NX,MPI_DOUBLE_PRECISION, $ dummy_global(1:NX_Global),NX,MPI_DOUBLE_PRECISION, $ Master, MPI_COMM_WORLD,ierr) #else dummy_global(1:NX) = dummy(1:NX) #endif if(myid .EQ. Master) then call lateral_smoothing_global(dummy_global, $ x_global, $ niter) endif #ifdef MPI call MPI_Bcast(dummy_global(1:NX_Global), NX_Global, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD, ierr) #endif dummy(1:NX) = $ dummy_global(1+myid*NX:NX+myid*NX) return end subroutine report_stdout( $ fluid_vol, solid_vol, air_vol, $ grid, $ pw_conc, pw_inv, sl_inv, bb_inv, $ lithosphere, $ x_global, z_seafloor_global, $ sea_level, z_water_table, iz_water_table, $ ocean_oxic_state, ocean_temperature_offset, $ air_temp_sea_level, $ rho, molwt, $ temperature, $ field, diagnostic_1d, $ dt, t_now, nz, $ myid, numprocs, i_out, i_shifts) implicit none #ifdef MPI include 'mpif.h' #endif double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ fluid_vol, solid_vol, air_vol double precision, dimension(0:NX+1,0:NZ_Max+1,N_Grids) :: $ grid double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc, pw_inv double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_inv double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_Bubble_Types) :: $ bb_inv double precision, dimension(0:NX+1,N_Lith_Slabs,N_Lith_Vars) :: $ lithosphere double precision, dimension(0:NX_Global+1) :: $ x_global, z_seafloor_global double precision, dimension(0:NX+1) :: z_water_table double precision :: rho(N_Rho), molwt(N_SL) double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1,N_Diags_2d) :: $ field double precision, dimension(0:NX+1,N_Diags_1d) :: $ diagnostic_1d double precision dt, t_now, t_last, sea_level, $ ocean_oxic_state, ocean_temperature_offset, $ air_temp_sea_level integer, dimension(NX) :: iz_water_table integer ix, nz, myid, numprocs, i_out, i_shifts c internal double precision, dimension(0:NX+1) :: $ fluid_vol_tot, fluid_vol_tot_old, $ solid_vol_tot, solid_vol_tot_old double precision :: $ solid_vol_domain_tot, solid_vol_domain_tot_old, $ d_solid_vol_domain_dt, $ solid_accum_tot, sedcol_flux(2) double precision, dimension(N_PW) :: $ pw_tot, pw_tot_old, d_pw_tot_dt double precision, dimension(N_SL) :: $ sl_tot, sl_tot_old, d_sl_tot_dt double precision, dimension(N_Bubble_Types) :: $ phase_tot, phase_tot_old, d_phase_tot_dt double precision, dimension(N_Diags_2d) :: $ field_tot double precision, dimension(N_Diags_1d) :: $ diagnostic_1d_tot double precision, dimension(N_Diags_2d) :: $ sea_floor_tot integer i_loop, ierr integer i_initialized /0/ save if(i_initialized .EQ. 0) then pw_tot_old = 0.d0 sl_tot_old = 0.d0 fluid_vol_tot_old = 0.d0 solid_vol_tot_old = 0.d0 solid_vol_domain_tot_old = 0.d0 phase_tot_old = 0.d0 t_last = -1.d-18 i_initialized = 1 endif if(i_out .EQ. Report_Skip) then return endif call sum_diag_2d(pw_inv, pw_tot, N_PW, nz) call sum_diag_2d(sl_inv, sl_tot, N_SL, nz) call sum_diag_2d(bb_inv, phase_tot, 4, nz) call column_inv_2d(fluid_vol,fluid_vol_tot,nz) call column_inv_2d(solid_vol,solid_vol_tot,nz) call domain_inv(solid_vol_tot,solid_vol_domain_tot) call compute_sedcol_flux(field(:,:,id2_por_melted), $ grid(:,:,ig_dz), $ diagnostic_1d(:,id1_sedcol_u), $ sedcol_flux, $ nz, myid, numprocs) d_pw_tot_dt = ( pw_tot - pw_tot_old ) $ / ( t_now - t_last ) d_sl_tot_dt = ( sl_tot - sl_tot_old ) $ / ( t_now - t_last ) d_phase_tot_dt = ( phase_tot - phase_tot_old ) $ / ( t_now - t_last ) d_solid_vol_domain_dt = ( solid_vol_domain_tot $ - solid_vol_domain_tot_old $ ) $ / ( t_now - t_last ) diagnostic_1d(0:NX+1,id1_d_fluid_vol_dt) = ! m3 / year over ix $ ( fluid_vol_tot $ - fluid_vol_tot_old $ ) $ / ( t_now - t_last ) diagnostic_1d(0:NX+1,id1_d_solid_vol_dt) = ! m3 / year over ix $ ( solid_vol_tot $ - solid_vol_tot_old $ ) $ / ( t_now - t_last ) solid_vol_domain_tot_old = solid_vol_domain_tot pw_tot_old = pw_tot sl_tot_old = sl_tot phase_tot_old = phase_tot fluid_vol_tot_old = fluid_vol_tot solid_vol_tot_old = solid_vol_tot t_last = t_now if(i_out .EQ. Report_Start_Clock) then return ! only really needs to fill up the _old arrays endif call sum_diag_2d(field(:,:,1:Nd2_Area_Rates), $ field_tot(1:Nd2_Area_Rates), $ Nd2_Area_Rates, nz) field_tot(1:Nd2_Area_Rates) = field_tot(1:Nd2_Area_Rates) $ / dt ! rate per year call sum_diag_1d(diagnostic_1d, $ diagnostic_1d_tot, N_Diags_1d) do i_loop = id2_CH4_bubble_flux, id2_CH4_adv_flux call sum_diag_1d(field(:,nz,i_loop), $ sea_floor_tot(i_loop), 1) enddo sea_floor_tot = sea_floor_tot / dt c write to stdout 990 format(A12, 5A12) 991 format(A12, 6G12.5) 992 format(A12, 2G12.4, A12, G12.3, A12) 993 format(6G12.3) 994 format(6F12.1) if(myid .EQ. 0) then write(6,*) if( i_out .GT. 0) then write(6,"(A5, F12.1, a10, f9.1, a8, i3, a15)") $ "Year", t_now, $ "iters", $ diagnostic_1d_tot(id1_w_n_iters)/NX_Global, $ "shifts ", i_shifts, $ "writing netcdf" else write(6,"(A5, F12.1, a10,f9.1, a8, i3)") $ "Year", t_now, $ "w_steps", $ diagnostic_1d_tot(id1_w_n_iters)/NX_Global, $ "shifts ", i_shifts endif write(6,"(A10,F9.3,A10,F6.1,A10,2F9.3)") $ "sealevel",sea_level, $ "oxygen",ocean_oxic_state, $ "temp", ocean_temperature_offset, $ air_temp_sea_level ix = 1 write(6,"(A3,i3, a9,2f9.2, a9,f9.2)") $ "iz", iz_water_table(ix), $ "ztop", grid(ix,iz_water_table(ix),ig_z_top), $ grid(ix,iz_water_table(ix)-1,ig_z_top), $ "wtable", z_water_table(ix) c write(6,"(a9,f9.4, a9,f9.4, a9,f9.4)") #ifdef Report_Groundwater write(6,"(a9,f9.4, a9,f9.4, a9,f9.4)") $ "liqsat", field(ix,iz_water_table(ix), $ id2_liquid_saturation), c $ "fluid", fluid_vol(1,15), c $ "air", air_vol(1,15) $ "por", field(ix,iz_water_table(ix), $ id2_por_melted), $ "por_d", field(ix,iz_water_table(ix), $ id2_por_dev) #endif #ifdef Report_POC write(6,990) " ", "tot", "bio", "thermal" write(6,991) "POC_rain", $ diagnostic_1d_tot(id1_POC_rain_flux), $ diagnostic_1d_tot(id1_POC_bio_rain_flux) write(6,991) "POC_deg", $ field_tot(id2_resp) $ + field_tot(id2_POC_sink_therm), $ field_tot(id2_resp), $ field_tot(id2_POC_sink_therm) write(6,991) "POC_inv", $ sl_tot(i_POC), $ sl_tot(i_Bio_POC), $ sl_tot(i_POC) - sl_tot(i_Bio_POC) if(diagnostic_1d_tot(id1_d_solid_vol_dt) .GT. 0.d0) then write(6,992) "dPOC/dt", $ d_sl_tot_dt(i_POC), $ diagnostic_1d_tot(id1_POC_rain_flux) $ - field_tot(id2_resp) $ - field_tot(id2_POC_sink_therm), $ "sum_src", $ d_sl_tot_dt(i_POC) ! moles $ / diagnostic_1d_tot(id1_d_solid_vol_dt) ! / m3 $ * molwt(i_Bio_POC) ! g org C / m3 $ / rho(i_Sediment), ! g org C / g solid $ "avg %" endif #endif #define Report_CH4 #ifdef Report_CH4 write(6,990) " ", "tot", "bio", "thermal" write(6,991) "CH4_gen", $ field_tot(id2_CH4_src_resp) $ + field_tot(id2_CH4_src_therm), $ field_tot(id2_CH4_src_resp), $ field_tot(id2_CH4_src_therm) write(6,990) "","tot", "aom", "bubbles", "diff", "adv" write(6,991) "CH4_loss", $ field_tot(id2_CH4_sink_aom) $ + sea_floor_tot(id2_CH4_bubble_flux) $ + sea_floor_tot(id2_CH4_diff_flux) $ + sea_floor_tot(id2_CH4_adv_flux), $ field_tot(id2_CH4_sink_aom), $ sea_floor_tot(id2_CH4_bubble_flux), $ sea_floor_tot(id2_CH4_diff_flux), $ sea_floor_tot(id2_CH4_adv_flux) write(6,992) "dCH4/dt", $ d_pw_tot_dt(i_CH4) $ + d_phase_tot_dt(i_CH4) $ + d_sl_tot_dt(i_Hydrate), $ field_tot(id2_CH4_src_resp) $ + field_tot(id2_CH4_src_therm) $ - field_tot(id2_CH4_sink_aom) $ - sea_floor_tot(id2_CH4_bubble_flux) $ - sea_floor_tot(id2_CH4_diff_flux) $ - sea_floor_tot(id2_CH4_adv_flux), $ "sum_src" write(6,990) "", "tot", "diss", "bubbles", "hydrate" write(6,991) "CH4_inv", $ pw_tot(i_CH4) $ + phase_tot(i_CH4) $ + sl_tot(i_Hydrate), $ pw_tot(i_CH4), $ phase_tot(i_CH4), $ sl_tot(i_Hydrate) #endif #ifdef Report_DIC write(6,991) "C13H4_inv", $ pw_tot(i_C13H4) $ + phase_tot(i_C13H4) $ + sl_tot(i_Hydrate_13), $ pw_tot(i_C13H4), $ phase_tot(i_C13H4), $ sl_tot(i_Hydrate_13) write(6,992) "DIC inv", $ pw_tot(i_DIC), $ pw_tot(i_DIC13), $ "DIC_13" #endif #ifdef Report_Vols write(6,991) "ice", $ sl_tot(i_Ice) write(6,991) "w", $ field(1,nz,id2_w), $ field(1,nz/2,id2_w), $ field(1,4,id2_w) write(6,991) "d_fluid_vol", $ diagnostic_1d(1,id1_d_fluid_vol_dt), $ diagnostic_1d(2,id1_d_fluid_vol_dt), $ diagnostic_1d(3,id1_d_fluid_vol_dt) write(6,991) "w_lim1", $ field(1,nz,id2_w_unlimited), $ field(1,nz/2,id2_w_unlimited), $ field(1,4,id2_w_unlimited) write(6,991) "w_lim2", $ field(2,nz,id2_w_unlimited), $ field(2,nz/2,id2_w_unlimited), $ field(2,4,id2_w_unlimited) c write(6,991) "temp", c $ temperature(NX-2,nz+1,degC), c $ temperature(NX-1,nz+1,degC), c $ temperature(NX,nz+1,degC) write(6,991) "por", $ field(NX/2,nz,id2_por_melted), $ field(NX/2,nz/2,id2_por_melted), $ field(NX/2,1,id2_por_melted) write(6,990) "mud_tot", "rain", "in", "out", "d" write(6,993) $ solid_vol_domain_tot, $ solid_accum_tot, $ sedcol_flux(2), $ sedcol_flux(1), $ solid_accum_tot $ + sedcol_flux(2) $ + sedcol_flux(1), $ z_seafloor_global(1) write(6,991) "temp", $ temperature(1,1:3,1) write(6,991) "water_z", $ z_seafloor_global(10)-sea_level, $ -grid(10,0,ig_z_top), $ -grid(10,nz,ig_z_top), $ diagnostic_1d(10,id1_isostat_eq) c $ diagnostic_1d(1,id1_sed_accum_rate) write(6,991) "column", $ diagnostic_1d(10,id1_column_mass), $ diagnostic_1d(10,id1_column_height), $ diagnostic_1d(10,id1_column_mass) $ / diagnostic_1d(10,id1_column_height)/1.d6 write(6,991) "sedcol", $ diagnostic_1d(10,id1_sedcol_mass), $ diagnostic_1d(10,id1_sedcol_height), $ diagnostic_1d(10,id1_sedcol_mass) $ / diagnostic_1d(10,id1_sedcol_height)/1.d6 #endif call flush(6) endif ! (myid .EQ. 0) c#ifdef MPI c call MPI_Barrier(MPI_COMM_WORLD,ierr) c#endif c if(myid .EQ. numprocs - 1) then c write(6,994) c $ lithosphere(NX-4:NX,OceanCrust,il_Age) c $ / 1.d6 c call flush(6) c endif c if(pw_tot(i_CH4) .GT. 1.d0) then c write(6,*) "debug" c endif return end subroutine compute_column_mh(lithosphere, $ volume, rho, dx, z_top, sea_level, z_water_table, $ nz, $ column_mass, column_height, $ sedcol_mass, sedcol_height) implicit none double precision, dimension(0:NX+1,N_Lith_Slabs,N_Lith_Vars) :: $ lithosphere double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume double precision :: rho(N_Rho), sea_level double precision, dimension(0:NX+1) :: dx, z_water_table double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_top double precision, dimension(0:NX+1) :: $ column_mass, column_height, sedcol_mass, sedcol_height integer ix, iz, nz c crust column_mass(1:NX) = $ ( lithosphere(1:NX,OceanCrust,il_Mass_per_m) $ + lithosphere(1:NX,Mantle,il_Mass_per_m) $ ) $ * lithosphere(1:NX,OceanCrust,il_Ocean_Fraction) $ + lithosphere(1:NX,ContCrust,il_Mass_per_m) $ * (1 - lithosphere(1:NX,OceanCrust,il_Ocean_Fraction)) column_height(1:NX) = $ ( lithosphere(1:NX,OceanCrust,il_Thickness) $ + lithosphere(1:NX,Mantle,il_Thickness) $ ) $ * lithosphere(1:NX,OceanCrust,il_Ocean_Fraction) $ + lithosphere(1:NX,ContCrust,il_Thickness) $ * (1 - lithosphere(1:NX,OceanCrust,il_Ocean_Fraction)) c plus sediment column #define Isostacy_Sediment #ifdef Isostacy_Sediment do ix = 1, NX sedcol_mass(ix) = 0.d0 do iz = 1, nz sedcol_mass(ix) = sedcol_mass(ix) $ + ( volume(ix,iz,ivol_solid) ! m2 solid / m dx $ * rho(i_Sediment) ! g / m3 -> g / m dx m antfarm $ + volume(ix,iz,ivol_fluid) $ * rho(i_Seawater) $ + volume(ix,iz,ivol_hydrate) $ * rho(i_Hydrate) $ + volume(ix,iz,ivol_ice) $ * rho(i_Ice) $ + volume(ix,iz,ivol_ice_sheet) $ * rho(i_Ice) $ ) / dx(ix) enddo sedcol_height(ix) = $ z_top(ix,nz) $ - z_top(ix,0) ! say -2000 - -3000 = 1000 enddo column_mass(1:NX) = column_mass(1:NX) $ + sedcol_mass(1:NX) column_height(1:NX) = column_height(1:NX) $ + sedcol_height(1:NX) #endif /* Isostacy_Sediment */ do ix = 1, NX c correct for buoyancy in seawater if( z_top(ix,nz) .LT. sea_level ) then ! submerged column_mass(ix) = column_mass(ix) $ - column_height(ix) $ * rho(i_Seawater) else ! outcropping column_mass(ix) = column_mass(ix) $ - ( column_height(ix) ! say 40000 $ + z_water_table(ix) ! say -10 $ - z_top(ix,nz) ! say 10 gives 39980 $ ) $ * rho(i_Seawater) endif enddo return end subroutine drain_sediment_column( $ z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid,por_mobile, $ por_drained, por_dev, $ liquid_saturation, $ z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, $ nz, myid, numprocs) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_top, z_center, dz double precision, dimension(0:NX+1) :: dx, z_water_table, $ z_ice_sheet_base double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ por_melted, por_mobile, $ por_liquid, $ p_hydro, $ por_drained, por_dev, liquid_saturation, $ stress_litho double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_inv double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_Bubble_Types) :: $ bb_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1) :: $ column_mass, column_height double precision molwt(N_SL),beta(2), por_0(0:2), rho(N_Rho), $ sea_level integer, dimension(NX) :: iz_water_table integer nz, myid, numprocs, ix, iz call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, $ iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) do ix=1,NX do iz=1,nz if(por_drained(ix,iz) .GT. 0.d0) then volume(ix,iz,ivol_fluid) = $ volume(ix,iz,ivol_solid) $ * por_drained(ix,iz) $ / (1.d0 - por_drained(ix,iz) ) else volume(ix,iz,ivol_fluid) = 0. endif enddo enddo return end subroutine setup_drained_sediment_column( $ z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, $ z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, $ nz, myid, numprocs) c maintains the dz values by adjusting both solid and fluid volumes implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_top, z_center, dz double precision, dimension(0:NX+1) :: dx, z_water_table, $ z_ice_sheet_base double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ por_melted,por_mobile, $ por_liquid, $ p_hydro, $ por_drained, por_dev, liquid_saturation, $ stress_litho double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_inv double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_Bubble_Types) :: $ bb_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1) :: $ column_mass, column_height double precision molwt(N_SL),beta(2), por_0(0:2), rho(N_Rho), $ sea_level integer, dimension(NX) :: iz_water_table integer nz, myid, numprocs, iter, iz do iter = 1, 10 call stack_em(z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid,por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, $ iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) do iz = nz, 1, -1 volume(1:NX,iz,ivol_solid) = volume(1:NX,iz,ivol_tot) $ * ( 1. - por_drained(1:NX,iz) ) volume(1:NX,iz,ivol_fluid) = volume(1:NX,iz,ivol_tot) $ * por_drained(1:NX,iz) enddo enddo call boundary_wrap_ghosts(volume(:,:,ivol_solid), $ myid,numprocs,NZ_Max) call boundary_wrap_ghosts(volume(:,:,ivol_fluid), $ myid,numprocs,NZ_Max) call boundary_wrap_ghosts(por_drained, $ myid,numprocs,NZ_Max) return end subroutine stack_em( $ z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz, myid, numprocs) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_top, z_center, dz double precision, dimension(0:NX+1) :: dx, z_water_table, $ z_ice_sheet_base double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ por_melted,por_mobile, $ por_liquid, $ p_hydro, $ por_drained, por_dev, liquid_saturation, $ stress_litho double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_inv double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_Bubble_Types) :: $ bb_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1) :: $ column_mass, column_height double precision molwt(N_SL),beta(2), por_0(0:2), rho(N_Rho) double precision sea_level integer, dimension(NX) :: iz_water_table integer myid, numprocs integer ix,iz,nz do ix = 1, NX call stack_column( ix, $ z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz) enddo return end subroutine stack_column( ix, $ z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz) c uses sl_inv to update the volumes of hydrate and ice, then takes primary input c from fluid, solid, and air volumes to calculate the vertical grid, porosities and c liquid saturation implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_top, z_center, dz double precision, dimension(0:NX+1) :: dx, z_water_table, $ z_ice_sheet_base double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ por_melted,por_mobile, $ por_liquid, $ p_hydro, $ por_drained, por_dev, liquid_saturation, $ stress_litho double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_inv double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_Bubble_Types) :: $ bb_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1) :: $ column_mass, column_height double precision molwt(N_SL),beta(2), por_0(0:2), rho(N_Rho) integer, dimension(NX) :: iz_water_table integer ix,iz,nz,i_vol double precision por_vol, total_pore, total_pore_solids, pore_vol double precision sea_level do iz=1,nz volume(ix,iz,ivol_hydrate) = $ molwt(i_Hydrate) $ * sl_inv(ix,iz,i_Hydrate) $ / rho(i_Hydrate) volume(ix,iz,ivol_hydrate_CO2) = $ molwt(i_Hydrate_CO2) $ * sl_inv(ix,iz,i_Hydrate_CO2) $ / rho(i_Hydrate_CO2) volume(ix,iz,ivol_ice) = $ molwt(i_Ice) * sl_inv(ix,iz,i_Ice) $ / rho(i_Ice) volume(ix,iz,ivol_tot) = 0.d0 do i_vol = 1, N_Vols-1 volume(ix,iz,ivol_tot) = volume(ix,iz,ivol_tot) $ + volume(ix,iz,i_vol) enddo por_melted(ix,iz) = ! for pressure / porosity calculation $ ( volume(ix,iz,ivol_fluid) $ + volume(ix,iz,ivol_air) $ + volume(ix,iz,ivol_ice) $ * rho(i_Ice) ! g/m3 -> g $ / rho(i_Seawater) ! m3 $ + volume(ix,iz,ivol_hydrate) ! m3 $ * rho(i_Hydrate) ! g/m3 -> g $ / rho(i_Seawater) ! m3 $ + volume(ix,iz,ivol_bubble) $ + volume(ix,iz,ivol_hydrate_CO2) ! m3 $ * rho(i_Hydrate_CO2) ! g/m3 -> g $ / rho(i_Seawater) ! m3 $ + volume(ix,iz,ivol_petro) $ ) $ / ( volume(ix,iz,ivol_tot) $ - volume(ix,iz,ivol_ice_sheet) $ ) c want this parameter to be unchanged by freezing ice or hydrate c#ifdef Thermal_Expansion_Porosity c $ * ( 1. + 2.e-4 * temperature(ix,iz,degC) ) c#endif c#ifdef Bubble_Pressure c $ + volume(ix,iz,ivol_bubble) c $ + volume(ix,iz,ivol_air) c $ + volume(ix,iz,ivol_petro) c#endif por_mobile(ix,iz) = ! for permeability $ ( volume(ix,iz,ivol_fluid) $ + volume(ix,iz,ivol_air) $ ) $ / volume(ix,iz,ivol_tot) por_liquid(ix,iz) = ! for solute concentrations $ volume(ix,iz,ivol_fluid) $ / volume(ix,iz,ivol_tot) dz(ix,iz) = volume(ix,iz,ivol_tot) / dx(ix) z_top(ix,iz) = z_top(ix,iz-1) + dz(ix,iz) z_center(ix,iz) = z_top(ix,iz-1) + dz(ix,iz)/2. enddo z_ice_sheet_base(ix) = z_top(ix,nz-1) $ + dz(ix,nz) $ / volume(ix,nz,ivol_tot) $ * ( volume(ix,nz,ivol_tot) $ - volume(ix,nz,ivol_ice_sheet) $ ) c Hydrology stuff. c iz_water_table is initialized in main setup, reset in advect, c affected by sea level rise here (nz+1 == submerged) if(z_top(ix,nz) .LT. sea_level) then iz_water_table(ix) = nz+1 else if( iz_water_table(ix) .EQ. nz+1 ) then iz_water_table(ix) = nz endif endif c diagnose z_water_table and liquid_saturation liquid_saturation(ix,:) = 1.d0 do iz = iz_water_table(ix), nz c operates on the volumes as the primary info store liquid_saturation(ix,iz) = volume(ix,iz,ivol_fluid) $ / ( volume(ix,iz,ivol_fluid) $ + volume(ix,iz,ivol_air) $ ) ! fraction water $ * ( volume(ix,iz,ivol_tot) $ - volume(ix,iz,ivol_ice_sheet) $ ) $ / volume(ix,iz,ivol_tot) ! scaled to non-sheet volume enddo ! iz if(z_ice_sheet_base(ix) .LT. sea_level) then z_water_table(ix) = sea_level else z_water_table(ix) = z_top( ix, iz_water_table(ix)-1 ) $ + liquid_saturation( ix, iz_water_table(ix) ) $ * dz(ix,iz_water_table(ix)) z_water_table(ix) = MAX(z_water_table(ix), sea_level) endif c top boundary dz(ix,nz+1) = 0.d0 ! dz(ix,nz) z_center(ix,nz+1) = z_center(ix,nz) + dz(ix,nz) / 2.d0 por_melted(ix,nz+1) = 1.d0 por_liquid(ix,nz+1) = 1.d0 p_hydro(ix,nz+1) = P_atm $ + ( MAX( sea_level ! say +1 $ - z_top(ix,nz), ! - (-2000) $ 0.d0 $ ) $ ) * 0.01 ! MPa stress_litho(ix,nz+1) = p_hydro(ix,nz+1) do iz = nz, 1, -1 p_hydro(ix,iz) = p_hydro(ix,iz+1) $ + ( volume(ix,iz+1,ivol_tot) / 2 ! m3 $ + volume(ix,iz,ivol_tot) / 2 ! m3 $ ) $ * liquid_saturation(ix,iz) ! to account for water table height $ * 1030. * 9.8 / 1.e6 ! Pa = kg / (m s2) !hydrostatic pressure is computed assuming this is all water $ / dx(ix) C the lithostatic overburden stress from Flemings uses the bulk density c for all the material above an element stress_litho(ix,iz) = stress_litho(ix,iz+1) !lithostatic overburden stress $ + ( $ ( volume(ix,iz+1,ivol_solid) ! m3 solid $ + volume(ix,iz,ivol_solid) ! m3 solid $ ) / 2.d0 $ * rho(i_Sediment) $ + ( volume(ix,iz+1,ivol_fluid) ! m3 solid $ + volume(ix,iz,ivol_fluid) ! m3 solid $ ) / 2.d0 $ * rho(i_Seawater) $ + ( volume(ix,iz+1,ivol_hydrate) ! m3 solid $ + volume(ix,iz,ivol_hydrate) ! m3 solid $ ) / 2.d0 $ * rho(i_Hydrate) $ + ( volume(ix,iz+1,ivol_hydrate_CO2) ! m3 solid $ + volume(ix,iz,ivol_hydrate_CO2) ! m3 solid $ ) / 2.d0 $ * rho(i_Hydrate_CO2) $ + ( volume(ix,iz+1,ivol_ice) ! m3 solid $ + volume(ix,iz,ivol_ice) ! m3 solid $ ) / 2.d0 $ * rho(i_Ice) $ + ( volume(ix,iz+1,ivol_petro) ! m3 solid $ + volume(ix,iz,ivol_petro) ! m3 solid $ ) / 2.d0 $ * rho(i_Ice) $ ) $ * 9.8 / 1.e9 $ / dx(ix) ! Pa = kg / (m s2) ! #ifdef MIN_STRESS_LITHO stress_litho(ix,iz) = $ MAX(stress_litho(ix,iz),p_hydro(ix,iz) $ + MIN_STRESS_LITHO) #endif enddo do iz=1,nz por_drained(ix,iz) = $ por_0(1) * exp( - beta(1) $ * ( stress_litho(ix,iz) $ - p_hydro(ix,iz) $ ) $ ) $ + por_0(2) * exp( - beta(2) $ * ( stress_litho(ix,iz) $ - p_hydro(ix,iz) $ ) $ ) enddo por_dev(ix,:) = por_melted(ix,:) - por_drained(ix,:) #ifdef Wrap_On_Update /* in subroutine stack_column */ call wrap_ghosts(dz,myid,numprocs,NZ_Max) call wrap_ghosts(z_top,myid,numprocs,NZ_Max) call wrap_ghosts(por_melted,myid,numprocs,NZ_Max) dont compile me im broken #endif return end subroutine fill_ghosts(dummy,nz) implicit none integer nz,ix,iz double precision dummy(0:NX+1,0:nz+1) dummy(:,0) = dummy(:,1) ! bedrock dummy(0,:) = dummy(1,:) ! left side dummy(NX+1,:) = dummy(NX,:) ! right side return end subroutine sediment_transport(sea_level, $ z_seafloor_global, dz_seafloor_global, $ x_global, dx_global, $ sedtrans_velocity, $ rain_frac, $ rho, por_0, $ particle_radius, tau_critical, sinking_rate, ! grid of size class $ diagnostic_ds2, $ sed_accum_rate, ! ix only $ tau_scour, $ seafloor_slope, seafloor_slope_2nd, $ sed_redeposit_frac, z_erosion_target, $ suspended_flux_tot, resuspended_flux_tot, $ deposit_flux_tot, redeposit_flux_tot, $ sl_frac, por_melted, $ nz, myid, numprocs) implicit none #ifdef MPI include 'mpif.h' #endif #define Smallest_Particle_Size 4.d-6 #define Largest_Particle_Size 40.d-6 #define Smallest_Particle_Conc 1.d0 #define Largest_Particle_Conc 2.d-2 c relative units of g/m3 or vol/vol #define ist_tot_suspended_flux 1 #define ist_tot_resuspended_flux 2 #define ist_tot_depositing_flux 3 #define ist_tot_redepositing_flux 4 #define ist_tot_redepositing_org_flux 5 #define ist_tot_resuspended_org_flux 6 c the first N_Diags_DS2 terms have to coincide with the ids2_ terms #define ist_redeposit_frac 7 #define ist_sedtrans_velocity 8 #define ist_tau_scour 9 #define ist_sea_floor_slope 10 #define ist_sea_floor_slope_2nd 11 #define ist_depo_domain 12 #define ist_accum_rate 13 #define ist_accum_rate_smoothed 14 #define ist_z_erosion_target 15 #define N_Local_DS 15 double precision sedtrans_velocity double precision :: rho(N_Rho), por_0(0:2) double precision, dimension(0:NX_Global+1,N_SL) :: $ rain_frac double precision, dimension(N_Size_Classes) :: $ particle_radius, tau_critical, sinking_rate, $ particle_radius_init double precision, dimension(0:NX+1, $ N_SL, 2, $ N_Diags_DS2) :: $ diagnostic_ds2 double precision, dimension(0:NX+1) :: $ tau_scour, seafloor_slope, seafloor_slope_2nd, $ sed_accum_rate, sed_surf_area_rain, $ sed_redeposit_frac, z_erosion_target, $ suspended_flux_tot, resuspended_flux_tot, $ deposit_flux_tot, redeposit_flux_tot double precision, dimension(0:NX_Global+1) :: $ x_global, dx_global, $ z_seafloor_global, dz_seafloor_global double precision sea_level, $ coastal_sediment_flux, river_depth, $ tot_suspended_conc, z_seafloor_target double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_frac double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ por_melted double precision, dimension(0:NX_Global+1,N_Local_DS) :: $ local_ds double precision, dimension( $ 0:NX_Global+1, $ N_SL, 2, $ N_Diags_DS2) :: $ local_ds2 double precision, dimension( $ N_SL, $ N_Diags_DS2) :: $ domain_tot double precision, dimension( $ 0:NX_Global+1,N_Diags_DS2) :: $ grid_point_tot double precision, dimension(0:NX_Global+1, $ N_SL) :: $ suspended_flux_global, $ suspended_frac_global, $ resuspended_flux_global, $ resuspended_frac_global, $ deposit_flux_global, $ deposit_frac_global, $ redeposit_flux_global, $ redeposit_frac_global, $ redeposit_org_flux_global, $ redeposit_org_frac_global, $ resuspended_org_flux_global, $ resuspended_org_frac_global, $ surf_sl_frac_global equivalence( local_ds2(0,1,ids2_flux,ids2_suspended), $ suspended_flux_global(0,1)) equivalence( local_ds2(0,1,ids2_frac,ids2_suspended), $ suspended_frac_global(0,1)) equivalence( local_ds2(0,1,ids2_flux,ids2_resuspended), $ resuspended_flux_global(0,1)) equivalence( local_ds2(0,1,ids2_frac,ids2_resuspended), $ resuspended_frac_global(0,1)) equivalence( local_ds2(0,1,ids2_flux,ids2_depositing), $ deposit_flux_global(0,1)) equivalence( local_ds2(0,1,ids2_frac,ids2_depositing), $ deposit_frac_global(0,1)) equivalence( local_ds2(0,1,ids2_flux,ids2_redepositing), $ redeposit_flux_global(0,1)) equivalence( local_ds2(0,1,ids2_frac,ids2_redepositing), $ redeposit_frac_global(0,1)) equivalence( local_ds2(0,1,ids2_flux,ids2_redeposit_org), $ redeposit_org_flux_global(0,1)) equivalence( local_ds2(0,1,ids2_frac,ids2_redeposit_org), $ redeposit_org_frac_global(0,1)) equivalence( local_ds2(0,1,ids2_flux,ids2_resuspended_org), $ resuspended_org_flux_global(0,1)) equivalence( local_ds2(0,1,ids2_frac,ids2_resuspended_org), $ resuspended_org_frac_global(0,1)) equivalence( local_ds2(0,1,ids2_frac,ids2_surf_sl), $ surf_sl_frac_global(0,1)) double precision :: depo_frac, $ tot_surf_area_sed, tot_surf_area_in, tot_sed_vol_in, $ tot_depo, scaled_frac_in, scaled_frac_sed double precision , dimension(NX,N_SL) :: $ sl_frac_dummy integer nz, myid, numprocs, ix, ierr, i_sl_sp, i_sl_c, $ i_sl_c_size, i_sl_cc, i_flux, ids2, i_sl_size #define UNDEFINED 0 #define LAND 1 #define EROSIONAL 2 #define DEPOSITIONAL 3 c i_sl_sp is used as a counter for variables that indices from 1:N_Size_Classes c i_sl_c is used for 1:N_SL including N_SL_Conc c i_sl is pointedly undefined to avoid ambiguity integer i_initialized /0/ save local_ds, local_ds2, i_initialized c Initialization Setup if(i_initialized .EQ. 0) then i_initialized = 1 tot_suspended_conc = 0.d0 do i_sl_sp = 1, N_Size_Spectrum + 1 ! for i_Pelagic i_sl_c = i_sl_sp - 1 + i_first_size_class particle_radius(i_sl_sp) = Smallest_Particle_Size $ * exp( (i_sl_sp-1) $ * LOG( Largest_Particle_Size $ / Smallest_Particle_Size $ ) ! e.g. factor of e -> 1 log unit $ / (N_Size_Spectrum-1) $ ) sinking_rate(i_sl_sp) = rho(i_Sediment) ! g/m3 $ * particle_radius(i_sl_sp)**2 ! g/m/s2 $ * 9.8d0 ! g $ / ( 18.d0 $ * rho(i_Seawater) $ * 1.4d-6 $ ) ! m/s suspended_frac_global(0,i_sl_c) = ! boundary condition at ix=0 $ Smallest_Particle_Conc $ * exp( (i_sl_sp-1) $ * LOG( Largest_Particle_Conc $ / Smallest_Particle_Conc $ ) ! e.g. factor of e -> 1 log unit $ / (N_Size_Spectrum-1) $ ) tot_suspended_conc = tot_suspended_conc $ + suspended_frac_global(0,i_sl_c) enddo c i_Pelagic and i_Aeolean suspended_frac_global(0, $ i_last_size_class+1:N_Size_Classes $ ) = 0.d0 suspended_frac_global(0,i_first_size_class:i_Pelagic) = $ suspended_frac_global(0,i_first_size_class:i_Pelagic) $ / tot_suspended_conc #ifdef Sediment_Homogenized suspended_frac_global(0,i_first_size_class) = 1 suspended_frac_global(0,i_first_size_class+1:i_Pelagic) = 0 #endif c needed for i_Pelagic to determine whether it will sediment sinking_rate(N_Size_Classes-1) = $ 100. / 86400. ! i_Pelagic ! apologies for the index mismatch, i_Pelagic itself wont work ! next reformulation separate size classes from chemical compositions do i_sl_sp = 1, N_Size_Spectrum + 2 ! for both tau_critical(i_sl_sp) = rho(i_Seawater) $ * sinking_rate(i_sl_sp)**2 enddo c needed for permeability calculations, both i_Pelagic and i_Aeolean particle_radius(N_Size_Classes-1:N_Size_Classes) = 1.d-5 resuspended_flux_global(0,:) = 0.d0 resuspended_frac_global(0,:) = 0.d0 endif ! initialized c suspended_flux_global and deposit_flux_global are both c defined on right-hand (exiting) faces coastal_sediment_flux = Coastal_Sediment_Flux ! m3 solid/(m coastline)/yr river_depth = 10.d0 do i_sl_c = i_first_size_class, i_last_size_class suspended_flux_global(0,i_sl_c) = $ suspended_frac_global(0,i_sl_c) $ * coastal_sediment_flux ! m3 solid / m antfarm year enddo #ifdef MPI sl_frac_dummy(1:NX,1:N_SL) = sl_frac(1:NX,nz,1:N_SL) call MPI_Gather(sl_frac_dummy(1:NX,1:N_SL),NX*N_SL, $ MPI_DOUBLE_PRECISION, $ surf_sl_frac_global(1:NX_Global,1:N_SL),NX*N_SL, $ MPI_DOUBLE_PRECISION, $ Master, MPI_COMM_WORLD,ierr) #else surf_sl_frac_global(1:NX,1:N_SL) = sl_frac(1:NX,nz,1:N_SL) #endif if(myid .EQ. Master) then local_ds(:,ist_accum_rate) = 0.d0 local_ds(:,ist_sea_floor_slope) = 0.d0 local_ds(:,ist_sea_floor_slope_2nd) = 0.d0 deposit_flux_global = 0.d0 redeposit_flux_global = 0.d0 resuspended_flux_global = 0.d0 c compute totals at ix=1 local_ds(0,1:N_Diags_DS2) = 0.d0 do i_sl_c = i_first_size_class, i_Pelagic do i_flux = 1, N_Diags_DS2 local_ds(0,i_flux) = local_ds(0,i_flux) $ + local_ds2(0,i_sl_c,ids2_flux,i_flux) enddo enddo local_ds(NX_Global+1,:) = local_ds(NX_Global,:) do ix = 1, NX_Global-1 local_ds(ix,ist_sea_floor_slope) = $ ( z_seafloor_global(ix+1) $ - z_seafloor_global(ix) $ ) $ / ( x_global(ix+1) $ - x_global(ix) $ ) ! m/m, fractional grade, -ve enddo do ix = 2, NX_Global-2 local_ds(ix,ist_sea_floor_slope_2nd) = $ ( z_seafloor_global(ix+2) $ + z_seafloor_global(ix+1) $ - z_seafloor_global(ix) $ - z_seafloor_global(ix-1) $ ) $ / ( x_global(ix+2) $ + x_global(ix+1) $ - x_global(ix) $ - x_global(ix-1) $ ) ! m/m, fractional grade, -ve enddo local_ds(NX_Global,ist_sea_floor_slope) = $ local_ds(NX_Global-1,ist_sea_floor_slope) local_ds(:,ist_sea_floor_slope) = $ - local_ds(:,ist_sea_floor_slope) #ifdef Sediment_Homogenized rain_frac(:,1) = 1 rain_frac(:,2:15) = 0 #endif do ix = 1, NX_Global c if(ix .EQ. 27) then c write(6,*) "booger", ix, c $ surf_sl_frac_global(27,16) c endif local_ds(ix,ist_depo_domain) = UNDEFINED c major options: land erosion, seafloor_erosion, c or size dependent deposition / winnowing. c each option needs to set c accum_rate, deposit_flux_global, redeposit_flux_global, c suspended_flux_global and resuspended_flux_global, for both size and chemical c fractions c deposit_flux_global and accum_rate etc. are not multiplied by T_Scale. local_ds(ix,ist_accum_rate) = 0.d0 deposit_flux_global(ix,:) = 0.d0 redeposit_flux_global(ix,:) = 0.d0 suspended_flux_global(ix,:) = 0.d0 resuspended_flux_global(ix,:) = 0.d0 local_ds(ix,ist_redeposit_frac) = 0.d0 c if(ix .EQ. 27) then c write(6,*) "starting out", ix, c $ z_seafloor_global(27)-sea_level, c $ z_seafloor_global(28)-sea_level c endif if( z_seafloor_global(ix) .GT. sea_level $ .OR. $ z_seafloor_global(ix+1) .GT. sea_level $ ) then local_ds(ix,ist_depo_domain) = LAND #ifdef Land_Deposition local_ds(ix,ist_accum_rate) = $ Land_Deposition ! m / yr c $ * tanh( ( z_seafloor_global(ix) c $ - sea_level c $ + 1.d0 ! 1 m no-mans zone c $ ) / 2.d0 ! meters transition zone c $ ) deposit_flux_global(ix,i_Aeolean) = ! m3 solid / m antfarm year $ local_ds(ix,ist_accum_rate) ! m total / year $ * dx_global(ix) ! m3 total/m coast year $ * ( 1 - por_0(0) ) ! m3 sol / m coast year deposit_flux_global(ix,i_POC) = $ deposit_flux_global(ix,i_Aeolean) $ * Land_Deposition_POC deposit_flux_global(ix,i_Bio_POC) = $ 0.5d0 * deposit_flux_global(ix,i_POC) deposit_flux_global(ix,i_POH) = $ 2.d0 * deposit_flux_global(ix,i_POC) deposit_flux_global(ix,i_POO) = $ deposit_flux_global(ix,i_POC) #endif #ifdef Land_Erosion local_ds(ix,ist_z_erosion_target) = sea_level local_ds(ix,ist_accum_rate) = ! < 0 for erosion $ ( local_ds(ix,ist_z_erosion_target) $ - z_seafloor_global(ix) $ ) $ * Land_Erosion_Tau ! m at por_0(0) do i_sl_c = i_first_size_class, i_Pelagic ! size fractions only deposit_flux_global(ix,i_sl_c) = ! m3 solid / m antfarm year $ local_ds(ix,ist_accum_rate) ! m total / year $ * dx_global(ix) ! m3 total/m coast year $ * ( 1 - por_0(0) ) ! m3 sol / m coast year $ * surf_sl_frac_global(ix,i_sl_c) ! m3 particular solid / m year c assumes uniform densities of different solid fractions enddo #endif suspended_flux_global(ix,:) = $ suspended_flux_global(ix-1,:) resuspended_flux_global(ix,:) = $ resuspended_flux_global(ix-1,:) else ! its underwater local_ds(ix,ist_depo_domain) = DEPOSITIONAL ! until proven otherwise local_ds(ix,ist_z_erosion_target) = $ z_seafloor_global(ix) #ifdef Seafloor_Erosion if(local_ds(ix,ist_sea_floor_slope) .GT. $ Seafloor_Slope_Critical ! first-order slope $ .AND. $ local_ds(ix,ist_sea_floor_slope) .GT. $ Seafloor_Slope_Critical ! second-order slope $ .AND. $ ix .LT. NX_Global) then ! too steep downhill seaward local_ds(ix,ist_depo_domain) = EROSIONAL local_ds(ix,ist_z_erosion_target) = $ z_seafloor_global(ix+1) ! say -1000 $ + Seafloor_Slope_Critical ! 0.06 $ * ( x_global(ix+1) $ - x_global(ix) $ ) ! dx positive. extrapolates right from offshore pt #ifdef Uphill_Too elseif(local_ds(ix-1,ist_sea_floor_slope) .LT. $ - Seafloor_Slope_Critical $ .AND. ix .GT. 1) then ! downhill landward local_ds(ix,ist_depo_domain) = EROSIONAL local_ds(ix,ist_z_erosion_target) = $ z_seafloor_global(ix-1) $ + Seafloor_Slope_Critical $ * ( x_global(ix) $ - x_global(ix-1) $ ) #endif endif #ifdef Topo_High_Erosion if(ix .GT. 1 .AND. ix .LT. NX_Global $ .AND. z_seafloor_global(ix) .GT. $ z_seafloor_global(ix-1) $ .AND. z_seafloor_global(ix) .GT. $ z_seafloor_global(ix+1) $ ) then local_ds(ix,ist_depo_domain) = EROSIONAL local_ds(ix,ist_z_erosion_target) = $ ( z_seafloor_global(ix-1) $ + z_seafloor_global(ix+1) $ ) / 2.d0 endif #endif #ifdef Erosion_Everywhere local_ds(ix,ist_depo_domain) = EROSIONAL local_ds(ix,ist_z_erosion_target) = $ z_seafloor_global(ix) $ - 1.d0 #endif #ifdef Jimmy_Erosion if(ix .EQ. 1) then local_ds(ix,ist_depo_domain) = EROSIONAL local_ds(ix,ist_z_erosion_target) = $ z_seafloor_global(ix) $ - 1.d0 else ! reset what may have been done above local_ds(ix,ist_depo_domain) = DEPOSITIONAL local_ds(ix,ist_z_erosion_target) = $ z_seafloor_global(ix) endif #endif #endif /* Seafloor_Erosion */ local_ds(ix,ist_tau_scour) = 1.d-2 ! arbitrary scaling factor . * 0.005d0 ! Cd . * rho(i_Seawater) $ * ( sedtrans_velocity $ * river_depth $ / ( sea_level $ - z_seafloor_global(ix) $ ) $ )**2 #ifdef Pelagic_Sedimentation suspended_flux_global(ix-1,i_Pelagic) = ! m3/m year $ Pelagic_Sedimentation ! m / yr $ * dx_global(ix) ! m3/m yr $ * ( 1 - por_0(0) ) ! m3 sol / m coast year #endif c Determine which size classes potentially deposit do i_sl_sp = 1, N_Size_Classes ! including i_Pelagic i_sl_c = i_sl_sp - 1 + i_first_size_class #ifdef Sediment_Dump_First_Cell local_ds(ix,ist_tau_scour) = 0.d0 #endif if( local_ds(ix,ist_tau_scour) $ .LT. tau_critical(i_sl_sp) $ ) then ! this size class deposits deposit_frac_global(ix,i_sl_c) = $ sinking_rate(i_sl_sp) ! m/yr $ * dx_global(ix) ! * m = m2/yr $ / sedtrans_velocity ! / m/yr = m $ / river_depth ! / m -> nondim $ * ( 1.d0 ! nondim scaling factor $ - ( local_ds(ix,ist_tau_scour) . ) $ / tau_critical(i_sl_sp) $ ) ! m3/m yr overall deposit_frac_global(ix,i_sl_c) = $ MIN( deposit_frac_global(ix,i_sl_c), $ 1.d0 ) redeposit_frac_global(ix,i_sl_c) = $ deposit_frac_global(ix,i_sl_c) #ifdef Turbidite_Redeposit_Slope if(local_ds(ix,ist_sea_floor_slope) .GT. $ Turbidite_Redeposit_Slope ) then redeposit_frac_global(ix,i_sl_c) = 0.d0 endif #endif #ifdef Resuspended_Forever redeposit_frac_global(ix,i_sl_c) = 0.d0 #endif #ifdef Sediment_Dump_First_Cell deposit_frac_global(ix,i_sl_c) = 1.d0 #endif #ifdef Sediment_Floats_Forever deposit_frac_global(ix,i_sl_c) = 0.d0 #endif #ifdef Sediment_Simple_Deposition deposit_frac_global(ix,i_sl_c) = 0.1d0 #endif if(local_ds(ix,ist_depo_domain) $ .EQ. DEPOSITIONAL) then deposit_flux_global(ix,i_sl_c) = $ suspended_flux_global(ix-1,i_sl_c) ! m3/m yr $ * deposit_frac_global(ix,i_sl_c) redeposit_flux_global(ix,i_sl_c) = $ resuspended_flux_global(ix-1,i_sl_c) $ * redeposit_frac_global(ix,i_sl_c) suspended_flux_global(ix,i_sl_c) = $ suspended_flux_global(ix-1,i_sl_c) ! m3/m yr $ * ( 1 - deposit_frac_global(ix,i_sl_c) ) ! settles out resuspended_flux_global(ix,i_sl_c) = $ resuspended_flux_global(ix-1,i_sl_c) ! m3/m yr $ * ( 1 - redeposit_frac_global(ix,i_sl_c) ) ! settles out else ! low-energy enough to deposit but too steep (EROSIONAL) suspended_flux_global(ix,i_sl_c) = $ suspended_flux_global(ix-1,i_sl_c) ! m3/m yr #ifdef POC_Sliding c resuspended what would have sedimented $ * ( 1 - deposit_frac_global(ix,i_sl_c) ) ! still settles out resuspended_flux_global(ix,i_sl_c) = $ resuspended_flux_global(ix-1,i_sl_c) ! m3/m yr $ + suspended_flux_global(ix-1,i_sl_c) ! m3/m yr $ * deposit_frac_global(ix,i_sl_c) ! converted to resusp. ! just added to resusp, ! needs to carry through from previous cells below #endif endif else ! potential resuspension of particular grain size #ifdef Winnowing /* this is off */ if( surf_sl_frac_global(ix,i_sl_c) .GT. 0.d0) then deposit_flux_global(ix,i_sl_c) = $ - Winnowing_Tau ! m / yr $ * ( local_ds(ix,ist_tau_scour) $ - tau_critical(i_sl_sp) $ )**2 $ * dx_global(ix) ! m3 / m ts $ * ( 1 - por_0(0) ) ! m3 sol / m coast year $ * surf_sl_frac_global(ix,i_sl_c) ! m3 partic sol / m ts endif #else deposit_flux_global(ix,i_sl_c) = 0.d0 #endif /* Winnowing */ redeposit_flux_global(ix,i_sl_c) = 0.d0 suspended_flux_global(ix,i_sl_c) = $ suspended_flux_global(ix-1,i_sl_c) ! just pass it on resuspended_flux_global(ix,i_sl_c) = $ resuspended_flux_global(ix-1,i_sl_c) $ - deposit_flux_global(ix,i_sl_c) ! would be negative #ifdef Winnowing do i_sl_cc = 1, N_SL_Conc would I want to include size fractionation of POC? enddo #endif endif ! deposition or erosion of particular grain size ! sets up deposit_flux up or down enddo ! size class if( local_ds(ix,ist_depo_domain) .EQ. EROSIONAL ) then ! wholesale erosion due to slope local_ds(ix,ist_z_erosion_target) = MAX( $ local_ds(ix,ist_z_erosion_target), $ z_seafloor_global(ix) $ - dz_seafloor_global(ix) $ - 1.d0 ! maintains this minimum thickness $ ) #ifdef Seafloor_Erosion local_ds(ix,ist_accum_rate) = ! < 0 for erosion $ ( local_ds(ix,ist_z_erosion_target) $ - z_seafloor_global(ix) $ ) ! say -1202 - 1200 = -2, neg accum rate $ * Seafloor_Erosion ! m at por_0(0) #endif do i_sl_c = i_first_size_class, N_SL ! not including chemistry deposit_flux_global(ix,i_sl_c) = ! m3 solid / m antfarm year $ local_ds(ix,ist_accum_rate) ! m total / year $ * dx_global(ix) ! m3 total/m coast year $ * ( 1 - por_0(0) ) ! m3 sol / m coast year $ * surf_sl_frac_global(ix,i_sl_c) ! m3 particular solid / m ts c assumes uniform densities of different solid fractions #define Erosion_Redeposition #ifdef Erosion_Redeposition resuspended_flux_global(ix, i_sl_c) = ! accumulates on stuff from above $ resuspended_flux_global(ix,i_sl_c) ! copied from ix-1 above $ - deposit_flux_global(ix,i_sl_c) ! this term is -ve #endif enddo else ! depositional, not erosional if(x_global(ix) .GT. Plate_Width) then deposit_flux_global(ix,:) = 0.d0 redeposit_flux_global(ix,:) = 0.d0 endif local_ds(ix,ist_accum_rate) = 0 do i_sl_c = i_first_size_class, i_Pelagic local_ds(ix,ist_accum_rate) = $ local_ds(ix,ist_accum_rate) $ + ( deposit_flux_global(ix,i_sl_c) ! m3 sol/m year $ + redeposit_flux_global(ix,i_sl_c) ! m3 sol/m year $ ) $ / dx_global(ix) ! m sol/year $ / ( 1 - por_0(0) ) ! m/year enddo endif ! depositional or erosional endif ! by land or by water c compute chemical fractions c start susp and resusp from ix = ix-1 values do i_sl_c = 1, N_SL_Conc suspended_flux_global(ix,i_sl_c) = $ suspended_flux_global(ix-1,i_sl_c) resuspended_flux_global(ix,i_sl_c) = $ resuspended_flux_global(ix-1,i_sl_c) enddo c compute the apparent suspended concentrations for a diagnostic do i_sl_c = 1, N_SL_Conc suspended_flux_global(ix-1,i_sl_c) = $ rain_frac(ix-1,i_sl_c) $ * local_ds(ix-1,ist_tot_suspended_flux) suspended_frac_global(ix-1,i_sl_c) = $ rain_frac(ix-1,i_sl_c) enddo c size stats for POC fractionation tot_surf_area_in = 0.d0 do i_sl_sp = 1, N_Size_Classes i_sl_c = i_sl_sp - 1 + i_first_size_class tot_surf_area_in = tot_surf_area_in $ + 1 / particle_radius(i_sl_sp) $ * local_ds2(ix-1,i_sl_c,ids2_frac, $ ids2_resuspended) enddo tot_sed_vol_in = 0.d0 do i_sl_sp = i_first_size_class, i_Pelagic tot_sed_vol_in = tot_sed_vol_in $ + resuspended_flux_global(ix-1,i_sl_sp) enddo c erosion on land or subsurface if(local_ds(ix,ist_accum_rate) $ .LT. 0.d0) then do i_sl_c = 1, N_SL deposit_flux_global(ix,i_sl_c) = ! m3 solid / m antfarm year $ local_ds(ix,ist_accum_rate) ! m total / year $ * dx_global(ix) ! m3 total/m coast year $ * ( 1 - por_0(0) ) ! m3 sol / m coast year $ * surf_sl_frac_global(ix,i_sl_c) ! m3 particular solid / m ts resuspended_flux_global(ix,i_sl_c) = $ resuspended_flux_global(ix,i_sl_c) $ - deposit_flux_global(ix,i_sl_c) c write(6,*) "surf_sl", i_sl_c, c $ surf_sl_frac_global(27,16) enddo endif c deal with sediment hitting the sea floor do i_sl_size = i_first_size_class, i_Pelagic i_sl_sp = i_sl_size - i_first_size_class + 1 do i_sl_c = 1, N_SL_Conc if(local_ds(ix,ist_accum_rate) .LE. 0.d0) then ! wholesale erosion #ifdef POC_Sliding suspended_flux_global(ix,i_sl_c) = $ suspended_flux_global(ix,i_sl_c) $ - deposit_frac_global(ix,i_sl_size) $ * suspended_flux_global(ix-1,i_sl_size) ! potential deposition $ * suspended_frac_global(ix-1,i_sl_c) resuspended_flux_global(ix,i_sl_c) = ! adds to inventory started above $ resuspended_flux_global(ix,i_sl_c) ! $ + deposit_frac_global(ix,i_sl_size) $ * suspended_flux_global(ix-1,i_sl_size) $ * suspended_frac_global(ix-1,i_sl_c) ! #endif else if( local_ds(ix,ist_depo_domain) .NE. LAND) then deposit_flux_global(ix,i_sl_c) = $ deposit_flux_global(ix,i_sl_c) ! incrementing $ + deposit_flux_global(ix,i_sl_size) ! deposition of size class $ * suspended_frac_global(ix-1,i_sl_c) ! * bulk poc no frac suspended_flux_global(ix,i_sl_c) = ! although this is overridden anyway $ suspended_flux_global(ix,i_sl_c) $ - deposit_flux_global(ix,i_sl_size) $ * suspended_frac_global(ix-1,i_sl_c) if( tot_sed_vol_in .GT. 0.d0 ) then if( i_sl_c .LE. N_POCs ) then scaled_frac_in = $ resuspended_flux_global( ix-1, $ i_sl_c ) $ / tot_sed_vol_in #ifdef Size_Fractionate_POC $ / particle_radius( i_sl_sp ) $ / tot_surf_area_in #endif else scaled_frac_in = $ resuspended_flux_global(ix-1,i_sl_c) $ / tot_sed_vol_in endif else scaled_frac_in = 0.d0 endif redeposit_flux_global(ix,i_sl_c) = ! poc etc $ redeposit_flux_global(ix,i_sl_c) $ + redeposit_flux_global(ix,i_sl_size) ! $ * scaled_frac_in resuspended_flux_global(ix,i_sl_c) = ! poc etc $ resuspended_flux_global(ix,i_sl_c) $ - redeposit_flux_global(ix,i_sl_size) ! $ * scaled_frac_in if( i_sl_c .EQ. i_POC ) then c the loading of POC per grain size resuspended_org_flux_global(ix, $ i_sl_size) = $ resuspended_flux_global(ix, $ i_sl_c) $ * scaled_frac_in c how carbon is depositing by grain size redeposit_org_flux_global(ix, $ i_sl_size) = $ redeposit_flux_global(ix,i_sl_size) $ * scaled_frac_in endif endif ! landslide or sub-sea (nonLand) deposition enddo ! i_sl_c enddo ! i_sl_size c compute totals suspended flux etc diagnostics local_ds(ix,1:N_Diags_DS1) = 0 do i_sl_c = i_first_size_class, i_Pelagic do i_flux = 1, N_Diags_DS2 local_ds(ix,i_flux) = local_ds(ix,i_flux) $ + local_ds2(ix,i_sl_c,ids2_flux,i_flux) enddo enddo c fractions from fluxes (diagnostics) do i_sl_c = 1, i_Pelagic do i_flux = 1, ids2_resuspended_org if(local_ds(ix,i_flux) .NE. 0) then local_ds2(ix,i_sl_c,ids2_frac,i_flux) = $ local_ds2(ix,i_sl_c,ids2_flux,i_flux) $ / local_ds(ix,i_flux) ! the total from the last loop c so should sum to one at any grid point. else local_ds2(ix,i_sl_c,ids2_frac,i_flux) = 0 endif enddo enddo c calculate what fraction of total accumulation comes from redeposition if( local_ds(ix, ids2_depositing) $ + local_ds(ix, ids2_redepositing) $ .NE. 0.d0 ) then local_ds(ix,ist_redeposit_frac) = $ local_ds(ix, ids2_redepositing) $ / ( local_ds(ix, ids2_depositing) $ + local_ds(ix, ids2_redepositing) $ ) else local_ds(ix,ist_redeposit_frac) = 0 endif enddo ! i_x #ifdef Sediment_Transport_Smoothed ! this is no longer relevant, as deposit_flux drives deposition do ix=2,NX_Global-1 local_ds(ix,ist_accum_rate_smoothed) = $ 0.25 * local_ds(ix-1,ist_accum_rate) $ + 0.5 * local_ds(ix,ist_accum_rate) $ + 0.25 * local_ds(ix+1,ist_accum_rate) enddo local_ds(:,ist_accum_rate) = $ local_ds(:,ist_accum_rate_smoothed) = #endif #ifdef Wedge_Limit_Accum do ix = 1, NX_Global if( x_global(ix) .GT. Plate_Xb ) then local_ds(ix,ist_accum_rate) = 0.d0 endif enddo #endif #ifdef Trench do ix = 1, NX_Global if( x_global(ix) .GT. Plate_Width ) then local_ds(ix,ist_accum_rate) = 0.d0 endif enddo #endif domain_tot = 0.d0 do ix=1, NX_Global do ids2 = 1, N_Diags_DS2 do i_sl_c = i_first_size_class, i_Pelagic domain_tot(i_first_size_class,ids2) = $ domain_tot(i_first_size_class,ids2) $ + local_ds2(ix,i_sl_c,ids2_flux,ids2) enddo enddo do ids2 = 1, 4 d o i_sl_c = 1, N_SL_Conc domain_tot(i_sl_c,ids2) = $ domain_tot(i_sl_c,ids2) $ + local_ds2(ix,i_sl_c,ids2_flux,ids2) c total deposition of each chemical fraction enddo enddo enddo #ifdef Booger #ifdef MPI c if(myid .EQ. 2) then ! .AND. ix .EQ. 27) then c if(sed_accum_rate(7) .LT. 0.d0) then write(6,*) "in sediment_transport mpi", myid, c $ sed_accum_rate(7), c $ diagnostic_ds2(7,i_Aeolean, c $ ids2_flux,ids2_depositing) $ local_ds(27,ist_accum_rate), $ local_ds2(27,i_Aeolean,ids2_flux,ids2_depositing) call flush(6) c endif c endif #else c if(sed_accum_rate(27) .LT. 0.d0) then c if(ix .EQ. 27) then write(6,*) "in sediment_transport single cpu", $ local_ds(27,ist_accum_rate), $ local_ds2(27,i_Aeolean,ids2_flux,ids2_depositing) call flush(6) c endif #endif #endif endif ! Master #ifdef MPI call MPI_Bcast(local_ds,(NX_Global+2)*N_Local_DS, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD, ierr) call MPI_Bcast(local_ds2, $ (NX_Global+2)*N_SL*2*N_Diags_DS2, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD, ierr) #ifdef MPIStdOut write(6,*) "MPI_Bcast 3717", myid call flush(6) #endif #endif diagnostic_ds2(1:NX,:,:,:) = $ local_ds2(1+myid*NX:NX+myid*NX,:,:,:) sed_accum_rate(1:NX) = $ local_ds(1+myid*NX:NX+myid*NX,ist_accum_rate) ! m / year tau_scour(1:NX) = $ local_ds(1+myid*NX:NX+myid*NX,ist_tau_scour) seafloor_slope(1:NX) = $ local_ds(1+myid*NX:NX+myid*NX,ist_sea_floor_slope) seafloor_slope_2nd(1:NX) = $ local_ds(1+myid*NX:NX+myid*NX,ist_sea_floor_slope_2nd) sed_redeposit_frac(1:NX) = $ local_ds(1+myid*NX:NX+myid*NX,ist_redeposit_frac) z_erosion_target(1:NX) = $ local_ds(1+myid*NX:NX+myid*NX,ist_z_erosion_target) suspended_flux_tot(1:NX) = $ local_ds(1+myid*NX:NX+myid*NX,ist_tot_suspended_flux) resuspended_flux_tot(1:NX) = $ local_ds(1+myid*NX:NX+myid*NX,ist_tot_resuspended_flux) deposit_flux_tot(1:NX) = $ local_ds(1+myid*NX:NX+myid*NX,ist_tot_depositing_flux) redeposit_flux_tot(1:NX) = $ local_ds(1+myid*NX:NX+myid*NX,ist_tot_redepositing_flux) c if(myid .EQ. Master) then c write(6,*) z_seafloor_global(26:28) c endif return end subroutine blake_ridge_accum(z_top, dx, $ t_now, myid, $ sed_accum_rate) implicit none double precision z_top(0:NX+1,0:NZ_Max), dx(0:NX+1), $ t_now, sed_accum_rate(0:NX+1) integer ix, myid z_top(:,0) = -500.d0 $ + t_now / DT_Scenario $ * 3000.d0 do ix=1,NX sed_accum_rate(ix) = $ 1000.d-8 * T_Scale ! m / yr $ + exp( - ( ( ( $ ( ix #ifdef MPI $ + myid * NX #endif $ ) $ * dx(1) $ - ( 15.d4 $ ) $ ) $ / 60.d3 $ )**2 $ ) $ ) $ * 2000.d-8 * T_Scale enddo return end #ifdef Accrete subroutine sediment_smashup(lithosphere, rho, $ z_top, z_seafloor_global, $ ocean_frac_global, sedcol_youngs_mod_global, $ column_height, freeboard_eq, $ dt, nz, $ myid, numprocs, $ sedcol_youngs_mod, sedcol_u, $ d_sedcol_u_dx, sedcol_thickening, $ sedcol_conv_dieqdt, $ x, dx, x_global, dx_global) implicit none #ifdef MPI include 'mpif.h' #endif double precision, dimension(0:NX+1,N_Lith_Slabs,N_Lith_Vars) :: $ lithosphere double precision rho(N_Rho) double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_top double precision :: dt integer nz, myid, numprocs, ix, i_wall double precision, dimension(0:NX+1) :: $ sedcol_smashup, sedcol_u, sedcol_youngs_mod, $ d_sedcol_u_dx, sedcol_thickening, $ sedcol_conv_dieqdt, $ freeboard_eq, column_height, $ x, dx double precision, dimension(0:NX_Global+1) :: $ x_global, dx_global, $ z_seafloor_global, ocean_frac_global c internal variables double precision :: subduction_rate, sedcol_u_x0, $ dx_logged, x_init double precision, dimension(0:NX_Global+1) :: $ sedcol_youngs_mod_global, $ sedcol_u_global, d_sedcol_u_dx_global, $ sedcol_h_global double precision, dimension(NX) :: sedcol_h integer ierr, i_iter integer i_initialized / 0 / c#define Sed_Column_U_Smoothed #ifdef Sed_Column_U_Smoothed double precision weight integer ixx #endif save x_init, $ dx_logged, i_initialized if (i_initialized .EQ. 0) then do ix = 1, NX_Global sedcol_youngs_mod_global(ix) = Sed_Youngs_Modulus $ * ( 1 $ + Youngs_amplitude $ * sin( $ x_global(ix) $ / Youngs_wavelength $ * 2 * 3.14 $ ) $ ) enddo x_init = x_global(NX_Global) dx_logged = 0.d0 i_initialized = 1 endif c fill in if the grid has shifted if(sedcol_youngs_mod_global(NX_Global-1) .EQ. $ sedcol_youngs_mod_global(NX_Global) ) then sedcol_youngs_mod_global(NX_Global) = Sed_Youngs_Modulus $ * ( 1 $ + Youngs_amplitude $ * sin( ( x_global(NX_Global) $ - dx_logged $ ) $ / Youngs_wavelength $ * 2 * 3.14 $ ) $ ) endif subduction_rate = Plate_Velocity ! m / yr $ * dt ! m / timestep $ * T_Scale sedcol_h(1:NX) = z_top(1:NX,nz) - z_top(1:NX,0) #ifdef MPI call MPI_Gather(sedcol_h(1:NX),NX,MPI_DOUBLE_PRECISION, $ sedcol_h_global(1:NX_Global),NX,MPI_DOUBLE_PRECISION, $ Master, MPI_COMM_WORLD,ierr) #else sedcol_h_global(1:NX) = sedcol_h(1:NX) #endif if(myid .EQ. Master) then i_wall = 1 #ifdef Wall_in_the_Trough do ix = NX_Global, 1, -1 ! takes the shoreward-most downhill bit if( z_seafloor_global(ix+1) .GT. $ z_seafloor_global(ix) $ .AND. $ x_global(ix) .LT. Plate_Xb $ ) then i_wall = ix endif enddo #endif #ifdef Wedge do ix = NX_Global, 1, -1 ! takes the shoreward-most positive one if( x_global(ix) .GT. 0.d0 $ ) then i_wall = ix endif enddo #endif #ifdef Trench sedcol_u_global = 0.d0 #endif #ifdef Wedge sedcol_u_x0 = subduction_rate * Sedcol_U_Out_Frac #endif #ifdef Wedge_No_Scrapeoff sedcol_u_x0 = subduction_rate #endif i_wall = 1 c fix the value from the left to i_wall do ix = 1, i_wall sedcol_u_global(ix) = sedcol_u_x0 $ + sedcol_youngs_mod_global(ix) $ * x_global(ix) ! +vs, the amount of the box greater than x=0 $ * ( subduction_rate $ - sedcol_u_x0 $ ) $ / sedcol_h_global(ix) #ifdef Sed_Pushback_Thickness $ * ( 1.d0 $ - sedcol_h_global(ix) $ / Sed_Pushback_Thickness $ ) #endif enddo c work outward to the right do ix = i_wall+1, NX_Global if(x_global(ix) .LT. Plate_Max_Deform_Zone) then sedcol_u_global(ix) = ! m / yr $ sedcol_u_global(ix-1) $ + sedcol_youngs_mod_global(ix) $ * dx_global(ix) $ * ( subduction_rate $ - sedcol_u_global(ix-1) $ ) $ / sedcol_h_global(ix-1) #ifdef Sed_Pushback_Thickness $ * ( 1.d0 $ - sedcol_h_global(ix-1) $ / Sed_Pushback_Thickness $ ) #endif else sedcol_u_global(ix) = ! m / yr $ sedcol_u_global(ix-1) endif enddo sedcol_u_global = MIN(sedcol_u_global, $ 2*subduction_rate) sedcol_u_global = MAX(sedcol_u_global, $ 0.d0) sedcol_u_global = - sedcol_u_global do ix = 1, NX_Global d_sedcol_u_dx_global(ix) = $ ( sedcol_u_global(ix) $ - sedcol_u_global(ix-1) $ ) / dx_global(ix) ! for diagnostic output c write(6,'(i3,5f12.4)') c $ ix, sedcol_u_global(ix), c $ subduction_rate + sedcol_u_global(ix-1), c $ z_seafloor_global(ix), c $ d_sedcol_u_dx_global(ix)*100., c $ dx_global(ix) enddo endif #ifdef MPI call MPI_Bcast(sedcol_youngs_mod_global, NX_Global+2, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) call MPI_Bcast(sedcol_u_global, NX_Global+2, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) call MPI_Bcast(d_sedcol_u_dx_global, NX_Global+2, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) #endif sedcol_youngs_mod(0:NX+1) = $ sedcol_youngs_mod_global(0+myid*NX:NX+1+myid*NX) ! still m/yr sedcol_u(0:NX+1) = $ sedcol_u_global(0+myid*NX:NX+1+myid*NX) ! still m/yr d_sedcol_u_dx(1:NX) = $ d_sedcol_u_dx_global(1+myid*NX:NX+myid*NX) $ / dt ! now in (squidge) per year do ix = 1, NX sedcol_thickening(ix) = - d_sedcol_u_dx(ix) $ * ( z_top(ix,nz) - z_top(ix,0) ) ! m / yr diagnostic sedcol_conv_dieqdt(ix) = sedcol_thickening(ix) $ * freeboard_eq(ix) / column_height(ix) enddo if(myid .EQ. Master) then do ix = 0, NX_Global+1 x_global(ix) = x_global(ix) $ + ( sedcol_u_global(ix) #ifdef Trench $ - sedcol_u_global(0) #endif $ ) enddo dx_logged = dx_logged - sedcol_u_global(NX_Global) do ix = 1, NX_Global dx_global(ix) = x_global(ix) - x_global(ix-1) enddo #define Smashup_LH_BC #ifdef Smashup_LH_BC dx_global(1) = 2 * dx_global(2) - dx_global(3) x_global(1) = x_global(2) - dx_global(2) #endif #ifdef Cont_Crust_DX c recenter on x=0 at i_continent_edge x_global(:) = x_global(:) $ - x_global(1) $ - Cont_Crust_DX #endif endif #ifdef MPI call MPI_Bcast(x_global, NX_Global+2, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) call MPI_Bcast(dx_global, NX_Global+2, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) x(0:NX+1) = x_global(0+myid*NX:NX+1+myid*NX) dx(0:NX+1) = dx_global(0+myid*NX:NX+1+myid*NX) #else x(0:NX+1) = x_global(0:NX+1) dx(0:NX+1) = dx_global(0:NX+1) #endif #ifdef Crust_Transition_Width lithosphere(:,OceanCrust,il_Ocean_Fraction) = $ 0.5 $ - ATAN( - x(:) $ / Crust_Transition_Width ! meters $ ) / 3.14 #ifdef MPI call MPI_Gather(lithosphere(1:NX, $ OceanCrust, $ il_Ocean_Fraction), $ NX,MPI_DOUBLE_PRECISION, $ ocean_frac_global(1:NX_Global), $ NX,MPI_DOUBLE_PRECISION, $ Master,MPI_COMM_WORLD,ierr) call MPI_Bcast(ocean_frac_global(1:NX_Global), NX_Global, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD,ierr) #endif /* MPI */ #endif /* Crust_Transition_Width */ lithosphere(:,OceanCrust,il_Age) = $ MAX( ( Plate_Width - x(:) ) $ / Plate_Velocity, $ Ocean_Crust_Min_Age $ ) do ix = 1, N_Lith_Vars-1 lithosphere(:,MeanCrust,ix) = $ lithosphere(:,OceanCrust,ix) $ * lithosphere(:,OceanCrust,il_Ocean_Fraction) $ + lithosphere(:,ContCrust,ix) $ * (1.d0 - lithosphere(:,OceanCrust,il_Ocean_Fraction)) enddo return end #endif /* Accrete */ subroutine find_timedep_drivers(t_now, dt_run, $ sea_level, surface_conc, $ ocean_oxic_state, ocean_temperature_offset, $ air_temp_sea_level) implicit none double precision t_now, dt_run, sea_level, $ ocean_oxic_state, ocean_temperature_offset, $ clock, air_temp_sea_level, $ surface_conc(0:NX+1, N_PW) double precision t_start, t_since, t_prime clock = 0 sea_level = 0 ocean_oxic_state = 3.d0 #ifdef East_Coast_POC_Interp ocean_oxic_state = 1 #endif #ifdef West_Coast_POC_Interp ocean_oxic_state = 2 #endif #ifdef Anoxic_POC_Interp ocean_oxic_state = 4 #endif ocean_temperature_offset = 0.d0 air_temp_sea_level = Air_Temp_Base #ifdef Geologic_Sea_Level_Cycles_Accel clock = sin( t_now * T_Scale $ / (DT_Scenario/3) ! 3) $ * 3.14 $ + 1.57 $ ) ! 1 -1 1 -1 1 sea_level = 150. * clock ! starts high ! clock=1 at t=0, sl=150 which means low sea level ocean_oxic_state = 3 - clock ocean_temperature_offset = 12.d0 * ( clock+1 ) / 2 #endif #ifdef Geologic_Sea_Level_Cycles_Haq clock = sin( t_now * T_Scale $ / 120.d6 $ * 3.14 $ + 2 ! 1.57 $ ) ! goes 1@0(low), -1@60(high), 1@120 sea_level = -150. * clock ! positive upward, -150 150 -150 lo hi lo ocean_oxic_state = 2.5 - clock ! Pacific / OMZ to OMZ / anoxic and back #ifdef Atlantic ocean_oxic_state = 2.5 - clock ! Atl to OMZ #endif ocean_temperature_offset = 6.d0 * ( 1-clock ) ! 0 +12 0 Zachos 12C hotter max #endif #ifdef Quaternary_Sea_Level_Cycles #define Ice_Age_Duration 1.d5 #define Ice_Age_Ramp_T1 0.7 #define Ice_Age_Ramp_T2 0.9 if(t_now * T_Scale $ .GT. Quaternary_Sea_Level_Cycles) then c clock = cos( ( t_now * T_Scale c $ - Quaternary_Sea_Level_Cycles c $ ) c $ / 1.d5 ! 100 kyr cycles c $ * 3.14 c $ + 1.57 c $ ) ! 0 1 0 -1 0 1 ... c clock = 1 - ( clock+1 )/2 ! 0 1 0 1 c c T2 c 0 1 c c T1 t_since = MOD( t_now * T_Scale - Quaternary_Sea_Level_Cycles, $ Ice_Age_Duration ) ! years if( t_since / Ice_Age_Duration ! 0-1 $ .LT. Ice_Age_Ramp_T1) then ! initial glide down t_prime = t_since ! years $ / ( Ice_Age_Duration * Ice_Age_Ramp_T1 ) ! 0-1 within phase sea_level = t_prime * Ice_Age_Low_SL else if( t_since / Ice_Age_Duration ! 0 - 1 $ .LT. Ice_Age_Ramp_T2) then ! ramping up t_prime = ( t_since / Ice_Age_Duration $ - Ice_Age_Ramp_T1 $ ) ! .7 - .9 $ / ( Ice_Age_Ramp_T2 - Ice_Age_Ramp_T1 ) ! now 0 - 1 sea_level = t_prime * Ice_Age_High_SL $ + ( 1 - t_prime ) * Ice_Age_Low_SL else ! third phase t_prime = ( t_since / Ice_Age_Duration ! .9 - 1 $ - Ice_Age_Ramp_T2 $ ) $ / ( 1.d0 - Ice_Age_Ramp_T2 ) ! now 0 - 1 sea_level = ( 1.d0 - t_prime ) $ * Ice_Age_High_SL endif c write(6,*) t_now, t_since, clock ocean_temperature_offset = ocean_temperature_offset $ - sea_level ! +120 to -20 $ / Ice_Age_Low_SL ! -1 to +0.2 $ * Ice_Age_Ocean_Temp_Cyc air_temp_sea_level = Air_Temp_Base $ - sea_level ! +120 to -20 $ / Ice_Age_Low_SL ! -1 to +0.2 $ * Ice_Age_Atm_Temp_Cyc endif #endif #ifdef Tectonic_Bouncing_Sea_Level clock = sin( t_now * T_Scale $ / 1.d6 ! 1e6 yr cycles $ * 3.14 $ ) ! 0 1 0 -1 sea_level = sea_level $ - 20. * clock #endif #ifdef Step_Sea_Level_Change if(t_now * T_Scale $ .GT. Step_Sea_Level_Change_Time ) then sea_level = sea_level + Step_Sea_Level_Change endif #endif #ifdef Global_Warming if(t_now * T_Scale $ .GT. Global_Warming) then t_since = t_now * T_Scale - Global_Warming clock = ( 0.15 * exp( - t_since / 5.d3 ) $ + 0.1 * exp( - t_since / 400.d3 ) $ ) $ * 5000.d0 ! Gton burn $ / 2.d0 ! ppm $ + 280.d0 ! ppm total clock = log(clock / 280.d0) / log(2.d0) ! doublings ocean_temperature_offset = ocean_temperature_offset $ + 3.d0 ! climate sensitivity dt2x $ * clock air_temp_sea_level = air_temp_sea_level $ + 3.d0 ! climate sensitivity dt2x $ * 2.d0 ! polar amplification $ * clock endif #endif #ifdef i_Delta18O surface_conc(:,i_Delta18O) = 0.d0 + 2.5 $ * sea_level $ / Icy_sea_level #endif #ifdef i_Sal surface_conc(:,i_Sal) = $ 35.d0*(1.d0-sea_level/4.d3) #endif return end subroutine find_surface_temp(z_top, $ sea_level, ocean_temperature_offset, air_temp_sea_level, $ surface_temp, surface_conc, nz) implicit none integer nz, nz_wc parameter(nz_wc=4) double precision, dimension(nz_wc) :: wc_t, wc_depth double precision dt, t_now, dt_run, sea_level, ocean_oxic_state, $ z_top(0:NX+1), $ surface_temp(0:NX+1),surface_conc(0:NX+1,N_PW), $ ocean_temperature_offset, air_temp_sea_level integer i_initialized / 0 / integer ix, iz save data wc_depth / $ 0, 300, 2000, 5000 / data wc_t / $ 15, 6, 2.5, 1 / #ifdef Mackenzie wc_t = 0.d0 #endif #ifdef Laptev wc_t = 0.d0 #endif do ix = 1, NX if(z_top(ix) .LT. sea_level) then ! submerged call depth_interp(wc_t, wc_depth, z_top(ix),nz_wc, $ surface_temp(ix)) surface_conc(ix,i_Sal) = Ocean_Sal surface_conc(ix,i_SO4) = Ocean_SO4 else ! exposed surface_temp(ix) = air_temp_sea_level $ - ( z_top(ix) - sea_level ) $ * 6.d-3 ! 6 deg / km lapse rate surface_conc(ix,i_Sal) = 0.1d0 surface_conc(ix,i_SO4) = 0.0d0 endif enddo surface_temp = surface_temp + ocean_temperature_offset #ifdef Ocean_Temp_Offset $ + Ocean_Temp_Offset #endif return end subroutine find_POC_rain_fraction(ocean_oxic_state, $ z_seafloor_global, sea_level, $ rain_frac) implicit none #ifdef MPI include 'mpif.h' #endif double precision ocean_oxic_state double precision, dimension(0:NX_Global+1) :: $ z_seafloor_global double precision, dimension(0:NX_Global+1,N_SL) :: $ rain_frac double precision sea_level integer ix,iz,is,isc double precision, dimension(N_Oc_Z,N_OcS) :: $ data_z double precision, dimension(N_Oc_Z,N_OcS,N_Oc_Props) :: $ data_props double precision, dimension(0:NX_Global+1,N_OcS,N_Oc_Props) :: $ data_zinterp double precision, dimension(0:NX_Global+1,N_Oc_Props) :: $ data_sinterp integer i_initialized / 0 / save data data_z / $ 0, 700, 1200, 3300, /* East_Coast */ $ 0, 300, 2500, 3300, /* West_Coast */ $ 0, 100, 2500, 3300, /* Strong_OMZ */ $ 0, 100, 2500, 3300 / /* Anoxic */ data data_props / $ 0.5, 2., 2., 1, /* East_Coast */ /* POC in percent */ $ 0.5, 2.5, 2.5, 1, /* West_Coast */ $ 1, 3, 3, 1, /* Strong_OMZ */ $ 1.5, 5, 5, 2, /* Anoxic */ $ 0.35, 1.4, 1.4, 0.7, /* East_Coast 0.7 */ /* POH */ $ 0.6, 2.75, 2.75, 1.2, /* West_Coast 1.2 */ $ 1.5, 4.5, 4.5, 1.5, /* Strong_OMZ 1.5 */ $ 3., 10, 10, 4, /* Anoxic 2 */ $ .05, .2, .2, .1, /* East_Coast .1 */ /* POO */ $ .05, .25, .25, .1, /* West_Coast .1 */ $ .075, .225, .225, .075, /* Strong_OMZ .075 */ $ 0.075, .25, .25, 0.1 / /* Anoxic .05 */ isc = ocean_oxic_state ! truncate to integer below isc = MIN(isc,N_OcS) rain_frac = 0.d0 do ix=1,NX_Global if( z_seafloor_global(ix) .GT. sea_level) then #ifdef Land_Deposition rain_frac(ix,i_POC) = Land_Deposition_POC rain_frac(ix,i_POH) = 2.d0 * Land_Deposition_POC rain_frac(ix,i_POO) = Land_Deposition_POC #endif else ! interpolate ocean profiles do is = 1, N_OcS data_zinterp(ix,is,:) = ! defaults to abyssal value $ data_props(N_Oc_Z,is,:) do iz = 1, N_Oc_Z-1 if( sea_level - z_seafloor_global(ix) .GT. $ data_z(iz,is) .AND. ! say 200 gt 0 $ sea_level - z_seafloor_global(ix) .LT. $ data_z(iz+1,is)) then c it is in between iz and iz+1 data_zinterp(ix,is,:) = $ data_props(iz,is,:) ! value at iz $ + ( data_props(iz+1,is,:) $ - data_props(iz,is,:) $ ) ! delta C $ / ( data_z(iz+1,is) $ - data_z(iz,is) $ ) ! delta Z $ * ( sea_level $ - z_seafloor_global(ix) $ - data_z(iz,is) $ ) endif ! its in the right iz enddo ! iz enddo ! is data_sinterp(ix,:) = data_zinterp(ix,isc,:) $ + ( data_zinterp(ix,isc+1,:) $ - data_zinterp(ix,isc,:) $ ) ! delta c $ * ( ocean_oxic_state - isc ) rain_frac(ix,i_POC) = $ data_sinterp(ix,Oc_POC_frac) $ / 100.d0 rain_frac(ix,i_POH) = $ data_sinterp(ix,Oc_POH_frac) $ / 100.d0 rain_frac(ix,i_POO) = $ data_sinterp(ix,Oc_POO_frac) $ / 100.d0 #ifdef POC_Imposed rain_frac(ix,i_POC) = POC_Imposed #endif endif ! below sea level rain_frac(ix,i_Bio_POC) = $ rain_frac(ix,i_POC) $ * Bio_POC_Frac rain_frac(ix,i_Montmorillonite) = 0.4 rain_frac(ix,i_CaCO3) = 0.1 rain_frac(ix,i_Quartz) = 0.5 $ - rain_frac(ix,i_POC) enddo ! ix return end #ifdef Muds_Interp subroutine find_POC_rain_fraction_muds( $ z_top, sea_level, $ sed_surf_area_rain, pw_conc, $ poc_rain_frac, $ t_now) implicit none integer nz_muds,no2_muds,nfields_muds parameter(nz_muds=32,no2_muds=40,nfields_muds=2) double precision, dimension(nz_muds,no2_muds,2) :: muds_array double precision o2_muds(no2_muds), depth_muds(nz_muds), $ wc_o2(nz_muds), wc_t(nz_muds), bw_o2(NX) double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc double precision, dimension(0:NX+1) :: z_top, $ sed_surf_area_rain, $ poc_rain_frac double precision t_now double precision poc_max, poc_abyss double precision sea_level integer ix integer i_initialized / 0 / save if (i_initialized .EQ. 0) then call read_wc_file( $ "wc_t.txt", $ wc_o2, wc_depth,nz_muds) call read_muds_files(muds_array,o2_muds,depth_muds, $ NZ_Muds,NO2_Muds,nfields_muds) if(t_now .LE. T_End_Anoxia) then bw_o2 = 0.d0 endif i_initialized = 1 endif do ix=1,NX if(z_top(ix) .LT. sea_level) then ! submerged call depth_interp(wc_o2,depth_muds,z_top(ix),nz_muds, $ bw_o2(ix)) call muds_interp(muds_array,depth_muds,o2_muds, $ nz_muds,no2_muds,nfields_muds, $ z_top(ix), bw_o2(ix), $ poc_rain_frac(ix), pw_conc(ix,nz+1,i_SO4)) endif enddo if(t_now .LE. T_End_Anoxia) then bw_o2 = 0.d0 endif return end #endif subroutine find_p_excess( ix, ! updates only in column ix, for sub-looping $ p_excess, p_supp, p_hydro, p_fluid, p_gas, $ por_melted, fluid_buoy, stress_litho, $ por_0, beta, $ dpsupp_dpor, $ dz, temperature, $ nz ) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ dz, $ p_excess, p_supp, p_hydro, p_fluid, p_gas, por_melted, $ fluid_buoy, stress_litho, dpsupp_dpor double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision por_0(0:2), beta(2) #ifdef DoubleExpPor double precision p_high, p_low, por_test, $ p_last, por_last #endif integer ix,iz,iter,nz,myid,numprocs p_excess(:,nz+1) = 0.d0 #ifdef Fluid_Buoy fluid_buoy(:,nz+1) = 0. #endif do iz = nz, 1, -1 #ifdef DoubleExpPor p_high = ( stress_litho(ix,iz) $ - p_hydro(ix,iz) $ ) * 10 ! some headroom allows negative pressures p_low = 0. p_supp(ix,iz) = 0.d0 por_test = 0.d0 if(por_melted(ix,iz) .GT. 0) then do iter=1,35 p_last = p_supp(ix,iz) por_last = por_test p_supp(ix,iz) = ( p_high + p_low ) / 2 por_test = $ por_0(1) * exp( - beta(1) * p_supp(ix,iz) ) $ + por_0(2) * exp( - beta(2) * p_supp(ix,iz) ) c if(ix .EQ. 1) then c write(6,'(3i3,5G12.4)') ix,iz,iter, p_low, p_supp, c $ p_high, por_test- por_melted(ix,iz) c endif if(por_test .GT. por_melted(ix,iz) ) then p_low = p_supp(ix,iz) else p_high = p_supp(ix,iz) endif enddo p_excess(ix,iz) = c $ MAX( 0.d0, $ stress_litho(ix,iz) - p_supp(ix,iz) $ - p_hydro(ix,iz) c $ ) if( por_test - por_last .NE. 0.d0 ) then dpsupp_dpor(ix,iz) = ( p_supp(ix,iz) - p_last ) $ / ( por_test - por_last ) else dpsupp_dpor(ix,iz) = 0.d0 endif else ! porosity = 0 p_excess(ix,iz) = 0. endif #else c not DoubleExpPor p_excess(ix,iz) = $ log( por_melted(ix,iz) $ / por_drained(ix,iz) $ ) / beta(1) ! MPa = 1E6 kg / (m s2) #endif #ifdef Fluid_Buoy fluid_buoy(ix,iz) = fluid_buoy(ix,iz+1) $ + ( dz(ix,iz) / 2 ! m $ * temperature(ix,iz,degC) ! deg. C $ + dz(ix,iz+1) / 2 ! m $ * temperature(ix,iz+1,degC) ! deg. C $ ) $ * 2.e-4 ! fraction / deg C $ * 1028. ! kg / m3 $ * 9.8 ! m / s2 $ / 1.e6 ! MPa c operates on dz(nz+1), temperature(:,nz+1) p_excess(ix,iz) = p_excess(ix,iz) $ - fluid_buoy(ix,iz) #endif enddo ! iz p_fluid = MAX(p_excess + p_hydro, P_atm) p_gas = p_fluid return end subroutine find_p_head( ix, $ p_head, p_head_canyon, $ temperature, temperature_canyon, pw_conc, $ dz, z_top, z_center, sea_level, rho, $ z_canyon, $ fluid_delta_z, $ fluid_delta_z_canyon, $ z_water_table, $ z_water_table_equiv, $ z_water_table_equiv_canyon, $ nz ) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ p_head, p_head_canyon, dz, $ z_top, z_center, $ fluid_delta_z, $ fluid_delta_z_canyon, $ z_water_table_equiv, $ z_water_table_equiv_canyon, $ temperature_canyon double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc double precision, dimension ( 0:NX+1 ) :: $ z_water_table, z_canyon double precision rho(N_Rho) double precision sea_level integer ix, iz, nz p_head(ix,:) = 0.d0 #ifdef Hydrology fluid_delta_z(ix,:) = 0.d0 fluid_delta_z_canyon(ix,:) = 0.d0 c First do all the grid points in the regular non-canyoned part c calculate the deviations in volume -> height from nonstandard T, P do iz = 1, nz c consider the top half of the box if( z_water_table(ix) .GE. z_top(ix,iz) ) then ! full of water #define dV_dT -2.d-4 #define dV_dS 8.5d-4 fluid_delta_z(ix,iz) = $ ( $ + dV_dT ! fraction / deg C $ * ( temperature(ix,iz,degC) ! deg. C $ - 25.d0 $ ) $ + dV_dS $ * ( pw_conc(ix,iz,i_Sal) ! psu $ - 35.d0 $ ) $ ) ! fraction change in volume $ * dz(ix,iz) / 2.d0 ! m change else if (z_water_table(ix) .GE. z_center(ix,iz) ) then ! half-box part water fluid_delta_z(ix,iz) = $ ( $ + dV_dT ! fraction / deg C $ * ( temperature(ix,iz,degC) ! deg. C $ - 25.d0 $ ) $ + dV_dS $ * ( pw_conc(ix,iz,i_Sal) ! psu $ - 35.d0 $ ) $ ) ! fraction change in volume $ * ( z_water_table(ix) $ - z_center(ix,iz) $ ) endif c the bottom half of the box if( z_water_table(ix) .GE. z_center(ix,iz) ) then ! full of water fluid_delta_z(ix,iz) = fluid_delta_z(ix,iz) $ + ( $ + dV_dT ! fraction / deg C $ * ( temperature(ix,iz,degC) ! deg. C $ - 25.d0 $ ) $ + dV_dS $ * ( pw_conc(ix,iz,i_Sal) ! psu $ - 35.d0 $ ) $ ) ! fraction change in volume $ * dz(ix,iz) / 2.d0 ! m change else if (z_water_table(ix) .GE. z_top(ix,iz-1) ) then ! half-box part water fluid_delta_z(ix,iz) = fluid_delta_z(ix,iz) $ + ( $ + dV_dT ! fraction / deg C $ * ( temperature(ix,iz,degC) ! deg. C $ - 25.d0 $ ) $ + dV_dS $ * ( pw_conc(ix,iz,i_Sal) ! psu $ - 35.d0 $ ) $ ) ! fraction change in volume $ * ( z_water_table(ix) $ - z_top(ix,iz-1) $ ) endif c repeat the calculations for a lowered water table in a canyon if there is one if( z_canyon(ix) .LT. z_top(ix,nz) ) then if( z_canyon(ix) .GT. z_top(ix,iz) ) then ! full of water fluid_delta_z_canyon(ix,iz) = $ ( $ + dV_dT ! fraction / deg C $ * ( temperature_canyon(ix,iz) ! deg. C $ - 25.d0 $ ) $ + dV_dS $ * ( pw_conc(ix,iz,i_Sal) ! psu $ - 35.d0 $ ) $ ) ! fraction change in volume $ * dz(ix,iz) / 2.d0 ! m change else if (z_canyon(ix) .GT. z_center(ix,iz) ) then ! half-box part water fluid_delta_z_canyon(ix,iz) = $ ( $ + dV_dT ! fraction / deg C $ * ( temperature_canyon(ix,iz) ! deg. C $ - 25.d0 $ ) $ + dV_dS $ * ( pw_conc(ix,iz,i_Sal) ! psu $ - 35.d0 $ ) $ ) ! fraction change in volume $ * ( z_canyon(ix) $ - z_center(ix,iz) $ ) endif c the bottom half of the box if( z_canyon(ix) .GT. z_center(ix,iz) ) then ! full of water fluid_delta_z_canyon(ix,iz) = $ fluid_delta_z_canyon(ix,iz) $ + ( $ + dV_dT ! fraction / deg C $ * ( temperature_canyon(ix,iz) ! deg. C $ - 25.d0 $ ) $ + dV_dS $ * ( pw_conc(ix,iz,i_Sal) ! psu $ - 35.d0 $ ) $ ) ! fraction change in volume $ * dz(ix,iz) / 2.d0 ! m change else if (z_canyon(ix) .GT. z_top(ix,iz-1) ) then ! half-box part water fluid_delta_z_canyon(ix,iz) = $ fluid_delta_z_canyon(ix,iz) $ + ( $ + dV_dT ! fraction / deg C $ * ( temperature_canyon(ix,iz) ! deg. C $ - 25.d0 $ ) $ + dV_dS $ * ( pw_conc(ix,iz,i_Sal) ! psu $ - 35.d0 $ ) $ ) ! fraction change in volume $ * ( z_canyon(ix) $ - z_top(ix,iz-1) $ ) endif ! bottom else fluid_delta_z_canyon(ix,iz) = fluid_delta_z(ix,iz) endif ! theres a canyon enddo ! iz #ifdef Ocean_Temperature_Dev_Sealevel c deviations due to ocean temperature if( iz_water_table(ix) .LE. nz ) then fluid_delta_z(ix,nz+1) = $ ( $ + dV_dT ! fraction / deg C $ * ( 10.d0 ! deg. C avg ocean temp, 35 psu sal $ - 25.d0 $ ) $ ) ! fraction change in volume $ * dz(ix,iz) / 2.d0 ! m change $ ( z_top(ix,nz) $ - sea_level $ ) endif c itself is variable, depends on density probably #endif c starting out z_water_table_equiv(ix,nz) = ( z_water_table(ix) $ - sea_level $ ) ! meters of head z_water_table_equiv_canyon(ix,nz) = $ MAX( z_canyon(ix), sea_level ) $ - sea_level do iz = nz-1,1,-1 z_water_table_equiv(ix,iz) = $ z_water_table_equiv(ix,iz+1) $ + fluid_delta_z(ix,iz) z_water_table_equiv_canyon(ix,iz) = $ z_water_table_equiv_canyon(ix,iz+1) $ + fluid_delta_z_canyon(ix,iz) enddo p_head(ix,:) = z_water_table_equiv(ix,:) $ * rho(i_Seawater) ! g / m3 $ / 1e3 ! kg / m3 $ * 9.8d0 ! kg / m s2 = Pa $ / 1.d6 ! MPa for consistency with p_excess p_head(ix,nz+1) = p_head(ix,nz) ! so water dont fly out da top p_head_canyon(ix,:) = z_water_table_equiv_canyon(ix,:) $ * rho(i_Seawater) ! g / m3 $ / 1e3 ! kg / m3 $ * 9.8d0 ! kg / m s2 = Pa $ / 1.d6 ! MPa for consistency with p_excess p_head_canyon(ix,nz+1) = p_head_canyon(ix,nz) ! so water dont fly out da top #ifdef No_Canyon p_head_canyon(ix,:) = p_head(ix,:) #endif #ifdef Wrap_On_Update call boundary_wrap_ghosts(p_head,myid,numprocs,NZ_Max) #endif #ifdef Hydrology_Head_Boundary if(myid .EQ. Master) then p_head(0) = p_head(1) $ + Hydrology_Head_Boundary ! meters rise per grid cell $ * rho(i_Seawater) ! g / m3 $ / 1e3 ! kg / m3 $ * 9.8d0 ! kg / m s2 = Pa $ / 1.d6 ! MPa for consistency with p_excess endif #endif #endif /* Hydrology */ #ifdef Wrap_On_Update call boundary_wrap_ghosts(p_excess,myid,numprocs,NZ_Max) #endif return end subroutine find_perm( ix, ! operates only on column ix $ sl_frac, por_liquid, por_mobile, $ particle_radius, perm_0, por_0, $ perm, perm_lateral, perm_goosefac, perm_mdarcys, $ grain_size, z_top, dz, $ nz, i_shifts) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_frac double precision, dimension(N_Size_Classes) :: $ particle_radius double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ grain_size, por_liquid, perm, perm_lateral, perm_mdarcys, $ perm_goosefac, por_mobile, z_top, dz double precision perm_0, por_0(0:2) double precision grain_mass, perm_goose integer nz, ix, iz, i_sl, myid, numprocs, i_shifts, $ my3, my8, inode #ifdef Perm_Grain_Size grain_size(ix,:) = 0.d0 do iz = 1, nz grain_mass = 0.d0 do i_sl = 0, N_Size_Classes-1 grain_size(ix,iz) = grain_size(ix,iz) $ + sl_frac(ix,iz,i_sl+i_first_size_class) $ * particle_radius(i_sl+1) grain_mass = grain_mass $ + sl_frac(ix,iz,i_sl+i_first_size_class) enddo if(grain_mass .GT. 0.d0) then grain_size(ix,iz) = grain_size(ix,iz) $ / grain_mass else grain_size(ix,iz) = 1.d-6 endif enddo do iz = 1, nz perm(ix,iz) = grain_size(ix,iz)**2 $ / 1800.d0 $ * por_mobile(ix,iz)**3 $ / ( 1.d0 - por_mobile(ix,iz) )**2 enddo #endif c Perm_Grain_Size #ifdef Perm_Wang_Nondim do iz = 1, nz perm(ix,iz) = perm_0 $ * ( por_liquid(ix,iz) $ / por_0(0) $ )**8 enddo #endif #ifdef Perm_Hyndmann do iz = 1, nz perm(ix,iz) = 10**( 1.3 $ * ( por_liquid(ix,iz) $ / ( 1.d0 - por_liquid(ix,iz) ) $ ) $ - 18.4 $ ) enddo #endif #ifdef Perm_Maximum perm(ix,:) = MIN(perm(ix,:), $ Perm_Maximum) #endif #ifdef Perm_Minimum perm(ix,:) = MAX(perm(ix,:), $ Perm_Minimum) #endif perm_lateral(ix,:) = perm(ix,:) #ifdef Perm_Anisotrophy $ * Perm_Anisotrophy #endif perm_goosefac = 1.d0 #ifdef Perm_Channels c do inode = 0, NX / 10 - 1 ! assumes 10 points per mpi node c my3 = MOD(1002 - i_shifts,10) + 1 + inode*10 c my8 = MOD(1007 - i_shifts,10) + 1 + inode*10 do inode = 0, NX / 5 - 1 ! a channel per 5 grid points my3 = MOD(1002 - i_shifts,5) + 1 + inode*5 if( ix .EQ. my3 ) then #define Perm_Channels_Soft #ifdef Perm_Channels_Hard if( z_top(ix,nz) - z_top(ix,0) $ .GT. 3000.d0) then perm_goosefac(ix,:) = 10.d0 endif #endif #ifdef Perm_Channels_Soft do iz=1, nz perm_goosefac(ix,iz) = $ ( $ ( ( z_top(ix,nz) $ - z_top(ix,0) $ ) $ / ( z_top(ix,nz) $ - z_top(ix,0) $ + 2000.d0 $ ) $ ) $ - 0.5d0 $ ) * 2.d0 ! -.8@ 100, 0@1000m, 0.6@5000m, 0.9@1000 perm_goosefac(ix,iz) = MAX( perm_goosefac(ix,iz), $ 0.d0 $ ) perm_goosefac(ix,iz) = 1.d0 $ + 10.d0 * perm_goosefac(ix,iz) perm(ix,iz) = perm(ix,iz) $ * perm_goosefac(ix,iz) enddo #endif /* Perm_Channels_Soft */ #ifdef Perm_Channels_Always perm_goosefac(ix,:) = 10.d0 perm(ix,:) = perm(ix,:) $ * perm_goosefac(ix,iz) #endif endif ! not one of mine (my3 my8) enddo ! inode #endif /* Perm_Channels */ #ifdef Wrap_On_Update call boundary_wrap_ghosts(perm,myid,numprocs,NZ_Max) dont compile this, its broken #endif perm_mdarcys(ix,:) = perm(ix,:) / 1.d-15 return end subroutine find_dP_dPdelta( ix, $ dp_dpdelta_i, dp_dpdelta_imin, $ p_excess_extrap, $ w_bur, $ solid_vol, ice_sheet_vol, tot_vol, $ perm, dyn_visc, $ dpsupp_dpor, $ iz_water_table, dt, dx, dz, nz) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ w_bur, $ solid_vol, ice_sheet_vol, tot_vol, $ perm, dyn_visc, dz, $ dp_dpdelta_i, dp_dpdelta_imin, $ p_excess_extrap, $ dpsupp_dpor double precision :: dt, dx(0:NX+1) integer ix, iz, nz integer, dimension(NX) :: iz_water_table c internal variables double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ k_i, d_por_i, d_por_imin do iz = 1, MIN(nz,iz_water_table(ix)) if( iz .LT. iz_water_table(ix)+1 ) then k_i(ix,iz) = perm(ix,iz) $ / dyn_visc(ix,iz) $ * 1.d6 ! Pa $ / ( ( dz(ix,iz) + dz(ix,iz+1) ) / 2. ) $ * 3.14d7 ! m / yr d_por_i(ix,iz) = $ ( tot_vol(ix,iz) $ - solid_vol(ix,iz) $ - ice_sheet_vol(ix,iz) $ - w_bur(ix,iz) * dx(ix) * dt $ ) ! new melted fluid (nonsolids) volume $ / ( tot_vol(ix,iz) $ - w_bur(ix,iz) * dx(ix) * dt $ ) ! new extrapolated porosity $ - ( tot_vol(ix,iz) $ - solid_vol(ix,iz) $ - ice_sheet_vol(ix,iz) $ ) $ / tot_vol(ix,iz) ! change in porosity if(w_bur(ix,iz) .NE. 0.d0) then dp_dpdelta_i(ix,iz) = k_i(ix,iz) ! k_i is positive $ * d_por_i(ix,iz) ! negative if cell is losing fluid through the step $ * ( - dpsupp_dpor(ix,iz) ) ! positive now (Pexcess = Ptot - Psupp) $ / w_bur(ix,iz) ! dp goes up, w goes up, want p_extrap goes down, overall negative else dp_dpdelta_i(ix,iz) = 0.d0 endif if( iz .GT. 1 ) then d_por_imin(ix,iz) = $ ( tot_vol(ix,iz) $ - solid_vol(ix,iz) $ - ice_sheet_vol(ix,iz) $ + w_bur(ix,iz-1) ! $ * dx(ix) * dt $ ) ! new melted fluid (nonsolids) volume $ / ( tot_vol(ix,iz) $ + w_bur(ix,iz-1) * dx(ix) * dt $ ) ! new total vol $ - ( tot_vol(ix,iz) $ - solid_vol(ix,iz) $ - ice_sheet_vol(ix,iz) $ ) $ / tot_vol(ix,iz) if(w_bur(ix,iz-1) .NE. 0.d0) then dp_dpdelta_imin(ix,iz) = k_i(ix,iz) $ * d_por_imin(ix,iz) ! positive if cell below is spurting fluid up $ * ( - dpsupp_dpor(ix,iz) ) ! positive $ / w_bur(ix,iz-1) ! p_imin goes up, por_i goes up, p_extrap goes up, resid goes up, positve else dp_dpdelta_imin(ix,iz) = 0.d0 endif else d_por_imin(ix,iz) = 0.d0 dp_dpdelta_imin(ix,iz) = 0.d0 endif p_excess_extrap(ix,iz) = $ ( d_por_i(ix,iz) $ + d_por_imin(ix,iz) ! say decrease in porosity (negative) $ ) * ( - dpsupp_dpor(ix,iz) ) ! new pressure (decrease is negative) endif enddo return end subroutine find_w( ix, $ w_darcy, v, w_hydro, $ perm, perm_lateral, $ dyn_visc, p_excess, por_mobile, por_melted, $ p_head_canyon, p_head, z_canyon, $ iz_water_table, $ dx, dz, z_top, nz ) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ w_darcy, v, w_hydro, $ perm, perm_lateral, $ dyn_visc, p_excess, por_mobile, por_melted, $ p_head_canyon, p_head, $ dz, z_top double precision, dimension(0:NX+1) :: $ dx, z_canyon integer ix, iz, nz integer, dimension(NX) :: iz_water_table double precision :: perm_min #ifdef VerticalFlow do iz = 1, nz c w defined on upper face toward iz+1, +ve toward iz+1 (upward) if( iz .LT. iz_water_table(ix) ) then ! fully saturated if( iz .EQ. nz ) then perm_min = perm(ix,iz) else perm_min = MIN( perm(ix,iz), $ perm(ix,iz+1) $ ) endif w_darcy(ix,iz) = perm_min $ / dyn_visc(ix,iz) $ * ( ( p_excess(ix,iz) $ - p_excess(ix,iz+1) $ ) #define Hydrology_Nonhydrostatic #ifdef Hydrology_Nonhydrostatic $ + ( p_head(ix,iz) $ - p_head(ix,iz+1) $ ) ! MPa #endif $ ) * 1.d6 ! Pa $ / ( ( dz(ix,iz) + dz(ix,iz+1) ) / 2. ) $ * 3.14d7 ! m / yr c if( ABS( p_excess(ix,iz) - p_excess(ix,iz+1) ) c $ .LT. 1.d-3 ) then c w_darcy(ix,iz) = 0.d0 c endif else w_darcy(ix,iz) = 0.d0 endif enddo ! iz #else w_darcy(ix,:) = 0.d0 #endif #ifdef Hydrology if( iz_water_table(ix) .LT. nz+1 ) then do iz = nz, 1, -1 if( z_canyon(ix) .LT. z_top(ix,iz)) then ! fully or partly canyoned v(ix,iz) = perm_lateral(ix,iz) ! pretend all boxes completely canyoned $ / dyn_visc(ix,iz) $ * ( p_head_canyon(ix,iz) $ - p_head(ix,iz) $ ) * 1.d6 ! Pa, positive inward $ / Canyon_Lengthscale $ * 3.14d7 ! m / yr if( z_canyon(ix) .GT. z_top(ix,iz-1) ) then ! only partly canyoned v(ix,iz) = v(ix,iz) $ * ( z_top(ix,iz) - z_canyon(ix) ) $ / dz(ix,iz) endif endif enddo endif c apparent vertical flow due to groundwater divergence into rivers w_hydro(ix,0) = 0.d0 do iz = 1, nz w_hydro(ix,iz) = w_hydro(ix,iz-1) ! vertical accumulator for river loss flow_vol $ + v(ix,iz) $ * dz(ix,iz) $ * por_mobile(ix,iz) ! m3 / timestep $ / dx(ix) enddo w_hydro(ix,1:nz) = w_hydro(ix,1:nz) $ / por_mobile(ix,1:nz) #endif /* Hydrology */ return end subroutine find_u( ! operates on local domain $ u, $ perm_lateral, dyn_visc, p_excess, p_head, $ liquid_saturation, dx, nz) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ u, $ perm_lateral, dyn_visc, p_excess, p_head, $ liquid_saturation double precision, dimension(0:NX+1) :: $ dx integer ix, iz, nz do ix=0,NX do iz=1,nz c u defined on face toward ix+1, +ve toward ix+1 u(ix,iz) = c $ ( perm_lateral(ix,iz), c $ + perm_lateral(ix,iz+1) c $ ) / 2. $ MIN( perm_lateral(ix,iz), $ perm_lateral(ix+1,iz) ) $ / dyn_visc(ix,iz) $ * ( ( p_excess(ix,iz) $ - p_excess(ix+1,iz) $ ) ! MPa #ifdef Hydrology $ + ( p_head(ix,iz) $ - p_head(ix+1,iz) $ ) ! MPa #endif $ ) * 1.d6 ! Pa $ / ( ( dx(ix) + dx(ix+1) ) / 2. ) $ * 3.14d7 ! m / yr #ifdef Hydrology $ * liquid_saturation(ix,iz) #endif enddo enddo return end subroutine advect_w( ix, dt_inner, $ w_darcy, w_bur, v, $ pw_inv, pw_conc, pw_adv, $ temperature, temperature_canyon, $ heat_adv_flux, $ fluid_vol, $ solid_vol, $ air_vol, $ ice_sheet_vol, $ tot_vol, $ liquid_saturation, $ por_liquid, por_drained, $ iz_water_table, $ dx, dz, nz) implicit none #ifdef MPI include 'mpif.h' #endif double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ w_darcy, w_bur, v, $ fluid_vol, solid_vol, air_vol, tot_vol, ice_sheet_vol, $ liquid_saturation, $ por_liquid, por_drained, por_mobile, por_melted, $ heat_adv_flux, dz, $ temperature_canyon double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_inv, pw_conc, pw_adv double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1) :: dx double precision dt_inner integer, dimension(NX) :: iz_water_table integer ix,iz,nz,myid,ierr c internal double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ flow_vol_darcy, flow_vol_tot, flow_vol_v, d_air double precision :: adv_conc(N_PW), adv_temp do iz = 1, MIN( nz, iz_water_table(ix) ) c#define Advect_Stdout #ifdef Advect_Stdout if( fluid_vol(ix,iz) .LT. 0.d0 ) then #ifdef MPI call MPI_COMM_RANK(MPI_COMM_WORLD,myid,ierr) write(6,*) "fv<0 coming in", myid,ix,iz, $ fluid_vol(ix,iz), $ flow_vol_darcy(ix,iz-1:iz) #else write(6,*) "sucked it dry in darcy flow", myid,ix,iz #endif endif #endif c the additional flow due to darcy pressure if( liquid_saturation(ix,iz) .GT. 0.d0 ) then flow_vol_darcy(ix,iz) = w_darcy(ix,iz) $ * por_liquid(ix,iz) $ / liquid_saturation(ix,iz) ! norm to all water no air $ * dx(ix) ! m3/yr $ * dt_inner ! m3 else flow_vol_darcy(ix,iz) = 0.d0 endif if( iz_water_table(ix) .LT. nz+1 ) then ! outcrops someplace if( iz .EQ. iz_water_table(ix) - 1 ) then ! just below the water table if( -flow_vol_darcy(ix,iz) .GT. fluid_vol(ix,iz+1) ) then ! the layer above drains air_vol(ix,iz) = -flow_vol_darcy(ix,iz) $ - fluid_vol(ix,iz+1) fluid_vol(ix,iz) = fluid_vol(ix,iz) $ - flow_vol_darcy(ix,iz) $ - fluid_vol(ix,iz+1) fluid_vol(ix,iz+1) = 0.d0 flow_vol_darcy(ix,iz+1) = 0.d0 iz_water_table(ix) = iz ! which puts it into the next if block endif endif if( iz .EQ. iz_water_table(ix) ) then ! at the water table if( flow_vol_darcy(ix,iz-1) .GT. air_vol(ix,iz) ) then ! the layer floods flow_vol_darcy(ix,iz-1) = air_vol(ix,iz) air_vol(ix,iz) = 0.d0 iz_water_table(ix) = MIN( iz+1, nz ) endif flow_vol_darcy(ix,iz) = 0.d0 #define Por_Unsat_Drained #ifdef Por_Unsat_Drained c maintains porosity at drained by filling up with air d_air(ix,iz) = ( solid_vol(ix,iz) $ / ( 1.d0 $ - por_drained(ix,iz) $ ) $ - ( tot_vol(ix,iz) $ - ice_sheet_vol(ix,iz) $ ) $ ) $ / 100.d0 ! slow down the response, but still aims to por_drained endpoint c d_air(ix,iz) = MAX( c $ d_air(ix,iz), c $ - fluid_vol(ix,iz) / 10.d0 ! slow down change in water table c $ ) air_vol(ix,iz) = MAX( air_vol(ix,iz) $ + d_air(ix,iz), $ 0.d0 $ ) #endif endif ! at the water table endif ! outcrops somewhere fluid_vol(ix,iz) = fluid_vol(ix,iz) $ - flow_vol_darcy(ix,iz) ! the other part (burial) done in deposit_sediment if( liquid_saturation(ix,iz) .GT. 0.d0 ) then flow_vol_tot(ix,iz) = w_bur(ix,iz) $ * por_liquid(ix,iz) $ / liquid_saturation(ix,iz) ! norm to all water no air $ * dx(ix) ! m3/yr $ * dt_inner ! m3 else flow_vol_tot(ix,iz) = 0.d0 endif if(w_bur(ix,iz) .GT. 0.d0) then ! upward flow, upwind is downward adv_conc(:) = pw_conc(ix,iz,:) adv_temp = temperature(ix,iz,degC) else ! downward flow if(iz .EQ. iz_water_table(ix)) then ! fresh groundwater (mmmm) adv_conc(:) = 0.d0 else ! pore water from above adv_conc(:) = pw_conc(ix,iz+1,:) endif adv_temp = temperature(ix,iz+1,degC) endif pw_inv(ix,iz,:) = pw_inv(ix,iz,:) $ - flow_vol_tot(ix,iz) * adv_conc(:) #define Heat_Capacity_SW 4120.d3 /* 4 J/degCg *1030d3 g/m3 */ #ifdef Advect_Temperature temperature(ix,iz,degC) = temperature(ix,iz,degC) $ - flow_vol_tot(ix,iz) ! m3 $ * adv_temp ! m3 degC $ * Ht_Capacity_SW $ / heat_capacity(ix,iz) $ / tot_vol(ix,iz) #endif c update the box above if(iz .LT. nz) then ! interior sediment column if(fluid_vol(ix,iz+1) + flow_vol_darcy(ix,iz) $ .GT. 0.d0) then ! box above not gonna blow fluid_vol(ix,iz+1) = fluid_vol(ix,iz+1) $ + flow_vol_darcy(ix,iz) pw_inv(ix,iz+1,:) = pw_inv(ix,iz+1,:) $ + flow_vol_tot(ix,iz) * adv_conc(:) #ifdef Advect_Temperature temperature(ix,iz+1,degC) = $ temperature(ix,iz+1,degC) $ + flow_vol_tot(ix,iz) ! m3 $ * adv_temp ! m3 degC $ * Heat_Capacity_SW $ / heat_capacity(ix,iz+1) $ / tot_vol(ix,iz+1) #endif endif ! not gonna blow a gasket endif ! iz < nz c diagnostics #define Advect_Stdout #ifdef Advect_Stdout if( fluid_vol(ix,iz) .LT. 0.d0 ) then #ifdef MPI call MPI_COMM_RANK(MPI_COMM_WORLD,myid,ierr) write(6,*) "sucked it dry in darcy flow", myid,ix,iz, $ fluid_vol(ix,iz), $ flow_vol_darcy(ix,iz-1:iz) #else write(6,*) "sucked it dry in darcy flow", myid,ix,iz #endif endif #endif pw_adv(ix,iz,:) = $ flow_vol_tot(ix,iz) $ * adv_conc(:) heat_adv_flux(ix,iz) = $ flow_vol_tot(ix,iz) ! m3 $ * adv_temp $ * Heat_Capacity_SW ! J / m3 K -> J $ / dx(ix) ! J / m2 (antfarm) $ / dt_inner / 3.14e7 ! W / m2 c if(flow_vol_w(ix,iz) .LT. fluid_vol(ix,iz)) then enddo ! iz c canyon flow flow_vol_v = 0.d0 do iz = 1, iz_water_table(ix) flow_vol_v(ix,iz) = v(ix,iz) ! m / yr $ * dz(ix,iz) $ * por_liquid(ix,iz) $ * dt_inner if( flow_vol_v(ix,iz) .GT. 0.d0 ) then ! inward adv_conc(:) = pw_conc(ix,iz,:) adv_temp = temperature_canyon(ix,iz) else ! outward adv_conc(:) = pw_conc(ix,iz,:) adv_temp = temperature(ix,iz,degC) if( - flow_vol_v(ix,iz) .GT. fluid_vol(ix,iz) ) then c write(6,*) "shit", ix,iz,flow_vol_v(ix,iz), c $ fluid_vol(ix,iz) flow_vol_v(ix,iz) = - fluid_vol(ix,iz) / 2. endif endif fluid_vol(ix,iz) = fluid_vol(ix,iz) $ + flow_vol_v(ix,iz) pw_inv(ix,iz,:) = pw_inv(ix,iz,:) $ + flow_vol_v(ix,iz) * adv_conc(:) #ifdef Advect_Stdout if( fluid_vol(ix,iz) .LT. 0.d0 ) then #ifdef MPI call MPI_COMM_RANK(MPI_COMM_WORLD,myid,ierr) write(6,*) "sucked it dry in canyon flow", myid,ix,iz, $ flow_vol_v(ix,iz), fluid_vol(ix,iz) #else write(6,*) "sucked it dry in canyon flow", myid,ix,iz #endif endif #endif enddo ! iz return end c if(myid .EQ. Master) then c do ix = 1, NX c do iz = 1, nz c if(fluid_vol(2,15) .GT. 10.d0) then c write(6,*) "oi" c endif c enddo c enddo c endif c write(6,*) "oi", fluid_vol(1,15) subroutine hydrology_recharge( ix, $ fluid_vol, $ air_vol, $ pw_inv, $ iz_water_table, $ hydro_runoff, hydro_recharge, $ dx, dt, nz) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ fluid_vol, air_vol double precision, dimension(0:NX+1) :: $ dx, hydro_recharge, hydro_runoff integer, dimension(NX) :: iz_water_table double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_inv double precision :: max_recharge, dt integer ix, iz, nz hydro_recharge(ix) = 0.d0 hydro_runoff(ix) = 0.d0 if( iz_water_table(ix) .LE. nz) then ! outcrops, its nzmax+1 for submerged #ifdef Hydrology_Recharge max_recharge = Hydrology_Recharge ! m / yr $ * dx(ix) $ * dt ! m3 of water #else max_recharge = 0.d0 #endif c add groundwater if( air_vol(ix,iz_water_table(ix)) $ .GT. max_recharge ) then ! put all the water here air_vol(ix,iz_water_table(ix)) = $ air_vol(ix,iz_water_table(ix)) $ - max_recharge fluid_vol(ix,iz_water_table(ix)) = $ fluid_vol(ix,iz_water_table(ix)) $ + max_recharge hydro_recharge(ix) = hydro_recharge(ix) $ + max_recharge max_recharge = 0 else ! the layer floods. take as much water as you had air fluid_vol(ix,iz_water_table(ix)) = $ fluid_vol(ix,iz_water_table(ix)) $ + air_vol(ix,iz_water_table(ix)) max_recharge = max_recharge $ - air_vol(ix,iz_water_table(ix)) hydro_recharge(ix) = hydro_recharge(ix) $ + air_vol(ix,iz_water_table(ix)) air_vol(ix,iz_water_table(ix)) = 0.d0 if(iz_water_table(ix) .LT. nz) then iz_water_table(ix) = iz_water_table(ix)+1 air_vol(ix,iz_water_table(ix)) = $ air_vol(ix,iz_water_table(ix)) $ - max_recharge fluid_vol(ix,iz_water_table(ix)) = $ fluid_vol(ix,iz_water_table(ix)) $ + max_recharge hydro_recharge(ix) = hydro_recharge(ix) $ + max_recharge max_recharge = 0 endif endif if(fluid_vol(ix,iz_water_table(ix)) $ .LT. 0.d0) then ! the box just drained c write(6,*) "negative fluid vol",ix,iz_water_table(ix) air_vol(ix,iz_water_table(ix)) = $ air_vol(ix,iz_water_table(ix)) $ - fluid_vol(ix,iz_water_table(ix)) ! less air needed if no -ve water fraction fluid_vol(ix,iz_water_table(ix)) = 0.d0 pw_inv(ix,iz_water_table(ix),:) = 0.d0 iz_water_table(ix) = iz_water_table(ix)-1 endif ! drained #ifdef Hydrology_Recharge hydro_runoff(ix) = Hydrology_Recharge ! m / yr $ * dx(ix) $ * dt $ - hydro_recharge(ix) #else hydro_runoff(ix) = 0.d0 #endif endif ! an outcrop point hydro_recharge(ix) = hydro_recharge(ix) / dx(ix) / dt hydro_runoff(ix) = hydro_runoff(ix) / dx(ix) / dt return end subroutine vertical_flow_implicit( $ z_top, z_center, dz, dx, sea_level, i_shifts, $ nz, dt, iz_water_table, $ sl_inv, sl_frac, $ pw_inv, pw_conc, pw_adv, $ bb_conc, $ volume, $ por_0, beta, rho, dyn_visc, molwt, $ por_liquid, por_mobile, por_melted, $ por_drained, por_dev, $ liquid_saturation, $ particle_radius, grain_size, perm_0, $ perm, perm_lateral, perm_goosefac, perm_mdarcys, $ p_excess, p_supp, p_hydro, p_fluid, p_gas, $ p_head_canyon, p_head, $ fluid_buoy, stress_litho, $ temperature, temperature_canyon, $ heat_adv_flux, $ w_darcy, w_hydro, w_bur, w_seafloor, v, $ hydro_runoff, hydro_recharge, $ fluid_vol_flux, w_d_press_potential, w_n_iters, $ fluid_delta_z, fluid_delta_z_canyon, $ z_canyon, $ z_water_table, $ z_water_table_equiv, $ z_water_table_equiv_canyon, $ z_ice_sheet_base, $ dpsupp_dpor $ ) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_top, z_center, dz, $ por_liquid, por_mobile, por_melted, $ por_drained, por_dev, $ liquid_saturation, $ perm, perm_lateral, perm_goosefac, perm_mdarcys, dyn_visc, $ p_excess, p_supp, p_hydro, p_fluid, p_gas, $ p_head_canyon, p_head, $ fluid_buoy, stress_litho, $ w_darcy, w_hydro, w_bur, w_seafloor, v, $ fluid_vol_flux, w_d_press_potential, $ dpsupp_dpor, $ temperature_canyon, heat_adv_flux, $ fluid_delta_z, fluid_delta_z_canyon, $ z_canyon, $ z_water_table_equiv, $ z_water_table_equiv_canyon, $ z_ice_sheet_base double precision, dimension(0:NX+1) :: $ z_water_table, hydro_recharge, hydro_runoff double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_inv, sl_frac double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_inv, pw_conc, pw_adv double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_Bubble_Types) :: $ bb_conc double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume double precision, dimension(N_Size_Classes) :: $ particle_radius, grain_size double precision, dimension(0:NX+1) :: $ dx, w_n_iters double precision :: perm_0, dt, sea_level, $ por_0(0:2), $ beta(2), $ rho(N_Rho), $ molwt(N_SL) integer, dimension(NX) :: iz_water_table integer ix,iz,nz,i_shifts, i_step c internal double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ p_excess_extrap, $ p_delta, $ dp_dpdelta_i, dp_dpdelta_imin, $ p_plus_dp, resid double precision, dimension(NZ_Max) :: $ aa, bb, cc, rr, uu double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ dz_top_dt, z_top_last double precision weight, sum_resid, sum_resid_old integer nz_solve, ierr, izz save dz_top_dt, z_top_last do ix = 1, NX call find_perm( ix, $ sl_frac, por_liquid, por_mobile, $ particle_radius, perm_0, por_0, $ perm, perm_lateral, perm_goosefac, perm_mdarcys, $ grain_size, z_top, dz, $ nz, i_shifts) c perm(:,1:nz-3) = 0.d0 call find_p_head( ix, ! leave this out of the loop unless want to create z_water table_delta or some like that $ p_head, p_head_canyon, $ temperature, temperature_canyon, pw_conc, $ dz, z_top, z_center, sea_level, rho, $ z_canyon, $ fluid_delta_z, $ fluid_delta_z_canyon, $ z_water_table, $ z_water_table_equiv, $ z_water_table_equiv_canyon, $ nz ) call find_p_excess( ix, $ p_excess, p_supp, p_hydro, p_fluid, p_gas, $ por_melted, fluid_buoy, stress_litho, $ por_0, beta, $ dpsupp_dpor, $ dz, temperature, $ nz) p_delta(ix,:) = 0.d0 sum_resid_old = 1.d6 weight = 0.05 do i_step = 1, 1000 p_plus_dp(ix,:) = p_excess(ix,:) + p_delta(ix,:) call find_w( ix, ! finds w based on sol/fluids which have been nudged in solids $ w_darcy, v, w_hydro, $ perm, perm_lateral, $ dyn_visc, p_plus_dp, por_mobile, por_melted, $ p_head_canyon, p_head, z_canyon, $ iz_water_table, $ dx, dz, z_top, nz ) call find_w_bur( ix, dt, $ por_liquid, $ w_darcy, w_hydro, $ fluid_vol_flux, $ dx, nz, w_bur ) call find_dP_dPdelta( ix, $ dp_dpdelta_i, dp_dpdelta_imin, $ p_excess_extrap, $ w_darcy, $ volume(:,:,ivol_solid), $ volume(:,:,ivol_ice_sheet), $ volume(:,:,ivol_tot), $ perm, dyn_visc, $ dpsupp_dpor, $ iz_water_table, dt, dx, dz, nz) resid(ix,1:nz) = $ p_excess_extrap(ix,1:nz) ! this is the change in pressure c $ - p_excess(ix,1:nz) $ - p_delta(ix,1:nz) sum_resid = 0.d0 do izz=1, nz sum_resid = sum_resid + resid(ix,izz)**2 enddo c if( sum_resid .GT. sum_resid_old * 1.5 ) then c weight = weight / 2 c endif c sum_resid_old = sum_resid if( sum_resid .GT. 1.d3) then weight = 0.05 else weight = 0.33 endif c#define Iterate_Stdout #ifdef Iterate_Stdout if(ix .EQ. 1) then write(6,*) "relax", i_step, sum_resid, $ z_water_table(ix) do izz=nz,1,-1 write(6,"(i4,8g12.4)") $ izz, $ z_top(ix,izz), $ liquid_saturation(ix,izz), $ volume(ix,izz,ivol_ice) $ / ( volume(ix,izz,ivol_fluid) $ + volume(ix,izz,ivol_ice) $ ), $ w_darcy(ix,izz), c $ p_excess(ix,izz), $ p_plus_dp(ix,izz)+p_head(ix,izz), $ resid(ix,izz) c $ w_bur(ix,izz), c $ fluid_vol_flux(ix,izz) / dx(ix) / dt, c $ volume(ix,izz,ivol_hydrate) c $ p_excess_extrap(ix,izz) + p_excess(ix,izz), enddo endif #endif if( sum_resid .LT. 1.d-11 ) then c if(ix .EQ. 1) then c write(6,*) "done" c endif w_n_iters(ix) = i_step goto 1413 endif aa = 0.d0 bb(1:nz) = dp_dpdelta_i(ix,1:nz) - 1.d0 cc(1:nz) = dp_dpdelta_imin(ix,1:nz) rr(1:nz) = - resid(ix,1:nz) nz_solve = MIN(iz_water_table(ix), nz) c bb(1:3) = dp_dpdelta_i(ix,13:15) c rr(1:3) = resid(ix,13:15) c nz_solve = 3 call tridiag_solver(aa,bb,cc,rr,uu, $ nz_solve,ierr) p_delta(ix,1:nz) = p_delta(ix,1:nz) $ + weight*uu(1:nz) c p_delta(ix,nz-2:nz) = p_delta(ix,nz-2:nz) c $ + weight*uu(1:3) enddo ! implicit iteration loop 1413 continue call find_w_bur( ix, dt, $ por_liquid, $ w_darcy, w_hydro, $ fluid_vol_flux, $ dx, nz, w_bur ) call stack_column( ix, $ z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz) call advect_w( ix, dt, $ w_darcy, w_bur, v, $ pw_inv, pw_conc, pw_adv, $ temperature, temperature_canyon, $ heat_adv_flux, $ volume(:,:,ivol_fluid), $ volume(:,:,ivol_solid), $ volume(:,:,ivol_air), $ volume(:,:,ivol_ice_sheet), $ volume(:,:,ivol_tot), $ liquid_saturation, $ por_liquid, por_drained, $ iz_water_table, $ dx, dz, nz) call stack_column( ix, $ z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz) call hydrology_recharge( ix, $ volume(:,:,ivol_fluid), $ volume(:,:,ivol_air), $ pw_inv, $ iz_water_table, $ hydro_runoff, hydro_recharge, $ dx, dt, nz ) call stack_column( ix, $ z_top, z_center, dz, dx, $ volume, $ por_melted, por_liquid, por_mobile, $ por_drained, por_dev, $ liquid_saturation, z_water_table, iz_water_table, $ z_ice_sheet_base, $ p_hydro, stress_litho, $ sl_inv, bb_conc, temperature, $ sea_level, rho, por_0, beta, molwt, $ nz) enddo ! ix c diagnostics dz_top_dt = z_top - z_top_last z_top_last = z_top do ix=1, NX do iz=1,nz w_seafloor(ix,iz) = w_bur(ix,iz) $ + ( dz_top_dt(ix,iz) $ - dz_top_dt(ix,nz) $ ) / dt !* por_0(0) enddo enddo return end subroutine find_w_bur( ix, dt, $ por_liquid, $ w_darcy, w_hydro, $ fluid_vol_flux, $ dx, nz, w_bur ) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ por_liquid, $ w_darcy, w_hydro, $ fluid_vol_flux, $ w_bur double precision, dimension(0:NX+1) :: $ dx double precision :: dt integer ix, iz, nz do iz=1,nz if(por_liquid(ix,iz) .GT. 0.d0) then w_bur(ix,iz) = w_darcy(ix,iz) c $ + w_hydro(ix,iz) $ - fluid_vol_flux(ix,iz) ! m3/yr $ / dx(ix) ! m / yr $ / por_liquid(ix,iz) $ * T_Scale ! huh. only the burial flux is time scaled, not darcy or hydro else w_bur(ix,iz) = w_darcy(ix,iz) endif enddo return end subroutine advect_u( dt, $ u, $ fluid_vol, tot_vol, $ pw_conc, pw_inv, $ temperature, $ heat_capacity, $ dz, por_liquid, $ myid, numprocs, nz ) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ u, $ fluid_vol, tot_vol, $ dz, por_liquid, $ heat_capacity double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc, pw_inv double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision dt integer ix, iz, nz, myid, numprocs, i_pw c internal vars double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ flow_vol_u double precision $ adv_conc(N_PW), $ adv_temp do ix=0,NX do iz=1,nz #ifdef HorizontalFlow flow_vol_u(ix,iz) = u(ix,iz) ! m / yr $ * ( dz(ix,iz) $ + dz(ix+1,iz) $ ) / 2. ! m3 / yr c $ * ( por_liquid(ix,iz) c $ + por_liquid(ix+1,iz) c $ ) / 2.d0 $ * MIN ( por_liquid(ix,iz) $ , por_liquid(ix+1,iz) $ ) $ * dt #else flow_vol_u(ix,iz) = 0.d0 #endif if(u(ix,iz) .GT. 0.d0) then adv_conc(:) = pw_conc(ix,iz,:) adv_temp = temperature(ix,iz,degC) else adv_conc(:) = pw_conc(ix+1,iz,:) adv_temp = temperature(ix+1,iz,degC) endif if(ix .GT. 0) then C if(flow_vol_u(ix,iz) .LT. fluid_vol(ix,iz)) then fluid_vol(ix,iz) = fluid_vol(ix,iz) ! m3 $ - flow_vol_u(ix,iz) pw_inv(ix,iz,:) = pw_inv(ix,iz,:) $ - flow_vol_u(ix,iz) * adv_conc(:) ! stuff comes out of 1 -> nx temperature(ix,iz,degC) = temperature(ix,iz,degC) $ - flow_vol_u(ix,iz) ! m3 $ * adv_temp $ * Heat_Capacity_SW $ / heat_capacity(ix,iz) $ / tot_vol(ix,iz) C endif endif if(ix .LT. NX) then fluid_vol(ix+1,iz) = fluid_vol(ix+1,iz) ! m3 $ + flow_vol_u(ix,iz) pw_inv(ix+1,iz,:) = pw_inv(ix+1,iz,:) $ + flow_vol_u(ix,iz) * adv_conc(:) ! stuff goes into 1 -> nx temperature(ix+1,iz,degC) = temperature(ix+1,iz,degC) $ + flow_vol_u(ix,iz) ! m3 $ * adv_temp $ * Heat_Capacity_SW $ / heat_capacity(ix+1,iz) $ / tot_vol(ix+1,iz) endif enddo enddo c#ifdef Wrap_On_Update call wrap_ghosts(fluid_vol,myid,numprocs,NZ_Max) do i_pw=1,N_PW call wrap_ghosts(pw_inv,myid,numprocs,NZ_Max) enddo c#endif return end subroutine horizontal_fluid_flow( dt, $ u, dx, dz, $ fluid_vol, tot_vol, por_liquid, $ pw_conc, pw_inv, temperature, $ p_head, p_excess, perm_lateral, dyn_visc, $ liquid_saturation, heat_capacity, $ myid, numprocs, nz ) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ u, dz, $ fluid_vol, tot_vol, por_liquid, $ p_head, p_excess, perm_lateral, dyn_visc, $ liquid_saturation, heat_capacity double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc, pw_inv double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1) :: $ dx double precision dt integer $ myid, numprocs, nz, i_pw c assume permeability still current from vertical flow #ifdef Wrap_On_Demand /* in horizontal_fluid_flow */ call boundary_wrap_ghosts(p_head,myid,numprocs,NZ_Max) call boundary_wrap_ghosts(perm_lateral,myid,numprocs,NZ_Max) call boundary_wrap_ghosts(p_excess,myid,numprocs,NZ_Max) c pw_conc, temperature, porosity etc wrapped_each_timestep, these have been c most strongly impacted by the vertical flow. is my thinking. #endif call find_u( u, $ perm_lateral, dyn_visc, p_excess, p_head, $ liquid_saturation, dx, nz) #ifdef MPI_Stdout #ifdef MPI if( myid .EQ. 0 ) then c write(6,*) "Im 0 u", u(1:5,nz) write(6,*) "Im 0 pl", por_liquid(1:6,nz) call flush(6) else if (myid .EQ. 1 ) then c write(6,*) "Im 1 u", u(0:5,nz) write(6,*) "Im 1 pl", por_liquid(0:5,nz) call flush(6) endif #else write(6,*) "u", u(:,nz) write(6,*) "px", por_liquid(:,nz) write(6,*) "ph", p_head(:,nz) write(6,*) "pl", perm_lateral(:,nz) #endif #endif #ifdef Wrap_On_Demand /* in subroutine horizontal_fluid_flow */ call wrap_ghosts(u,myid,numprocs,NZ_Max) call wrap_ghosts(por_liquid,myid,numprocs,NZ_Max) call wrap_ghosts(dz,myid,numprocs,NZ_Max) do i_pw=1,N_PW call boundary_wrap_ghosts(pw_conc(:,:,i_pw), $ myid,numprocs,NZ_Max) enddo #endif call advect_u( dt, $ u, $ fluid_vol, tot_vol, $ pw_conc, pw_inv, $ temperature, $ heat_capacity, $ dz, por_liquid, $ myid, numprocs, nz ) return end #ifdef Hydrology subroutine evolve_canyon(dx, z_canyon, z_top, z_center, $ seafloor_slope_canyon, $ temperature, temperature_canyon, $ dt, nz) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ temperature_canyon, z_top, z_center double precision, dimension(0:NX+1) :: $ dx, surface_temp, z_canyon, seafloor_slope_canyon double precision dt integer iz_water_table(NX) double precision, dimension(0:NX+1) :: $ d_temperature_canyon integer ix, iz, nz do ix = 2, NX seafloor_slope_canyon(ix) = $ ( z_canyon(ix) $ - z_canyon(ix-1) $ ) $ / dx(ix) enddo seafloor_slope_canyon(1) = $ seafloor_slope_canyon(2) c evolve depth of river channel in time from Whipple and Tucker 1999 do ix = 1, NX if( iz_water_table(ix) .LE. nz) then ! outcrops, its nzmax+1 for submerged z_canyon(ix) = z_canyon(ix) $ - 2d-5! K in eq 13 $ * 6.69 ! ka $ **0.5 ! m $ * ABS( seafloor_slope_canyon(ix) ) $ **1 ! n $ * dt endif enddo c adjust temperature in the sediment below the canyon do ix = 1, NX if( z_canyon(ix) .LT. z_top(ix,nz) ) then ! there is a canyon d_temperature_canyon(ix) = $ ( temperature(ix,nz,degC) $ - temperature(ix,nz-1,degC) $ ) / $ ( z_center(ix,nz) $ - z_center(ix,nz-1) $ ) $ * ( z_top(ix,nz) $ - z_canyon(ix) $ ) #define No_Temperature_Canyon #ifdef No_Temperature_Canyon d_temperature_canyon(ix) = 0.d0 #endif do iz = 1, nz temperature_canyon(ix,iz) = $ temperature(ix,iz,degC) $ + d_temperature_canyon(ix) if( z_center(ix,iz) .GT. z_canyon(ix) ) then ! its ocean temperature_canyon(ix,iz) = $ surface_temp(ix) ! just the local bottom water for now, no cold deep endif enddo endif enddo #ifdef Crap hydro_recharge = 0.d0 hydro_runoff = 0.d0 do ix = 1, NX if( iz_water_table(ix) .LE. nz) then ! outcrops, its nzmax+1 for submerged max_recharge = Hydrology_Recharge ! m / yr $ * dx(ix) $ * dt ! m3 of water if( fluid_vol(ix,iz_water_table(ix)) .LT. $ fluid_vol_init(ix,iz_water_table(ix)) $ ) then ! losing fluid, gotta add air air_vol(ix,iz_water_table(ix)) = $ air_vol(ix,iz_water_table(ix)) $ + fluid_vol_init(ix,iz_water_table(ix)) ! say 3 $ - fluid_vol(ix,iz_water_table(ix)) ! goes down to 2, air = 1 endif endif enddo c add air if porosity too low in outcropping gridpoint yc if( por_melted(ix,iz_water_table(ix)) c $ .LT. por_drained(ix,iz_water_table(ix)) c $ ) then ! fill it back up with air c air_vol(ix,iz_water_table(ix)) = c $ air_vol(ix,iz_water_table(ix)) c $ + solid_vol(ix,iz_water_table(ix)) c $ / ( 1.d0 c $ - por_drained(ix,iz_water_table(ix)) c $ ) ! sol/(1-por) = new total volume target c $ - tot_vol(ix,iz_water_table(ix)) ! tot_new - tot_old -> new air c endif #endif /* Crap */ return end #endif /* Hydrology */ subroutine bubble_crit_vanish(z_top, perm, $ bb_conc, bb_inv, pw_inv, pw_conc, ch4_eq, $ bubble_ch4_excess, bubble_ch4_redissolve, $ CH4_bubble_flux, $ dt, nz) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_top, perm double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_CH4_Isotopes) :: $ bb_conc, bb_inv double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_inv, pw_conc double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ bubble_ch4_excess, bubble_ch4_redissolve, $ CH4_bubble_flux double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ ch4_eq double precision dt c internal variables double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_CH4_Isotopes) :: $ bubble_CH4_excess_i, $ CH4_bubble_flux_i, bubble_ch4_redissolve_i double precision $ bubble_rediss_fract(nz), bubble_flux_fract(nz) integer ix, iz, izz, nz, ib bubble_ch4_redissolve_i = 0.d0 ch4_bubble_flux_i = 0.d0 do ix = 1, NX c if(ix .EQ. 5) then c write(6,*) "booger" c endif do iz = 1, nz c compute the excess #ifdef Bubble_Escape_Hard_Cutoff if( bb_conc(ix,iz,i_CH4) $ .GT. BB_Conc_Crit ) then bubble_ch4_excess(ix,iz) $ = bb_inv(ix,iz,i_CH4) ! moles $ * ( bb_conc(ix,iz,i_CH4) $ - BB_Conc_Crit $ ) $ / bb_conc(ix,iz,i_CH4) ! scaled to BB_Conc_Crit #else bubble_ch4_excess(ix,iz) $ = bb_inv(ix,iz,i_CH4) ! moles $ * dt / 0.5d0 ! weird formulation consistent with initial dt=.5 runs $ * MAX( 0.d0, $ ( 0.5 $ + ATAN( ( bb_conc(ix,iz,i_CH4) $ - BB_Conc_Crit $ ) $ / 0.5d-2 ! cutoff width $ ) / 3.14159 $ )**3.d0 $ ) #endif if(bb_inv(ix,iz,i_CH4) .GT. 0.d0) then c compute excess for isotopes do ib = i_CH4, i_CDH3 bubble_ch4_excess_i(ix,iz,ib) $ = bubble_ch4_excess(ix,iz) $ * bb_inv(ix,iz,ib) $ / bb_inv(ix,iz,i_CH4) enddo c remove the excess do ib = i_CH4, i_CDH3 bb_inv(ix,iz,ib) $ = bb_inv(ix,iz,ib) $ - bubble_ch4_excess_i(ix,iz,ib) c add it to the upgoing flux CH4_bubble_flux_i(ix,iz,ib) = $ CH4_bubble_flux_i(ix,iz,ib) $ + bubble_ch4_excess_i(ix,iz,ib) enddo else ! bb_inv .LE. 0 bb_inv(ix,iz,:) = 0.d0 endif c find the fate of the upgoing flux #ifdef Bubble_Rediss_Scale do izz = iz, nz #ifdef Perm_Inhibit_Bubble_Rising if(perm(ix,izz) .GT. Perm_Inhibit_Bubble_Rising) then #endif bubble_flux_fract(izz) = $ exp( ( z_top(ix,iz) $ - z_top(ix,izz) $ ) $ / Bubble_Rediss_Scale $ ) ! flux fraction out the top of each box #ifdef Perm_Inhibit_Bubble_Rising else bubble_flux_fract(izz:nz) = 0.d0 goto 1234 endif #endif enddo 1234 continue do izz = iz+1, nz if(CH4_bubble_flux_i(ix,iz,i_CH4) .GT. 0.d0) then do ib = i_CH4, i_CDH3 bubble_ch4_redissolve_i(ix,izz,ib) = ! what from this box goes into box izz above,moles $ bubble_ch4_redissolve_i(ix,izz,ib) $ + bubble_ch4_excess(ix,iz) ! moles $ * ( bubble_flux_fract(izz-1) $ - bubble_flux_fract(izz) $ ) ! sum dissolution in each box from all boxes below $ * CH4_bubble_flux_i(ix,iz,ib) $ / CH4_bubble_flux_i(ix,iz,i_CH4) ! including isotopic fractionation of source iz CH4_bubble_flux_i(ix,izz,ib) = ! what bubbles from this box will still be rising in izz $ CH4_bubble_flux_i(ix,izz,ib) $ + bubble_CH4_excess(ix,iz) $ * bubble_flux_fract(izz) $ * CH4_bubble_flux_i(ix,iz,ib) $ / CH4_bubble_flux_i(ix,iz,i_CH4) ! including isotopic fractionation of source iz enddo ! ib endif enddo #else bubble_ch4_redissolve(ix,iz) = 0.d0 do izz = iz+1, nz ! add it to the fluxes above also CH4_bubble_flux(ix,izz) = CH4_bubble_flux(ix,izz) $ + bubble_CH4_excess(ix,iz) enddo #endif #ifdef Bubble_Escape_Hard_Cutoff endif #endif enddo ! iz enddo ! ix do ix = 1, NX do iz = 1, nz if(bubble_ch4_redissolve_i(ix,iz,i_CH4) .GT. 0.d0) then do ib = i_CH4, i_CDH3 if(pw_conc(ix,iz,i_CH4) .LT. ch4_eq(ix,iz)) then pw_inv(ix,iz,ib) $ = pw_inv(ix,iz,ib) $ + bubble_ch4_redissolve_i(ix,iz,ib) else bb_inv(ix,iz,ib) $ = bb_inv(ix,iz,ib) $ + bubble_ch4_redissolve_i(ix,iz,ib) endif ! redissolves or just stays bubbles enddo ! isotope endif ! anything going on enddo enddo CH4_bubble_flux = CH4_bubble_flux_i(:,:,i_CH4) bubble_ch4_redissolve = bubble_ch4_redissolve_i(:,:,i_CH4) return end subroutine bubbles_flow(dx, dz, z_top, $ bb_conc, bb_inv, temperature, $ gas_visc, dyn_visc, perm, perm_lateral, $ p_excess, p_gas, $ bb_u, bb_w, bb_buoy, $ CH4_bubble_flux, $ nz, dt, myid, numprocs) implicit none double precision, dimension(0:NX+1) :: $ dx double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_top, dz double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ gas_visc, dyn_visc, perm, perm_lateral, $ p_excess, p_gas, $ bb_u, bb_w, bb_buoy, $ CH4_bubble_flux double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_Bubble_Types) :: $ bb_inv, bb_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision dt, flux_bubbles double precision rho_bb, rho_fluid integer i_bubble_timestep, ix, iz, i_pw, $ nz, myid, numprocs, $ n_bubble_timesteps n_bubble_timesteps = 1 do i_bubble_timestep = 1, n_bubble_timesteps #ifdef Scale_Gas_Visc do ix=1,NX do iz=1,nz gas_visc(ix,iz) = 3.d0 $ + ( 5.d0 - 3.d0 ) $ * ( 0.5 $ + ATAN( ( bb_conc(ix,iz,i_CH4) $ - 0.1d0 ! offset $ ) $ / 0.02d0 ! half-width $ ) / 3.14 $ ) gas_visc(ix,iz) = $ 10**(-gas_visc(ix,iz)) enddo enddo gas_visc(:,nz+1) = $ dyn_visc(:,nz+1) #else gas_visc(:,:) = dyn_visc(:,:) #endif #ifdef Bubble_Buoy do ix=1,NX do iz=1,nz rho_bb = 16.E-3 / 22.4e-3 ! kg / m3 $ * p_gas(ix,iz) / 0.1 $ * 298. / temperature(ix,iz,Kelvins) rho_fluid = 1028. $ * ( 1. + 2.e-4 * temperature(ix,iz,degC) ) bb_buoy(ix,iz) = ( rho_fluid - rho_bb ) ! kg / m3 $ * 9.8 ! m / s2 = kg / m2 s2 if(iz .EQ. nz) then rho_bb = 16.E-3 / 22.4e-3 ! kg / m3 $ * p_gas(ix,iz+1) / 0.1 $ * 298. / temperature(ix,iz+1,Kelvins) rho_fluid = 1028. $ * ( 1. + 2.e-4 * temperature(ix,iz+1,degC) ) bb_buoy(ix,iz+1) = ( rho_fluid - rho_bb ) ! kg / m3 $ * 9.8 ! m / s2 = kg / m2 s2 endif enddo enddo #endif c c ghost cells required for perm, gas_visc, dx, p_excess c #ifdef Wrap_On_Demand_not call wrap_ghosts(perm,myid,numprocs,NZ_Max) call wrap_ghosts(p_excess,myid,numprocs,NZ_Max) #endif do ix=1,NX do iz=nz,1,-1 bb_w(ix,iz) = perm(ix,iz) $ / ( ( gas_visc(ix,iz) $ + gas_visc(ix,iz+1) $ ) $ / 2.d0 $ ) $ * ( 0.d0 #ifdef Bubble_Driven_by_P_Excess $ + ( p_excess(ix,iz) $ - p_excess(ix,iz+1) $ ) $ * 1.d6 ! Pa = kg / m s2 $ / ((dz(ix,iz) + dz(ix,iz+1)) / 2.) ! kg / m2 s2 #endif #ifdef Bubble_Buoy_Cut $ + ( bb_buoy(ix,iz) $ + bb_buoy(ix,iz+1) $ ) / 2.d0 ! also kg / m2 s2 #endif $ ) $ * 3.14d7 ! m / yr bb_u(ix,iz) = ( perm_lateral(ix,iz) $ + perm(ix+1,iz) $ ) / 2. $ / ( ( gas_visc(ix,iz) $ + gas_visc(ix+1,iz) $ ) $ / 2. $ ) $ * ( p_excess(ix,iz) $ - p_excess(ix+1,iz) $ ) * 1.d6 ! Pa $ / ( ( dx(ix) $ + dx(ix+1) $ ) $ / 2. $ ) $ * 3.14d7 ! m / yr if(bb_w(ix,iz) .GT. Bubble_Vel_Max) then bb_w(ix,iz) = Bubble_Vel_Max endif if(bb_w(ix,iz) .LT. -Bubble_Vel_Max) then bb_w(ix,iz) = -Bubble_Vel_Max endif if(bb_u(ix,iz) .GT. Bubble_Vel_Max) then bb_u(ix,iz) = Bubble_Vel_Max elseif(bb_u(ix,iz) .LT. -Bubble_Vel_Max) then bb_u(ix,iz) = -Bubble_Vel_Max endif enddo enddo bb_w(:,nz+1) = bb_w(:,nz) #ifdef Bubble_Flow_U_ifTrapped c c ghost cells for z_top required here c #ifdef Wrap_On_Demand_not call wrap_ghosts(z_top,myid,numprocs,NZ_Max) #endif do ix=1,NX do iz=nz-1,1,-1 if( bb_w(ix,iz) .GT. bb_w(ix,iz+1) ) then ! vertical bubble trap if(z_top(ix-1,iz) .LE. z_top(ix,iz) $ .AND. $ z_top(ix+1,iz) .GT. z_top(ix,iz) ) then ! flow to the right bb_u(ix,iz) = $ bb_u(ix,iz) $ + ( bb_w(ix,iz) - bb_w(ix,iz-1) ) $ / dz(ix,iz) ! evac frac $ * dx(ix) ! m / yr endif if(z_top(ix+1,iz) .LE. z_top(ix,iz) $ .AND. $ z_top(ix-1,iz) .GT. z_top(ix,iz) ) then ! flow to the left bb_u(ix-1,iz) = $ bb_u(ix-1,iz) $ - ( bb_w(ix,iz) - bb_w(ix,iz-1) ) $ / dz(ix,iz) ! evac frac $ * dx(ix) ! m / yr endif endif if(bb_u(ix,iz) .GT. Bubble_Vel_Max) then bb_u(ix,iz) = Bubble_Vel_Max elseif(bb_u(ix,iz) .LT. -Bubble_Vel_Max) then bb_u(ix,iz) = -Bubble_Vel_Max endif if(bb_u(ix-1,iz) .GT. Bubble_Vel_Max) then bb_u(ix-1,iz) = Bubble_Vel_Max elseif(bb_u(ix-1,iz) .LT. -Bubble_Vel_Max) then bb_u(ix-1,iz) = -Bubble_Vel_Max endif enddo enddo #endif #ifdef Bubble_Flow_U c c ghost cells for bb_inv dumped into here c do ix=1,NX do iz=1,nz-1 do i_pw=i_CH4,i_CO2 flux_bubbles = bb_inv(ix,iz,i_pw) $ * bb_u(ix,iz) ! m / yr $ * dt ! m $ / n_bubble_timesteps $ / dx(ix) ! fraction scales with x bb_inv(ix,iz,i_pw) = $ bb_inv(ix,iz,i_pw) ! moles $ - flux_bubbles bb_inv(ix+1,iz,i_pw) = $ bb_inv(ix+1,iz,i_pw) $ + flux_bubbles enddo enddo enddo #endif #ifdef Bubble_Flow_W do ix=1,NX do iz=1,nz do i_pw=i_CH4,i_CO2 CH4_bubble_flux(ix,iz) $ = bb_inv(ix,iz,i_pw) $ * bb_w(ix,iz) ! m / yr $ / dz(ix,iz) ! fraction of the bubbles scales with y $ * dt ! mol $ / n_bubble_timesteps bb_inv(ix,iz,i_pw) = bb_inv(ix,iz,i_pw) ! moles $ - flux_bubbles bb_inv(ix,iz+1,i_pw) = bb_inv(ix,iz+1,i_pw) ! moles $ + flux_bubbles enddo ! i_pw enddo ! iz enddo #endif c Bubble_Flow_W c write(6,*) "debug", bb_inv(4,6,:) enddo return end #ifdef Rising_Black_Gold subroutine black_gold_risin(petro_inv, $ dz, nz, dt) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ petro_inv, dz double precision :: dt, petro_flux integer ix, iz, nz do ix = 1, NX do iz = nz, 1, -1 petro_flux = petro_inv(ix,iz) $ * Rising_Black_Gold ! m / yr $ / dz(ix,iz) $ * dt $ * T_Scale petro_flux = MIN( petro_flux, petro_inv(ix,iz) ) petro_inv(ix,iz) = petro_inv(ix,iz) $ - petro_flux if(iz .LT. nz) then petro_inv(ix,iz+1) = petro_inv(ix,iz+1) $ + petro_flux endif enddo enddo return end #endif subroutine update_pw_inv(pw_conc,pw_inv,fluid_vol,nz) implicit none integer nz,ix,iz,i_pw,myid,numprocs double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc, pw_inv double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ fluid_vol do ix=1,NX do iz=1,nz do i_pw=1,N_PW pw_inv(ix,iz,i_pw) = $ pw_conc(ix,iz,i_pw) $ * fluid_vol(ix,iz) pw_inv(ix,iz,i_pw) = $ MAX ( pw_inv(ix,iz,i_pw), $ 0.d0 $ ) enddo enddo enddo return end subroutine update_pw_conc(pw_conc,pw_inv,fluid_vol, $ nz,myid,numprocs) implicit none integer nz,ix,iz,i_pw,myid,numprocs double precision molwt_pw(N_PW) double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc, pw_inv double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ fluid_vol double precision pw_frac do ix=1,NX do iz=1,nz do i_pw=1,N_PW if(fluid_vol(ix,iz) .GT. 1.d-1) then pw_conc(ix,iz,i_pw) = MAX( 0.d0, $ pw_inv(ix,iz,i_pw) ! moles $ / fluid_vol(ix,iz) ! / m3 $ ) else pw_conc(ix,iz,i_pw) = 0.d0 endif enddo enddo enddo #ifdef Wrap_On_Update do i_pw=1,N_PW call wrap__boundary_ghosts(pw_conc(:,:,i_pw), $ myid,numprocs,NZ_Max) enddo #endif return end subroutine find_thermal_properties(z_center, dz, $ volume, $ heat_capacity, therm_diffusivity, $ sl_inv, bb_inv, $ diffusivity, molwt, rho, $ dt, nz) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_center, dz double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ heat_capacity, therm_diffusivity double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_inv double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_Bubble_Types) :: $ bb_inv double precision diffusivity(N_PW), molwt(N_SL), rho(N_Rho), $ dt integer nz,ix,iz,n_sl do ix=1,NX do iz = 1, nz C third, compute average heat capacity heat_capacity(ix,iz) = !J/(m3 tot)/degK $ ( 4.d0 ! specific heat of seawater, J / g deg K $ * rho(i_Seawater) ! now J/m3 deg $ * volume(ix,iz,ivol_fluid) ! each term is J / deg $ + 0.820d0 ! sediment, J / g deg K $ * rho(i_Sediment) $ * volume(ix,iz,ivol_solid) $ + 2.080d0 ! hydrate, J / g deg K; Gupta et al 2006 $ * rho(i_Hydrate) $ * volume(ix,iz,ivol_hydrate) $ + 2.25d0 ! specific heat consant p methane gas, J / g deg K $ / molwt(i_CH4) ! now J / mol K $ * bb_inv(ix,iz,i_CH4) ! J / K $ + 2.097d0 ! ice $ * rho(i_Ice) $ * ( volume(ix,iz,ivol_ice) $ + volume(ix,iz,ivol_ice_sheet) $ ) $ ) / volume(ix,iz,ivol_tot) ! now J / m3 K C fourth, compute average thermal conductivity C Note: we use the arithmetic mixing formula of Gupta et al., J. Phys. Chem B (2006) C (instead of the geometric mixing formula suggested by C Buffett Feb 2009). therm_diffusivity(ix,iz) = $ ( 2.2d0 ! thermal conductivity of sediment, W / m deg K $ * volume(ix,iz,ivol_solid) $ + 0.58d0 ! thermal conductivity of seawater, W / m deg K $ * volume(ix,iz,ivol_fluid) $ + 0.7d0 ! thermal conductivity of hydrate, W / m deg K $ * volume(ix,iz,ivol_hydrate) $ + 0.03281d0 ! thermal conductivity of methane gas $ * volume(ix,iz,ivol_bubble) $ + 2.3d0 ! thermal conductivity of ice, W / m deg K $ * ( volume(ix,iz,ivol_ice) $ + volume(ix,iz,ivol_ice_sheet) $ ) $ + 0.7d0 ! thermal conductivity of hydrate, W / m deg K $ * volume(ix,iz,ivol_hydrate_CO2) $ ) / volume(ix,iz,ivol_tot) $ / heat_capacity(ix,iz) $ * 3.14d7 enddo enddo return end subroutine heat_sources(dz, tot_vol, temperature, $ heat_src_hydrate, heat_src_ice, $ heat_capacity, $ heat_geotherm_flux, $ dt, nz) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ dz, tot_vol double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ heat_src_hydrate, heat_src_ice, $ heat_capacity double precision, dimension(0:NX+1) :: $ heat_geotherm_flux double precision dt integer ix, iz, nz #ifdef Heat_Internal_Sources do ix=1, NX do iz=1, nz temperature(ix,iz,degC) = temperature(ix,iz,degC) $ + ( $ heat_src_hydrate(ix,iz) $ + heat_src_ice(ix,iz) $ ) ! J $ / heat_capacity(ix,iz) ! 1/ (J/m3K) $ / tot_vol(ix,iz) enddo enddo #endif #ifdef Geothermal_Heat temperature(1:NX,1,degC) = temperature(1:NX,1,degC) $ + heat_geotherm_flux(1:NX) ! W/m2 = J / s m2 $ * dt * 3.14e7 ! J / m2 $ * T_Scale_Diff $ / dz(1:NX,1) ! J / m3 $ / heat_capacity(1:NX,1) ! degC m3 / J -> degC #endif return end subroutine organic_reactions(pw_conc, pw_inv, $ sl_inv, sl_conc, sl_frac, $ resp, resp_doc, resp_petro, $ resp_k, resp_diss_k, $ resp_h2c, resp_o2c, resp_alpha_so4,resp_alpha_ch4, $ therm_k, therm_h, therm_o, $ petro_src,CH4_src_petro, $ CH4_sink_aom, $ CH4_src_resp, CH4_src_therm, $ DOC_src_therm, DIC_src_therm, $ POC_sink_therm, POH_sink_therm, POO_sink_therm, $ temperature, ice_frac, x, $ resp_rc, molwt, alpha, $ dt, nz) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc, pw_inv double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_inv, sl_conc, sl_frac double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ ice_frac double precision, dimension(0:NX+1) :: $ x double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ resp, resp_doc, resp_petro, $ resp_k, resp_diss_k, $ resp_h2c, resp_o2c, resp_alpha_so4, resp_alpha_ch4, $ therm_k, therm_h, therm_o, $ petro_src,CH4_src_petro, $ CH4_sink_aom, $ CH4_src_resp, CH4_src_therm, $ DOC_src_therm, DIC_src_therm, $ POC_sink_therm, POH_sink_therm, POO_sink_therm double precision :: molwt(N_SL), resp_rc, $ alpha(N_Alpha) double precision dt, $ SO4coeff, fract_temp_scale, DIC_src_13 integer ix, iz, nz c first calculate reaction rates resp_k = 0.d0 resp = 0.d0 resp_doc = 0.d0 therm_k = 0.d0 therm_h = 0.d0 therm_o = 0.d0 resp_h2c = 0.d0 resp_o2c = 0.d0 CH4_sink_aom = 0.d0 petro_src = 0.d0 CH4_src_petro = 0.d0 resp_petro = 0.d0 do ix = 1, NX do iz = 1, nz c if(ix .EQ. 1 .AND. iz .EQ. 35) then c write(6,*) "going into", ix, iz c call flush(6) c endif resp_k(ix,iz) = $ resp_rc #ifdef Resp_Scale_T $ * exp( 0.11 $ * MIN( temperature(ix,iz,degC), $ 100.d0 $ ) ! x3 in 10 C, Whiticar 1999 $ ) $ * ( 0.5 $ + ATAN( -0.1 $ * ( temperature(ix,iz,degC) $ - 50. ! cutoff temp $ ) $ ) $ / 3.1415 $ )**6 #endif #ifdef Resp_Scale_Age $ * exp( -log( MAX( 1.d0, $ sl_frac(ix,iz,i_Age) $ ) $ ) $ * 1.1 - 0.5 ! fit to plot 3 in Hedges and Keil 1995 $ ) #endif #ifdef Resp_Wallmann $ * ( Resp_Wallmann $ / ( ! pw_conc(ix,iz,i_DIC) $ + pw_conc(ix,iz,i_CH4) $ + Resp_Wallmann $ ) $ ) ! **6 #endif resp(ix,iz) = $ resp_k(ix,iz) $ * sl_inv(ix,iz,i_Bio_POC) $ * dt #ifdef Resp_Wallmann $ * T_Scale ! Wallmann takes over from age dominance of rate constant, ! which scaled automagically with T_Scale #endif c resp_k(ix,iz) = c $ 1.d0 / resp_k(ix,iz) ! years, for diagnostic enddo enddo do ix = 1, NX do iz = 1, nz if(sl_inv(ix,iz,i_POC) .GT. 0) then resp_h2c(ix,iz) = $ sl_inv(ix,iz,i_POH) $ / sl_inv(ix,iz,i_POC) resp_o2c(ix,iz) = $ sl_inv(ix,iz,i_POO) $ / sl_inv(ix,iz,i_POC) $ * 2.d0 ! pulls POO down faster than POC resp_alpha_so4(ix,iz) = $ ( 2.d0 + resp_h2c(ix,iz) / 2.d0 ) $ / 4.d0 resp_alpha_ch4(ix,iz) = 0.5d0 $ + resp_h2c(ix,iz) / 8.d0 resp_alpha_ch4(ix,iz) = 0.6 * resp_alpha_ch4(ix,iz) ! booger booger c CHx + Y H2O -> a CO2 + (1-a) CH4 c H: x + 2Y = 4 (1-a) c O: Y = 2 a c solve alpha(CO2) = .5-x/8, alpha(CH4)= 0.5+x/8 endif resp_diss_k(ix,iz) = $ 1.d0 #ifdef Resp_Scale_T $ * exp( 0.11 $ * MIN( temperature(ix,iz,degC), $ 100.d0 $ ) ! x3 in 10 C, Whiticar 1999 $ ) $ * ( 0.5 $ + ATAN( -0.1 $ * ( temperature(ix,iz,degC) $ - 50. ! cutoff temp $ ) $ ) $ / 3.1415 $ )**6 #endif #ifdef Resp_Wallmann $ * ( Resp_Wallmann $ / ( ! pw_conc(ix,iz,i_DIC) $ + pw_conc(ix,iz,i_CH4) $ + Resp_Wallmann $ ) $ ) !**6 #endif #ifdef Resp_DOC resp_doc(ix,iz) = resp_diss_k(ix,iz) $ * Resp_DOC $ * pw_inv(ix,iz,i_DOC) $ * dt $ * T_Scale #endif #ifdef Resp_Petro resp_petro(ix,iz) = resp_diss_k(ix,iz) $ * Resp_Petro $ * sl_inv(ix,iz,i_Petro) $ * dt $ * T_Scale #endif #ifdef Reaction_Ice_Freeze resp(ix,iz) = resp(ix,iz) $ * ( 1.d0 - ice_frac(ix,iz) ) resp_doc(ix,iz) = resp_doc(ix,iz) $ * ( 1.d0 - ice_frac(ix,iz) ) resp_petro(ix,iz) = resp_petro(ix,iz) $ * ( 1.d0 - ice_frac(ix,iz) ) #endif enddo enddo do ix = 1, NX do iz = 1, nz c thermogenic reactions #ifdef Reaction_Thermogen therm_k(ix,iz) = Therm_A ! yr-1 $ * exp( - Therm_E $ / 8.314 $ / temperature(ix,iz,Kelvins) $ ) * T_Scale therm_h(ix,iz) = therm_k(ix,iz) $ * sl_inv(ix,iz,i_POH) $ * dt therm_o(ix,iz) = therm_k(ix,iz) $ * sl_inv(ix,iz,i_POO) $ * dt #endif #ifdef Black_Gold if(sl_inv(ix,iz,i_POH) $ .GT. sl_inv(ix,iz,i_POC) ) then ! H/C > 1, relaxes toward 1 petro_src(ix,iz) = Petro_A $ * exp( - Petro_E $ / 8.314 $ / temperature(ix,iz,Kelvins) $ ) $ * ( sl_inv(ix,iz,i_POH) $ - sl_inv(ix,iz,i_POC) $ ) $ * dt * T_Scale endif #endif enddo ! iz enddo ! ix DOC_src_therm(1:NX,1:nz) = therm_o(1:NX,1:nz) ! makin acetate CH4_src_therm(1:NX,1:nz) = therm_h(1:NX,1:nz) / 4 ! 4H/1C in CH4 -> mol C DIC_src_therm(1:NX,1:nz) = 0.d0 POC_sink_therm(1:NX,1:nz) = $ DOC_src_therm(1:NX,1:nz) $ + CH4_src_therm(1:NX,1:nz) POH_sink_therm(1:NX,1:nz) = $ therm_h(1:NX,1:nz) $ + therm_o(1:NX,1:nz) * 2 POO_sink_therm(1:NX,1:nz) = $ therm_o(1:NX,1:nz) c update inventories ch4_src_resp = 0.d0 do ix = 1, NX do iz = 1, nz c#ifdef Update_Inventories c respiration reactions c dic gets the full resp and therm rates because CH4 is c pulled from DIC in a separate step pw_inv(ix,iz,i_DIC) = pw_inv(ix,iz,i_DIC) $ + resp(ix,iz) c#ifdef Resp_Sloppy_Frac $ * ( 1. - Resp_Sloppy_Frac ) c#endif $ + resp_doc(ix,iz) $ + resp_petro(ix,iz) pw_inv(ix,iz,i_DIC13) = pw_inv(ix,iz,i_DIC13) $ + ( resp(ix,iz) c#ifdef Resp_Sloppy_Frac $ * ( 1. - Resp_Sloppy_Frac ) c#endif $ + resp_doc(ix,iz) $ + resp_petro(ix,iz) $ ) $ * ( 1.d0 $ + alpha(i_alpha_org) $ ) c#endif /* Update_Inventories */ if( sl_inv(ix,iz,i_POC) .GT. 0 ) then sl_inv(ix,iz,i_Bio_POC) = sl_inv(ix,iz,i_Bio_POC) $ - ( resp(ix,iz) $ + petro_src(ix,iz) $ ) c $ * sl_inv(ix,iz,i_Bio_POC) c $ / sl_inv(ix,iz,i_POC) endif sl_inv(ix,iz,i_POC) = sl_inv(ix,iz,i_POC) $ - resp(ix,iz) $ - petro_src(ix,iz) sl_inv(ix,iz,i_POH) = sl_inv(ix,iz,i_POH) $ - resp(ix,iz) $ * resp_h2c(ix,iz) $ - petro_src(ix,iz) $ * 1.85 sl_inv(ix,iz,i_POO) = sl_inv(ix,iz,i_POO) $ - resp(ix,iz) $ * resp_o2c(ix,iz) $ - petro_src(ix,iz) $ * resp_o2c(ix,iz) pw_inv(ix,iz,i_DOC) = pw_inv(ix,iz,i_DOC) c#ifdef Resp_Sloppy_Frac $ + resp(ix,iz) $ * Resp_Sloppy_Frac c#endif $ - resp_doc(ix,iz) #ifdef Black_Gold sl_inv(ix,iz,i_Petro) = sl_inv(ix,iz,i_Petro) $ + petro_src(ix,iz) * Black_Gold ! only produces mobile oil $ - resp_petro(ix,iz) #endif enddo enddo c#ifdef Update_Inventories do ix = 1, NX do iz = 1, nz #ifdef Reaction_SO4_Reduction c sulfate or methane NOTE THIS CAN GO NEGATIVE, LOSES CONSERVATION if(pw_conc(ix,iz,i_SO4) .GT. 1.d0) then ! SO4 reduction pw_inv(ix,iz,i_SO4) = pw_inv(ix,iz,i_SO4) $ - resp(ix,iz) $ * resp_alpha_so4(ix,iz) ! 1/(4-2y+x) from CHx $ - resp_doc(ix,iz) $ * 0.6666d0 ! acetate CH2O coupled to S0 $ - resp_petro(ix,iz) * 0.73 ! for CH(1.85) #ifdef Reaction_SO4_Reduction_pH #ifdef i_Alk pw_inv(ix,iz,i_Alk) = pw_inv(ix,iz,i_Alk) $ + resp(ix,iz) $ * 2.d0 * resp_alpha(ix,iz) / 6.d0 $ + resp_doc(ix,iz) $ * 0.111 ! for acetate coupled to S0 #endif #endif else ! methanogenesis #endif c Reaction_SO4_Reduction #ifdef Reaction_CO2_Reduction CH4_src_resp(ix,iz) = resp(ix,iz) $ * resp_alpha_CH4(ix,iz) $ + resp_doc(ix,iz) $ * 0.5d0 ! from acetate $ + resp_petro(ix,iz) $ * 0.73d0 ! from CH(1.85) CH4_src_petro(ix,iz) = $ resp_petro(ix,iz) $ * 0.73d0 ! from CH(1.85) #endif if(pw_conc(ix,iz,i_DIC) .GT. 0.) then DIC_src_13 = pw_conc(ix,iz,i_DIC13) $ / pw_conc(ix,iz,i_DIC) else DIC_src_13 = 0.0 endif #ifdef Reaction_d_CH4 fract_temp_scale = 1.d0 $ - 10**( - temperature(ix,iz,degC) $ * 0.004 $ + LOG( - alpha(i_alpha_co2_redn) ) $ / 2.303 $ ) #else fract_temp_scale = 1.d0 #endif pw_inv(ix,iz,i_DIC) = pw_inv(ix,iz,i_DIC) $ - CH4_src_resp(ix,iz) ! already got resp, now remove methanogen pw_inv(ix,iz,i_DIC13) = pw_inv(ix,iz,i_DIC13) $ - CH4_src_resp(ix,iz) $ * DIC_src_13 $ * fract_temp_scale pw_inv(ix,iz,i_CH4) = pw_inv(ix,iz,i_CH4) $ + CH4_src_resp(ix,iz) pw_inv(ix,iz,i_C13H4) = pw_inv(ix,iz,i_C13H4) $ + CH4_src_resp(ix,iz) $ * DIC_src_13 $ * fract_temp_scale pw_inv(ix,iz,i_CDH3) = pw_inv(ix,iz,i_CDH3) $ + CH4_src_resp(ix,iz) $ * ( 1 $ + alpha(i_alpha_co2_redn_d) $ ) ! -160-180, from Whiticar $ * fract_temp_scale #ifdef Reaction_SO4_Reduction endif ! sulfate or methanogenesis #endif enddo enddo c#endif /* Update_Inventories */ do ix = 1, NX do iz = 1, nz #ifdef Reaction_AOM if(pw_conc(ix,iz,i_SO4) .GT. 1.d-18 $ .AND. $ pw_conc(ix,iz,i_CH4) .GT. 1.d-18) then CH4_sink_aom(ix,iz) = $ MIN( pw_inv(ix,iz,i_SO4) * 8/6, ! stoic to S0 $ pw_inv(ix,iz,i_CH4) $ ) * Reaction_AOM else CH4_sink_aom(ix,iz) = 0.d0 endif #else CH4_sink_aom(ix,iz) = 0.d0 #endif if(CH4_sink_aom(ix,iz) .GT. 0.d0 c $ .AND. pw_inv(ix,iz,i_CH4) .GT. 0.d0 c $ .AND. pw_inv(ix,iz,i_C13H4) .GT. 0.d0 c $ .AND. pw_inv(ix,iz,i_CDH3) .GT. 0.d0 $ ) then pw_inv(ix,iz,i_SO4) = pw_inv(ix,iz,i_SO4) $ - CH4_sink_aom(ix,iz) / 8*6 pw_inv(ix,iz,i_C13H4) = pw_inv(ix,iz,i_C13H4) $ - CH4_sink_aom(ix,iz) $ * pw_conc(ix,iz,i_C13H4) $ / pw_conc(ix,iz,i_CH4) $ * ( 1.d0 + alpha(i_alpha_aom) ) ! - 4-10 o/oo from Whiticar, ! -8.8 o/oo from Reeberg 2007 pg 16 pw_inv(ix,iz,i_CDH3) = pw_inv(ix,iz,i_CDH3) $ - CH4_sink_aom(ix,iz) $ * pw_conc(ix,iz,i_CDH3) $ / pw_conc(ix,iz,i_CH4) $ * ( 1.d0 + alpha(i_alpha_aom_d) ) ! - 160 o/oo from Reeberg pw_inv(ix,iz,i_CH4) = pw_inv(ix,iz,i_CH4) $ - CH4_sink_aom(ix,iz) pw_inv(ix,iz,i_DIC13) = pw_inv(ix,iz,i_DIC13) $ + CH4_sink_aom(ix,iz) $ * pw_conc(ix,iz,i_C13H4) $ / pw_conc(ix,iz,i_CH4) $ * ( 1.d0 + alpha(i_alpha_aom) ) pw_inv(ix,iz,i_DIC) = pw_inv(ix,iz,i_DIC) $ + CH4_sink_aom(ix,iz) endif enddo enddo c thermogenic reactions do ix = 1, NX do iz = 1, nz pw_inv(ix,iz,i_CH4) = pw_inv(ix,iz,i_CH4) $ + CH4_src_therm(ix,iz) pw_inv(ix,iz,i_C13H4) = pw_inv(ix,iz,i_C13H4) $ + CH4_src_therm(ix,iz) $ * ( 1.d0 + alpha(i_alpha_org) ) pw_inv(ix,iz,i_CDH3) = pw_inv(ix,iz,i_CDH3) $ + CH4_src_therm(ix,iz) $ * ( 1.d0 + alpha(i_alpha_therm_d) ) pw_inv(ix,iz,i_DIC) = pw_inv(ix,iz,i_DIC) $ + DIC_src_therm(ix,iz) pw_inv(ix,iz,i_DIC13) = pw_inv(ix,iz,i_DIC13) $ + DIC_src_therm(ix,iz) $ * ( 1.d0 + alpha(i_alpha_org) ) pw_inv(ix,iz,i_DOC) = pw_inv(ix,iz,i_DOC) $ + DOC_src_therm(ix,iz) sl_inv(ix,iz,i_POC) = $ sl_inv(ix,iz,i_POC) $ - POC_sink_therm(ix,iz) if(sl_inv(ix,iz,i_POC) .GT. 0.d0) then sl_inv(ix,iz,i_Bio_POC) = $ sl_inv(ix,iz,i_Bio_POC) $ - POC_sink_therm(ix,iz) $ / sl_inv(ix,iz,i_POC) $ * sl_inv(ix,iz,i_Bio_POC) endif sl_inv(ix,iz,i_POH) = $ sl_inv(ix,iz,i_POH) $ - POH_sink_therm(ix,iz) sl_inv(ix,iz,i_POO) = $ sl_inv(ix,iz,i_POO) $ - POO_sink_therm(ix,iz) c Iodine pw_inv(ix,iz,i_I129) = pw_inv(ix,iz,i_I129) $ * ( 1.d0 - dt / Decay_Time_I129 ) ! decay of the dissolved I129 $ + ( resp(ix,iz) $ + POC_sink_therm(ix,iz) $ ) $ * exp( -sl_frac(ix,iz,i_Age) $ / Decay_Time_I129 $ ) ! decay of the iodine in the source organic matter pw_inv(ix,iz,i_ITot) = pw_inv(ix,iz,i_ITot) $ + ( resp(ix,iz) $ + POC_sink_therm(ix,iz) $ ) enddo enddo sl_inv(:,:,1:N_POCs) = MAX( 0.d0, $ sl_inv(:,:,1:N_POCs) ) c#endif return end #ifdef Reaction_Rocks subroutine urey_reactions(fluid_vol, $ pw_conc, pw_inv, sl_conc, sl_inv, temperature, $ p_hydro, pH, hplus, CO3, CO2, HCO3, $ K1, K2, Ksp_CaCO3, $ igneous_k, rxn_igneous, $ omega_caco3, omega_igneous, csat_igneous, $ caco3_pcp, igneous_diss, $ dt, nz) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ omega_caco3, omega_igneous, csat_igneous, $ caco3_pcp, igneous_diss double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ fluid_vol double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc, pw_inv double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_conc, sl_inv double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ p_hydro, pH, hplus, CO3, CO2, HCO3, igneous_k, rxn_igneous, $ K1, K2, Ksp_CaCO3 double precision dt c internal variables double precision :: rxn_caco3, $ rxn_caco3_lo, rxn_caco3_hi double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc_tmp integer iter, ix, iz, nz, iz2,ierr do ix=1, NX do iz=1, nz #ifdef Reaction_Urey_TDep igneous_k(ix,iz) = $ MIN( Reaction_Igneous/T_Scale, ! keeps accelerated runs on tighter leash $ 10**( Reaction_Urey_TDep $ + temperature(ix,iz,degC) $ * 0.062 $ ) ! yr-1 efold const $ ) #else igneous_k(ix,iz) = Reaction_Igneous #endif csat_igneous(ix,iz) = exp( $ ( -66.83d0 * 1000d0 ! delta Ho $ - temperature(ix,iz,Kelvins) $ * (-107d0) ! delta So $ ) $ / 8.314 $ / temperature(ix,iz,Kelvins) $ ) ! M $ * 1000.d0 ! mol/m3 c write(6,*) csat_igneous(ix,iz) c if(pw_conc(ix,iz,i_DIC) .GT. 1.d-12) then c if(CO2(ix,iz) .GT. csat_igneous(ix,iz)) then rxn_igneous(ix,iz) = igneous_k(ix,iz) ! year-1 $ * ( pw_conc(ix,iz,i_DIC) - csat_igneous(ix,iz) ) c $ * ( CO2(ix,iz) - csat_igneous(ix,iz) ) c $ * pw_conc_tmp(ix,iz,i_DIC) ! first order in DIC c $ * ( 1.d0 - omega_igneous(ix,iz) ) ! max for zip undersat, but now off the table? $ * dt * T_Scale c else c rxn_igneous = 0.d0 c endif enddo enddo c igneous_k = 1.d-2 #ifdef Reaction_CaCO3 pw_conc_tmp = pw_conc do ix=1,NX do iz=1,nz c if(myid .EQ. 2 .AND. ix .EQ. 1 .AND. iz .EQ. 15) then c write(6,*) "thru caco3", myid, ix, iz, pw_conc(ix,iz,:) c endif c call MPI_Barrier(MPI_COMM_WORLD,ierr) rxn_caco3_hi = $ rxn_igneous(ix,iz) + pw_conc(ix,iz,i_Ca)*0.9 rxn_caco3_hi = MIN(rxn_caco3_hi, $ rxn_igneous(ix,iz) + pw_conc(ix,iz,i_DIC)*0.9) rxn_caco3_hi = MIN(rxn_caco3_hi, $ rxn_igneous(ix,iz) + 2.d0 * pw_conc(ix,iz,i_Alk)*0.9) rxn_caco3_lo = - sl_conc(ix,iz,i_CaCO3)*0.9 rxn_caco3 = rxn_igneous(ix,iz) do iter = 1, 25 pw_conc_tmp(ix,iz,i_DIC) = pw_conc(ix,iz,i_DIC) $ - rxn_caco3 pw_conc_tmp(ix,iz,i_Alk) = pw_conc(ix,iz,i_Alk) $ + 2.d0 * rxn_igneous(ix,iz) $ - 2.d0 * rxn_caco3 pw_conc_tmp(ix,iz,i_Ca) = pw_conc(ix,iz,i_Ca) $ + rxn_igneous(ix,iz) $ - rxn_caco3 ! Ca + ig - caco3 > 0, so caco3 < Ca + ig call caco3_eq(pw_conc_tmp, temperature, $ p_hydro, omega_igneous, $ omega_caco3, pH, hplus, $ CO3, CO2, HCO3, $ K1, K2, Ksp_CaCO3, $ ix,iz,nz) if(abs(omega_caco3(ix,iz)-1.d0) .LT. 1.d-3) then c $ .OR. rxn_caco3 .EQ. 0.d0) then goto 1234 endif if(omega_caco3(ix,iz) .GT. 1) then ! too much rxn_caco3_lo = rxn_caco3 ! caco3_diss hi is pcp too slow else rxn_caco3_hi = rxn_caco3 endif c write(6,*) "caco3", iter,rxn_caco3, omega_caco3(ix,iz) rxn_caco3 = ( rxn_caco3_hi + rxn_caco3_lo ) / 2.d0 enddo ! iter c write(6,*) "failed to converge in caco3" 1234 continue caco3_pcp(ix,iz) = $ rxn_caco3 $ * fluid_vol(ix,iz) igneous_diss(ix,iz) = $ rxn_igneous(ix,iz) $ * fluid_vol(ix,iz) enddo ! iz enddo ! ix #else igneous_diss = rxn_igneous * fluid_vol caco3_pcp = igneous_diss #endif /* Reaction_CaCO3 */ c Flux Limiters #ifdef CutThis do ix=1,NX do iz=1,nz caco3_pcp(ix,iz) = MIN(caco3_pcp(ix,iz), $ 0.9 * sl_inv(ix,iz,i_CaCO3) $ ) ! unlimited precipitation but limits dissolution caco3_pcp(ix,iz) = MAX(caco3_pcp(ix,iz), $ 0.9 * pw_inv(ix,iz,i_DIC) $ ) ! limited pcp caco3_pcp(ix,iz) = MAX(caco3_pcp(ix,iz), $ 0.9 * 2.d0 * pw_inv(ix,iz,i_Alk) $ ) ! limited pcp caco3_pcp(ix,iz) = MAX(caco3_pcp(ix,iz), $ 0.9 * pw_inv(ix,iz,i_Ca) $ ) ! limited pcp igneous_diss(ix,iz) = MAX(igneous_diss(ix,iz), $ 0.d0) ! no reverse weathering enddo enddo #endif do ix=1,NX do iz=1,nz c if(caco3_pcp(ix,iz) .LT. 0.d0) then ! dissolution c pw_inv(ix,iz,i_DIC13) = pw_inv(ix,iz,i_DIC13) c $ - caco3_pcp(ix,iz) ! unfractionated c else if(pw_inv(ix,iz,i_DIC) .GT. 0.d0) then pw_inv(ix,iz,i_DIC13) = pw_inv(ix,iz,i_DIC13) $ - caco3_pcp(ix,iz) $ * pw_inv(ix,iz,i_DIC13) $ / pw_inv(ix,iz,i_DIC) endif c endif pw_inv(ix,iz,i_DIC) = pw_inv(ix,iz,i_DIC) $ - caco3_pcp(ix,iz) pw_inv(ix,iz,i_Alk) = pw_inv(ix,iz,i_Alk) $ + 2. * igneous_diss(ix,iz) $ - 2. * caco3_pcp(ix,iz) pw_inv(ix,iz,i_Ca) = pw_inv(ix,iz,i_Ca) $ + igneous_diss(ix,iz) $ - caco3_pcp(ix,iz) sl_inv(ix,iz,i_CaCO3) = sl_inv(ix,iz,i_CaCO3) $ + caco3_pcp(ix,iz) enddo enddo return end #endif /* Reaction_Rocks */ #ifdef Reaction_Ice_Freeze subroutine ice_freeze_reaction(volume, $ sl_inv, pw_conc, pw_inv, temperature, heat_capacity, $ dT_Ice, ice_freeze, ice_frac, heat_src_ice, $ rho, molwt, $ dt, nz) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_inv double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc, pw_inv double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ dT_Ice, ice_freeze, heat_src_ice, $ heat_capacity, ice_frac double precision :: molwt(N_SL),rho(N_Rho), dt double precision :: dfluid, fluid_inv, fluid_inv_min c internal variables integer ix, iz, nz ice_freeze = 0.d0 do ix=1,NX do iz=1,nz heat_src_ice(ix,iz) = ! the maximum moles H2O phase transition to achieve the melting T $ - Reaction_Ice_Freeze ! ~ 0.9 to avoid oscillations $ * dT_Ice(ix,iz) ! deg C $ * heat_capacity(ix,iz)! J / m3 deg C -> J / m3 $ * volume(ix,iz,ivol_tot) ! m3 -> J overall ice_freeze(ix,iz) = $ heat_src_ice(ix,iz) ! J $ / 334.d0 ! latent heat of fusion for ice, J/g, -> g $ / molwt(i_Ice) ! moles H2O if(dT_Ice(ix,iz) .GT. 0.d0) then ! melting c#define No_Ice_Melting #ifdef No_Ice_Melting ice_freeze(ix,iz) = 0.d0 heat_src_ice(ix,iz) = 0.d0 #endif if( - ice_freeze(ix,iz) .GT. $ sl_inv(ix,iz,i_Ice) $ * Reaction_Ice_Freeze ) then ice_freeze(ix,iz) = - sl_inv(ix,iz,i_Ice) $ * Reaction_Ice_Freeze heat_src_ice(ix,iz) = ice_freeze(ix,iz) $ * 334.d0 $ * molwt(i_Ice) endif else ! freezing fluid_inv = volume(ix,iz,ivol_fluid) $ * rho(i_Freshwater) ! this assumes no dV upon salt solution $ / molwt(i_Freshwater) ! mol fluid_inv_min = ( volume(ix,iz,ivol_fluid) $ + volume(ix,iz,ivol_ice) $ ) $ * rho(i_Freshwater) $ / molwt(i_Freshwater) $ * Min_Unfrozen_Fluid_Frac if( fluid_inv - ice_freeze(ix,iz) .LT. $ fluid_inv_min ) then ice_freeze(ix,iz) = ( fluid_inv $ - fluid_inv_min $ ) $ * Reaction_Ice_Freeze heat_src_ice(ix,iz) = ice_freeze(ix,iz) $ * 334.d0 $ * molwt(i_Ice) endif endif volume(ix,iz,ivol_fluid) = volume(ix,iz,ivol_fluid) $ - ice_freeze(ix,iz) $ * molwt(i_Ice) ! g $ / rho(i_Freshwater) ! m3 if( volume(ix,iz,ivol_fluid) .LT. 0.d0 ) then write(6,*) "sucked it dry in freeze_ice",ix,iz endif sl_inv(ix,iz,i_Ice) = sl_inv(ix,iz,i_Ice) $ + ice_freeze(ix,iz) volume(ix,iz,ivol_ice) = sl_inv(ix,iz,i_Ice) ! mol $ * molwt(i_Ice) ! g $ / rho(i_Ice) ! m3 ice_frac(ix,iz) = volume(ix,iz,ivol_ice) $ / ( volume(ix,iz,ivol_ice) + volume(ix,iz,ivol_fluid) ) #ifdef Ice_Brine_Convective_Rejection c preserves the original concentrations call update_pw_inv(pw_conc,pw_inv, $ volume(:,:,ivol_fluid),nz) #endif enddo enddo return end #endif subroutine diffuse_vertical(dx, z_center, dz, $ fluid_vol, ice_vol, iz_water_table, $ por_liquid, therm_diffusivity, heat_capacity, $ diffusivity, $ pw_conc, temperature, $ pw_diff, heat_diff_flux, $ dt, nz) implicit none double precision, dimension(0:NX+1) :: dx double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_center, dz, heat_diff_flux double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ fluid_vol, ice_vol double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ por_liquid, therm_diffusivity, heat_capacity double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision diffusivity(N_PW), $ pw_diff(0:NX+1,0:NZ_Max+1,N_PW), dt integer ix,iz,i_pw,nz_start,nz_end,nz,iz_up,ierr integer, dimension(NX) :: iz_water_table double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ porosity_up, porosity_down double precision, dimension(NZ_Max) :: $ aa, bb, cc, rr, uu, $ const_up, const_down do ix = 1, NX do iz = 1, nz porosity_up(ix,iz) = $ ( por_liquid(ix,iz) $ + por_liquid(ix,iz+1) $ ) / 2.d0 porosity_down(ix,iz) = $ ( por_liquid(ix,iz) $ + por_liquid(ix,iz-1) $ ) / 2.d0 enddo porosity_up(ix,nz) = por_liquid(ix,iz) enddo do i_pw = 0, N_PW ! the zero index will be used to indicate temperature do ix=1,NX #ifdef Diffusion_Exclude_Thin_Boxes nz_start = 0 nz_end = 0 do iz=1,nz if( nz_start .EQ. 0 $ .AND. $ dz(ix,iz) .GT. Min_Dz_Calc $ .AND. $ fluid_vol(ix,iz) $ / ( fluid_vol(ix,iz) + ice_vol(ix,iz) ) .GT. 0.01d0 $ ) then nz_start = iz nz_end = iz endif if( nz_start .GT. 0 $ .AND. $ dz(ix,iz) .GT. Min_Dz_Calc $ .AND. $ fluid_vol(ix,iz) / ice_vol(ix,iz) .GT. 0.01d0 $ ) then nz_end = iz endif enddo if(nz_start .EQ. 0) then return endif #else nz_start = 1 nz_end = MIN(nz,iz_water_table(ix)) #endif const_up = 0.d0 const_down = 0.d0 do iz=nz_start,nz_end if(iz .EQ. nz_end) then iz_up = nz+1 else iz_up = iz+1 endif if( i_pw .EQ. 0 ) then ! our secret signal to do temperature const_up(iz) = $ therm_diffusivity(ix,iz) ! m2 / yr $ / ( z_center(ix,iz+1) $ - z_center(ix,iz) ! say -1000 - -1500 = 500 $ ) ! degC m / yr $ * dt / dz(ix,iz) ! 1/dz = dx / tot vol #ifdef SemiImplicit $ / 2. #endif const_down(iz) = $ therm_diffusivity(ix,iz) $ / ( z_center(ix,iz) $ - z_center(ix,iz-1) ! say -1000 - -1500 = 500 $ ) ! degC m / yr $ * dt / dz(ix,iz) ! degC m #ifdef SemiImplicit $ / 2. #endif else ! solute, not temperature const_up(iz) = $ diffusivity(i_pw) ! m2 / yr $ * porosity_up(ix,iz)**2 $ * dt * dx(ix) $ / ( z_center(ix,iz+1) $ - z_center(ix,iz) $ ) ! m / yr $ / fluid_vol(ix,iz) #ifdef SemiImplicit $ / 2. #endif const_down(iz) = $ diffusivity(i_pw) $ * porosity_down(ix,iz)**2 $ * dt * dx(ix) ! degC m $ / ( z_center(ix,iz) $ - z_center(ix,iz-1) $ ) ! degC m / yr $ / fluid_vol(ix,iz) #ifdef SemiImplicit $ / 2. #endif endif ! temperature or a solute enddo ! iz const_down(nz_start) = 0. aa = 0. bb = 0. cc = 0. rr = 0. uu = 0. do iz=nz_start,nz_end if(iz .EQ. nz_end) then iz_up = nz+1 else iz_up = iz+1 endif aa(1+iz-nz_start) = - const_down(iz) bb(1+iz-nz_start) = 1 + const_up(iz) + const_down(iz) cc(1+iz-nz_start) = - const_up(iz) if( i_pw .EQ. 0) then rr(1+iz-nz_start) = temperature(ix,iz,degC) #ifdef SemiImplicit $ + const_up(iz) $ * ( temperature(ix,iz_up,degC) $ - temperature(ix,iz,degC) $ ) $ - const_down(iz) $ * ( temperature(ix,iz,degC) $ - temperature(ix,iz-1,degC) $ ) #endif else rr(1+iz-nz_start) = pw_conc(ix,iz,i_pw) #ifdef SemiImplicit $ + const_up(iz) $ * ( pw_conc(ix,iz_up,i_pw) $ - pw_conc(ix,iz,i_pw) $ ) $ - const_down(iz) $ * ( pw_conc(ix,iz,i_pw) $ - pw_conc(ix,iz-1,i_pw) $ ) #endif endif ! temperature or a solute enddo ! iz c imposed concentration condition at sea floor if( i_pw .EQ. 0) then rr(1+nz_end-nz_start) = rr(1+nz_end-nz_start) $ + const_up(nz_end) * temperature(ix,nz+1,degC) else rr(1+nz_end-nz_start) = rr(1+nz_end-nz_start) $ + const_up(nz_end) * pw_conc(ix,nz+1,i_pw) endif call tridiag_solver(aa,bb,cc,rr,uu, $ 1+nz_end-nz_start,ierr) if(ierr .GT. 0) then ierr = ierr + 10 * i_pw return endif if( i_pw .EQ. 0) then do iz=nz_start,nz_end temperature(ix,iz,degC) = uu(1+iz-nz_start) enddo do iz=1,nz_start-1 temperature(ix,iz,degC) = $ temperature(ix,nz_start,degC) ! filling down enddo do iz=nz_end+1,nz temperature(ix,iz,degC) = temperature(ix,nz+1,degC) ! filling from ocean enddo do iz = 1, nz heat_diff_flux(ix,iz) = $ therm_diffusivity(ix,iz) ! m2 / yr $ * heat_capacity(ix,iz) ! J / m3 K -> J / m K yr $ / ( z_center(ix,iz+1) $ - z_center(ix,iz) $ ) ! 1/m -> J / m2 K yr $ * ( temperature(ix,iz,degC) $ - temperature(ix,iz+1,degC) $ ) ! J / m2 yr $ / 3.14E7 ! J / m2 s = W / m2 enddo else do iz=nz_start,nz_end pw_conc(ix,iz,i_pw) = uu(1+iz-nz_start) enddo do iz=1,nz_start-1 pw_conc(ix,iz,i_pw) = pw_conc(ix,nz_start,i_pw) ! filling up from below enddo do iz=nz_end+1,nz pw_conc(ix,iz,i_pw) = pw_conc(ix,nz+1,i_pw) ! filling from ocean enddo do iz = 1, nz pw_diff(ix,iz,i_pw) = $ diffusivity(i_pw) ! m2 / yr $ * porosity_up(ix,iz)**2 $ * ( pw_conc(ix,iz,i_pw) ! +ve upward flux $ - pw_conc(ix,iz+1,i_pw) $ ) ! moles / m3 $ / ( z_center(ix,iz+1) $ - z_center(ix,iz) $ ) ! mol / m2 yr $ * dt * dx(ix) ! mol / timestep enddo endif ! temperature or solute enddo ! ix enddo ! i_pw return end SUBROUTINE tridiag_solver(a,b,c,r,u,n,ierr) implicit none INTEGER n INTEGER j integer runid, idebug, ierr double precision gam(1000), $ a(n), b(n), c(n), r(n), u(n) double precision bet if (b(1).EQ.0.) then write(6,*) "b(1) = 1 in tridiag", runid ierr = 1 return endif bet=b(1) u(1)=r(1)/bet DO 1 j=2,n gam(j)=c(j-1)/bet bet=b(j)-a(j)*gam(j) IF(bet.EQ.0.) then write(6,*) 'singular matrix in tridiag' ierr = 2 return endif u(j)=(r(j)-a(j)*u(j-1))/bet 1 CONTINUE DO 2 j=n-1,1,-1 u(j)=u(j)-gam(j+1)*u(j+1) 2 CONTINUE ierr = 0 RETURN END subroutine sum_diag_2d(inv, tot, n, nz) implicit none #ifdef MPI include 'mpif.h' integer ierr #endif double precision, dimension(0:NX+1,0:NZ_Max+1, n) :: $ inv double precision, dimension(n) :: tot, global_tot integer ix, iz, nz, n tot = 0.d0 do ix = 1, NX do iz = 1, nz tot(1:n) = tot(1:n) $ + inv(ix,iz,1:n) enddo enddo #ifdef MPI call MPI_Reduce(tot,global_tot,n, $ MPI_DOUBLE_PRECISION,MPI_SUM,Master, $ MPI_COMM_WORLD,ierr) tot = global_tot #endif return end subroutine sum_diag_1d(inv, tot, n) implicit none #ifdef MPI include 'mpif.h' integer ierr #endif double precision, dimension(0:NX+1,n) :: $ inv double precision, dimension(n) :: tot, global_tot integer ix, n tot = 0.d0 do ix = 1, NX tot(1:n) = tot(1:n) $ + inv(ix,1:n) enddo #ifdef MPI call MPI_Reduce(tot,global_tot,n, $ MPI_DOUBLE_PRECISION,MPI_SUM,Master, $ MPI_COMM_WORLD,ierr) tot = global_tot #endif return end subroutine column_inv_2d(inv, tot, nz) implicit none #ifdef MPI include 'mpif.h' integer ierr #endif double precision, dimension(0:NX+1,0:nz) :: inv double precision, dimension(0:NX+1) :: tot integer ix, iz, nz tot = 0.d0 do ix = 1, NX do iz = 1, nz tot(ix) = tot(ix) $ + inv(ix,iz) enddo enddo return end subroutine domain_inv(inv,tot) implicit none #ifdef MPI include 'mpif.h' integer ierr #endif double precision, dimension(0:NX+1) :: inv double precision :: tot, global_tot integer ix, iz, nz tot = 0.d0 do ix = 1, NX tot = tot + inv(ix) enddo #ifdef MPI call MPI_Reduce(tot,global_tot,1, $ MPI_DOUBLE_PRECISION,MPI_SUM,Master, $ MPI_COMM_WORLD,ierr) tot = global_tot #endif return end subroutine compute_sedcol_flux(por_melted, dz, sedcol_u, $ sedcol_flux, $ nz, myid, numprocs) implicit none #ifdef MPI include 'mpif.h' integer ierr #endif double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ por_melted, dz double precision, dimension(0:NX+1) :: sedcol_u double precision :: sedcol_flux(2) double precision :: tot integer iz, nz, myid, numprocs if(myid .EQ. 0) then ! do left-hand side tot = 0.d0 do iz = 1, nz tot = tot + sedcol_u(0) ! m / yr $ * dz(1,iz) ! m3 tot / yr $ * ( 1.d0 - por_melted(1,iz) ) ! m3 solid / yr enddo c sedcol_u(0) is left-hand side of cell 1, removes stuff from cell 1 c sedcol_u is negative, so this comes out as a sink endif #ifdef MPI call MPI_Bcast(tot,1, $ MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) #endif sedcol_flux(1) = tot if(myid .EQ. numprocs-1) then ! do right-hand side tot = 0.d0 do iz = 1, nz tot = tot - sedcol_u(NX) ! m / yr $ * dz(NX+1,iz) ! m3 tot / yr $ * ( 1.d0 - por_melted(NX+1,iz) ) ! m3 solid / yr enddo c sedcol_u(NX) is right-hand side of cell NX brings in boundary condtion c from ghost cell. sedcol_u is negative, so overall tot > 0 src endif #ifdef MPI call MPI_Bcast(tot,1, $ MPI_DOUBLE_PRECISION, numprocs-1, MPI_COMM_WORLD, ierr) #endif sedcol_flux(2) = tot return end subroutine read_wc_file(filename,wc_var,wc_z,nz) implicit none integer nz, iz double precision wc_var(nz), wc_z(nz), a_junk character(11) filename open(7,file=filename) do iz=1,nz read(7,*) wc_z(iz), wc_var(iz) enddo close(7) return end subroutine read_muds_files(muds_array,o2_muds,depth_muds, $ nz_muds,no2_muds,nfields_muds) implicit none integer nz_muds, no2_muds, nfields_muds, i_depth, i_o2 double precision, dimension(nz_muds,no2_muds,nfields_muds) :: $ muds_array double precision o2_muds(no2_muds), depth_muds(nz_muds) character(12) varname open(7,file='/home/mcguire/models/sponge/muds.txt') read(7,*) varname c write(6,*) varname read(7,*) o2_muds do i_depth=1,nz_muds read(7,*) depth_muds(i_depth), $ (muds_array(i_depth,i_o2,1),i_o2=1,no2_muds) ! POC enddo read(7,*) varname c write(6,*) varname read(7,*) do i_depth=1,nz_muds read(7,*) depth_muds(i_depth), $ (muds_array(i_depth,i_o2,2),i_o2=1,no2_muds) ! SO4 enddo #ifdef FixPOC muds_array(:,:,1) = FixPOC #endif return end subroutine depth_interp(wc_profile,depth_profile,depth_val,nz, $ val_interp) implicit none integer nz, i_shallower, i_o2, i_depth, i_val double precision wc_profile(nz), depth_profile(nz), $ depth_val, val_interp, weight_coeff(2) i_shallower = 1 do i_depth=1,nz-1 if(depth_profile(i_depth) .LT. depth_val) then i_shallower = i_depth endif enddo weight_coeff(1) = ( depth_profile(i_shallower+1) - depth_val ) $ / ( depth_profile(i_shallower+1) $ - depth_profile(i_shallower)) c dont extrapolate weight_coeff(1) = MIN(weight_coeff(1),1.0d0) weight_coeff(1) = MAX(weight_coeff(1),0.0d0) weight_coeff(2) = 1. - weight_coeff(1) val_interp = 0. do i_depth=1,2 val_interp = val_interp $ + wc_profile(i_depth+i_shallower-1) $ * weight_coeff(i_depth) enddo return end subroutine muds_interp(muds_array,depth_muds,o2_muds, $ nz_muds, no2_muds, nfields_muds, $ depth, o2, poc, so4_1m) implicit none integer nz_muds, no2_muds, nfields_muds, $ i_shallower, i_lessO2, i_depth, i_o2, i_coeff double precision, dimension(nz_muds,no2_muds,nfields_muds) :: $ muds_array double precision o2_muds(no2_muds), depth_muds(nz_muds), $ out_data(2), weight_coeff(2,2), depth, o2, poc, so4_1m i_shallower = 1 do i_depth=1,nz_muds-1 if(depth_muds(i_depth) .LT. depth) then i_shallower = i_depth endif enddo i_lessO2 = 1 do i_o2=2,no2_muds-1 ! assures that i_lessO2+1 is within bounds if(o2_muds(i_o2) .LT. o2) then i_lessO2 = i_o2 endif enddo weight_coeff(1,1) = ( depth_muds(i_shallower+1) - depth ) $ / ( depth_muds(i_shallower+1) $ - depth_muds(i_shallower)) weight_coeff(2,1) = ( o2_muds(i_lessO2+1) - o2 ) $ / ( o2_muds(i_lessO2+1) - o2_muds(i_lessO2)) c dont extrapolate weight_coeff(:,1) = MIN(weight_coeff(:,1),1.0d0) weight_coeff(:,1) = MAX(weight_coeff(:,1),0.0d0) do i_coeff = 1, 2 weight_coeff(i_coeff,2) = 1. - weight_coeff(i_coeff,1) enddo out_data(:) = 0. do i_depth = 1,2 do i_O2 = 1,2 out_data(:) = out_data(:) $ + muds_array(i_depth+i_shallower-1, $ i_O2+i_lessO2-1, $ :) $ * weight_coeff(1,i_depth) $ * weight_coeff(2,i_O2) enddo enddo poc = out_data(1) so4_1m = out_data(2) return end subroutine update_sl_inv(sl_frac,sl_inv,solid_vol, $ molwt,rho,nz) c computes the inventory from the fraction, used in initialization and spawning c for particle sizes the fractions sum to 1, independently of the chem species implicit none integer nz,ix,iz,i_sl double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_frac, sl_inv double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ solid_vol double precision molwt(N_SL), rho(N_Rho) do ix=1,NX do iz=1,nz do i_sl=1,N_SL_Conc sl_inv(ix,iz,i_sl) = $ sl_frac(ix,iz,i_sl) ! g / g sed $ / molwt(i_sl) ! mol / g sed $ * rho(i_Sediment) ! mol / m3 sed $ * solid_vol(ix,iz) ! mol enddo do i_sl=N_SL_Conc+1,N_SL sl_inv(ix,iz,i_sl) = $ sl_frac(ix,iz,i_sl) ! g / g sed $ * rho(i_Sediment) ! g / m3 sed $ * solid_vol(ix,iz) ! g enddo enddo enddo return end subroutine update_sl_conc(sl_inv,sl_conc,sl_frac,solid_vol, $ molwt,rho,nz) c updates the solid_vol, fraction, and the concentration from the inventory implicit none integer nz, ix,iz,i_sl double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_inv, sl_conc, sl_frac double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ solid_vol double precision molwt(N_SL), rho(N_Rho) double precision sum_frac,tmp_rho,tmp_normalized, $ tot_mass, tot_grains c solid_vol = 0.d0 do ix=1,NX do iz=1,nz c update solid_vol based on chemical species tot_mass = 0.d0 do i_sl=1,N_SL_Conc c solid_vol(ix,iz) = solid_vol(ix,iz) c $ + sl_inv(ix,iz,i_sl) ! moles c $ * molwt(i_sl) ! grams c $ / rho(i_sl) ! m3 tot_mass = tot_mass $ + sl_inv(ix,iz,i_sl) $ * molwt(i_sl) enddo c concentrations of all species do i_sl = 1, N_SL sl_conc(ix,iz,i_sl) = sl_inv(ix,iz,i_sl) ! mol or g $ / solid_vol(ix,iz) ! mol or g/m3 enddo c chemical fractions do i_sl = 1, N_SL_Conc sl_frac(ix,iz,i_sl) = sl_inv(ix,iz,i_sl) ! mol $ * molwt(i_sl) ! g $ / solid_vol(ix,iz) ! g / m3 $ / rho(i_Sediment) ! g / g enddo sl_frac(ix,iz,i_Age) = sl_conc(ix,iz,i_Age) $ / rho(i_Sediment) c normalize grain fractions to tot_grains tot_grains = 0.d0 do i_sl = i_first_size_class, i_Pelagic tot_grains = tot_grains $ + sl_inv(ix,iz,i_sl) enddo if(tot_grains .GT. 0.d0) then do i_sl = i_first_size_class, i_Pelagic sl_frac(ix,iz,i_sl) = sl_inv(ix,iz,i_sl) $ / tot_grains enddo else sl_frac(ix,iz,i_first_size_class:i_Pelagic)= $ 0.d0 endif enddo enddo return end #ifdef Reaction_CH4_Phases subroutine three_phase_reactions(fluid_vol, $ sl_inv, $ dissolved_conc, $ dissolved_inv, $ third_phase_inv, $ dTemp, hydrate_frac, $ heat_src, exsolve, $ freeze, c_eq_pw, $ rho, molwt_pw, molwt_sl, $ latent_heat, $ n_isotopes, $ dt, nz) implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ fluid_vol double precision, dimension(0:NX+1,0:NZ_Max+1,n_isotopes) :: $ sl_inv double precision, dimension(0:NX+1,0:NZ_Max+1,n_isotopes) :: $ dissolved_conc, dissolved_inv double precision, dimension(0:NX+1,0:NZ_Max+1, $ n_isotopes) :: $ third_phase_inv double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ dTemp, hydrate_frac, heat_src, exsolve, freeze, c_eq_pw double precision :: rho(N_Rho) double precision latent_heat, molwt_sl, molwt_pw, dt $ , dfluid integer n_isotopes, i_sl_pointer, i_pw_pointer, nz, $ ix, iz, i_isotope double precision, dimension(0:NX+1,0:NZ_Max+1,N_CH4_Isotopes) :: $ rxn rxn = 0.d0 ! standardize -- gas leaving solution is positive heat_src = 0.d0 exsolve = 0.d0 freeze = 0.d0 #ifdef Hydrate_Bubbles_Only dTemp = 10.d0 hydrate_frac = 0.d0 #endif #ifdef Hydrate_Hydrate_Only dTemp = -10.d0 hydrate_frac = 1.d0 #endif #ifdef Hydrate_Split_Box do ix = 1, NX do iz = 1, nz c if(sl_inv(ix,iz,1) .GT. 0.d0 .AND. c $ hydrate_frac(ix,iz) .LT. 1.d0) then c write(6,*) "split box", ix,iz c endif c if(hydrate_frac(ix,iz) .GT. 0.d0) then c write(6,*) "wtf" c endif c partitions bubbles / hydrate inventory as hydrate_frac tells it to do i_isotope = 0, n_isotopes - 1 rxn(ix,iz,1+i_isotope) = $ ( sl_inv(ix,iz,1+i_isotope) $ + third_phase_inv(ix,iz,1+i_isotope) $ ) * hydrate_frac(ix,iz) ! proper partitioned sl_inv value rxn(ix,iz,1+i_isotope) = ! positive means gas -> hydrate $ ( rxn(ix,iz,1+i_isotope) $ - sl_inv(ix,iz,1+i_isotope) $ ) $ * Reaction_CH4_Phases * dt c $ * tanh(dTemp(ix,iz)/5.d0) sl_inv(ix,iz,1+i_isotope) = $ sl_inv(ix,iz,1+i_isotope) $ + rxn(ix,iz,1+i_isotope) third_phase_inv(ix,iz,1+i_isotope) = $ third_phase_inv(ix,iz,1+i_isotope) $ - rxn(ix,iz,1+i_isotope) enddo #ifdef Hydrate_Release_Fluid_Volume dfluid = rxn(ix,iz,1) ! mol hydrate $ * ( molwt_sl - molwt_pw ) ! g water $ / rho(i_Seawater) ! m3 water if(dfluid .LT. fluid_vol(ix,iz)) then fluid_vol(ix,iz) = fluid_vol(ix,iz) $ - dfluid endif #endif heat_src(ix,iz) = $ rxn(ix,iz,1) ! mol hydrate $ * molwt_sl ! g hydrate $ * latent_heat ! J/g -> J freeze(ix,iz) = rxn(ix,iz,1) ! diagnostic enddo enddo #endif #ifdef Hydrate_Gas_Phase_All_or_Nothing do ix = 1, NX do iz = 1, nz if( dTemp(ix,iz) .GT. 0 ) then ! bubble zone, hydrate converts to bubbles do i_isotope = 0, n_isotopes - 1 if(sl_inv(ix,iz,1+i_isotope) $ .GT. 0.d0) then rxn(ix,iz,1+i_isotope) = $ - sl_inv(ix,iz,1+i_isotope) $ * Reaction_CH4_Phases * dt $ * tanh(dTemp(ix,iz)/5.d0) sl_inv(ix,iz,1+i_isotope) = $ sl_inv(ix,iz,1+i_isotope) $ + rxn(ix,iz,1+i_isotope) dissolved_inv(ix,iz,1+i_isotope) = $ dissolved_inv(ix,iz,1+i_isotope) $ - rxn(ix,iz,1+i_isotope) endif enddo #ifdef Hydrate_Release_Fluid_Volume dfluid = rxn(ix,iz,1) ! mol hydrate $ * ( molwt_sl - molwt_pw ) ! g water $ / rho(i_Seawater) ! m3 water if(dfluid .LT. fluid_vol(ix,iz)) then fluid_vol(ix,iz) = fluid_vol(ix,iz) $ - dfluid endif #endif heat_src(ix,iz) = $ rxn(ix,iz,1) ! mol hydrate $ * molwt_sl ! g hydrate $ * latent_heat ! J/g -> J freeze(ix,iz) = rxn(ix,iz,1) else ! hydrate forms from bubble/liquid phase do i_isotope = 0, n_isotopes - 1 if(third_phase_inv(ix,iz,1+i_isotope) $ .GT. 0.d0) then rxn(ix,iz,1+i_isotope) = $ - third_phase_inv(ix,iz,1+i_isotope) $ * Reaction_CH4_Phases * dt $ * tanh(dTemp(ix,iz)/5.d0) ! < 0 if dTemp < 0 sl_inv(ix,iz,1+i_isotope) = $ sl_inv(ix,iz,1+i_isotope) $ + rxn(ix,iz,1+i_isotope) third_phase_inv(ix,iz,1+i_isotope) = $ third_phase_inv(ix,iz,1+i_isotope) $ - rxn(ix,iz,1+i_isotope) endif enddo #ifdef Hydrate_Release_Fluid_Volume dfluid = rxn(ix,iz,1) ! mol hydrate $ * ( molwt_sl - molwt_pw ) ! g water $ / rho(i_Seawater) ! m3 water if(dfluid .LT. fluid_vol(ix,iz)) then fluid_vol(ix,iz) = fluid_vol(ix,iz) $ - dfluid endif #endif heat_src(ix,iz) = $ rxn(ix,iz,1) $ * molwt_sl $ * latent_heat freeze(ix,iz) = rxn(ix,iz,1) endif enddo enddo #endif C Hydrate_Gas_Phase_All_or_Nothing #ifdef Hydrate_Reaction_Degassing rxn = 0.d0 do ix = 1, NX do iz = 1, nz c de-solving reactions to bubbles or hydrate rxn(ix,iz,1) = $ ( dissolved_conc(ix,iz,1) $ - c_eq_pw(ix,iz) $ ) ! mol/m3 $ * fluid_vol(ix,iz) ! moles $ * Reaction_CH4_Phases * dt if( rxn(ix,iz,1) .GT. 0.d0) then ! supersat exsolve(ix,iz) = rxn(ix,iz,1) do i_isotope = 1, n_isotopes-1 if(dissolved_conc(ix,iz,1) .GT. 0.d0) then rxn(ix,iz,i_isotope+1) = $ rxn(ix,iz,1) $ * dissolved_conc(ix,iz,1+i_isotope) $ / dissolved_conc(ix,iz,1) ! scale to conc else rxn(ix,iz,i_isotope+1) = 0.d0 endif enddo C if(hydrate_frac(ix,iz) .LT. 0) then C write(6,*) "debug me A ", ix,iz,hydrate_frac(ix,iz) C call flush(6) C endif do i_isotope = 0, 2 dissolved_inv(ix,iz,1+i_isotope) = $ dissolved_inv(ix,iz,1+i_isotope) $ - rxn(ix,iz,1+i_isotope) sl_inv(ix,iz,1+i_isotope) = $ sl_inv(ix,iz,1+i_isotope) $ + rxn(ix,iz,1+i_isotope) $ * hydrate_frac(ix,iz) third_phase_inv(ix,iz,1+i_isotope) = $ third_phase_inv(ix,iz,1+i_isotope) $ + rxn(ix,iz,1+i_isotope) $ * ( 1.d0 - hydrate_frac(ix,iz) ) enddo freeze(ix,iz) = rxn(ix,iz,1) $ * hydrate_frac(ix,iz) #ifdef Hydrate_Release_Fluid_Volume dfluid = rxn(ix,iz,1) ! mol hydrate $ * hydrate_frac(ix,iz) $ * ( molwt_sl - molwt_pw ) ! g water $ / rho(i_Seawater) ! m3 water if(dfluid .LT. fluid_vol(ix,iz)) then fluid_vol(ix,iz) = fluid_vol(ix,iz) $ - dfluid endif #endif heat_src(ix,iz) = $ rxn(ix,iz,1) $ * hydrate_frac(ix,iz) $ * molwt_sl $ * latent_heat #ifdef Hydrate_Reaction_Redissolve else ! undersaturated, rxn < 0, possible dissolution c first get any bubbles if(third_phase_inv(ix,iz,1) .GT. 0.d0) then rxn(ix,iz,1) = third_phase_inv(ix,iz,1) $ * Reaction_CH4_Phases exsolve(ix,iz) = rxn(ix,iz,1) do i_isotope = 0, n_isotopes-1 rxn(ix,iz,1+i_isotope) = $ MAX( rxn(ix,iz,1) $ * third_phase_inv(ix,iz,1+i_isotope) $ / third_phase_inv(ix,iz,1), $ - third_phase_inv(ix,iz,1+i_isotope) $ ) third_phase_inv(ix,iz,1+i_isotope) = $ third_phase_inv(ix,iz,1+i_isotope) $ - rxn(ix,iz,1+i_isotope) dissolved_inv(ix,iz,1+i_isotope) = $ dissolved_inv(ix,iz,1+i_isotope) $ + rxn(ix,iz,1+i_isotope) enddo endif c#define Hydrate_Reaction_Redissolve_Hydrate #ifdef Hydrate_Reaction_Redissolve_Hydrate c then get any hydrate if(sl_inv(ix,iz,1) .GT. 0.d0) then rxn(ix,iz,1) = sl_inv(ix,iz,1) $ * Reaction_CH4_Phases freeze(ix,iz) = - rxn(ix,iz,1) do i_isotope = 0, n_isotopes-1 rxn(ix,iz,1+i_isotope) = $ MAX( rxn(ix,iz,1) $ * sl_inv(ix,iz,1+i_isotope) $ / sl_inv(ix,iz,1), $ - sl_inv(ix,iz,1+i_isotope) $ ) sl_inv(ix,iz,1+i_isotope) = $ sl_inv(ix,iz,1+i_isotope) $ - rxn(ix,iz,1+i_isotope) dissolved_inv(ix,iz,1+i_isotope) = $ dissolved_inv(ix,iz,1+i_isotope) $ + rxn(ix,iz,1+i_isotope) enddo #ifdef Hydrate_Release_Fluid_Volume dfluid = rxn(ix,iz,1) ! mol hydrate $ * ( molwt_sl - molwt_pw ) ! g water $ / rho(i_Seawater) ! m3 water if(dfluid .LT. fluid_vol(ix,iz)) then fluid_vol(ix,iz) = fluid_vol(ix,iz) $ + dfluid endif #endif heat_src(ix,iz) = $ rxn(ix,iz,1) $ * molwt_sl $ * latent_heat endif #endif #endif c Hydrate_Reaction_Redissolve endif ! undersat or supersat enddo ! iz enddo ! ix #endif c Hydrate_Reaction_Degassing sl_inv(:,:,1:n_isotopes) = $ MAX( sl_inv(:,:,1:n_isotopes), 0.d0 ) dissolved_inv(:,:,1:n_isotopes) = $ MAX( dissolved_inv(:,:,1:n_isotopes), 0.d0 ) third_phase_inv(:,:,1:n_isotopes) = $ MAX( third_phase_inv(:,:,1:n_isotopes), 0.d0 ) return end #endif #ifdef Reaction_Clays subroutine clay_reactions(sl_inv,fluid_vol, temperature, $ field, molwt, rho, dt, nz) implicit none integer nz double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: sl_inv double precision, dimension(0:NX+1,0:NZ_Max+1) :: fluid_vol double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1,N_Diags_2d) :: $ field double precision :: molwt(N_SL),rho(N_Rho) double precision dt integer ix, iz do ix=1,NX do iz=1,nz C From Xin-She Yang 'Theoretical Basin Modeling' (2006) C one-step dehydration approximation, Eq. 2.8 field(ix,iz,id2_clay_dewater) = $ Reaction_Clays ! yr-1 $ * exp( - Clay_Act_Energy $ / ( 8.314 ! GAS_CONSTANT $ * temperature(ix,iz,Kelvins) $ ) $ ) $ * sl_inv(ix,iz,i_Montmorillonite) ! mol/yr $ * dt ! mol sl_inv(ix,iz,i_Montmorillonite) = $ sl_inv(ix,iz,i_Montmorillonite) $ - field(ix,iz,id2_clay_dewater) sl_inv(ix,iz,i_Illite) = $ sl_inv(ix,iz,i_Illite) $ + field(ix,iz,id2_clay_dewater) fluid_vol(ix,iz) = fluid_vol(ix,iz) $ + field(ix,iz,id2_clay_dewater) ! moles $ * 9d0 ! rxn stoic $ * molwt(i_Freshwater) ! g $ / rho(i_Freshwater) ! m3 enddo enddo return end #endif subroutine update_bb_conc(bb_conc,bb_inv, $ p_gas, fluid_vol, temperature, $ rho, CO2_liq_drho, nz) implicit none integer nz,ix,iz double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ p_gas,fluid_vol, CO2_liq_drho double precision rho(N_Rho) double precision, dimension(0:NX+1,0:NZ_Max+1,N_Bubble_Types) :: $ bb_inv, bb_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature do ix=1,NX do iz=1,nz if(fluid_vol(ix,iz) .GT. 0.) then bb_conc(ix,iz,i_CH4:i_CDH3) = $ bb_inv(ix,iz,i_CH4:i_CDH3) ! moles $ * 22.414e-3 ! m3 at STP $ * 0.1 $ / p_gas(ix,iz) $ * temperature(ix,iz,Kelvins) $ / 298. ! m3 in situ $ / fluid_vol(ix,iz) ! bubble fraction bb_conc(ix,iz,i_CO2) = $ bb_inv(ix,iz,i_CO2) ! moles $ * 44.d0 ! g CO2 $ / ( rho(i_Seawater) $ + CO2_liq_drho(ix,iz) $ ) ! m3 CO2 liquid $ / fluid_vol(ix,iz) ! bubble fraction else bb_conc(ix,iz,:) = 0. endif bb_conc(ix,iz,:) = MAX(bb_conc(ix,iz,:), 0.d0) bb_inv(ix,iz,:) = MAX(bb_inv(ix,iz,:), 0.d0) enddo enddo return end subroutine update_bb_inv(bb_conc,bb_inv, $ p_gas, fluid_vol, temperature, $ rho, CO2_liq_drho, nz) implicit none integer nz,ix,iz,i_isotope double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ p_gas,fluid_vol, CO2_liq_drho double precision rho(N_Rho) double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1,N_Bubble_Types) :: $ bb_inv, bb_conc do ix=1,NX do iz=1,nz if(fluid_vol(ix,iz) .GT. 0.) then do i_isotope=0,2 ! only does i_CH4 bb_inv(ix,iz,i_CH4+i_isotope) = $ bb_conc(ix,iz,i_CH4+i_isotope) ! bubble fraction $ / 22.414e-3 ! mol/m3 at STP $ / 0.1 $ * p_gas(ix,iz) $ / temperature(ix,iz,Kelvins) $ * 298. ! mol/m3 in situ $ * fluid_vol(ix,iz) ! mol enddo bb_inv(ix,iz,i_CO2) = $ bb_conc(ix,iz,i_CO2) ! bubble fraction $ / 44.d0 ! mol/m3 at STP $ * ( rho(i_Seawater) $ + CO2_liq_drho(ix,iz) $ ) ! m3 CO2 liquid $ / fluid_vol(ix,iz) ! bubble fraction else bb_inv(ix,iz,:) = 0. endif bb_conc(ix,iz,:) = MAX(bb_conc(ix,iz,:), 0.d0) bb_inv(ix,iz,:) = MAX(bb_inv(ix,iz,:), 0.d0) enddo enddo return end subroutine boundary_wrap_ghosts(dummy,myid,numprocs,nz_max) implicit none integer nz_max double precision, dimension(0:NX+1,0:nz_max+1) :: dummy integer myid, numprocs call wrap_ghosts(dummy,myid,numprocs,nz_max) call boundary_ghosts(dummy,myid,numprocs,nz_max) return end subroutine wrap_ghosts(dummy,myid,numprocs,nz_max) implicit none #ifdef MPI include 'mpif.h' #endif integer nx, nz_max parameter(nx=NX) !,nz_max=NZ_Max) double precision, dimension(0:nx+1,0:nz_max+1) :: dummy integer myid, numprocs, ierr,iproc,nxtproc,lstproc, $ sendtag, recvtag,status #ifdef MPI c send up unless Im at the top if( myid .LT. numprocs - 1 ) then call MPI_Send( dummy(nx,:), nz_max+2, MPI_DOUBLE_PRECISION, $ myid + 1, 0, MPI_COMM_WORLD, status,ierr) endif c receive unless Im zero if( myid .GT. 0 ) then call MPI_Recv( dummy(0,:), nz_max+2, MPI_DOUBLE_PRECISION, $ myid - 1, 0, MPI_COMM_WORLD, status,ierr) endif c send down unless Im 0 if( myid .GT. 0 ) then call MPI_Send( dummy(1,:), nz_max+2, MPI_DOUBLE_PRECISION, $ myid - 1, 0, MPI_COMM_WORLD, status,ierr) endif c receive unless Im top if( myid .LT. numprocs - 1 ) then call MPI_Recv( dummy(nx+1,:), nz_max+2, MPI_DOUBLE_PRECISION, $ myid + 1, 0, MPI_COMM_WORLD, status,ierr) endif #endif return end subroutine boundary_ghosts(dummy,myid,numprocs,nz_max) c sets the values at the edges of the domain equal to the ones inside implicit none integer nz_max double precision, dimension(0:NX+1,0:nz_max+1) :: dummy integer myid, numprocs #ifdef MPI if(myid .EQ. 0) then dummy(0,:) = dummy(1,:) endif if(myid .EQ. numprocs-1) then dummy(NX+1,:) = dummy(NX,:) endif #else dummy(0,:) = dummy(1,:) ! left side dummy(NX+1,:) = dummy(NX,:) ! right side #endif return end subroutine collect_global(dummy_send, dummy_global, $ myid, numprocs, nz_external) implicit none #ifdef MPI include 'mpif.h' #endif integer nz_external integer myid, numprocs, ierr, n_tot,iproc, NX_offset, $ status, tag,i, n_global, iz real, dimension(NX,nz_external) :: $ dummy_send real, dimension(NX_Global,nz_external) :: dummy_global #ifdef MPI tag = 99 n_tot = NX * nz_external n_global = n_tot * numprocs do iz=1,nz_external call MPI_Gather(dummy_send(1,iz), NX, MPI_REAL, $ dummy_global(1,iz), NX, MPI_REAL, $ Master, MPI_COMM_WORLD, ierr) enddo #else dummy_global = dummy_send #endif return end subroutine cooling_ocean_crust( $ rho, $ temperature, $ lithosphere, $ dt, crust_therm_dieqdt, heat_geotherm_flux) implicit none double precision $ rho(N_Rho) double precision, dimension(0:NX+1,N_Lith_Slabs,N_Lith_Vars) :: $ lithosphere double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1) :: $ heat_geotherm_flux double precision, dimension(0:NX+1) :: $ crust_therm_dieqdt double precision dt, kappa, thermal_exp, $ boundary_thickness, $ temp_base, mantle_temp_avg, crust_temp_avg, time_clamped integer ix, iz c sets the thickness of the mantle boundary layer c and the densities of both lithosphere layers c use crust_therm_dieqdt as a placeholder for an initial freeboard_eq, c neglecting sediment do ix = 1, NX crust_therm_dieqdt(ix) = $ ( lithosphere(ix,MeanCrust,il_Thickness) $ + lithosphere(ix,Mantle,il_Thickness) $ ) ! column height $ - ( lithosphere(ix,MeanCrust,il_Thickness) ! corrected for T $ * ( lithosphere(ix,MeanCrust,il_Density)! also corrected $ - rho(i_Seawater) $ ) $ + lithosphere(ix,Mantle,il_Thickness) $ * ( lithosphere(ix,Mantle,il_Density) $ - rho(i_Seawater) $ ) $ ) $ / ( rho(i_Mantle) $ - rho(i_Seawater) $ ) ! height displaced enddo c update densities and thicknesses according to current lith age do ix = 1, NX c the boundary layer stuff is calculated for a pure ocean end-member, c then blended with the pure continental end member in the calculation c of density. time_clamped = MAX(0.d0, lithosphere(ix,OceanCrust,il_Age)) kappa = 1.D-6 ! m2/s thermal_exp = 3.d-5 boundary_thickness = SQRT( kappa ! m2/s $ * time_clamped * 3.14d7 ! m2 $ ) ! m boundary_thickness = MAX( boundary_thickness, $ Ocean_Crust_H0 $ ) lithosphere(ix,Mantle,il_Thickness) = $ boundary_thickness $ - Ocean_Crust_H0 temp_base = temperature(ix,1,degC) + $ ( Mantle_T0 - temperature(ix,1,degC) ) $ * Ocean_Crust_H0 $ / boundary_thickness ! e.g. 1600 if bound = litho(2) mantle_temp_avg = ( Mantle_T0 + temp_base ) / 2.d0 crust_temp_avg = ( temperature(ix,1,degC) $ + temp_base $ ) $ / 2.d0 lithosphere(ix,OceanCrust,il_Density) = $ rho(i_Ocean_Crust) $ * ( 1.d0 $ - thermal_exp $ * ( crust_temp_avg - Mantle_T0 / 2 ) $ ) c gives rho 3.0 at zero crust age lithosphere(ix,ContCrust,il_Density) = $ rho(i_Continental_Crust) lithosphere(ix,OceanCrust,il_Thickness) = $ lithosphere(ix,OceanCrust,il_Mass_per_m) ! g $ / lithosphere(ix,OceanCrust,il_Density) ! m3/g -> m (m antfarm) lithosphere(ix,Mantle,il_Density) = $ rho(i_Mantle) $ * ( 1.d0 $ - thermal_exp $ * ( mantle_temp_avg - Mantle_T0 ) c gives 3.5 at Mantle_T0 $ ) lithosphere(ix,Mantle,il_Mass_per_m) = $ lithosphere(ix,Mantle,il_Thickness) ! m $ * lithosphere(ix,Mantle,il_Density) ! g / m3 -> g / m (m antfarm) lithosphere(ix,MeanCrust,1:N_Lith_Vars-2) = $ lithosphere(ix,OceanCrust,1:N_Lith_Vars-2) $ * lithosphere(ix,OceanCrust,il_Ocean_Fraction) $ + lithosphere(ix,ContCrust,1:N_Lith_Vars-2) $ * (1 - lithosphere(ix,OceanCrust,il_Ocean_Fraction) ) #ifdef Geothermal_Heat_Coupled heat_geotherm_flux(ix) = $ kappa ! m2 / s $ * 0.84 ! J / g s K for basalt $ * lithosphere(ix,OceanCrust,il_Density) ! g/m3 -> J / m3 s K $ * ( temp_base $ - temperature(ix,1,degC) $ ) ! J / m3 s $ / lithosphere(ix,OceanCrust,il_Thickness) ! J / m2 s = W/m2 #endif enddo c update freeboard_eq as estimate for dz/dt. actually d isostat_eq / dt, c as is sedcol_conv_dieqdt do ix = 1, NX crust_therm_dieqdt(ix) = $ ( lithosphere(ix,MeanCrust,il_Thickness) $ + lithosphere(ix,Mantle,il_Thickness) $ ) $ - ( lithosphere(ix,MeanCrust,il_Thickness) $ * ( lithosphere(ix,MeanCrust,il_Density) $ - rho(i_Seawater) $ ) $ + lithosphere(ix,Mantle,il_Thickness) $ * ( lithosphere(ix,Mantle,il_Density) $ - rho(i_Seawater) $ ) $ ) $ / ( rho(i_Mantle) $ - rho(i_Seawater) $ ) $ - crust_therm_dieqdt(ix) enddo crust_therm_dieqdt(1:NX) = crust_therm_dieqdt(1:NX) / dt return end subroutine isostacy(z_top, x, dx, $ x_global, $ lithosphere, volume, rho, $ dt, tau_isostacy, sea_level, $ plate_pulldown, plate_x_scale, isostat_eq, $ column_mass, column_height, freeboard_eq, $ isostat_dzdt, $ nz, myid, numprocs) implicit none integer nz double precision, dimension(0:NX+1,N_Lith_Slabs,N_Lith_Vars) :: $ lithosphere double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_top double precision, dimension(0:NX+1) :: $ x, dx double precision :: rho(N_Rho) double precision :: sea_level, $ dt, tau_isostacy double precision, dimension(0:NX+1) :: isostat_eq, $ plate_pulldown, plate_x_scale, $ column_mass, column_height, freeboard_eq, isostat_dzdt double precision, dimension(NX) :: h_displaced double precision, dimension(0:NX*numprocs+1) :: $ x_global integer myid, numprocs integer ix, iz, ierr integer ixx, iter save do ix=1,NX h_displaced(ix) = ! height of equally massive column of mantle floating in sw $ column_mass(ix) ! g / m dx m antfarm $ / ( rho(i_Mantle) ! -> meters $ - rho(i_Seawater) $ ) isostat_eq(ix) = column_height(ix) $ - h_displaced(ix) $ + Ocean_Depth_0 ! the eq bedrock z value (iz=0) enddo c#ifdef Plate_Torque isostat_eq(1:NX) = isostat_eq(1:NX) ! positive upward $ + plate_pulldown(1:NX) ! positive upward c#endif #ifdef Isostacy_Smoothed call lateral_smoothing(isostat_eq, $ x_global,3, $ myid,numprocs) #endif isostat_dzdt(1:NX) = z_top(1:NX,0) ! placeholder #ifdef TAU_ISOSTACY z_top(1:NX,0) = z_top(1:NX,0) $ * ( 1.d0 - tau_isostacy ) $ + ( isostat_eq(1:NX) $ - z_top(1:NX,nz) $ + z_top(1:NX,0) ! offset because isostat_eq is for top of sed col $ ) $ * tau_isostacy #else z_top(1:NX,0) = isostat_eq(1:NX) $ - z_top(1:NX,nz) $ + z_top(1:NX,0) #endif freeboard_eq(1:NX) = column_height(1:NX) $ - h_displaced(1:NX) isostat_dzdt(1:NX) = z_top(1:NX,0) $ - isostat_dzdt(1:NX) isostat_dzdt(1:NX) = isostat_dzdt(1:NX) / dt return end #ifdef Sinking_Crust subroutine sinking_crust(t_now, dt_run, $ ocean_frac, $ plate_pulldown) implicit none double precision t_now, dt_run, $ ocean_frac(0:NX+1), $ plate_pulldown(0:NX+1) plate_pulldown(1:NX) = -Sinking_Crust #ifdef Sinking_Ocean_Crust_Only $ * ocean_frac(1:NX)**5.d0 #endif $ * t_now / dt_run return end #endif #ifdef Ice_Sheet subroutine ice_sheet(ice_sheet_vol, tot_vol, $ dz_ice_sheet, ice_sheet_active, $ ice_sheet_u, ice_sheet_vol_flow, $ ice_sheet_accum, ice_sheet_ablate, $ z_ice_sheet_base, $ ice_sheet_base_dt, $ dx, dz, z_top, $ rho, molwt, dt_ice, $ sea_level, dt, myid, numprocs, nz) implicit none #define Ice_Sheet_Accum 1.d-1 /* m / year. 1000m/100kyr=1e-2 */ #define Ice_Sheet_Flow_Coeff 1.d4 /* 10% grade gives 1 m/yr */ #define Ice_Sheet_Coast_Melt 3.d-2 double precision, dimension(0:NX) :: $ dz_ice_sheet, $ ice_sheet_u, ice_sheet_vol_flow, $ ice_sheet_accum, ice_sheet_ablate, $ z_ice_sheet_base, ice_sheet_base_dt, dx double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ ice_sheet_active, ice_sheet_vol, tot_vol, $ dz, z_top, dt_ice double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_inv double precision :: molwt(N_SL),rho(N_Rho) double precision dt, sea_level integer myid, numprocs, nz integer ix,iz ice_sheet_active = 0.d0 ice_sheet_u = 0.d0 do ix = 1, NX dz_ice_sheet(ix) = dz(ix,nz) $ / tot_vol(ix,nz) $ * ice_sheet_vol(ix,nz) ice_sheet_base_dt(ix) = $ dt_ice(ix,nz+1) $ + ( dt_ice(ix,nz-1) $ - dt_ice(ix,nz+1) $ ) $ / ( dz(ix,nz) $ + dz(ix,nz-1) / 2.d0 $ ) $ * dz_ice_sheet(ix) enddo do ix = 1, NX if(ice_sheet_vol(ix,nz) .GT. 0.d0 ) then ice_sheet_active(ix,nz-1:nz) = 1.d0 ice_sheet_u(ix) = ( z_top(ix,nz) $ - z_top(ix+1,nz) $ ) $ / dx(ix) $ * Ice_Sheet_Flow_Coeff ! m/yr c if( ice_sheet_base_dt(ix) .LT. 0.d0 ) then ! frozen to the bed c ice_sheet_u(ix) = ice_sheet_u(ix) / 10.d0 c endif endif enddo c advect the ice do ix = 1, NX ice_sheet_vol_flow(ix) = $ ice_sheet_u(ix) ! m/yr $ * dz_ice_sheet(ix) ! m3/yr antfarm $ * dt $ * T_Scale ! m3 enddo c write(6,"(a8,12g15.5)") "iceman", c $ z_top(1:4,nz), c $ ice_sheet_vol_flow(1:3), c $ ice_vol(1:4,nz) call wrap_ghosts(ice_sheet_vol_flow,myid,numprocs,1) if(myid .EQ. Master) then ice_sheet_vol_flow(0) = 0.d0 endif do ix = 0, NX ice_sheet_vol(ix,nz) = ice_sheet_vol(ix,nz) $ - ice_sheet_vol_flow(ix) ice_sheet_vol(ix+1,nz) = ice_sheet_vol(ix+1,nz) $ + ice_sheet_vol_flow(ix) enddo c accumulate snow or net melt at the base do ix = 1, NX if( z_top(ix,nz) .GT. sea_level) then if( ice_sheet_base_dt(ix) .LT. 0.d0 ) then ice_sheet_accum(ix) = Ice_Sheet_Accum else ice_sheet_accum(ix) = - Ice_Sheet_Accum endif ice_sheet_vol(ix,nz) = ice_sheet_vol(ix,nz) $ + ice_sheet_accum(ix) ! m/yr $ * dx(ix) ! m3/yr antfarm $ * dt ! m3 $ * T_Scale endif enddo c melt in the ocean do ix = 1, NX if( z_top(ix+1,nz) .LT. sea_level .AND. $ z_ice_sheet_base(ix) .LT. sea_level ) then ice_sheet_ablate(ix) = ice_sheet_vol(ix,nz) $ * Ice_Sheet_Coast_Melt ! m3/yr $ / dx(ix) ! m/yr ice_sheet_vol(ix,nz) = ice_sheet_vol(ix,nz) $ * ( 1.d0 $ - Ice_Sheet_Coast_Melt $ * dt ! m3 $ * T_Scale $ ) else ice_sheet_ablate(ix) = 0.d0 endif enddo return end #endif #ifdef Plate_Torque subroutine plate_torque( $ x_global, ocean_frac_global, $ plate_pulldown, plate_x_scale, $ myid, numprocs) implicit none #ifdef MPI include 'mpif.h' #endif double precision, dimension(0:NX_Global+1) :: $ x_global, ocean_frac_global double precision, dimension(0:NX+1) :: $ plate_pulldown, plate_x_scale integer myid, numprocs, ix, $ ix_0, ix_seafloor_z, ierr double precision plate_x0, plate_xb double precision, dimension(NX_Global) :: $ plate_x_scale_global, plate_pulldown_global data plate_x0 /Plate_X0/ data plate_xb /Plate_Xb/ save if(myid .EQ. Master) then plate_x_scale_global(1:NX_Global) = $ ( x_global(1:NX_Global) - plate_x0 ) $ / ( plate_xb - plate_x0 ) plate_x_scale_global(1:NX_Global) = $ MAX( plate_x_scale_global(1:NX_Global), $ -3.d0 $ ) c keeps weird 4th order equation from turning around plate_x_scale_global(1:NX_Global) = $ MIN( plate_x_scale_global(1:NX_Global), $ 4.d0 $ ) c kills loch ness monster ripples plate_pulldown_global(1:NX_Global) = Plate_Wb $ * 3.1 ! sqrt(2) * exp(pi/4) $ * exp( - 0.785 * plate_x_scale_global(1:NX_Global) ) $ * sin( 0.785 * plate_x_scale_global(1:NX_Global) ) c plate_pulldown_global(1:NX_Global) = c $ plate_pulldown_global(1:NX_Global) c $ * ocean_frac_global(1:NX_Global)**2 #ifdef Trench_Max_Depth plate_pulldown_global(1:NX_Global) = $ MAX( plate_pulldown_global(1:NX_Global), $ - Trench_Max_Depth ! relative to sea level $ + 3.d3 ! but pulldown wants rel seafloor $ ) #endif c call lateral_smoothing_global(plate_pulldown_global, c $ x_global, 10, NX_Global) endif ! Master #ifdef MPI call MPI_Bcast(plate_pulldown_global, NX_Global, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD, ierr) call MPI_Bcast(plate_x_scale_global, NX_Global, $ MPI_DOUBLE_PRECISION, Master, MPI_COMM_WORLD, ierr) #endif plate_pulldown(1:NX) = $ plate_pulldown_global(1+myid*NX:NX+myid*NX) plate_x_scale(1:NX) = $ plate_x_scale_global(1+myid*NX:NX+myid*NX) c write(6,*) "got here", myid, numprocs, plate_pulldown(1) c call MPI_Barrier(MPI_COMM_WORLD,ierr) c stop return end #endif subroutine deposit_sediment(dx, dz, $ volume, volume_flux, fluid_vol_flux, $ por_0, por_melted, $ rho, molwt, particle_radius, $ sl_inv, sl_conc, $ pw_inv, pw_conc, bb_inv, bb_conc, $ CH4_hydrate_frac, $ grain_size, $ sed_accum_rate, iz_water_table, $ deposit_flux, redeposit_flux, $ poc_rain_flux, poc_bio_rain_flux, $ dt, nz) implicit none c#ifdef MPI c include 'mpif.h' c#endif double precision, dimension(0:NX+1) :: $ dx double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ dz, $ grain_size, $ por_melted, $ CH4_hydrate_frac, fluid_vol_flux double precision, dimension(0:NX+1,0:NZ_Max+1,N_Vols) :: $ volume, volume_flux double precision :: molwt(N_SL),rho(N_Rho), $ por_0(0:2) double precision, dimension(N_Size_Classes) :: $ particle_radius double precision, dimension(0:NX+1,0:NZ_Max+1,N_SL) :: $ sl_inv, sl_conc double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_inv, pw_conc double precision, dimension(0:NX+1,0:NZ_Max+1, $ N_Bubble_Types) :: $ bb_inv, bb_conc double precision, dimension(0:NX+1) :: $ sed_accum_rate, $ poc_rain_flux, $ poc_bio_rain_flux double precision, dimension(0:NX+1,N_SL) :: $ deposit_flux, redeposit_flux double precision dt double precision accum_total, accum_solid, accum_fluid, $ grain_mass, sl_conc_tmp, totvol integer, dimension(NX) :: iz_water_table integer ix, iz, nz, i_pw, i_sl integer n_filled_stripes, i_step, n_steps, i_vol do ix=1,NX volume_flux(ix,:,:) = 0.d0 do i_sl = i_first_size_class, i_Pelagic volume_flux(ix,nz,ivol_solid) = $ volume_flux(ix,nz,ivol_solid) $ + ( deposit_flux(ix,i_sl) ! m3 sol/m year $ + redeposit_flux(ix,i_sl) ! m3 sol/m year $ ) * dt * T_Scale ! m3 sol / m timestep enddo if( iz_water_table(ix) .GT. nz ) then ! submerged volume_flux(ix,nz,ivol_fluid) = $ volume_flux(ix,nz,ivol_solid) $ * por_0(0) / ( 1 - por_0(0) ) else volume_flux(ix,nz,ivol_air) = $ volume_flux(ix,nz,ivol_solid) $ * por_0(0) / ( 1 - por_0(0) ) endif c calculate solid_vol_flux values through the grid if( sed_accum_rate(ix) .GE. 0) then #ifdef Growzinta_Sigma n_filled_stripes = 0 do iz = nz, nz-NZ_Top+1, -1 if( dz(ix,iz) .GT. DZ_Top_Zone ) then n_filled_stripes = n_filled_stripes + 1 endif enddo c if(n_filled_stripes .EQ. NZ_Top) then c write(6,*) "stop here" c endif do iz = nz-1, 1, -1 if( dz(ix,iz+1) .GT. DZ_Top_Zone $ .AND. $ iz .GE. nz-NZ_Top $ ) then volume_flux(ix,iz,ivol_solid) = $ volume_flux(ix,iz+1,ivol_solid) else volume_flux(ix,iz,ivol_solid) = $ volume_flux(ix,iz+1,ivol_solid) $ - volume_flux(ix,nz,ivol_solid) $ / ( nz - n_filled_stripes ) endif enddo #else /* always constant-thickness top layers */ do iz = nz - NZ_Top, nz volume_flux(ix,iz,ivol_solid) = $ volume_flux(ix,nz,ivol_solid) ! +ve up, value will be -ve enddo c interior layers do iz = nz-NZ_Top, 1, -1 volume_flux(ix,iz,ivol_solid) = $ volume_flux(ix,nz,ivol_solid) $ * iz / (nz - NZ_Top) ! scale to zero enddo #endif /* Growzinta_Sigma */ else ! upward flow; erosion n_filled_stripes = 0 totvol = 0.d0 do iz = 1, nz if( dz(ix,iz) .GT. 10.d0 ) then totvol = totvol + volume(ix,iz,ivol_solid) n_filled_stripes = n_filled_stripes + 1 endif enddo do iz = nz-1, 1, -1 if(dz(ix,iz) .GT. 10.d0 ) then volume_flux(ix,iz,ivol_solid) = $ volume_flux(ix,iz+1,ivol_solid) $ - volume_flux(ix,nz,ivol_solid) $ * volume(ix,iz+1,ivol_solid) $ / totvol else volume_flux(ix,iz,ivol_solid) = $ volume_flux(ix,iz+1,ivol_solid) endif enddo endif c fluxes of other phases do iz = nz-1, 1, -1 do i_vol = 1, N_Vols-1 ! dont bother with tot volume_flux(ix,iz,i_vol) = $ volume_flux(ix,iz,ivol_solid) $ / volume(ix,iz+1,ivol_solid) $ * volume(ix,iz+1,i_vol) enddo c fluid_vol_flux(ix,iz) = solid_vol_flux(ix,iz) ! also -ve c $ * por_melted(ix,iz+1) c $ / ( 1.d0 - por_melted(ix,iz+1) ) c bubble_vol_flux(ix,iz) = fluid_vol_flux(ix,iz) c $ * bb_conc(ix,iz+1,i_CH4) if(CH4_hydrate_frac(ix,iz+1) .GT. 0.d0 $ .AND. $ CH4_hydrate_frac(ix,iz+1) .LT. 1.d0 $ ) then ! bubbles concentrated in ! sub-layer volume_flux(ix,iz,ivol_bubble) = $ volume_flux(ix,iz,ivol_bubble) $ / ( 1.d0 - CH4_hydrate_frac(ix,iz+1) ) endif enddo c sediment accumulates at the sea floor n_steps = 1 if( ABS(sed_accum_rate(ix)) $ .GT. dz(ix,nz)/2 ) then n_steps = sed_accum_rate(ix) / dz(ix,nz) * 3 + 1 endif do i_step = 1, n_steps do i_vol = 1, N_Vols-1 volume(ix,nz,i_vol) = volume(ix,nz,i_vol) $ + volume_flux(ix,nz,i_vol) $ / n_steps enddo do i_sl = 1, N_SL sl_inv(ix,nz,i_sl) = sl_inv(ix,nz,i_sl) $ + ( deposit_flux(ix,i_sl) ! m3 / m ts $ + redeposit_flux(ix,i_sl) $ ) $ * dt * T_Scale $ * rho(i_Sediment) ! g sol / m ts $ / molwt(i_sl) ! mol sol / ts $ / n_steps enddo poc_rain_flux(ix) = $ + ( deposit_flux(ix,i_POC) ! m3 / m ts $ + redeposit_flux(ix,i_POC) $ ) $ * dt * T_Scale $ * rho(i_Sediment) ! g / timestep $ / molwt(i_Bio_POC) ! mol / ts $ / n_steps poc_bio_rain_flux(ix) = $ + ( deposit_flux(ix,i_Bio_POC) ! m3 / m ts $ + redeposit_flux(ix,i_Bio_POC) $ ) $ * dt * T_Scale $ * rho(i_Sediment) $ / molwt(i_Bio_POC) $ / n_steps c Advect stuff through the grid in the interior of the sed column if(sed_accum_rate(ix) .GT. 0.d0) then ! accumulation, going down do iz = nz-1, 1, -1 c phases do i_vol = 1, N_Vols-1 volume(ix,iz,i_vol) = volume(ix,iz,i_vol) $ + volume_flux(ix,iz,i_vol) $ / n_steps volume(ix,iz+1,i_vol) = volume(ix,iz+1,i_vol) $ - volume_flux(ix,iz,i_vol) $ / n_steps enddo c solid inventories do i_sl = 1, N_SL sl_conc_tmp = MAX( sl_conc(ix,iz+1,i_sl), ! mol $ 0.d0 ) if(i_sl .GE. i_Hydrate $ .AND. i_sl .LE. i_Hydrate_CO2 $ .AND. CH4_hydrate_frac(ix,iz) .LT. 1.d0 $ ) then sl_conc_tmp = 0.d0 ! no hydrate advection from bottom of ! box with phase boundary within it endif sl_inv(ix,iz,i_sl) = sl_inv(ix,iz,i_sl) ! mol $ + volume_flux(ix,iz,ivol_solid) ! m3 $ / n_steps $ * sl_conc_tmp ! mol/m3 sl_inv(ix,iz+1,i_sl) = ! MAX( $ sl_inv(ix,iz+1,i_sl) $ - volume_flux(ix,iz,ivol_solid) $ / n_steps $ * sl_conc_tmp enddo ! i_sl c bubbles if(bb_inv(ix,iz+1,i_CH4) .GT. 0.d0) then do i_sl = 1, N_Bubble_Types bb_inv(ix,iz,i_sl) = $ bb_inv(ix,iz,i_sl) $ + volume_flux(ix,iz,ivol_bubble) $ * bb_inv(ix,iz+1,i_sl) $ / bb_inv(ix,iz+1,i_CH4) bb_inv(ix,iz+1,i_sl) = $ bb_inv(ix,iz+1,i_sl) $ - volume_flux(ix,iz,ivol_bubble) $ * bb_inv(ix,iz+1,i_sl) $ / bb_inv(ix,iz+1,i_CH4) enddo endif #ifdef Solute_Advection_in_Deposit_Sediment do i_pw = 1, N_PW pw_inv(ix,iz,i_pw) = pw_inv(ix,iz,i_pw) $ + volume_flux(ix,iz,ivol_fluid) ! m3 $ / n_steps $ * pw_conc(ix,iz+1,i_pw) ! mol/m3 pw_inv(ix,iz+1,i_pw) = pw_inv(ix,iz+1,i_pw) $ - volume_flux(ix,iz,ivol_fluid) $ / n_steps $ * pw_conc(ix,iz+1,i_pw) enddo #endif enddo ! iz else ! erosion if(volume(ix,nz,ivol_solid) .LT. 0.d0) then write(6,*) "erosion too fast", ix,nz return endif do iz = 1, nz-1 c phases do i_vol = 1, N_Vols-1 volume(ix,iz,i_vol) = volume(ix,iz,i_vol) $ + volume_flux(ix,iz,i_vol) ! negative $ / n_steps volume(ix,iz+1,i_vol) = volume(ix,iz+1,i_vol) $ - volume_flux(ix,iz,i_vol) $ / n_steps enddo c solid inventories do i_sl = 1, N_SL sl_conc_tmp = MAX(sl_conc(ix,iz,i_sl), ! mol $ 0.d0) sl_inv(ix,iz,i_sl) = sl_inv(ix,iz,i_sl) ! mol $ + volume_flux(ix,iz,ivol_solid) ! m3 $ / n_steps $ * sl_conc_tmp ! mol/m3 sl_inv(ix,iz+1,i_sl) = sl_inv(ix,iz+1,i_sl) $ - volume_flux(ix,iz,ivol_solid) $ / n_steps $ * sl_conc_tmp enddo c bubbles if(bb_inv(ix,iz+1,i_CH4) .GT. 0.d0) then if(CH4_hydrate_frac(ix,iz) .EQ. 0.d0) then ! no upward bubble ! advection if theres hydrate in the upper part do i_sl = 1, N_Bubble_Types bb_inv(ix,iz,i_sl) = $ bb_inv(ix,iz,i_sl) $ + volume_flux(ix,iz,ivol_bubble) $ * bb_inv(ix,iz+1,i_sl) $ / bb_inv(ix,iz+1,i_CH4) bb_inv(ix,iz+1,i_sl) = $ bb_inv(ix,iz+1,i_sl) $ - volume_flux(ix,iz,ivol_bubble) $ * bb_inv(ix,iz+1,i_sl) $ / bb_inv(ix,iz+1,i_CH4) enddo endif endif #ifdef Solute_Advection_in_Deposit_Sediment do i_pw = 1, N_PW pw_inv(ix,iz,i_pw) = pw_inv(ix,iz,i_pw) $ + volume_flux(ix,iz,ivol_fluid) ! m3 $ * pw_conc(ix,iz,i_pw) ! mol/m3 pw_inv(ix,iz+1,i_pw) = pw_inv(ix,iz+1,i_pw) $ - volume_flux(ix,iz,ivol_fluid) $ * pw_conc(ix,iz,i_pw) enddo #endif enddo ! iz endif ! accumulation or erosion do i_sl = 1, N_SL do iz = 1, nz sl_conc(ix,iz,i_sl) = sl_inv(ix,iz,i_sl) $ / volume(ix,iz,ivol_solid) enddo ! ultimately sl_conc is updated in update_sl_conc enddo ! but it is useful here as a buffer enddo ! i_step enddo ! ix c call MPI_COMM_RANK(MPI_COMM_WORLD,i_step,n_steps) c if(i_step .EQ. 1) then c write(6,*) "I am", i_step, deposit_flux(:,1) c endif fluid_vol_flux = volume_flux(:,:,ivol_fluid) $ / dt / T_Scale ! m3 fluid / m year return end subroutine find_freeze_temperatures(z_top, z_center, dz, $ pw_conc, temperature, $ p_fluid, p_gas, T_Ice, dT_Ice, $ dT_CH4_hydrate, T3P_CH4_hydrate, $ CH4_eq, CH4_eq_T3P, CH4_hydrate_frac, $ dT_CO2_hydrate, CO2_eq, CO2_hydrate_frac, $ CO2_liq_drho, $ myid, $ nz) C from matlab code C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% C% the freezing point T is given by Tf = a0*S + a1*S^(3/2) + a2*S^2 + b*P C% C% where S = salinity (psu) C% P = pressure (decibars) C% Tf = freezing T (celsius) C% C% from Fofunoff, P and RC Millar Jr 1983 Algorithms for Computations C% of fundamental properties of seawater C% UNESCO Technical Papers in Marine Science Volume 44 C% (Crerar: GC1.U54) C% C% modified 10/27/06 C% translated to Fortran by PCMcGuire 8/3/09 C% C% note: valid from 4 - 40 psu at atmospheric pressure, error .003 C; C% so should find something a bit more accurate? C% C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% implicit none double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ z_top, z_center, dz double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ p_fluid, p_gas, T_Ice, dT_Ice, $ dT_CH4_Hydrate, T3P_CH4_hydrate, $ CH4_eq, CH4_eq_T3P, CH4_hydrate_frac, $ dT_CO2_hydrate, CO2_eq, CO2_hydrate_frac, $ CO2_liq_drho integer ix, iz, nz integer myid C internal variables double precision a(0:2), b, c(3), z_min, c_ice(2), c2(3), $ zcc, z_interface, sal_mol_l, sal_mol_frac data a / -0.0575d0, 1.710523d-3, -2.154996d-4 / data b / -7.53d-4 / data c /20.5, 2.2, 11.726 / data z_min/0.29/ ! in km, estimated from Fig4.1 in Sloans book (0.1MPa=0.01km) ! this is the Q1 point at T=273K data c_ice/26.69,49.65/ ! estimated from Sloans book (Fig4.1), for a log fit ! for T3=273K & 268K, for lower temps, this is an extrapolation data c2/20.5, 2.2, 11.726 / #ifdef Reaction_Ice_Freeze pw_conc(:,:,i_Sal) = MIN(pw_conc(:,:,i_Sal), $ 10.d0 * Ocean_Sal ) #ifdef Ice_Sal_Feedback T_Ice(:,:) = a(0) * pw_conc(:,:,i_Sal) $ + a(1) * pw_conc(:,:,i_Sal)**(3/2) $ + a(2) * pw_conc(:,:,i_Sal)**2 $ + b * p_fluid(:,:) * 1.d2 ! convert pressure from MPa to dbar #else T_Ice(:,:) = a(0) * Ocean_Sal $ + a(1) * Ocean_Sal**(3/2) $ + a(2) * Ocean_Sal**2 $ + b * p_fluid(:,:) * 1.d2 ! convert pressure from MPa to dbar #endif dt_ice(:,:) = temperature(:,:,degC) - t_ice(:,:) #endif #ifdef Reaction_CH4_Phases do ix=1,NX do iz=nz,1,-1 c if( ix .EQ. 4 .AND. iz .EQ. 10 ) then c write(6,*) "fuckthis1", ix,iz, pw_conc(ix,iz,i_Sal) c endif sal_mol_l = pw_conc(ix,iz,i_Sal) $ / 35. * 0.5 ! mol/l from psu sal_mol_frac = MIN( sal_mol_l $ / 18.d0, ! mol H20 / liter $ 0.99d0 $ ) c de Roo 1982 T3P_CH4_Hydrate(ix,iz) = -8160.43d0 $ / ( log(p_gas(ix,iz) / 0.1d0) $ - 33.1103d0 $ + 128.65d0 * sal_mol_frac $ - 40.28d0 * sal_mol_frac**2 $ + 138.49d0 * log(1.d0-sal_mol_frac) $ ) ! now the boundary temperature t3p in Kelvins dt_CH4_hydrate(ix,iz) = temperature(ix,iz,Kelvins) $ - T3P_CH4_hydrate(ix,iz) c Davie 2004 ch4_eq_t3p(ix,iz) = 156.36 $ + ( p_gas(ix,iz) - 20.d0 ) * 1.11d0 $ + ( T3P_CH4_hydrate(ix,iz) $ - 292.d0 $ ) * 6.34 #define HackDavie #ifdef HackDavie if(p_gas(ix,iz) .LT. 12.d0) then ch4_eq_t3p(ix,iz) = 5.d0 * p_gas(ix,iz) $ + 8.d0 * log(p_gas(ix,iz)) $ + 20.d0 endif #endif ch4_eq_t3p(ix,iz) = ch4_eq_t3p(ix,iz) $ * ( 1.d0 - 0.1 * sal_mol_l ) if(dT_CH4_hydrate(ix,iz) .GT. 0) then ! bubbles ch4_eq(ix,iz) = ch4_eq_t3p(ix,iz) $ * exp( - 0.014d0 * dt_CH4_hydrate(ix,iz) ) else ch4_eq(ix,iz) = ch4_eq_t3p(ix,iz) $ * exp( dt_CH4_hydrate(ix,iz) $ / 14.4 $ ) $ + 0.25 * ( 20.d0 - p_fluid(ix,iz) ) endif enddo ! iz enddo ! ix do ix=1, NX do iz = 1, nz CH4_hydrate_frac(ix,iz) = 0.5 $ * ( 1 - TANH( dt_CH4_hydrate(ix,iz) / 1.d0 ) ) ! 1 cold 0 hot enddo enddo #ifdef Interpolate_Temperature do ix=1,NX do iz = 1, nz if(dt_CH4_hydrate(ix,iz) .LT. 0) then CH4_hydrate_frac(ix,iz) = 1.d0 else CH4_hydrate_frac(ix,iz) = 0.d0 endif enddo enddo do ix=1,NX do iz = 1, nz-1 if( dt_CH4_hydrate(ix,iz) * dt_CH4_hydrate(ix,iz+1) $ .LT. 0.d0 ) then if( dt_CH4_hydrate(ix,iz) .GT. 0.d0 ) then ! normal, bubbles below hydrate above c product is negative means a sign change in this box, gotta split it up z_interface = z_center(ix,iz) $ + ( z_center(ix,iz+1) $ - z_center(ix,iz) $ ) ! say -1000 - -1200 = 200 $ * dt_CH4_hydrate(ix,iz) $ / ( dt_CH4_hydrate(ix,iz) $ - dt_CH4_hydrate(ix,iz+1) $ ) if(z_interface .LT. z_top(ix,iz)) then ! boundary in the lower cell CH4_hydrate_frac(ix,iz) = $ ( z_top(ix,iz) $ - z_interface $ ) ! say -2000 - -2500 = 500 $ / dz(ix,iz) else ! boundary in cell iz+1 CH4_hydrate_frac(ix,iz+1) = $ ( z_interface $ - z_top(ix,iz) $ ) ! say -2000 - -2500 = 500 $ / dz(ix,iz) endif else ! weird inversion, just leave it chunky style c call flush(6) endif endif enddo enddo #endif /* Interpolate_Temperature */ #endif /* Reaction_CH4_Phases */ c#ifdef Reaction_CO2_Phases do ix=1,NX do iz=1,nz dT_CO2_hydrate(ix,iz) = c2(3) $ + c2(1) $ * log10(-z_center(ix,iz)/1000.) $ - c2(2) $ * log10(-z_center(ix,iz)/1000.) $ * log10(-z_center(ix,iz)/1000.) dT_CO2_hydrate(ix,iz) = temperature(ix,iz,degC) $ - dT_CO2_hydrate(ix,iz) if(dT_CO2_hydrate(ix,iz) .GT. 0) then ! liquid CO2 CO2_eq(ix,iz) = 230. $ * ( 1. - exp( - p_gas(ix,iz) $ / 20. $ ) $ ) $ * exp( - 0.014 * temperature(ix,iz,Kelvins) ) $ / exp( - 0.014 * 300. ) CO2_liq_drho(ix,iz) = 1039.8 $ - 3.83333 * temperature(ix,iz,Kelvins) $ - 1.54809 * p_fluid(ix,iz) $ + 0.06735 * p_fluid(ix,iz)**2 ! difference from sw from House 2006 eyeballed else CO2_eq(ix,iz) = 1.417d-7 $ * exp( temperature(ix,iz,Kelvins) / 14.d0 ) $ + 0.25 * ( 20.d0 - p_fluid(ix,iz) ) CO2_liq_drho(ix,iz) = 0.d0 endif enddo enddo c#endif return end c#ifdef Reaction_Rocks subroutine caco3_eq(pw_conc, temperature, $ p_hydro, omega_igneous, omega_caco3, pH, hplus, $ CO3, CO2, HCO3, k1, k2, ksp_CaCO3, $ ix,iz,nz) implicit none integer nz,ix,iz double precision, dimension(0:NX+1,0:NZ_Max+1,N_PW) :: $ pw_conc double precision, dimension(0:NX+1,0:NZ_Max+1,2) :: $ temperature double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ p_hydro, omega_igneous, omega_caco3, pH, hplus, $ CO3, CO2, HCO3, k1, k2, ksp_CaCO3 c internal variables double precision, dimension(0:NX+1,0:NZ_Max+1) :: $ c1, c2, $ p_bars, $ k_igneous double precision :: cp, prat, xx, kprime, delv, rr, dk p_bars(ix,iz) = p_hydro(ix,iz) * 10.d0 ! MPa to bars hplus(ix,iz) = 1.d-8 c do ix = 1, NX c do iz = 1, nz if(pw_conc(ix,iz,i_Sal) .GT. 0.0) then ! or some other qc check C k1 and k2 (apparent), from mehrbach #ifdef Reaction_Ceq_TDep k1(ix,iz) = 13.7201 $ - 0.031334 * temperature(ix,iz,Kelvins) * - 3235.76 / temperature(ix,iz,Kelvins) * - 1.3E-5 * pw_conc(ix,iz,i_Sal) $ * temperature(ix,iz,Kelvins) * + 0.1032 * SQRT(pw_conc(ix,iz,i_Sal)) k1(ix,iz) = 10**(k1(ix,iz)) cp = (p_bars(ix,iz)) / 83.143 $ / temperature(ix,iz,Kelvins) prat = ( 24.2 - 0.085 * temperature(ix,iz,degC) ) * * cp prat = exp(prat) k1(ix,iz) = k1(ix,iz) * prat k2(ix,iz) = - 5371.9645 * - 1.671221 * temperature(ix,iz,Kelvins) * + 128375.28 / temperature(ix,iz,Kelvins) * + 2194.3055 $ * LOG( temperature(ix,iz,Kelvins) ) $ / 2.30259 * - 0.22913 * pw_conc(ix,iz,i_Sal) * - 18.3802 $ * LOG( pw_conc(ix,iz,i_Sal) ) $ / 2.30259 * + 8.0944E-4 * pw_conc(ix,iz,i_Sal) $ * temperature(ix,iz,Kelvins) * + 5617.11 * LOG( pw_conc(ix,iz,i_Sal) ) $ / 2.30259 $ / temperature(ix,iz,Kelvins) * - 2.136 * pw_conc(ix,iz,i_Sal) $ / temperature(ix,iz,Kelvins) k2(ix,iz) = 10**(k2(ix,iz)) prat = (16.4 - 0.04 * temperature(ix,iz,degC)) * * cp prat = exp(prat) k2(ix,iz) = k2(ix,iz) * prat #else k1(ix,iz) = 1.d-6 k2(ix,iz) = 1.d-9 #endif C1(ix,iz) = K1(ix,iz)/2.0 C2(ix,iz) = 1.0 - 4.0*K2(ix,iz)/K1(ix,iz) xx = pw_conc(ix,iz,i_Alk) / pw_conc(ix,iz,i_DIC) if(xx .LT. 1.d-2) then hplus(ix,iz) = SQRT( K1(ix,iz) $ / pw_conc(ix,iz,i_DIC) $ ) elseif( xx .LT. 2.d0 ) then hplus(ix,iz) = k2(ix,iz) else hplus(ix,iz) = C1(ix,iz) / xx $ * ( 1.0 $ - xx $ + SQRT( 1.0 $ + C2(ix,iz) $ * xx $ * (-2. + xx) $ ) $ ) endif pH(ix,iz) = -LOG(hplus(ix,iz)) / 2.303 CO3(ix,iz) = pw_conc(ix,iz,i_DIC) $ / ( hplus(ix,iz)**2 $ / ( k1(ix,iz) * k2(ix,iz) ) $ + hplus(ix,iz) / k2(ix,iz) $ + 1.d0 $ ) ! alpha2 from Stumm and Morgan p 174 #ifdef NewtOrig CO3(ix,iz) = ( pw_conc(ix,iz,i_Alk) $ - pw_conc(ix,iz,i_DIC) $ ) $ / ( 1.0 $ - hplus(ix,iz)**2 $ / k1(ix,iz)**2 $ ) #endif HCO3(ix,iz) = pw_conc(ix,iz,i_DIC) $ / ( hplus(ix,iz) / k1(ix,iz) $ + 1.d0 $ + k2(ix,iz) / hplus(ix,iz) $ ) ! alpha1 CO2(ix,iz) = pw_conc(ix,iz,i_DIC) $ / ( 1.d0 $ + k1(ix,iz) / hplus(ix,iz) $ + k1(ix,iz) * k2(ix,iz) $ / hplus(ix,iz)**2 $ ) c Calcite solubility, from sayles, and from millero KPRIME = 4.75E-7 C mol2 / kg2 DELV = -44 C cm3 / mol RR = 83.14 C cm3 bar / K mol DK = -.0133 C cm3 / bar mol ksp_CaCO3(ix,iz) = $ LOG(KPRIME) #ifdef Reaction_CaCO3eq_TDep $ - DELV $ / ( RR * temperature(ix,iz,Kelvins) ) $ * p_bars(ix,iz) $ + 0.5 $ * DK $ / ( RR * temperature(ix,iz,Kelvins) ) $ * (P_BARS(ix,iz))**2 #endif ksp_CaCO3(ix,iz) = EXP(ksp_CaCO3(ix,iz)) $ * 1.e3 ! to mol / m3 #ifdef Reaction_Rocks_TDep k_igneous(ix,iz) = 10**( - temperature(ix,iz,degC) $ * 0.07 + 20 $ ) #else k_igneous(ix,iz) = 3.d14 #endif omega_caco3(ix,iz) = CO3(ix,iz) $ * pw_conc(ix,iz,i_Ca) $ / ksp_CaCO3(ix,iz) omega_igneous(ix,iz) = $ pw_conc(ix,iz,i_Ca)/1000 ! m3 to l $ / ( hplus(ix,iz)**2 $ * k_igneous(ix,iz) $ ) c < 1 in deep seds, means anorthite -> kaolinite c H+ uptake, Ca2+ release endif ! pw salinity quality check c enddo c enddo RETURN END c#endif /* Reaction_Rocks */